diff options
| -rw-r--r-- | frontend/convertcases.icl | 2 | ||||
| -rw-r--r-- | frontend/syntax.dcl | 7 | ||||
| -rw-r--r-- | frontend/syntax.icl | 8 | ||||
| -rw-r--r-- | frontend/trans.icl | 286 |
4 files changed, 287 insertions, 16 deletions
diff --git a/frontend/convertcases.icl b/frontend/convertcases.icl index 28fecb0..3cf2454 100644 --- a/frontend/convertcases.icl +++ b/frontend/convertcases.icl @@ -736,7 +736,7 @@ newFunctionWithType opt_id fun_bodies local_vars fun_type group_index (cs_next_f = ({ symb_name = fun_id, symb_kind = SK_GeneratedFunction fun_def_ptr cs_next_fun_nr, symb_arity = arity }, (inc cs_next_fun_nr, [fun_def_ptr : cs_new_functions], cs_fun_heap <:= (fun_def_ptr, FI_Function { gf_fun_def = fun_def, gf_instance_info = II_Empty, - gf_fun_index = cs_next_fun_nr, gf_cons_args = {cc_size=0, cc_args = [], cc_linear_bits = []} }))) + gf_fun_index = cs_next_fun_nr, gf_cons_args = {cc_size=0, cc_args = [], cc_linear_bits = [], cc_producer = False} }))) addNewFunctionsToGroups :: !{#.CommonDefs} FunctionHeap ![FunctionInfoPtr] !Int !*{! Group} !*{#{# CheckedTypeDef}} !ImportedFunctions !*TypeHeaps !*VarHeap -> (!*{! Group}, ![FunDef], !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*TypeHeaps, !*VarHeap) diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index 928c2d5..b3dc90d 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -507,10 +507,15 @@ cIsALocalVar :== False { cc_size ::!Int , cc_args ::![ConsClass] , cc_linear_bits ::![Bool] + , cc_producer ::!ProdClass } :: ConsClass :== Int +:: ProdClass :== Bool + +pIsSafe :== True + :: OptionalVariable :== Optional (Bind Ident VarInfoPtr) :: AuxiliaryPattern @@ -639,7 +644,7 @@ cNonRecursiveAppl :== False :: Producer = PR_Empty | PR_Function !SymbIdent !Index | PR_Class !App ![(BoundVar, Type)] !Type -// | PR_Constructor !SymbIdent ![Expression] + | PR_Constructor !SymbIdent ![Expression] | PR_GeneratedFunction !SymbIdent !Index | PR_Curried !SymbIdent diff --git a/frontend/syntax.icl b/frontend/syntax.icl index a7335f2..4427233 100644 --- a/frontend/syntax.icl +++ b/frontend/syntax.icl @@ -500,10 +500,15 @@ cIsALocalVar :== False { cc_size ::!Int , cc_args ::![ConsClass] , cc_linear_bits ::![Bool] + , cc_producer ::!ProdClass } :: ConsClass :== Int +:: ProdClass :== Bool + +pIsSafe :== True + :: OptionalVariable :== Optional (Bind Ident VarInfoPtr) :: AuxiliaryPattern @@ -627,7 +632,7 @@ cNotVarNumber :== -1 :: Producer = PR_Empty | PR_Function !SymbIdent !Index | PR_Class !App ![(BoundVar, Type)] !Type -// | PR_Constructor !SymbIdent ![Expression] + | PR_Constructor !SymbIdent ![Expression] | PR_GeneratedFunction !SymbIdent !Index | PR_Curried !SymbIdent @@ -1735,6 +1740,7 @@ where (<<<) file (CheckedBody {cb_args,cb_rhs}) = file <<< "C " <<< cb_args <<< " = " <<< cb_rhs <<< '\n' (<<<) file (TransformedBody {tb_args,tb_rhs}) = file <<< "T " <<< tb_args <<< " = " <<< tb_rhs <<< '\n' (<<<) file (BackendBody body) = file <<< body <<< '\n' + (<<<) file (Expanding vars) = file <<< "E " <<< vars (<<<) file NoBody = file <<< "Array function\n" instance <<< FunCall diff --git a/frontend/trans.icl b/frontend/trans.icl index 995d823..599424b 100644 --- a/frontend/trans.icl +++ b/frontend/trans.icl @@ -548,7 +548,7 @@ analyseGroups common_defs imported_funs {ir_from, ir_to} main_dcl_module_n stdSt nr_of_groups = size groups # consumerAnalysisRO=ConsumerAnalysisRO {common_defs=common_defs,imported_funs=imported_funs,main_dcl_module_n=main_dcl_module_n,stdStrictLists_module_n=stdStrictLists_module_n} = iFoldSt (analyse_group consumerAnalysisRO) 0 nr_of_groups - ([], createArray nr_of_funs { cc_size = 0, cc_args = [], cc_linear_bits = []}, groups, fun_defs, var_heap, expr_heap) + ([], createArray nr_of_funs { cc_size = 0, cc_args = [], cc_linear_bits = [], cc_producer=False}, groups, fun_defs, var_heap, expr_heap) where analyse_group common_defs group_nr (cleanup_info, class_env, groups, fun_defs, var_heap, expr_heap) # ({group_members}, groups) = groups![group_nr] @@ -602,7 +602,7 @@ where # (TransformedBody {tb_args}) = fun_def.fun_body (fresh_vars, next_var_number, var_heap) = fresh_variables tb_args 0 next_var_number var_heap = initial_cons_class funs next_var_number (length fun_def.fun_info.fi_local_vars + nr_of_local_vars) var_heap - { class_env & [fun] = { cc_size = 0, cc_args = fresh_vars, cc_linear_bits=[]}} fun_defs + { class_env & [fun] = { cc_size = 0, cc_args = fresh_vars, cc_linear_bits=[], cc_producer=False}} fun_defs initial_cons_class [] next_var_number nr_of_local_vars var_heap class_env fun_defs = (next_var_number, nr_of_local_vars, var_heap, class_env, fun_defs) @@ -1143,7 +1143,7 @@ possibly_generate_case_function kees=:{case_info_ptr} aci=:{aci_free_vars} ro ti # cc_args_from_outer_fun = [ cons_arg \\ cons_arg <- outer_cons_args.cc_args & used <- used_mask | used ] cc_linear_bits_from_outer_fun = [ cons_arg \\ cons_arg <- outer_cons_args.cc_linear_bits & used <- used_mask | used ] new_cons_args = { cc_size = fun_arity, cc_args = repeatn nr_of_lifted_vars cPassive++cc_args_from_outer_fun, - cc_linear_bits = repeatn nr_of_lifted_vars False++cc_linear_bits_from_outer_fun } + cc_linear_bits = repeatn nr_of_lifted_vars False++cc_linear_bits_from_outer_fun, cc_producer = False} gf = { gf_fun_def = fun_def, gf_instance_info = II_Empty, gf_cons_args = new_cons_args, gf_fun_index = fun_index} ti_fun_heap = writePtr fun_info_ptr (FI_Function gf) ti.ti_fun_heap ti = { ti & ti_new_functions = [fun_info_ptr:ti.ti_new_functions], ti_var_heap = ti_var_heap, ti_fun_heap = ti_fun_heap, @@ -1537,9 +1537,11 @@ generateFunction fd=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_info = {fi new_fd_expanding = { fd & fun_body = Expanding new_fun_args, fun_arity = fun_arity,fun_type=new_fun_type, fun_info.fi_group_index = fi_group_index} + new_fd_cons_args + = {cc_args = new_cons_args, cc_size = length new_cons_args, cc_linear_bits=new_linear_bits, cc_producer = False} new_gen_fd = { gf_fun_def = new_fd_expanding, gf_instance_info = II_Empty, gf_fun_index = ti_next_fun_nr, - gf_cons_args = {cc_args = new_cons_args, cc_size = length new_cons_args, cc_linear_bits=new_linear_bits} } + gf_cons_args = new_fd_cons_args } ti_fun_heap = writePtr fun_def_ptr (FI_Function new_gen_fd) ti_fun_heap (subst, _) @@ -1573,7 +1575,7 @@ generateFunction fd=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_info = {fi } ti_trace =False - | ti_trace && (False--->("transforming new function:",tb_rhs)) + | False -!-> ("transforming new function:",tb_rhs) = undef # ti = { ti & ti_var_heap = us_var_heap, ti_fun_heap = ti_fun_heap, ti_symbol_heap = us_symbol_heap, @@ -1584,9 +1586,27 @@ generateFunction fd=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_info = {fi = transform tb_rhs ro ti new_fd = { new_fd_expanding & fun_body = TransformedBody {tb_args = new_fun_args, tb_rhs = new_fun_rhs} } -// | (False--->("generated function", new_fd, new_cons_args)) -// = undef - = (ti_next_fun_nr, fun_arity, { ti & ti_fun_heap = ti.ti_fun_heap <:= (fun_def_ptr, FI_Function { new_gen_fd & gf_fun_def = new_fd })}) + | False -!-> ("generated function", new_fd, new_cons_args) + = undef +// DvA... + # fun_heap = ti.ti_fun_heap + // producer requirements for generated function here... + #! prs = + { prs_group = [dec ti_next_fun_nr] + , prs_cons_args = ti.ti_cons_args + , prs_main_dcl_module_n = ro.ro_main_dcl_module_n + , prs_fun_heap = fun_heap + } + # (safe,prs) = producerRequirements new_fun_rhs prs + # fun_heap = prs.prs_fun_heap + // put back prs info into ti? +// ...DvA + # new_gen_fd = { new_gen_fd & gf_fun_def = new_fd, gf_cons_args = {new_fd_cons_args & cc_producer = safe}} + # ti = + { ti + & ti_fun_heap = fun_heap <:= (fun_def_ptr, FI_Function new_gen_fd) + } + = (ti_next_fun_nr, fun_arity, ti) where is_dictionary {at_type=TA {type_index} _} es_td_infos = type_index.glob_object>=size es_td_infos.[type_index.glob_module] @@ -1764,11 +1784,13 @@ where Yes cons_classes -> ({ cc_size = symb_arity, cc_args = take symb_arity cons_classes.cc_args, cc_linear_bits = if curried (repeatn symb_arity linear_bit) - (take symb_arity cons_classes.cc_linear_bits)} + (take symb_arity cons_classes.cc_linear_bits), + cc_producer = False} , fun_heap) No -> ({cc_size = symb_arity, cc_args = repeatn symb_arity cPassive, - cc_linear_bits = repeatn symb_arity linear_bit}, fun_heap) + cc_linear_bits = repeatn symb_arity linear_bit, + cc_producer = False}, fun_heap) get_fun_def (SK_Function {glob_module, glob_object}) main_dcl_module_n fun_defs fun_heap @@ -2448,11 +2470,53 @@ transformGroups cleanup_info main_dcl_module_n stdStrictLists_module_n groups fu # (ti_fun_defs, imported_types, collected_imports, ti_type_heaps, ti_var_heap) = foldSt (convert_function_type common_defs) group_members (ti.ti_fun_defs, imported_types, collected_imports, ti.ti_type_heaps, ti.ti_var_heap) - = transform_groups (inc group_nr) groups common_defs imported_funs imported_types collected_imports - (foldSt (transform_function common_defs imported_funs) group_members - { ti & ti_fun_defs = ti_fun_defs, ti_type_heaps = ti_type_heaps, ti_var_heap = ti_var_heap }) + # ti = { ti & ti_fun_defs = ti_fun_defs, ti_type_heaps = ti_type_heaps, ti_var_heap = ti_var_heap } + # ti = foldSt (transform_function common_defs imported_funs) group_members ti + # ti = reannotate_producers (group_members -!-> ("reannotate_producers",group_nr)) ti + = transform_groups (inc group_nr) groups common_defs imported_funs imported_types collected_imports ti = (groups, imported_types, collected_imports, ti) +// DvA ... + reannotate_producers group_members ti + // determine if safe group + # (safe,ti) = safe_producers group_members group_members ti + | safe + // if safe mark all members as safe + = foldSt mark_producer_safe group_members ti + = ti + + safe_producers group_members [] ti + = (True,ti) + safe_producers group_members [fun:funs] ti + // look for occurrence of group_members in safe argument position of fun RHS + // i.e. linearity ok && ... + #! prs = + { prs_group = group_members + , prs_cons_args = ti.ti_cons_args + , prs_main_dcl_module_n = main_dcl_module_n + , prs_fun_heap = ti.ti_fun_heap + } + # (fun_def, ti) = ti!ti_fun_defs.[fun] + {fun_body = TransformedBody tb} = fun_def + fun_body = tb.tb_rhs + # (safe,prs) = producerRequirements fun_body prs + // put back prs info into ti? + | safe -!-> ("producerRequirements",fun_def.fun_symb,safe) + = safe_producers group_members funs ti + = (safe,ti) + + mark_producer_safe fun ti + // update cc_prod for fun + // doesn't work with array update since that requires unique array?! + #! ti_cons_args = {safe x fun tca \\ tca <-: ti.ti_cons_args & x <- [0..]} + ti = {ti & ti_cons_args = ti_cons_args} + = ti + where + safe x f t + | x ==f = {t & cc_producer = pIsSafe} + = t +// ... DvA + transform_function common_defs imported_funs fun ti=:{ti_fun_defs, ti_var_heap} # (fun_def, ti_fun_defs) = ti_fun_defs![fun] (Yes {st_args}) = fun_def.fun_type @@ -2965,3 +3029,199 @@ foldrExprSt f expr st :== foldr_expr_st expr st = f lad st foldr_expr_st sel=:(Selection a expr b) st = f sel (foldr_expr_st expr st) + +:: *PRState = + { prs_group :: ![Int] + , prs_cons_args :: !{!ConsClasses} + , prs_main_dcl_module_n :: !Int + , prs_fun_heap :: !*FunctionHeap + } + +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_symb,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... + -> (True,prs) + Yes ca // for each arg: + // if safe && top of arg is App of group member... + // else recurse into arg + -> 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 + | is_SK_Function_or_SK_LocalMacroFunction symb_kind + #! 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 } + | glob_module <> main_dcl_module_n + = (False,prs) + #! rec = isMember glob_object prs.prs_group + = (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 + = (False,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 _ _ _) prs + // ... + = (False,prs) + producerRequirements (Update _ _ _) prs + // ... + = (False,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 _ _ _) prs + // what's this? + = (False,prs) + producerRequirements (DynamicExpr _) prs + // what's this? + = (False,prs) + producerRequirements (TypeCodeExpression _) prs + // what's this? + = (False,prs) + producerRequirements (EE) prs + // what's this? + = (False,prs) + producerRequirements (NoBind var) prs + // what's this? + = (False,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 (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 + +// compare with 'get_fun_def_and_cons_args' +retrieve_consumer_args si=:{symb_kind, symb_arity} prs=:{prs_cons_args, prs_main_dcl_module_n} + = case symb_kind of + SK_Function {glob_module, glob_object} + | glob_module == prs_main_dcl_module_n && glob_object < size prs_cons_args + -> (Yes prs_cons_args.[glob_object],prs) + -> (No,prs) -!-> ("r_c_a",si) + SK_LocalMacroFunction glob_object + | glob_object < size prs_cons_args + -> (Yes prs_cons_args.[glob_object],prs) + -> (No,prs) -!-> ("r_c_a",si) + SK_GeneratedFunction fun_ptr fun_index + | fun_index < size prs_cons_args + -> (Yes prs_cons_args.[fun_index],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 <<< SymbIdent +where + (<<<) file symb=:{symb_kind = SK_Function symb_index } + = file <<< symb.symb_name <<< '@' <<< symb_index + (<<<) file symb=:{symb_kind = SK_LocalMacroFunction symb_index } + = file <<< symb.symb_name <<< '@' <<< symb_index + (<<<) file symb=:{symb_kind = SK_GeneratedFunction _ symb_index } + = file <<< symb.symb_name <<< '@' <<< symb_index + (<<<) file symb=:{symb_kind = SK_OverloadedFunction symb_index } + = file <<< symb.symb_name <<< "[o]@" <<< symb_index + (<<<) file symb + = file <<< symb.symb_name + |