Commit 9003637d authored by John van Groningen's avatar John van Groningen
Browse files

move producerRequirements from module trans to module classify

parent 96c1b6b7
......@@ -16,3 +16,16 @@ analyseGroups :: !{# CommonDefs} !{#{#FunType}} !IndexRange !Int !Int !*{! Group
reanalyseGroups :: !{# CommonDefs} !{#{#FunType}} !Int !Int ![FunctionInfoPtr] ![Group] !*{#FunDef} !*VarHeap !*ExpressionHeap !*FunctionHeap !*{!ConsClasses}
-> (!CleanupInfo, !*{#FunDef}, !*VarHeap, !*ExpressionHeap, !*FunctionHeap, !*{!ConsClasses}, !Bool)
:: *PRState =
{ prs_group :: ![Int]
, prs_cons_args :: !*{!ConsClasses}
, prs_main_dcl_module_n :: !Int
, prs_fun_heap :: !*FunctionHeap
, prs_fun_defs :: !*{#FunDef}
, prs_group_index :: !Int
}
class producerRequirements a :: !a !*PRState -> *(!Bool,!*PRState)
instance producerRequirements Expression
\ No newline at end of file
......@@ -1498,3 +1498,244 @@ is_non_zero rc = score rc > 0
is_non_zero` :: !RefCount -> Bool
is_non_zero` rc = score` rc > 0
//@ producerRequirements
:: *PRState =
{ prs_group :: ![Int]
, prs_cons_args :: !*{!ConsClasses}
, prs_main_dcl_module_n :: !Int
, prs_fun_heap :: !*FunctionHeap
, prs_fun_defs :: !*{#FunDef}
, prs_group_index :: !Int
}
class producerRequirements a
:: !a !*PRState -> *(!Bool,!*PRState)
instance producerRequirements [a] | producerRequirements a where
producerRequirements [] prs
= (True,prs)
producerRequirements [x:xs] prs
# (safe,prs) = producerRequirements x prs
| safe = producerRequirements xs prs
= (safe,prs)
instance producerRequirements Expression where
producerRequirements (Var var) prs
= (True,prs)
producerRequirements (App {app_symb={symb_kind=(SK_Constructor _)},app_args}) prs
= producerRequirements app_args prs
producerRequirements app=:(App {app_symb,app_args}) prs
/*
# (rec,prs) = is_recursive_app app prs
| not rec
= producerRequirements app_args prs
*/
// look up consumer class for app_symb args
#! (maybe_ca,prs) = retrieve_consumer_args app_symb prs
// need to check for recursive call in safe arg...
= case maybe_ca of
No // assuming that for functions that have no consumer info no unfolding will occur
// note that this means that generated functions must be visible this way...
// # prs = prs ---> ("No cons info for",app_symb)
-> (True,prs)
Yes ca // for each arg:
// if safe && top of arg is App of group member...
// else recurse into arg
// # prs = prs ---> ("Yes cons info for",app_symb,ca.cc_args,ca.cc_linear_bits)
-> check_app_arguments ca.cc_args ca.cc_linear_bits app_args prs
where
check_app_arguments [cc_arg:cc_args] [cc_linear_bit:cc_bits] [app_arg:app_args] prs
| cc_arg == CActive && cc_linear_bit
# (rec,prs) = is_recursive_app app_arg prs
| rec = (False,prs)
# (safe,prs)= producerRequirements app_arg prs
| safe = check_app_arguments cc_args cc_bits app_args prs
= (safe,prs)
# (safe,prs) = producerRequirements app_arg prs
| safe = check_app_arguments cc_args cc_bits app_args prs
= (safe,prs)
check_app_arguments _ _ _ prs
= (True,prs)
is_recursive_app (App {app_symb}) prs
// check if app_symb member of prs_group
# {symb_kind} = app_symb
#! main_dcl_module_n = prs.prs_main_dcl_module_n
# { glob_module, glob_object }
= case symb_kind of
SK_Function global_index -> global_index
SK_LocalMacroFunction index -> { glob_module = main_dcl_module_n, glob_object = index }
SK_GeneratedFunction info_ptr index -> { glob_module = main_dcl_module_n, glob_object = index }
_ -> {glob_module = -1, glob_object = -1}
| glob_module <> main_dcl_module_n
= (False,prs)
#! (fun_def,fun_defs,fun_heap) = get_fun_def symb_kind prs.prs_main_dcl_module_n prs.prs_fun_defs prs.prs_fun_heap
prs = {prs & prs_fun_defs = fun_defs, prs_fun_heap = fun_heap}
rec = fun_def.fun_info.fi_group_index == prs.prs_group_index
= (rec,prs)
where
get_fun_def :: !SymbKind !Int !u:{#FunDef} !*FunctionHeap -> (!FunDef, !u:{#FunDef}, !*FunctionHeap)
get_fun_def (SK_Function {glob_module, glob_object}) main_dcl_module_n fun_defs fun_heap
| glob_module<>main_dcl_module_n
= abort "sanity check 2 failed in module trans"
# (fun_def, fun_defs) = fun_defs![glob_object]
= (fun_def, fun_defs, fun_heap)
get_fun_def (SK_LocalMacroFunction glob_object) main_dcl_module_n fun_defs fun_heap
# (fun_def, fun_defs) = fun_defs![glob_object]
= (fun_def, fun_defs, fun_heap)
get_fun_def (SK_GeneratedFunction fun_ptr _) main_dcl_module_n fun_defs fun_heap
# (FI_Function {gf_fun_def}, fun_heap) = readPtr fun_ptr fun_heap
= (gf_fun_def, fun_defs, fun_heap)
is_recursive_app _ prs
= (False,prs)
producerRequirements (fun_expr @ exprs) prs
// recurse
# (safe,prs) = producerRequirements fun_expr prs
| safe = producerRequirements exprs prs
= (safe,prs)
producerRequirements (Let {let_strict_binds,let_lazy_binds,let_expr}) prs
// watch out for function shadowing by 'let' binds
// recurse into binding exprs
// continue with 'in' body
# (safe,prs) = producerRequirements let_lazy_binds prs
| not safe = (safe,prs)
# (safe,prs) = producerRequirements let_strict_binds prs
| not safe = (safe,prs)
# (safe,prs) = producerRequirements let_expr prs
| not safe = (safe,prs)
= (safe,prs)
producerRequirements (Case {case_expr,case_guards,case_default,case_ident}) prs
// watch out for function shadowing by guards or case ident
// check case_expr
# (safe,prs) = producerRequirements case_expr prs
| not safe = (safe,prs)
// check case_guards
# (safe,prs) = producerRequirements case_guards prs
| not safe = (safe,prs)
// check case_default
# (safe,prs) = producerRequirements case_default prs
| not safe = (safe,prs)
= (True,prs)
producerRequirements (Selection _ expr sels) prs
# (safe,prs) = producerRequirements expr prs
| safe = producerRequirements sels prs
= (safe,prs)
producerRequirements (Update expr1 sels expr2) prs
# (safe,prs) = producerRequirements expr1 prs
| not safe = (safe,prs)
# (safe,prs) = producerRequirements expr2 prs
| not safe = (safe,prs)
# (safe,prs) = producerRequirements sels prs
| not safe = (safe,prs)
= (True,prs)
producerRequirements (RecordUpdate _ expr exprs) prs
// ...
# (safe,prs) = producerRequirements expr prs
| safe = producerFieldRequirements exprs prs
= (safe,prs)
where
producerFieldRequirements [] prs
= (True,prs)
producerFieldRequirements [{bind_src}:fields] prs
# (safe,prs) = producerRequirements bind_src prs
| safe = producerFieldRequirements fields prs
= (safe,prs)
producerRequirements (TupleSelect _ _ expr) prs
= producerRequirements expr prs
producerRequirements (BasicExpr _) prs
= (True,prs)
producerRequirements (AnyCodeExpr _ _ _) prs
= (False,prs)
producerRequirements (ABCCodeExpr _ _) prs
= (False,prs)
producerRequirements (MatchExpr _ expr) prs
= producerRequirements expr prs
producerRequirements (DynamicExpr _) prs
= (False,prs)
producerRequirements (TypeCodeExpression _) prs
= (False,prs)
producerRequirements (EE) prs
= (False,prs)
producerRequirements (NoBind var) prs
= (True,prs)
producerRequirements (FailExpr _) prs
= (True,prs)
producerRequirements expr prs
= abort ("producerRequirements " ---> expr)
instance producerRequirements (Optional a) | producerRequirements a where
producerRequirements (Yes x) prs
= producerRequirements x prs
producerRequirements No prs
= (True,prs)
instance producerRequirements CasePatterns where
producerRequirements (AlgebraicPatterns index patterns) prs
// name shadowing...
# (safe,prs) = producerRequirements patterns prs
= (safe,prs)
producerRequirements (BasicPatterns type patterns) prs
// name shadowing...
# (safe,prs) = producerRequirements patterns prs
= (safe,prs)
producerRequirements (OverloadedListPatterns _ _ patterns) prs
// name shadowing...
# (safe,prs) = producerRequirements patterns prs
= (safe,prs)
producerRequirements (DynamicPatterns patterns) prs
//...disallow for now...
= (False,prs)
producerRequirements NoPattern prs
= (True,prs)
instance producerRequirements AlgebraicPattern where
producerRequirements {ap_expr} prs
// name shadowing...
= producerRequirements ap_expr prs
instance producerRequirements BasicPattern where
producerRequirements {bp_expr} prs
// name shadowing...
= producerRequirements bp_expr prs
instance producerRequirements LetBind where
producerRequirements {lb_src} prs
= producerRequirements lb_src prs
instance producerRequirements Selection where
producerRequirements (RecordSelection _ _) prs
= (True,prs)
producerRequirements (ArraySelection _ _ expr) prs
= producerRequirements expr prs
producerRequirements (DictionarySelection _ sels _ expr) prs
# (safe,prs) = producerRequirements expr prs
| safe = producerRequirements sels prs
= (safe,prs)
retrieve_consumer_args :: !SymbIdent !*PRState -> (!Optional ConsClasses, !*PRState)
retrieve_consumer_args si=:{symb_kind} prs=:{prs_cons_args, prs_main_dcl_module_n}
# (prs_size, prs_cons_args) = usize prs_cons_args
prs = {prs & prs_cons_args = prs_cons_args}
= case symb_kind of
SK_Function {glob_module, glob_object}
| glob_module == prs_main_dcl_module_n && glob_object < prs_size
# (cons_args,prs) = prs!prs_cons_args.[glob_object]
-> (Yes cons_args,prs)
-> (No,prs)
SK_LocalMacroFunction glob_object
| glob_object < prs_size
# (cons_args,prs) = prs!prs_cons_args.[glob_object]
-> (Yes cons_args,prs)
-> (No,prs)
SK_GeneratedFunction fun_ptr fun_index
| fun_index < prs_size
# (cons_args,prs) = prs!prs_cons_args.[fun_index]
-> (Yes cons_args,prs)
# (FI_Function {gf_cons_args}, fun_heap) = readPtr fun_ptr prs.prs_fun_heap
# prs = {prs & prs_fun_heap = fun_heap}
-> (Yes gf_cons_args,prs)
// SK_Constructor cons_index
sk -> (No,prs)
......@@ -4244,214 +4244,6 @@ where
_
-> ([ v : global_vars ], var_heap)
/*
isYes (Yes _) = True
isYes _ = False
*/
//@ producerRequirements
:: *PRState =
{ prs_group :: ![Int]
, prs_cons_args :: !*{!ConsClasses}
, prs_main_dcl_module_n :: !Int
, prs_fun_heap :: !*FunctionHeap
, prs_fun_defs :: !*{#FunDef}
, prs_group_index :: !Int
}
class producerRequirements a
:: !a !*PRState -> *(!Bool,!*PRState)
instance producerRequirements [a] | producerRequirements a where
producerRequirements [] prs
= (True,prs)
producerRequirements [x:xs] prs
# (safe,prs) = producerRequirements x prs
| safe = producerRequirements xs prs
= (safe,prs)
instance producerRequirements Expression where
producerRequirements (Var var) prs
= (True,prs)
producerRequirements (App {app_symb={symb_kind=(SK_Constructor _)},app_args}) prs
= producerRequirements app_args prs
producerRequirements app=:(App {app_symb,app_args}) prs
/*
# (rec,prs) = is_recursive_app app prs
| not rec
= producerRequirements app_args prs
*/
// look up consumer class for app_symb args
#! (maybe_ca,prs) = retrieve_consumer_args app_symb prs
// need to check for recursive call in safe arg...
= case maybe_ca of
No // assuming that for functions that have no consumer info no unfolding will occur
// note that this means that generated functions must be visible this way...
// # prs = prs ---> ("No cons info for",app_symb)
-> (True,prs)
Yes ca // for each arg:
// if safe && top of arg is App of group member...
// else recurse into arg
// # prs = prs ---> ("Yes cons info for",app_symb,ca.cc_args,ca.cc_linear_bits)
-> check_app_arguments ca.cc_args ca.cc_linear_bits app_args prs
where
check_app_arguments [cc_arg:cc_args] [cc_linear_bit:cc_bits] [app_arg:app_args] prs
| cc_arg == CActive && cc_linear_bit
# (rec,prs) = is_recursive_app app_arg prs
| rec = (False,prs)
# (safe,prs)= producerRequirements app_arg prs
| safe = check_app_arguments cc_args cc_bits app_args prs
= (safe,prs)
# (safe,prs) = producerRequirements app_arg prs
| safe = check_app_arguments cc_args cc_bits app_args prs
= (safe,prs)
check_app_arguments _ _ _ prs
= (True,prs)
is_recursive_app (App {app_symb}) prs
// check if app_symb member of prs_group
# {symb_kind} = app_symb
#! main_dcl_module_n = prs.prs_main_dcl_module_n
# { glob_module, glob_object }
= case symb_kind of
SK_Function global_index -> global_index
SK_LocalMacroFunction index -> { glob_module = main_dcl_module_n, glob_object = index }
SK_GeneratedFunction info_ptr index -> { glob_module = main_dcl_module_n, glob_object = index }
_ -> {glob_module = -1, glob_object = -1}
| glob_module <> main_dcl_module_n
= (False,prs)
#! (fun_def,fun_defs,fun_heap) = get_fun_def symb_kind prs.prs_main_dcl_module_n prs.prs_fun_defs prs.prs_fun_heap
prs = {prs & prs_fun_defs = fun_defs, prs_fun_heap = fun_heap}
rec = fun_def.fun_info.fi_group_index == prs.prs_group_index
= (rec,prs)
is_recursive_app _ prs
= (False,prs)
producerRequirements (fun_expr @ exprs) prs
// recurse
# (safe,prs) = producerRequirements fun_expr prs
| safe = producerRequirements exprs prs
= (safe,prs)
producerRequirements (Let {let_strict_binds,let_lazy_binds,let_expr}) prs
// watch out for function shadowing by 'let' binds
// recurse into binding exprs
// continue with 'in' body
# (safe,prs) = producerRequirements let_lazy_binds prs
| not safe = (safe,prs)
# (safe,prs) = producerRequirements let_strict_binds prs
| not safe = (safe,prs)
# (safe,prs) = producerRequirements let_expr prs
| not safe = (safe,prs)
= (safe,prs)
producerRequirements (Case {case_expr,case_guards,case_default,case_ident}) prs
// watch out for function shadowing by guards or case ident
// check case_expr
# (safe,prs) = producerRequirements case_expr prs
| not safe = (safe,prs)
// check case_guards
# (safe,prs) = producerRequirements case_guards prs
| not safe = (safe,prs)
// check case_default
# (safe,prs) = producerRequirements case_default prs
| not safe = (safe,prs)
= (True,prs)
producerRequirements (Selection _ expr sels) prs
# (safe,prs) = producerRequirements expr prs
| safe = producerRequirements sels prs
= (safe,prs)
producerRequirements (Update expr1 sels expr2) prs
# (safe,prs) = producerRequirements expr1 prs
| not safe = (safe,prs)
# (safe,prs) = producerRequirements expr2 prs
| not safe = (safe,prs)
# (safe,prs) = producerRequirements sels prs
| not safe = (safe,prs)
= (True,prs)
producerRequirements (RecordUpdate _ expr exprs) prs
// ...
# (safe,prs) = producerRequirements expr prs
| safe = producerFieldRequirements exprs prs
= (safe,prs)
where
producerFieldRequirements [] prs
= (True,prs)
producerFieldRequirements [{bind_src}:fields] prs
# (safe,prs) = producerRequirements bind_src prs
| safe = producerFieldRequirements fields prs
= (safe,prs)
producerRequirements (TupleSelect _ _ expr) prs
= producerRequirements expr prs
producerRequirements (BasicExpr _) prs
= (True,prs)
producerRequirements (AnyCodeExpr _ _ _) prs
= (False,prs)
producerRequirements (ABCCodeExpr _ _) prs
= (False,prs)
producerRequirements (MatchExpr _ expr) prs
= producerRequirements expr prs
producerRequirements (DynamicExpr _) prs
= (False,prs)
producerRequirements (TypeCodeExpression _) prs
= (False,prs)
producerRequirements (EE) prs
= (False,prs)
producerRequirements (NoBind var) prs
= (True,prs)
producerRequirements (FailExpr _) prs
= (True,prs)
producerRequirements expr prs
= abort ("producerRequirements " ---> expr)
instance producerRequirements (Optional a) | producerRequirements a where
producerRequirements (Yes x) prs
= producerRequirements x prs
producerRequirements No prs
= (True,prs)
instance producerRequirements CasePatterns where
producerRequirements (AlgebraicPatterns index patterns) prs
// name shadowing...
# (safe,prs) = producerRequirements patterns prs
= (safe,prs)
producerRequirements (BasicPatterns type patterns) prs
// name shadowing...
# (safe,prs) = producerRequirements patterns prs
= (safe,prs)
producerRequirements (OverloadedListPatterns _ _ patterns) prs
// name shadowing...
# (safe,prs) = producerRequirements patterns prs
= (safe,prs)
producerRequirements (DynamicPatterns patterns) prs
//...disallow for now...
= (False,prs)
producerRequirements NoPattern prs
= (True,prs)
instance producerRequirements AlgebraicPattern where
producerRequirements {ap_expr} prs
// name shadowing...
= producerRequirements ap_expr prs
instance producerRequirements BasicPattern where
producerRequirements {bp_expr} prs
// name shadowing...
= producerRequirements bp_expr prs
instance producerRequirements LetBind where
producerRequirements {lb_src} prs
= producerRequirements lb_src prs
instance producerRequirements Selection where
producerRequirements (RecordSelection _ _) prs
= (True,prs)
producerRequirements (ArraySelection _ _ expr) prs
= producerRequirements expr prs
producerRequirements (DictionarySelection _ sels _ expr) prs
# (safe,prs) = producerRequirements expr prs
| safe = producerRequirements sels prs
= (safe,prs)
//@ fun_def & cons_arg getters...
get_fun_def :: !SymbKind !Int !u:{#FunDef} !*FunctionHeap -> (!FunDef, !u:{#FunDef}, !*FunctionHeap)
......@@ -4490,31 +4282,6 @@ get_fun_def_and_cons_args (SK_GeneratedFunction fun_info_ptr fun_index) cons_arg
# (FI_Function {gf_fun_def, gf_cons_args}, fun_heap) = readPtr fun_info_ptr fun_heap
= (gf_fun_def, gf_cons_args, cons_args, fun_defs, fun_heap)
retrieve_consumer_args :: !SymbIdent !*PRState -> (!Optional ConsClasses, !*PRState)
retrieve_consumer_args si=:{symb_kind} prs=:{prs_cons_args, prs_main_dcl_module_n}
# (prs_size, prs_cons_args) = usize prs_cons_args
prs = {prs & prs_cons_args = prs_cons_args}
= case symb_kind of
SK_Function {glob_module, glob_object}
| glob_module == prs_main_dcl_module_n && glob_object < prs_size
# (cons_args,prs) = prs!prs_cons_args.[glob_object]
-> (Yes cons_args,prs)
-> (No,prs) -!-> ("r_c_a",si)
SK_LocalMacroFunction glob_object
| glob_object < prs_size
# (cons_args,prs) = prs!prs_cons_args.[glob_object]
-> (Yes cons_args,prs)
-> (No,prs) -!-> ("r_c_a",si)
SK_GeneratedFunction fun_ptr fun_index
| fun_index < prs_size
# (cons_args,prs) = prs!prs_cons_args.[fun_index]
-> (Yes cons_args,prs)
# (FI_Function {gf_cons_args}, fun_heap) = readPtr fun_ptr prs.prs_fun_heap
# prs = {prs & prs_fun_heap = fun_heap}
-> (Yes gf_cons_args,prs)
// SK_Constructor cons_index
sk -> (No -!-> ("Unexpected symbol kind: ", si, sk),prs)
//@ <<<
instance <<< Group where
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment