diff options
| -rw-r--r-- | frontend/classify.dcl | 13 | ||||
| -rw-r--r-- | frontend/classify.icl | 241 | ||||
| -rw-r--r-- | frontend/trans.icl | 233 |
3 files changed, 254 insertions, 233 deletions
diff --git a/frontend/classify.dcl b/frontend/classify.dcl index c448395..c8fa829 100644 --- a/frontend/classify.dcl +++ b/frontend/classify.dcl @@ -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 diff --git a/frontend/classify.icl b/frontend/classify.icl index f14072f..92c14f1 100644 --- a/frontend/classify.icl +++ b/frontend/classify.icl @@ -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) diff --git a/frontend/trans.icl b/frontend/trans.icl index f1837b5..3985063 100644 --- a/frontend/trans.icl +++ b/frontend/trans.icl @@ -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 |