diff options
Diffstat (limited to 'frontend')
| -rw-r--r-- | frontend/classify.dcl | 15 | ||||
| -rw-r--r-- | frontend/classify.icl | 616 | ||||
| -rw-r--r-- | frontend/trans.icl | 326 |
3 files changed, 614 insertions, 343 deletions
diff --git a/frontend/classify.dcl b/frontend/classify.dcl index 0a0015e..86734de 100644 --- a/frontend/classify.dcl +++ b/frontend/classify.dcl @@ -2,20 +2,17 @@ definition module classify import syntax, checksupport, transform -CUnused :== -1 -CPassive :== -2 -CActive :== -3 -CAccumulating :== -4 -CVarOfMultimatchCase :== -5 +CUnusedLazy :== -1 +CUnusedStrict :== -2 +CPassive :== -3 +CActive :== -4 +CAccumulating :== -5 +CVarOfMultimatchCase :== -6 :: CleanupInfo :== [ExprInfoPtr] analyseGroups :: !{# CommonDefs} !{#{#FunType}} !IndexRange !Int !Int !*{! Group} !*{#FunDef} !*VarHeap !*ExpressionHeap -> (!CleanupInfo, !*{!ConsClasses}, !*{!Group}, !*{#FunDef}, !*VarHeap, !*ExpressionHeap) -reanalyseFunction - :: !Int !FunctionInfoPtr !{# CommonDefs} !{#{#FunType}} !Int !Int !*{#FunDef} !*VarHeap !*FunctionHeap !*{!ConsClasses} - -> *(!ConsClasses,!*{#FunDef},!*VarHeap,!*FunctionHeap,!*{!ConsClasses}) - reanalyseGroups :: !{# CommonDefs} !{#{#FunType}} !Int !Int ![FunctionInfoPtr] ![Group] !*{#FunDef} !*VarHeap !*ExpressionHeap !*FunctionHeap !*{!ConsClasses} -> (!CleanupInfo, !*{#FunDef}, !*VarHeap, !*ExpressionHeap, !*FunctionHeap, !*{!ConsClasses}, !Bool) diff --git a/frontend/classify.icl b/frontend/classify.icl index c5d5f36..897c125 100644 --- a/frontend/classify.icl +++ b/frontend/classify.icl @@ -4,8 +4,10 @@ implementation module classify SwitchMultimatchClassification multi no_multi :== multi +SwitchNewOld new old :== new import syntax, checksupport, transform +import StdStrictLists :: CleanupInfo :== [ExprInfoPtr] @@ -95,8 +97,141 @@ where //@ Consumer Analysis datatypes... -:: RefCounts :== {#Int} +:: RefCounts +// :== {#RefCount} + :== {RefCount} +:: RefCount +// :== Int +// = RC !Int +// = RC !Int [[(!FunIndex,!ArgIndex)]] // (fun_index,arg_index) + = Par !Int !.[!.RefCount!] + | Seq !Int !.[!.RefCount!] + | Dep !FunIndex !ArgIndex + +:: FunIndex :== Int +:: ArgIndex :== Int + +replace_global_idx_by_group_idx table rcs + = {{replace rc \\ rc <-: frcs} \\ frcs <-: rcs} +where + replace rc + = case rc of + Par i d -> Par i [|replace rc \\ rc <|- d]//(map replace d) + Seq i d -> Seq i [|replace rc \\ rc <|- d]//(map replace d) + Dep f a -> Dep (get_index f 0 table) a + + get_index f x [] = abort "classify:get_index: no index for function\n" + get_index f x [t:ts] + | t == f + = x + = get_index f (x+1) ts + +Max a m [|] + = a + m +Max a m [|d:ds] + | a + m >= 2 + = 2 + # s = score d + | s > m + = Max a s ds + = Max a m ds + +Sum a [|] + = a +Sum a [|d:ds] + | a >= 2 + = 2 + = Sum (a + score d) ds + +score (Par i d) = Max i 0 d +score (Seq i d) = Sum i d +score (Dep f a) = 0 + +Max` a m [|] + = a + m +Max` a m [|d:ds] + | a + m >= 2 + = 2 + # s = score` d + | s > m + = Max` a s ds + = Max` a m ds + +Sum` a [|] + = a +Sum` a [|d:ds] + | a >= 2 + = 2 + = Sum` (a + score` d) ds + +score` (Par i d) = Max` i 0 d +score` (Seq i d) = Sum` i d +score` (Dep f a) = 1 + +substitute_dep :: ![(!FunIndex,!ArgIndex)] !u:RefCount -> u:RefCount +substitute_dep subs (Par i d) + = Par i [|substitute_dep subs rc \\ rc <|- d] +substitute_dep subs (Seq i d) + = Seq i [|substitute_dep subs rc \\ rc <|- d] +substitute_dep subs rc=:(Dep f a) + | isMember (f,a) subs + = Seq 1 [|] + = Dep f a + +n_zero_counts n + :== createArray n (Seq 0 [|]) +n_twos_counts n + :== createArray n (Seq 2 [|]) + +inc_ref_count :: !RefCount -> RefCount +//inc_ref_count (RC ref_count deps) +// :== RC (min (ref_count+1) 2) deps +inc_ref_count rc + = case rc of + Par i d -> if (i > 0) (Seq 2 [|]) (Par (i+1) d) + Seq i d -> if (i > 0) (Seq 2 [|]) (Seq (i+1) d) + _ -> abort "classify:inc_ref_count: unexpected Dep\n" + +add_dep_count :: !(!Int,!Int) !RefCount -> RefCount +//add_dep_count dep (RC ref_count deps) +// :== RC ref_count (map (\l->[dep:l]) deps) +add_dep_count (fi,ai) rc + = case rc of + Par i d -> Par i [|Dep fi ai:d] + Seq i d -> Seq i [|Dep fi ai:d] + _ -> abort "classify:add_dep_count: unexpected Dep\n" + +combine_counts :: !RefCounts !RefCounts -> .RefCounts +combine_counts c1 c2 + = {Seq 0 [|rc1,rc2] \\ rc1 <-: c1 & rc2 <-: c2} + +unify_counts :: !RefCounts !RefCounts -> RefCounts +unify_counts c1 c2 + = {Par 0 [|rc1,rc2] \\ rc1 <-: c1 & rc2 <-: c2} + +show_counts group_members group_counts + # (_,group_counts) = foldSt show group_members (0,group_counts) + = group_counts +where + show fun (fun_index,group_counts) + # (fun_counts,group_counts) = group_counts![fun_index] + = (fun_index+1,group_counts) + ---> ( fun_index,fun + , [score rc \\ rc <-: fun_counts] + , [score` rc \\ rc <-: fun_counts] + , [is_non_zero rc \\ rc <-: fun_counts] + , fun_counts + ) + +instance <<< [!a!] | <<< a +where + (<<<) s a = s <<< [e \\ e <|- a] + +instance <<< {a} | <<< a +where + (<<<) s a = s <<< [e \\ e <-: a] + :: *AnalyseInfo = { ai_var_heap :: !*VarHeap , ai_cons_class :: !*{!ConsClasses} @@ -106,7 +241,10 @@ where , ai_next_var_of_fun :: !Int , ai_cases_of_vars_for_function :: ![(!Bool,!Case)] , ai_fun_heap :: !*FunctionHeap - , ai_def_ref_counts :: !RefCounts + , ai_fun_defs :: !*{#FunDef} + + , ai_group_members :: ![Int] + , ai_group_counts :: !*{!RefCounts} } /* defined in syntax.dcl: @@ -120,11 +258,12 @@ where :: ConsClass :== Int */ -CUnused :== -1 -CPassive :== -2 -CActive :== -3 -CAccumulating :== -4 -CVarOfMultimatchCase :== -5 +CUnusedLazy :== -1 +CUnusedStrict :== -2 +CPassive :== -3 +CActive :== -4 +CAccumulating :== -5 +CVarOfMultimatchCase :== -6 /* NOTE: ordering of above values is relevant since unification @@ -171,10 +310,10 @@ where = case var_info of VI_AccVar temp_var arg_position #! (ref_count,ai) = ai!ai_cur_ref_counts.[arg_position] - ai = { ai & ai_cur_ref_counts.[arg_position] = min (ref_count+1) 2 } + ai = { ai & ai_cur_ref_counts.[arg_position] = inc_ref_count ref_count } -> (temp_var, False, ai) _ - -> abort ("consumerRequirements [BoundVar] " ---> (var_name)) + -> abort ("consumerRequirements [BoundVar] " ---> (var_name,var_info_ptr)) instance consumerRequirements Expression where consumerRequirements (Var var) common_defs ai @@ -235,12 +374,12 @@ instance consumerRequirements Expression where = consumerRequirements expr common_defs ai consumerRequirements (AnyCodeExpr _ _ _) _ ai=:{ai_cur_ref_counts} #! s = size ai_cur_ref_counts - twos_array = createArray s 2 + twos_array = n_twos_counts s ai = { ai & ai_cur_ref_counts=twos_array } = (CPassive, False, ai) consumerRequirements (ABCCodeExpr _ _) _ ai=:{ai_cur_ref_counts} #! s = size ai_cur_ref_counts - twos_array = createArray s 2 + twos_array = n_twos_counts s ai = { ai & ai_cur_ref_counts=twos_array } = (CPassive, False, ai) consumerRequirements (DynamicExpr dynamic_expr) common_defs ai @@ -273,13 +412,15 @@ where instance consumerRequirements App where consumerRequirements {app_symb={symb_kind = SK_Function {glob_module,glob_object},symb_name}, app_args} common_defs=:(ConsumerAnalysisRO {main_dcl_module_n,stdStrictLists_module_n,imported_funs}) - ai=:{ai_cons_class} + ai=:{ai_cons_class,ai_group_members} | glob_module == main_dcl_module_n | glob_object < size ai_cons_class - # (fun_class, ai_cons_class) = ai_cons_class![glob_object] - = reqs_of_args fun_class.cc_args app_args CPassive common_defs { ai & ai_cons_class = ai_cons_class } - = consumerRequirements app_args common_defs ai + # (fun_class, ai) = ai!ai_cons_class.[glob_object] + | isMember glob_object ai_group_members + = reqs_of_args glob_object 0 fun_class.cc_args app_args CPassive common_defs ai + = reqs_of_args (-1) 0 fun_class.cc_args app_args CPassive common_defs ai + = consumerRequirements app_args common_defs ai | glob_module == stdStrictLists_module_n && (not (isEmpty app_args)) && is_nil_cons_or_decons_of_UList_or_UTSList glob_object glob_module imported_funs @@ -305,8 +446,14 @@ instance consumerRequirements App where */ // ACTIVATE DICTIONARIES... [SUBSUMES SPECIAL] # num_dicts = length imported_funs.[glob_module].[glob_object].ft_type.st_context + + # num_specials = case imported_funs.[glob_module].[glob_object].ft_specials of + (SP_ContextTypes [sp:_]) -> length sp.spec_types + _ -> 0 +// # num_dicts = num_dicts ---> ("NUM_DICTS",num_dicts,num_specials) + | num_dicts > 0 && num_dicts <= length app_args - = reqs_of_args (repeatn num_dicts CActive ++ repeatn (imported_funs.[glob_module].[glob_object].ft_arity) CPassive) app_args CPassive common_defs ai + = reqs_of_args (-1) 0 (repeatn num_dicts CActive ++ repeatn (imported_funs.[glob_module].[glob_object].ft_arity) CPassive) app_args CPassive common_defs ai /* wrong version... = activeArgs num_dicts app_args common_defs ai with @@ -321,19 +468,24 @@ instance consumerRequirements App where = consumerRequirements app_args common_defs ai consumerRequirements {app_symb={symb_kind = SK_LocalMacroFunction glob_object,symb_name}, app_args} common_defs=:(ConsumerAnalysisRO {main_dcl_module_n}) - ai=:{ai_cons_class} + ai=:{ai_cons_class,ai_group_members} | glob_object < size ai_cons_class - # (fun_class, ai_cons_class) = ai_cons_class![glob_object] - = reqs_of_args fun_class.cc_args app_args CPassive common_defs { ai & ai_cons_class = ai_cons_class } - = consumerRequirements app_args common_defs ai + # (fun_class, ai) = ai!ai_cons_class.[glob_object] + | isMember glob_object ai_group_members + = reqs_of_args glob_object 0 fun_class.cc_args app_args CPassive common_defs ai + = reqs_of_args (-1) 0 fun_class.cc_args app_args CPassive common_defs ai + = consumerRequirements app_args common_defs ai // new alternative for generated function + reanalysis... consumerRequirements {app_symb={symb_kind = SK_GeneratedFunction fun_info_ptr index,symb_name}, app_args} common_defs - ai - # (FI_Function {gf_cons_args={cc_args,cc_linear_bits}}, ai_fun_heap) + ai=:{ai_group_members} + # (FI_Function {gf_cons_args={cc_args,cc_linear_bits},gf_fun_def}, ai_fun_heap) = readPtr fun_info_ptr ai.ai_fun_heap - = reqs_of_args cc_args app_args CPassive common_defs {ai & ai_fun_heap = ai_fun_heap} + # ai = {ai & ai_fun_heap = ai_fun_heap} + | isMember index ai_group_members + = reqs_of_args index 0 cc_args app_args CPassive common_defs ai + = reqs_of_args (-1) 0 cc_args app_args CPassive common_defs ai consumerRequirements {app_args} common_defs ai = not_an_unsafe_pattern (consumerRequirements app_args common_defs ai) @@ -345,29 +497,34 @@ instance <<< (Ptr a) where (<<<) file p = file <<< ptrToInt p -reqs_of_args :: ![ConsClass] !.[Expression] ConsClass ConsumerAnalysisRO !*AnalyseInfo -> *(!ConsClass,!.Bool,!*AnalyseInfo) -reqs_of_args _ [] cumm_arg_class _ ai +reqs_of_args :: !Int !Int ![ConsClass] !.[Expression] ConsClass ConsumerAnalysisRO !*AnalyseInfo -> *(!ConsClass,!.Bool,!*AnalyseInfo) +reqs_of_args _ _ _ [] cumm_arg_class _ ai = (cumm_arg_class, False, ai) -reqs_of_args [] _ cumm_arg_class _ ai +reqs_of_args _ _ [] _ cumm_arg_class _ ai = (cumm_arg_class, False, ai) -reqs_of_args [form_cc : ccs] [arg : args] cumm_arg_class common_defs ai - # (act_cc, _, ai) = consumerRequirements arg common_defs ai - ai = aiUnifyClassifications form_cc act_cc ai - = reqs_of_args ccs args (combineClasses act_cc cumm_arg_class) common_defs ai -reqs_of_args cc xp _ _ _ = abort "classify:reqs_of_args doesn't match" ---> (cc,xp) -/* -showRefCount :: !String !*AnalyseInfo -> *AnalyseInfo -showRefCount msg ai=:{ai_cur_ref_counts} - = ai <--- (msg,display ai_cur_ref_counts) -*/ -display :: !RefCounts -> String -display rc = {show c \\ c <-: rc} +reqs_of_args fun_idx arg_idx [form_cc : ccs] [(Var arg): args] cumm_arg_class common_defs ai + | fun_idx >= 0 + # (act_cc, _, ai) = consumerRequirements` arg common_defs ai + ai = aiUnifyClassifications form_cc act_cc ai + = reqs_of_args fun_idx (inc arg_idx) ccs args (combineClasses act_cc cumm_arg_class) common_defs ai where - show 0 = '0' - show 1 = '1' - show 2 = '2' - show _ = '?' + consumerRequirements` {var_info_ptr,var_name} _ ai + # (var_info, ai_var_heap) = readPtr var_info_ptr ai.ai_var_heap + ai = { ai & ai_var_heap=ai_var_heap } + = case var_info of + VI_AccVar temp_var arg_position + #! (ref_count,ai) = ai!ai_cur_ref_counts.[arg_position] + ai = { ai & ai_cur_ref_counts.[arg_position] = add_dep_count (fun_idx,arg_idx) ref_count } + -> (temp_var, False, ai) + _ + -> abort ("reqs_of_args [BoundVar] " ---> (var_name)) + +reqs_of_args fun_idx arg_idx [form_cc : ccs] [arg : args] cumm_arg_class common_defs ai + # (act_cc, _, ai) = consumerRequirements arg common_defs ai + ai = aiUnifyClassifications form_cc act_cc ai + = reqs_of_args fun_idx (inc arg_idx) ccs args (combineClasses act_cc cumm_arg_class) common_defs ai +reqs_of_args _ _ cc xp _ _ _ = abort "classify:reqs_of_args doesn't match" ---> (cc,xp) instance consumerRequirements Case where consumerRequirements kees=:{case_expr,case_guards,case_default,case_info_ptr,case_explicit} @@ -375,7 +532,7 @@ instance consumerRequirements Case where # (cce, _, ai) = consumerRequirements case_expr ro ai #! env_counts = ai.ai_cur_ref_counts (s,env_counts) = usize env_counts - zero_array = createArray s 0 + zero_array = n_zero_counts s ai = {ai & ai_cur_ref_counts = zero_array} (ccd, default_is_unsafe, ai) = consumerRequirements case_default ro ai # (ccgs, unsafe_bits, guard_counts, ai) @@ -384,7 +541,7 @@ instance consumerRequirements Case where # (every_constructor_appears_in_safe_pattern, may_be_active) = inspect_patterns common_defs_parameter has_default case_guards unsafe_bits ref_counts = combine_pattern_counts has_default case_guards unsafe_bits guard_counts default_counts - ref_counts = combine_counts s ref_counts env_counts + ref_counts = combine_counts ref_counts env_counts ai = {ai & ai_cur_ref_counts = ref_counts } safe = case_explicit || (has_default && not default_is_unsafe) || every_constructor_appears_in_safe_pattern ai = aiUnifyClassifications (SwitchMultimatchClassification @@ -436,22 +593,6 @@ instance consumerRequirements Case where has_default = case case_default of Yes _ -> True _ -> False -// use_context_default = not (case_explicit || has_default) - - combine_counts :: !Int !*{#Int} !{#Int} -> *{#Int} - combine_counts 0 accu env - = accu - combine_counts i accu env - #! i1 = dec i - rca = accu.[i1] - rce = env.[i1] - accu = { accu & [i1] = unify_counts rca rce } - = combine_counts i1 accu env - where - unify_counts :: !Int !Int -> Int - unify_counts 0 x = x - unify_counts 1 x = if (x==2) 2 (inc x) - unify_counts 2 x = 2 inspect_patterns :: !{#.CommonDefs} !.Bool !.CasePatterns ![.Bool] -> (!.Bool,!Bool) inspect_patterns common_defs has_default (AlgebraicPatterns {glob_object, glob_module} algebraic_patterns) unsafe_bits @@ -539,10 +680,10 @@ instance consumerRequirements Case where = True = multimatch_loop has_default (dropWhile (\(ds_index,_,_)->ds_index==cip) constructors_in_pattern) -combine_pattern_counts :: !.Bool !.CasePatterns ![.Bool] ![{#.Int}] !{#Int} -> *{#Int} +combine_pattern_counts :: !.Bool !.CasePatterns ![.Bool] ![RefCounts] !RefCounts -> *RefCounts combine_pattern_counts has_default patterns unsafe_bits guard_counts default_counts | not ok_pattern_type - = createArray (size default_counts) 2 + = n_twos_counts (size default_counts) # sorted_pattern_constructors` = sort3 pattern_constructors unsafe_bits guard_counts # initial_count = case has_default of True -> default_counts @@ -550,8 +691,6 @@ combine_pattern_counts has_default patterns unsafe_bits guard_counts default_cou = count_loop default_counts initial_count sorted_pattern_constructors` where - rc2str (a,b,c,d) = (a,b,c,display d) - ok_pattern_type = case patterns of (AlgebraicPatterns _ _) -> True @@ -578,7 +717,7 @@ where _ -> abort "unsupported?!" ---> ("pattern_constructors",patterns) //[] // ??? count_size = size default_counts - zero_array = createArray count_size 0 + zero_array = n_zero_counts count_size sort3 :: !.[Int] !.[a] !.[b] -> .[(!Int,!Int,!a,!b)] sort3 constr_indices unsafe_bits counts @@ -620,45 +759,8 @@ where = count_constructor default_counts (combine_counts combined_counts counts) patterns = combine_counts combined_counts counts - combine_counts :: !RefCounts !RefCounts -> RefCounts - combine_counts c1 c2 - = {unify_counts e1 e2 \\ e1 <-: c1 & e2 <-: c2} - where - combine 0 accu env - = accu - combine i accu env - #! i1 = dec i - rca = accu.[i1] - rce = env.[i1] - accu = { accu & [i1] = unify_counts rca rce } - = combine i1 accu env - - unify_counts :: !Int !Int -> Int - unify_counts 0 x = x - unify_counts 1 x = if (x==2) 2 (inc x) - unify_counts 2 x = 2 - - unify_counts :: !RefCounts !RefCounts -> *RefCounts - unify_counts c1 c2 - = {unify_counts e1 e2 \\ e1 <-: c1 & e2 <-: c2} - where - unify :: !Int !*RefCounts !RefCounts -> *RefCounts - unify 0 accu env - = accu - unify i accu env - #! i1 = dec i - rca = accu.[i1] - rce = env.[i1] - accu = { accu & [i1] = unify_counts rce rca } - = unify i1 accu env - - unify_counts :: !Int !Int -> Int - unify_counts 0 x = x - unify_counts 1 x = if (x==0) 1 x - unify_counts 2 x = 2 - //consumer_requirements_of_guards :: !CasePatterns ConsumerAnalysisRO !*AnalyseInfo -> (!Int,.[Bool],!*AnalyseInfo) -consumer_requirements_of_guards :: !.CasePatterns !.ConsumerAnalysisRO !*AnalyseInfo -> *(!Int,!.[Bool],![{#Int}],!*AnalyseInfo) +consumer_requirements_of_guards :: !.CasePatterns !.ConsumerAnalysisRO !*AnalyseInfo -> *(!Int,!.[Bool],![RefCounts],!*AnalyseInfo) consumer_requirements_of_guards (AlgebraicPatterns type patterns) common_defs ai # pattern_exprs = [ ap_expr \\ {ap_expr}<-patterns] @@ -700,18 +802,18 @@ independentConsumerRequirements :: !.[Expression] !ConsumerAnalysisRO !*AnalyseI independentConsumerRequirements exprs info ai # ref_counts = ai.ai_cur_ref_counts # (count_size,ref_counts) = usize ref_counts - # zero_array = createArray count_size 0 + # zero_array = n_zero_counts count_size # (counts_unsafe,(cc,ai)) = mapSt cons_reqs exprs (CPassive,{ ai & ai_cur_ref_counts = zero_array}) # (counts,unsafe) = unzip counts_unsafe = (cc,unsafe,counts,{ ai & ai_cur_ref_counts = ref_counts}) where - cons_reqs :: !Expression !*(!.Int,!*AnalyseInfo) -> *(!.(!{#Int},!Bool),!*(!Int,!*AnalyseInfo)) + cons_reqs :: !Expression !*(!.Int,!*AnalyseInfo) -> *(!.(!RefCounts,!Bool),!*(!Int,!*AnalyseInfo)) cons_reqs expr (cc,ai) # (cce, unsafe, ai) = consumerRequirements expr info ai # cc = combineClasses cce cc # ref_counts = ai.ai_cur_ref_counts # count_size = size ref_counts - # zero_array = createArray count_size 0 + # zero_array = n_zero_counts count_size = ((ref_counts,unsafe),(cc, { ai & ai_cur_ref_counts=zero_array })) instance consumerRequirements DynamicExpr where @@ -780,19 +882,32 @@ where , ai_next_var_of_fun = 0 , ai_cases_of_vars_for_function = [] , ai_fun_heap = newHeap - , ai_def_ref_counts = {} + , ai_fun_defs = fun_defs + , ai_group_members = group_members + , ai_group_counts = createArray (length group_members) {} +// , ai_def_ref_counts = {} } - # (ai_cases_of_vars_for_group, ai, fun_defs) - = foldSt (analyse_functions common_defs) group_members ([], ai, fun_defs) - + # (_,ai_cases_of_vars_for_group, rev_strictness_for_group, ai) + = foldSt (analyse_functions common_defs) group_members (0, [], [], ai) + ai_group_counts + = ai.ai_group_counts + ai_group_counts + = replace_global_idx_by_group_idx group_members ai_group_counts + #! + ai_group_counts + = substitute_dep_counts group_members ai_group_counts + ai = { ai & ai_group_counts = ai_group_counts} + + # (_,_,ai) + = foldSt set_linearity_info_for_group group_members (0,reverse rev_strictness_for_group,ai) class_env = ai.ai_cons_class class_env = foldSt (collect_classifications ai.ai_class_subst) group_members class_env (cleanup_info, class_env, fun_defs, var_heap, expr_heap) = foldSt (set_case_expr_info ai.ai_class_subst) (flatten ai_cases_of_vars_for_group) - (cleanup_info, class_env, fun_defs, ai.ai_var_heap, expr_heap) + (cleanup_info, class_env, ai.ai_fun_defs, ai.ai_var_heap, expr_heap) = (cleanup_info, class_env, groups, fun_defs, var_heap, expr_heap) where //initial classification... @@ -809,38 +924,47 @@ where class_env = { class_env & [fun] = fun_class} = (next_var, nr_of_local_vars, var_heap, class_env, fun_defs) //determine classification... - analyse_functions common_defs fun (cfvog_accu, ai, fun_defs) - # (fun_def, fun_defs) = fun_defs![fun] + analyse_functions common_defs fun (fun_index, cfvog_accu, strictness_accu, ai) + # (fun_def, ai) = ai!ai_fun_defs.[fun] (TransformedBody {tb_args, tb_rhs}) = fun_def.fun_body nr_of_locals = length fun_def.fun_info.fi_local_vars nr_of_args = length tb_args ai = { ai - & ai_cur_ref_counts = createArray (nr_of_args + nr_of_locals) 0 - , ai_def_ref_counts = createArray (nr_of_args + nr_of_locals) 0 + & ai_cur_ref_counts = n_zero_counts (nr_of_args + nr_of_locals) , ai_next_var_of_fun = nr_of_args } +// ---> ("analyse",fun_def) // classify (_, _, ai) = consumerRequirements tb_rhs common_defs ai - // set linearity info based on cur_ref_counts # ai_cur_ref_counts = ai.ai_cur_ref_counts - ai_cons_class = ai.ai_cons_class - (fun_cons_class,ai_cons_class) = ai_cons_class![fun] - linear_bits = [ ref_count<2 \\ ref_count <-: ai_cur_ref_counts ] - fun_cons_class = { fun_cons_class & cc_linear_bits=linear_bits } - cc_args = add_unused_args fun_cons_class.cc_args ai_cur_ref_counts - fun_cons_class = { fun_cons_class & cc_args = cc_args } - ai_cons_class = {ai_cons_class & [fun] = fun_cons_class} - cases_of_vars_for_function = [(a,fun) \\ a <- ai.ai_cases_of_vars_for_function ] + # cases_of_vars_for_function = [(a,fun) \\ a <- ai.ai_cases_of_vars_for_function ] cfvog_accu = [cases_of_vars_for_function:cfvog_accu] + strictness_accu = [get_strictness_list fun_def:strictness_accu] + with + get_strictness_list {fun_type = Yes {st_args_strictness}} + = st_args_strictness ai = { ai - & ai_cons_class = ai_cons_class - , ai_cases_of_vars_for_function = [] + & ai_cases_of_vars_for_function = [] , ai_cur_ref_counts = {} + , ai_group_counts = {ai.ai_group_counts & [fun_index] = ai_cur_ref_counts} } - = (cfvog_accu, ai, fun_defs) + = (fun_index + 1, cfvog_accu, strictness_accu, ai) + set_linearity_info_for_group fun (fun_index,group_strictness,ai=:{ai_cons_class,ai_group_counts}) + # (fun_cons_class,ai_cons_class) = ai_cons_class![fun] + (fun_ref_counts,ai_group_counts) = ai_group_counts![fun_index] + fun_cons_class = set_linearity_info fun fun_index fun_cons_class fun_ref_counts group_strictness + ai_cons_class = {ai_cons_class & [fun] = fun_cons_class} + ai = {ai & ai_cons_class = ai_cons_class, ai_group_counts = ai_group_counts} + = (fun_index+1,group_strictness,ai) + set_linearity_info fun fun_index fun_cons_class fun_ref_counts group_strictness + # linear_bits = determine_linear_bits fun_ref_counts + fun_cons_class = { fun_cons_class & cc_linear_bits=linear_bits } + cc_args = add_unused_args fun fun_index fun_cons_class.cc_args fun_ref_counts group_strictness + fun_cons_class = { fun_cons_class & cc_args = cc_args } + = fun_cons_class //final classification... collect_classifications class_subst fun class_env # (fun_class, class_env) = class_env![fun] @@ -852,13 +976,7 @@ where # (VI_AccVar cc arg_position, var_heap) = readPtr var_info_ptr var_heap ({cc_size, cc_args, cc_linear_bits},class_env) = class_env![fun_index] (aci_linearity_of_patterns, var_heap) = get_linearity_info cc_linear_bits case_guards var_heap -//* Try always marking -// | arg_position<cc_size && (arg_position>=cc_size || cc_args!!arg_position==CActive) && cc_linear_bits!!arg_position - // mark non multimatch cases whose case_expr is an active linear function argument | ((arg_position>=cc_size && CActive==skip_indirections class_subst cc) || (arg_position<cc_size && cc_args!!arg_position==CActive)) && cc_linear_bits!!arg_position - -//*/ -// | True # aci = { aci_params = [] , aci_opt_unfolder = No @@ -926,7 +1044,6 @@ reanalyseGroups :: !{# CommonDefs} !{#{#FunType}} !Int !Int ![FunctionInfoPtr] -> (!CleanupInfo, !*{#FunDef}, !*VarHeap, !*ExpressionHeap, !*FunctionHeap, !*{!ConsClasses}, !Bool) reanalyseGroups common_defs imported_funs main_dcl_module_n stdStrictLists_module_n new_functions groups fun_defs var_heap expr_heap fun_heap class_env -// #! nr_of_groups = size groups # consumerAnalysisRO=ConsumerAnalysisRO { common_defs = common_defs , imported_funs = imported_funs @@ -951,11 +1068,24 @@ where , ai_next_var_of_fun = 0 , ai_cases_of_vars_for_function = [] , ai_fun_heap = fun_heap - , ai_def_ref_counts = {} + , ai_fun_defs = fun_defs + , ai_group_members = group_members + , ai_group_counts = createArray (length group_members) {} } - # (ai_cases_of_vars_for_group, ai, fun_defs) - = foldSt (analyse_functions common_defs) group_members ([], ai, fun_defs) + # (_, ai_cases_of_vars_for_group, rev_strictness_for_group, ai) + = foldSt (analyse_functions common_defs) group_members (0, [], [], ai) + ai_group_counts + = ai.ai_group_counts + ai_group_counts + = replace_global_idx_by_group_idx group_members ai_group_counts + #! + ai_group_counts + = substitute_dep_counts group_members ai_group_counts + ai = { ai & ai_group_counts = ai_group_counts} + + # (_,_,ai) + = foldSt set_linearity_info_for_group group_members (0,reverse rev_strictness_for_group,ai) class_env = ai.ai_cons_class @@ -965,7 +1095,7 @@ where = foldSt (collect_classifications ai.ai_class_subst) group_members (class_env,fun_heap,same,reverse old_cons_class) (cleanup_info, class_env, fun_defs, var_heap, expr_heap, fun_heap) = foldSt set_case_expr_info (flatten ai_cases_of_vars_for_group) - (cleanup_info, class_env, fun_defs, ai.ai_var_heap, expr_heap, fun_heap) + (cleanup_info, class_env, ai.ai_fun_defs, ai.ai_var_heap, expr_heap, fun_heap) = (cleanup_info, fun_defs, var_heap, expr_heap, fun_heap, class_env, same) where //initial classification... @@ -1004,7 +1134,6 @@ where set_fun_class` fun fun_class fun_heap class_env | fun < size class_env -// # class_env = { class_env & [fun] = fun_class} # (old,class_env) = replace class_env fun fun_class = (fun_heap,class_env,old) @@ -1018,49 +1147,57 @@ where = (fun_def_ptr, ti_fun_heap) = lookup_ptr fun new_functions ti_fun_heap # (FI_Function gf, fun_heap) = readPtr fun_def_ptr fun_heap -// # gf = {gf & gf_cons_args = fun_class} # (old,gf) = (gf.gf_cons_args, {gf & gf_cons_args = fun_class}) # fun_heap = writePtr fun_def_ptr (FI_Function gf) fun_heap = (fun_heap,class_env,old) //determine classification... - analyse_functions common_defs fun (cfvog_accu, ai, fun_defs) - # (fun_def, fun_defs, fun_heap) = get_fun_def fun fun_defs ai.ai_fun_heap - ai = {ai & ai_fun_heap = fun_heap} + analyse_functions common_defs fun (fun_index, cfvog_accu, strictness_accu, ai) + # (fun_def, fun_defs, fun_heap) = get_fun_def fun ai.ai_fun_defs ai.ai_fun_heap + ai = {ai + & ai_fun_heap = fun_heap + , ai_fun_defs = fun_defs + } +// ---> ("reanalyse",fun_def) (TransformedBody {tb_args, tb_rhs}) = fun_def.fun_body nr_of_locals = count_locals tb_rhs 0 nr_of_args = length tb_args ai = { ai - & ai_cur_ref_counts = createArray (nr_of_args + nr_of_locals) 0 - , ai_def_ref_counts = createArray (nr_of_args + nr_of_locals) 0 + & ai_cur_ref_counts = n_zero_counts (nr_of_args + nr_of_locals) , ai_next_var_of_fun = nr_of_args } // classify (_, _, ai) = consumerRequirements tb_rhs common_defs ai - // set linearity info based on cur_ref_counts # ai_cur_ref_counts = ai.ai_cur_ref_counts - ai_cons_class = ai.ai_cons_class - - # fun_heap = ai.ai_fun_heap - # (fun_cons_class,fun_heap,ai_cons_class) = get_fun_class fun fun_heap ai_cons_class - - linear_bits = [ ref_count<2 \\ ref_count <-: ai_cur_ref_counts ] - fun_cons_class = { fun_cons_class & cc_linear_bits=linear_bits } - cc_args = add_unused_args fun_cons_class.cc_args ai_cur_ref_counts - fun_cons_class = { fun_cons_class & cc_args = cc_args } - # (fun_heap,ai_cons_class) = set_fun_class fun fun_cons_class fun_heap ai_cons_class cases_of_vars_for_function = [(a,fun) \\ a <- ai.ai_cases_of_vars_for_function ] cfvog_accu = [cases_of_vars_for_function:cfvog_accu] + strictness_accu = [get_strictness_list fun_def:strictness_accu] + with + get_strictness_list {fun_type = Yes {st_args_strictness}} + = st_args_strictness ai = { ai - & ai_cons_class = ai_cons_class - , ai_cases_of_vars_for_function = [] + & ai_cases_of_vars_for_function = [] , ai_cur_ref_counts = {} - , ai_fun_heap = fun_heap + , ai_group_counts = {ai.ai_group_counts & [fun_index] = ai_cur_ref_counts} } - = (cfvog_accu, ai, fun_defs) + = (fun_index + 1, cfvog_accu, strictness_accu, ai) + set_linearity_info_for_group fun (fun_index,group_strictness,ai=:{ai_cons_class,ai_group_counts,ai_fun_heap}) + # (fun_cons_class,ai_fun_heap,ai_cons_class) + = get_fun_class fun ai_fun_heap ai_cons_class + (fun_ref_counts,ai_group_counts) = ai_group_counts![fun_index] + fun_cons_class = set_linearity_info fun fun_index fun_cons_class fun_ref_counts group_strictness + (ai_fun_heap,ai_cons_class) = set_fun_class fun fun_cons_class ai_fun_heap ai_cons_class + ai = {ai & ai_cons_class = ai_cons_class, ai_group_counts = ai_group_counts, ai_fun_heap = ai_fun_heap} + = (fun_index+1,group_strictness,ai) + set_linearity_info fun fun_index fun_cons_class fun_ref_counts group_strictness + # linear_bits = determine_linear_bits fun_ref_counts + fun_cons_class = { fun_cons_class & cc_linear_bits=linear_bits } + cc_args = add_unused_args fun fun_index fun_cons_class.cc_args fun_ref_counts group_strictness + fun_cons_class = { fun_cons_class & cc_args = cc_args } + = fun_cons_class //final classification... collect_classifications :: !.{#Int} !Int !*(!*{!ConsClasses},!*FunctionHeap,!Bool,!u:[w:ConsClasses]) -> *(!*{!ConsClasses},!*FunctionHeap,!Bool,!v:[x:ConsClasses]), [w <= x, u <= v]; collect_classifications class_subst fun (class_env,fun_heap,same,[old_class:old_acc]) @@ -1082,11 +1219,7 @@ where # (VI_AccVar _ arg_position, var_heap) = readPtr var_info_ptr var_heap ({cc_size, cc_args, cc_linear_bits},fun_heap,class_env) = get_fun_class fun_index fun_heap class_env (aci_linearity_of_patterns, var_heap) = get_linearity_info cc_linear_bits case_guards var_heap -//* Try always marking... | arg_position<cc_size && (arg_position>=cc_size || cc_args!!arg_position==CActive) && cc_linear_bits!!arg_position - // mark non multimatch cases whose case_expr is an active linear function argument -//*/ - | True # aci = { aci_params = [] , aci_opt_unfolder = No @@ -1163,67 +1296,7 @@ where = lookup_ptr fun new_functions ti_fun_heap # (FI_Function {gf_fun_def}, fun_heap) = readPtr fun_def_ptr fun_heap - = (gf_fun_def, fun_defs, fun_heap) - -reanalyseFunction - :: !Int !FunctionInfoPtr !{# CommonDefs} !{#{#FunType}} !Int !Int !*{#FunDef} !*VarHeap !*FunctionHeap !*{!ConsClasses} - -> *(!ConsClasses,!*{#FunDef},!*VarHeap,!*FunctionHeap,!*{!ConsClasses}) -reanalyseFunction fun fun_info_ptr common_defs imported_funs main_dcl_module_n stdStrictLists_module_n fun_defs var_heap fun_heap class_env - # consumerAnalysisRO=ConsumerAnalysisRO - { common_defs = common_defs - , imported_funs = imported_funs - , main_dcl_module_n = main_dcl_module_n - , stdStrictLists_module_n = stdStrictLists_module_n - } - - # (fifun, fun_heap) = readPtr fun_info_ptr fun_heap - fun_def = case fifun of - FI_Function {gf_fun_def} -> gf_fun_def - FI_Empty -> abort "unexpected FI_Empty.\n" - - ({tb_args, tb_rhs}) = case fun_def.fun_body of - TransformedBody body -> body - body -> abort "unexpected non-Transformed body?\n" - - nr_of_locals = count_locals tb_rhs 0 - nr_of_args = length tb_args - - # (fresh_vars, next_var, var_heap) - = fresh_variables tb_args 0 0 var_heap - # fun_class = { cc_size = 0, cc_args = fresh_vars, cc_linear_bits=[], cc_producer=False} - - # (fun_info, fun_heap) = readPtr fun_info_ptr fun_heap - # fun_info = case fun_info of - FI_Function gf - -> FI_Function {gf & gf_cons_args = fun_class} - # fun_heap = writePtr fun_info_ptr fun_info fun_heap - - # ai = - { ai_var_heap = var_heap - , ai_cons_class = class_env - , ai_cur_ref_counts = createArray (nr_of_args + nr_of_locals) 0 - , ai_class_subst = createArray (nr_of_args + nr_of_locals) CPassive - , ai_next_var = next_var - , ai_next_var_of_fun = nr_of_args - , ai_cases_of_vars_for_function = [] - , ai_fun_heap = fun_heap - , ai_def_ref_counts = createArray (nr_of_args + nr_of_locals) 0 - } - - // classify - # (_, _, ai) = consumerRequirements tb_rhs consumerAnalysisRO ai - // set linearity info based on cur_ref_counts? - ai_cur_ref_counts = ai.ai_cur_ref_counts - ai_cons_class = ai.ai_cons_class - fun_cons_class = determine_classification fun_class ai.ai_class_subst - linear_bits = [ ref_count<2 \\ ref_count <-: ai_cur_ref_counts ] - fun_cons_class = { fun_cons_class & cc_linear_bits=linear_bits } - cc_args = add_unused_args fun_cons_class.cc_args ai_cur_ref_counts - fun_cons_class = { fun_cons_class & cc_args = cc_args } - cases_of_vars_for_function = [(a,fun) \\ a <- ai.ai_cases_of_vars_for_function ] - // set_case_expr_info cases_of_vars_for_function - = (fun_cons_class,fun_defs,ai.ai_var_heap,ai.ai_fun_heap,ai_cons_class) - + = (gf_fun_def, fun_defs, fun_heap) // ---> ("read",fun_def_ptr,gf_fun_def) fresh_variables :: ![.FreeVar] !Int !Int !*(Heap VarInfo) -> *(!.[Int],!Int,!*(Heap VarInfo)) fresh_variables [{fv_info_ptr} : vars] arg_position next_var_number var_heap @@ -1324,5 +1397,94 @@ where count_selector_locals _ n = n -add_unused_args args ref_counts - = [if (ref_count > 0) arg CUnused \\ arg <- args & ref_count <-: ref_counts] +add_unused_args fun fun_index args ref_counts group_strictness + = SwitchNewOld + [if (is_non_zero rc) + arg + (unused2class (collect_deps (if (arg_strictness fun_index idx group_strictness) UStrict ULazy) [!rc!]) ) + \\ arg <- args & rc <-: ref_counts & idx <- [0..]] // new + [if (is_non_zero` rc) arg CUnusedStrict \\ arg <- args & rc <-: ref_counts] // old +where + unused2class :: !UnusedStatus -> ConsClass + unused2class u = case u of + UStrict -> CUnusedStrict + ULazy -> CUnusedLazy + UMixed -> CUnusedStrict + + collect_deps :: !UnusedStatus ![!RefCount!] -> UnusedStatus + collect_deps s [|] + = s + collect_deps s [|(Par _ d):ds] + # s = collect_deps s d + | isMixed s = s + = collect_deps s ds + collect_deps s [|(Seq _ d):ds] + # s = collect_deps s d + | isMixed s = s + = collect_deps s ds + collect_deps s [|(Dep f a):ds] + # s = case arg_strictness f a group_strictness of + True/*Strict*/ -> case s of + UStrict -> UStrict + _ -> UMixed + _/*Lazy*/ -> case s of + ULazy -> ULazy + _ -> UMixed + | isMixed s = s + = collect_deps s ds + + isMixed UMixed = True + isMixed _ = False + + arg_strictness f a group_strictness + = arg_is_strict a (group_strictness!!f) + +:: UnusedStatus = UEmpty | ULazy | UStrict | UMixed + +determine_linear_bits ref_counts + = [ score` rc < 2 \\ rc <-: ref_counts] + +substitute_dep_counts group_members ai_group_counts + #! am = size ai_group_counts.[0] + (known,ai_group_counts) = build_known ai_group_counts + ai_group_counts = subst_non_zero [] 0 0 (length group_members) am known ai_group_counts + = ai_group_counts +where + build_known :: !*{!RefCounts} -> (!*{*{#Bool}},!*{!RefCounts}) + build_known t + = arrayAndElementsCopy {} (\e->(createArray (size e) False,e)) t + + subst_non_zero :: ![(!FunIndex,!ArgIndex)] !FunIndex !ArgIndex !FunIndex !ArgIndex !*{*{#Bool}} !*{!RefCounts}-> *{!RefCounts} + subst_non_zero iter fi ai fm am known rcs + | ai >= am + # fi = fi + 1 + # ai = 0 + | fi >= fm + | not (isEmpty iter) + # rcs = {{fix iter rc \\ rc <-: frcs} \\ frcs <-: rcs} + #! fi = 0 + am = size rcs.[fi] + = subst_non_zero [] fi ai fm am known rcs + = rcs + #! am = size rcs.[fi] + = subst_non_zero iter fi ai fm am known rcs + | known.[fi,ai] + = subst_non_zero iter fi (ai + 1) fm am known rcs + | SwitchNewOld (is_non_zero rcs.[fi,ai]) (is_non_zero` rcs.[fi,ai]) + # known = {known & [fi,ai] = True} + = subst_non_zero [(fi,ai):iter] fi (ai + 1) fm am known rcs + = subst_non_zero iter fi (ai + 1) fm am known rcs + + fix :: ![(!FunIndex,!ArgIndex)] !RefCount -> RefCount + fix subs rc + # rc = substitute_dep subs rc +// ---> ("substitute",fi,ai) + | score rc == 2 + = Seq 2 [|] + = rc + +is_non_zero :: !RefCount -> Bool +is_non_zero rc = score rc > 0 + +is_non_zero` :: !RefCount -> Bool +is_non_zero` rc = score` rc > 0 diff --git a/frontend/trans.icl b/frontend/trans.icl index b7d6e76..5a10bd5 100644 --- a/frontend/trans.icl +++ b/frontend/trans.icl @@ -14,7 +14,7 @@ SwitchFunctionFusion fuse dont_fuse :== fuse SwitchConstructorFusion fuse dont_fuse :== dont_fuse SwitchRnfConstructorFusion rnf linear :== rnf SwitchCurriedFusion fuse xtra dont_fuse :== fuse -SwitchExtraCurriedFusion fuse macro :== (fuse && macro)//fuse +SwitchExtraCurriedFusion fuse macro :== fuse//(fuse && macro)//fuse SwitchTrivialFusion fuse dont_fuse :== fuse SwitchUnusedFusion fuse dont_fuse :== fuse SwitchReanalyseFunction rean dont_rean :== dont_rean @@ -29,6 +29,7 @@ SwitchAlwaysIntroduceCaseFunction yes no :== no//yes SwitchNonRecFusion fuse dont_fuse :== dont_fuse SwitchHOFusion fuse dont_fuse :== fuse SwitchHOFusion` fuse dont_fuse :== fuse +SwitchStrictPossiblyAddLet strict lazy :== lazy//strict //import RWSDebug @@ -151,6 +152,7 @@ cleanup_attributes expr_info_ptr symbol_heap , ro_fun_root :: !SymbIdent // original function , ro_fun_case :: !SymbIdent // original function or possibly generated case , ro_fun_args :: ![FreeVar] // args of above + , ro_fun_vars :: ![FreeVar] // strict variables , ro_fun_geni :: !(!Int,!Int) , ro_fun_orig :: !SymbIdent // original consumer @@ -217,7 +219,8 @@ where transform (Case kees) ro ti # ti = store_type_info_of_patterns_in_heap kees ti - = transformCase kees ro ti + # (res,ti) = transformCase kees ro ti + = (res,ti) // ---> ("transform (Case kees)",Case kees,res) where store_type_info_of_patterns_in_heap {case_guards,case_info_ptr} ti = case case_guards of @@ -307,7 +310,8 @@ transformCase this_case=:{case_expr,case_guards,case_default,case_ident,case_inf _ -> transCase True (Yes aci) this_case ro ti _ -> transCase False No this_case ro ti ti = { ti & ti_symbol_heap = remove_aci_free_vars_info case_info_ptr ti.ti_symbol_heap } - = (removeNeverMatchingSubcases result_expr ro, ti) + # final_expr = removeNeverMatchingSubcases result_expr ro + = (final_expr, ti) // ---> ("transformCase",result_expr,final_expr) where is_variable (Var _) = True is_variable _ = False @@ -428,7 +432,8 @@ where possiblyFoldOuterCase` final guard_expr outer_case ro ti | final - = transformCase {outer_case & case_expr = guard_expr} ro ti + # new_case = {outer_case & case_expr = guard_expr} + = transformCase new_case ro ti // ---> ("possiblyFoldOuterCase`",Case new_case) # us = { us_var_heap = ti.ti_var_heap, us_symbol_heap = ti.ti_symbol_heap, us_opt_type_heaps = No ,us_cleanup_info=ti.ti_cleanup_info, us_local_macro_functions = No } ui = {ui_handle_aci_free_vars = LeaveThem } @@ -441,7 +446,7 @@ where _ -> us_cleanup_info ti = { ti & ti_var_heap = us.us_var_heap, ti_symbol_heap = ti_symbol_heap, ti_cleanup_info=new_cleanup_info } new_case = { outer_case & case_expr = guard_expr, case_guards=outer_guards, case_info_ptr=new_info_ptr } - = transformCase new_case ro ti + = transformCase new_case ro ti // ---> ("possiblyFoldOuterCase`",Case new_case) transCase is_active opt_aci this_case=:{case_expr = case_expr=:(App app=:{app_symb,app_args}),case_guards,case_default,case_explicit,case_ident} ro ti = case app_symb.symb_kind of @@ -663,12 +668,20 @@ where instantiate linearity app_args ap_vars ap_expr cons_type_args_strictness cons_type_args ti # zipped = zip2 ap_vars app_args - unfoldables = [ ((not (arg_is_strict i cons_type_args_strictness)) && linear) || in_normal_form app_arg \\ linear <- linearity & app_arg <- app_args & i <- [0..]] +// XXX +// unfoldables = [ ((not (arg_is_strict i cons_type_args_strictness)) && linear) || in_normal_form app_arg \\ linear <- linearity & app_arg <- app_args & i <- [0..]] +// YYY + (body_strictness,ti_fun_defs,ti_fun_heap) = body_strict ap_expr ap_vars ro ti.ti_fun_defs ti.ti_fun_heap + ti = {ti & ti_fun_defs = ti_fun_defs, ti_fun_heap = ti_fun_heap} +// ---> ("body_strictness",[if (arg_is_strict i body_strictness) '!' '.' \\ i <- [0..] & a <- ap_vars],ap_vars,ap_expr) + unfoldables = [ (arg_is_strict i body_strictness || ((not (arg_is_strict i cons_type_args_strictness))) && linear) || in_normal_form app_arg \\ linear <- linearity & app_arg <- app_args & i <- [0..]] +// ZZZ unfoldable_args = filterWith unfoldables zipped not_unfoldable = map not unfoldables non_unfoldable_args = filterWith not_unfoldable zipped ti_var_heap = foldSt (\({fv_info_ptr}, arg) -> writeVarInfo fv_info_ptr (VI_Expression arg)) unfoldable_args ti.ti_var_heap - (new_expr, ti_symbol_heap) = possibly_add_let non_unfoldable_args ap_expr not_unfoldable cons_type_args ro ti.ti_symbol_heap +// (new_expr, ti_symbol_heap) = possibly_add_let non_unfoldable_args ap_expr not_unfoldable cons_type_args ro ti.ti_symbol_heap + (new_expr, ti_symbol_heap) = possibly_add_let zipped ap_expr not_unfoldable cons_type_args ro ti.ti_symbol_heap cons_type_args_strictness unfold_state = { us_var_heap = ti_var_heap, us_symbol_heap = ti_symbol_heap, us_opt_type_heaps = No,us_cleanup_info=ti.ti_cleanup_info, us_local_macro_functions = No } ui= {ui_handle_aci_free_vars = LeaveThem } @@ -676,8 +689,45 @@ where (final_expr, ti) = transform unfolded_expr { ro & ro_root_case_mode = NotRootCase } { ti & ti_var_heap = unfold_state.us_var_heap, ti_symbol_heap = unfold_state.us_symbol_heap,ti_cleanup_info=unfold_state.us_cleanup_info } +// | False ---> ("instantiate",app_args,ap_vars,ap_expr,final_expr,unfoldables) = undef = (Yes final_expr, ti) - + where + body_strict (Var v) ap_vars ro fun_defs fun_heap + # lazy_args = insert_n_lazy_values_at_beginning (length app_args) NotStrict + # is = [i \\ i <- [0..] & var <- ap_vars | v.var_info_ptr == var.fv_info_ptr] + = case is of + [] -> (lazy_args,fun_defs,fun_heap) + [i:_] -> (add_strictness i lazy_args,fun_defs,fun_heap) + body_strict (App app) ap_vars ro fun_defs fun_heap + # (is,fun_defs,fun_heap) = app_indices app ro fun_defs fun_heap + # lazy_args = insert_n_lazy_values_at_beginning (length app_args) NotStrict + = (seq (map add_strictness is) lazy_args, fun_defs,fun_heap) + body_strict _ _ ro fun_defs fun_heap + # lazy_args = insert_n_lazy_values_at_beginning (length app_args) NotStrict + = (lazy_args,fun_defs,fun_heap) + + app_indices {app_symb,app_args} ro fun_defs fun_heap + # ({st_args_strictness,st_arity},fun_defs,fun_heap) = get_producer_type app_symb ro fun_defs fun_heap + | length app_args == st_arity + = find_indices st_args_strictness 0 app_args ro fun_defs fun_heap + = ([],fun_defs,fun_heap) + where + find_indices st_args_strictness i [] ro fun_defs fun_heap + = ([],fun_defs,fun_heap) + find_indices st_args_strictness i [e:es] ro fun_defs fun_heap + # (is,fun_defs,fun_heap) = find_index st_args_strictness i e ro fun_defs fun_heap + # (iss,fun_defs,fun_heap) = find_indices st_args_strictness (i+1) es ro fun_defs fun_heap + = (is++iss,fun_defs,fun_heap) + + find_index st_args_strictness i e ro fun_defs fun_heap + | arg_is_strict i st_args_strictness + = case e of + Var v -> ([i \\ i <- [0..] & var <- ap_vars | v.var_info_ptr == var.fv_info_ptr],fun_defs,fun_heap) + App a -> app_indices a ro fun_defs fun_heap + _ -> ([],fun_defs,fun_heap) + = ([],fun_defs,fun_heap) + + expr_or_never_matching_case (Yes match_expr) case_ident ti = (match_expr, ti) expr_or_never_matching_case No case_ident ti @@ -728,31 +778,43 @@ filterWith [False:t2] [h1:t1] filterWith _ _ = [] -possibly_add_let [] ap_expr _ _ _ ti_symbol_heap +possibly_add_let [] ap_expr _ _ _ ti_symbol_heap cons_type_args_strictness = (ap_expr, ti_symbol_heap) -possibly_add_let non_unfoldable_args ap_expr not_unfoldable cons_type_args ro ti_symbol_heap +possibly_add_let non_unfoldable_args ap_expr not_unfoldable cons_type_args ro ti_symbol_heap cons_type_args_strictness # let_type = filterWith not_unfoldable cons_type_args (new_info_ptr, ti_symbol_heap) = newPtr (EI_LetType let_type) ti_symbol_heap -/* DvA... STRICT_LET - = ( Let { let_strict_binds = [ {lb_src=lb_src, lb_dst=lb_dst, lb_position = NoPos} + = SwitchStrictPossiblyAddLet + ( Let + { let_strict_binds = [ {lb_src=lb_src, lb_dst=lb_dst, lb_position = NoPos} \\ (lb_dst,lb_src)<-non_unfoldable_args - & type <- let_type | type.at_annotation == AN_Strict + & n <- not_unfoldable + & i <- [0..] + | n && arg_is_strict i cons_type_args_strictness ] , let_lazy_binds = [ {lb_src=lb_src, lb_dst=lb_dst, lb_position = NoPos} \\ (lb_dst,lb_src)<-non_unfoldable_args - & type <- let_type | type.at_annotation == AN_None + & n <- not_unfoldable + & i <- [0..] + | n && not (arg_is_strict i cons_type_args_strictness) ] -...DvA */ - = ( Let { let_strict_binds = [] + , let_expr = ap_expr + , let_info_ptr = new_info_ptr + , let_expr_position = NoPos + } + , ti_symbol_heap + ) + ( Let { let_strict_binds = [] , let_lazy_binds = [ {lb_src=lb_src, lb_dst=lb_dst, lb_position = NoPos} - \\ (lb_dst,lb_src)<-non_unfoldable_args] + \\ (lb_dst,lb_src)<-non_unfoldable_args + & n <- not_unfoldable + | n + ] , let_expr = ap_expr , let_info_ptr = new_info_ptr , let_expr_position = NoPos } , ti_symbol_heap ) - possibly_generate_case_function :: !Case !ActiveCaseInfo !ReadOnlyTI !*TransformInfo -> *(!Expression, !*TransformInfo) possibly_generate_case_function kees=:{case_info_ptr} aci=:{aci_free_vars} ro ti=:{ti_recursion_introduced=old_ti_recursion_introduced} // | False -!-> ("possibly_generate_case_function",ro.ro_fun_root.symb_name.id_name,ro.ro_fun_case.symb_name.id_name,ro.ro_root_case_mode) @@ -816,7 +878,7 @@ possibly_generate_case_function kees=:{case_info_ptr} aci=:{aci_free_vars} ro ti ti = { ti & ti_cons_args = ti_cons_args, ti_fun_defs = ti_fun_defs, ti_fun_heap = ti_fun_heap, ti_recursion_introduced = No } (new_expr, ti) - = transformCase kees new_ro ti + = transformCase kees new_ro ti //---> ("possibly_generate_case_function",Case kees) (ti_recursion_introduced, ti) = ti!ti_recursion_introduced <-!- ("transformCaseFunction>>>",fun_ident) @@ -1088,6 +1150,13 @@ where = compare_producers (inc prod_index) nr_of_prods prods1 prods2 = cmp +instance =< Bool +where + (=<) True True = Equal + (=<) True False = Smaller + (=<) False True = Greater + (=<) False False = Equal + instance =< Producer where (=<) pr1 pr2 @@ -1219,12 +1288,12 @@ compute_args_strictness new_arg_types_array = compute_args_strictness 0 0 NotStr * GENERATE FUSED FUNCTION */ -generateFunction :: !SymbIdent !FunDef ![ConsClass] ![Bool] !{! Producer} !FunctionInfoPtr !ReadOnlyTI !*TransformInfo -> (!Index, !Int, !*TransformInfo) +generateFunction :: !SymbIdent !FunDef ![ConsClass] ![Bool] !{! Producer} !FunctionInfoPtr !ReadOnlyTI !Int !*TransformInfo -> (!Index, !Int, !*TransformInfo) generateFunction app_symb fd=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_info = {fi_group_index}} - cc_args cc_linear_bits prods fun_def_ptr ro + cc_args cc_linear_bits prods fun_def_ptr ro n_extra ti=:{ti_var_heap,ti_next_fun_nr,ti_new_functions,ti_fun_heap,ti_symbol_heap,ti_fun_defs, ti_type_heaps,ti_cons_args,ti_cleanup_info, ti_type_def_infos} -// | False--->("generating new function",fd.fun_symb.id_name,"->",ti_next_fun_nr,prods) = undef +// | False--->("generating new function",fd.fun_symb.id_name,"->",ti_next_fun_nr,prods,tb_args) = undef /* | False-!->("generating new function",fd.fun_symb.id_name,"->",ti_next_fun_nr) = undef | False-!->("with type",fd.fun_type) = undef @@ -1303,6 +1372,10 @@ generateFunction app_symb fd=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_i , das_predef = ti.ti_predef_symbols } # das = determine_args cc_linear_bits cc_args 0 prods opt_sound_function_producer_types tb_args ro das + uvar = [arg \\ prod <-: prods & arg <- tb_args | isUnused prod] + with + isUnused PR_Unused = True + isUnused _ = False new_fun_args = das.das_vars new_arg_types_array = das.das_arg_types @@ -1543,15 +1616,18 @@ generateFunction app_symb fd=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_i | False -!-> ("genFun",(tb_args,new_fun_args),args1,(args2o,args2n),args3,(resto,restn)) = undef | not (isEmpty resto) = abort "genFun:resto" | not (isEmpty restn) = abort "genFun:restn" + # ro = { ro & ro_root_case_mode = ro_root_case_mode, ro_fun_root = ro_fun, ro_fun_case = ro_fun, ro_fun_orig = app_symb, ro_fun_args = new_fun_args, + ro_fun_vars = uvar ++ [arg \\ arg <- new_fun_args & i <- [0..] | arg_is_strict i new_args_strictness], + // evt ++ verwijderde stricte arg... ro_fun_geni = (length args1,length args2n) - } + } // ---> ("genfun uvars",uvar,[arg \\ arg <- new_fun_args & i <- [0..] | arg_is_strict i new_args_strictness]) // | False ---> ("transform generated function:",ti_next_fun_nr,ro_root_case_mode) = undef -// | False -!-> ("transforming new function:",ti_next_fun_nr) = undef +// | False ---> ("transforming new function:",ti_next_fun_nr,tb_rhs) = undef // | 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, @@ -1562,52 +1638,28 @@ generateFunction app_symb fd=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_i ti_predef_symbols = ti_predef_symbols } # ti = arity_warning "generateFunction" fd.fun_symb.id_name ti_next_fun_nr new_fun_arity ti + # (tb_rhs,ti) = case n_extra of + 0 -> (tb_rhs,ti) + _ + # act_args = map f2b (reverse (take n_extra (reverse new_fun_args))) + with + f2b { fv_name, fv_info_ptr } + = Var { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = nilPtr } + -> add_args_to_fun_body act_args fresh_result_type tb_rhs ro ti + (new_fun_rhs, ti) = 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 +// | False ---> ("generated function", new_fd) = undef # new_gen_fd = { new_gen_fd & gf_fun_def = new_fd, gf_cons_args = new_fd_cons_args} - # (new_gen_fd,fun_defs,var_heap,fun_heap,cons_args) - = SwitchReanalyseFunction - (reanalyse_function new_gen_fd ti_next_fun_nr ti.ti_cons_args ti.ti_fun_heap ti.ti_fun_defs ti.ti_var_heap fi_group_index new_fun_rhs - ) - (new_gen_fd,ti.ti_fun_defs,ti.ti_var_heap,ti.ti_fun_heap,ti.ti_cons_args) - # ti = { ti - & ti_fun_heap = fun_heap <:= (fun_def_ptr, FI_Function new_gen_fd) - , ti_cons_args = cons_args - , ti_fun_defs = fun_defs - , ti_var_heap = var_heap + & ti_fun_heap = ti.ti_fun_heap <:= (fun_def_ptr, FI_Function new_gen_fd) } = (ti_next_fun_nr, new_fun_arity, ti) where - reanalyse_function new_gen_fd ti_next_fun_nr ti_cons_args ti_fun_heap ti_fun_defs ti_var_heap fi_group_index new_fun_rhs - # prs = - { prs_group = [dec ti_next_fun_nr] - , prs_cons_args = ti_cons_args - , prs_main_dcl_module_n = ro.ro_main_dcl_module_n - , prs_fun_heap = ti_fun_heap - , prs_fun_defs = ti_fun_defs - , prs_group_index = fi_group_index - } - # (safe,prs) = producerRequirements new_fun_rhs prs - # (new_fd_cons_args`,fun_defs,var_heap,fun_heap,cons_args) = reanalyseFunction - ti_next_fun_nr - fun_def_ptr - ro.ro_common_defs - ro.ro_imported_funs - ro.ro_main_dcl_module_n - ro.ro_stdStrictLists_module_n - prs.prs_fun_defs - ti_var_heap - (prs.prs_fun_heap <:= (fun_def_ptr, FI_Function new_gen_fd)) - prs.prs_cons_args - # new_gen_fd = { new_gen_fd & gf_cons_args = {new_fd_cons_args` & cc_producer = safe}} - = (new_gen_fd,fun_defs,var_heap,fun_heap,cons_args) - st_args_array :: ![AType] !StrictnessList -> .{#ATypesWithStrictness} st_args_array st_args args_strictness # strict1=Strict 1 @@ -1823,9 +1875,10 @@ determine_args [linear_bit : linear_bits] [cons_arg : cons_args] prod_index prod # das = determine_args linear_bits cons_args (inc prod_index) producers prod_atypes forms input das // # producer = if (cons_arg == CActive) (producers.[prod_index]) PR_Empty # producer = case cons_arg of - CActive -> producers.[prod_index] - CUnused -> producers.[prod_index] - _ -> PR_Empty + CActive -> producers.[prod_index] + CUnusedStrict -> producers.[prod_index] + CUnusedLazy -> producers.[prod_index] + _ -> PR_Empty = determine_arg producer prod_atype form prod_index ((linear_bit,cons_arg), input) das determine_arg @@ -1938,6 +1991,7 @@ determine_arg producer (Yes {st_args, st_args_strictness, st_result, st_attr_var # (succ, das_subst, das_type_heaps) = unify application_type arg_type type_input das_subst das_type_heaps | not succ + | False ---> ("94",application_type,arg_type,symbol) = undef = abort "sanity check nr 94 in module trans failed\n" # (attr_inequalities, das_type_heaps) = accAttrVarHeap (mapSt substitute_attr_inequality st_attr_env) das_type_heaps @@ -2069,8 +2123,9 @@ where copy_classes 0 _ = [] copy_classes n [cc:ccs] = case cc of - CUnused -> [CActive:copy_classes (dec n) ccs] - cc -> [cc:copy_classes (dec n) ccs] + CUnusedStrict -> [CActive:copy_classes (dec n) ccs] + CUnusedLazy -> [CActive:copy_classes (dec n) ccs] + cc -> [cc:copy_classes (dec n) ccs] /* build_application_type st_arity nr_context_args st_result st_args nr_of_applied_args @@ -2351,27 +2406,33 @@ transformFunctionApplication fun_def instances cc=:{cc_size, cc_args, cc_linear_ non_var (Var _) = False non_var _ = True # ok_non_rec_consumer = non_rec_consumer && safe_args - #! (producers, new_args, ti) + #! (producers, new_args, strict_let_binds, ti) = determineProducers is_applied_to_macro_fun consumer_is_curried ok_non_rec_consumer fun_def.fun_type cc_linear_bits cc_args app_args 0 (createArray cc_size PR_Empty) ro ti - #! (arity_changed,new_args,extra_args,producers,cc_args,cc_linear_bits,fun_def,ti) + #! (arity_changed,new_args,extra_args,producers,cc_args,cc_linear_bits,fun_def,n_extra,ti) = determineCurriedProducersInExtraArgs new_args extra_args is_applied_to_macro_fun producers cc_args cc_linear_bits fun_def ro ti | containsProducer cc_size producers || arity_changed # (is_new, fun_def_ptr, instances, ti_fun_heap) = tryToFindInstance producers instances ti.ti_fun_heap | is_new # ti = update_instance_info app_symb.symb_kind instances { ti & ti_fun_heap = ti_fun_heap } - # (fun_index, fun_arity, ti) = generateFunction app_symb fun_def cc_args cc_linear_bits producers fun_def_ptr ro ti + # (fun_index, fun_arity, ti) = generateFunction app_symb fun_def cc_args cc_linear_bits producers fun_def_ptr ro n_extra ti | fun_index == (-1) - = (build_application { app & app_args = app_args } extra_args, ti) + = (build_application { app & app_args = app_args } extra_args, ti) // ---> ("failed instance") # app_symb = { app_symb & symb_kind = SK_GeneratedFunction fun_def_ptr fun_index } # (app_args, extra_args) = complete_application fun_arity new_args extra_args - = transformApplication { app & app_symb = app_symb, app_args = app_args } extra_args ro ti + +// # (FI_Function {gf_fun_def},ti_fun_heap) = readPtr fun_def_ptr ti.ti_fun_heap +// # ti = {ti & ti_fun_heap = ti_fun_heap} ---> ("generated",fun_def_ptr,gf_fun_def) + + # (expr,ti) = transformApplication { app & app_symb = app_symb, app_args = app_args } extra_args ro ti + = possiblyAddStrictLetBinds expr strict_let_binds ti # (FI_Function {gf_fun_index, gf_fun_def}, ti_fun_heap) = readPtr fun_def_ptr ti_fun_heap | gf_fun_index == (-1) - = (build_application { app & app_args = app_args } extra_args, ti) + = (build_application { app & app_args = app_args } extra_args, ti) // ---> ("known failed instance") # app_symb` = { app_symb & symb_kind = SK_GeneratedFunction fun_def_ptr gf_fun_index } (app_args, extra_args) = complete_application gf_fun_def.fun_arity new_args extra_args - # ti = {ti & ti_fun_heap = ti_fun_heap } - = transformApplication { app & app_symb = app_symb`, app_args = app_args } extra_args ro ti + # ti = {ti & ti_fun_heap = ti_fun_heap } // ---> ("known instance",gf_fun_index) + # (expr,ti) = transformApplication { app & app_symb = app_symb`, app_args = app_args } extra_args ro ti + = possiblyAddStrictLetBinds expr strict_let_binds ti | SwitchTrivialFusion ro.ro_transform_fusion False = transform_trivial_function app app_args extra_args ro ti = (build_application { app & app_args = app_args } extra_args, ti) @@ -2384,6 +2445,19 @@ where is_not_caf FK_Caf = False is_not_caf _ = True + possiblyAddStrictLetBinds expr strict_lets ti + # (strict_let_binds,let_type) = unzip strict_lets + = case strict_let_binds of + [] -> (expr,ti) + _ + # (new_info_ptr, ti_symbol_heap) = newPtr (EI_LetType let_type) ti.ti_symbol_heap + ti = {ti & ti_symbol_heap = ti_symbol_heap} + -> (Let { let_strict_binds = strict_let_binds + , let_lazy_binds = [] + , let_expr = expr + , let_info_ptr = new_info_ptr + , let_expr_position = NoPos + },ti) ---> "added strict_let_binds" transform_trivial_function :: !.App ![.Expression] ![.Expression] !.ReadOnlyTI !*TransformInfo -> *(!Expression,!*TransformInfo) transform_trivial_function app=:{app_symb} app_args extra_args ro ti # (fun_def,ti_fun_defs,ti_fun_heap) = get_fun_def app_symb.symb_kind ro.ro_main_dcl_module_n ti.ti_fun_defs ti.ti_fun_heap @@ -2426,27 +2500,30 @@ is_cons_or_decons_of_UList_or_UTSList glob_object glob_module imported_funs :== let type = imported_funs.[glob_module].[glob_object].ft_type; in type.st_arity>0 && not (isEmpty type.st_context); -determineCurriedProducersInExtraArgs :: ![Expression] ![Expression] !Bool !{!.Producer} ![Int] ![Bool] !FunDef !ReadOnlyTI !*TransformInfo -> *(!Bool,![Expression],![Expression],!{!Producer},![Int],![Bool],!FunDef,!*TransformInfo) +determineCurriedProducersInExtraArgs :: ![Expression] ![Expression] !Bool !{!.Producer} ![Int] ![Bool] !FunDef !ReadOnlyTI !*TransformInfo -> *(!Bool,![Expression],![Expression],!{!Producer},![Int],![Bool],!FunDef,!Int,!*TransformInfo) determineCurriedProducersInExtraArgs new_args [] is_applied_to_macro_fun producers cc_args cc_linear_bits fun_def ro ti - = (False,new_args,[],producers,cc_args,cc_linear_bits,fun_def,ti) + = (False,new_args,[],producers,cc_args,cc_linear_bits,fun_def,0,ti) determineCurriedProducersInExtraArgs new_args extra_args is_applied_to_macro_fun producers cc_args cc_linear_bits fun_def ro ti | not (SwitchExtraCurriedFusion ro.ro_transform_fusion is_applied_to_macro_fun) - = (False,new_args,extra_args,producers,cc_args,cc_linear_bits,fun_def,ti) + = (False,new_args,extra_args,producers,cc_args,cc_linear_bits,fun_def,0,ti) # n_extra_args = length extra_args # {fun_type = Yes symbol_type=:{st_args,st_result,st_arity}} = fun_def # (ok,new_args_types,new_result_type) = get_new_args_types_from_result_type st_result n_extra_args | not ok - = (False,new_args,extra_args,producers,cc_args,cc_linear_bits,fun_def,ti) + = (False,new_args,extra_args,producers,cc_args,cc_linear_bits,fun_def,0,ti) # symbol_type = {symbol_type & st_result=new_result_type,st_args=st_args++new_args_types,st_arity=st_arity+n_extra_args} # fun_def = {fun_def & fun_type=Yes symbol_type} - # (form_args,act_args,var_heap) = create_new_args n_extra_args ti.ti_var_heap + # (form_args,var_heap) = create_new_args n_extra_args ti.ti_var_heap # ti = {ti & ti_var_heap=var_heap} - # (fun_body,ti) = add_args_to_fun_body form_args act_args new_result_type fun_def.fun_body ro ti - # fun_def = {fun_def & fun_body=fun_body} + # fun_def = case fun_def.fun_body of + TransformedBody tb + -> {fun_def & fun_body=TransformedBody + {tb & tb_args = add_args_to_fun_args form_args tb.tb_args + }} # new_producers = arrayPlusList producers [PR_Empty \\ i<-[0..n_extra_args-1]] # new_cc_args = cc_args ++ [CPassive \\ i<-[0..n_extra_args-1]] # new_cc_linear_bits = cc_linear_bits ++ [True \\ i<-[0..n_extra_args-1]] - = (True,new_args++extra_args,[],new_producers,new_cc_args,new_cc_linear_bits,fun_def,ti) + = (True,new_args++extra_args,[],new_producers,new_cc_args,new_cc_linear_bits,fun_def,n_extra_args,ti) where get_new_args_types_from_result_type type 0 = (True,[],type) @@ -2458,20 +2535,19 @@ where create_new_args n_new_args var_heap | n_new_args==0 - = ([], [], var_heap) + = ([], var_heap) # new_name = { id_name = "_a", id_info = nilPtr } (info_ptr, var_heap) = newPtr VI_Empty var_heap form_var = { fv_name = new_name, fv_info_ptr = info_ptr, fv_count = 0, fv_def_level = NotALevel } - act_var = { var_name = new_name, var_info_ptr = info_ptr, var_expr_ptr = nilPtr } - (form_vars,act_vars,var_heap) - = create_new_args (n_new_args-1) var_heap - = ([form_var : form_vars],[Var act_var : act_vars],var_heap) + (form_vars,var_heap) = create_new_args (n_new_args-1) var_heap + = ([form_var : form_vars],var_heap) - add_args_to_fun_body form_args act_args new_result_type (TransformedBody {tb_args,tb_rhs}) ro ti - # tb_args = tb_args ++ form_args - # (tb_rhs,ti) = add_arguments tb_rhs act_args new_result_type ro ti - = (TransformedBody {tb_args=tb_args,tb_rhs=tb_rhs},ti) +add_args_to_fun_args form_args tb_args + = tb_args ++ form_args +add_args_to_fun_body act_args new_result_type tb_rhs ro ti + = add_arguments tb_rhs act_args new_result_type ro ti +where add_arguments (App app=:{app_symb,app_args}) extra_args new_result_type ro ti # (form_arity,fun_defs,fun_heap) = get_arity app_symb ro ti.ti_fun_defs ti.ti_fun_heap # ti = {ti & ti_fun_defs=fun_defs,ti_fun_heap=fun_heap} @@ -2495,7 +2571,7 @@ where add_arguments (expr1 @ expr2) extra_args _ ro ti = (expr1 @ (expr2++extra_args),ti) add_arguments expr extra_args _ ro ti - = (expr @ extra_args,ti) + = (expr @ extra_args,ti) // ---> ("????",expr) add_arguments_opt No _ _ ro ti = (No,ti) add_arguments_opt (Yes expr) extra_args new_result_type ro ti @@ -2520,13 +2596,13 @@ where add_arguments_apats [] extra_args _ ro ti = ([],ti) add_arguments_apats [ap=:{ap_expr}:aps] extra_args new_result_type ro ti # (ap_expr, ti) = add_arguments ap_expr extra_args new_result_type ro ti - # (aps, ti) = add_arguments_apats aps extra_args new_result_type ro ti + # (aps, ti) = add_arguments_apats aps extra_args new_result_type ro ti = ([{ap & ap_expr = ap_expr}:aps],ti) add_arguments_bpats [] extra_args _ ro ti = ([],ti) add_arguments_bpats [bp=:{bp_expr}:bps] extra_args new_result_type ro ti # (bp_expr, ti) = add_arguments bp_expr extra_args new_result_type ro ti - # (bps, ti) = add_arguments_bpats bps extra_args new_result_type ro ti + # (bps, ti) = add_arguments_bpats bps extra_args new_result_type ro ti = ([{bp & bp_expr = bp_expr}:bps],ti) add_arguments_dpats [] extra_args _ ro ti = ([],ti) @@ -2919,27 +2995,62 @@ transformSelection selector_kind selectors expr ro ti // XXX store linear_bits and cc_args together ? -determineProducers :: !Bool !Bool !Bool !(Optional SymbolType) ![Bool] ![Int] ![Expression] !Int *{!Producer} !ReadOnlyTI !*TransformInfo -> *(!*{!Producer},![Expression],!*TransformInfo); +determineProducers :: !Bool !Bool !Bool !(Optional SymbolType) ![Bool] ![Int] ![Expression] !Int *{!Producer} !ReadOnlyTI !*TransformInfo -> *(!*{!Producer},![Expression],![(LetBind,AType)],!*TransformInfo); determineProducers _ _ _ _ _ _ [] _ producers _ ti - = (producers, [], ti) + = (producers, [], [], ti) determineProducers is_applied_to_macro_fun consumer_is_curried ok_non_rec_consumer fun_type [linear_bit : linear_bits] [ cons_arg : cons_args ] [ arg : args ] prod_index producers ro ti | cons_arg == CActive # (producers, new_arg, ti) = determine_producer is_applied_to_macro_fun consumer_is_curried ok_non_rec_consumer linear_bit arg [] prod_index producers ro ti | isProducer producers.[prod_index] - = (producers, new_arg++args, ti) - #! (producers, new_args, ti) = determineProducers is_applied_to_macro_fun consumer_is_curried ok_non_rec_consumer fun_type linear_bits cons_args args (inc prod_index) producers ro ti - = (producers, new_arg++new_args, ti) - | SwitchUnusedFusion (ro.ro_transform_fusion && cons_arg == CUnused && isLazyArg fun_type prod_index) False + = (producers, new_arg++args, [], ti) + #! (producers, new_args, lb, ti) = determineProducers is_applied_to_macro_fun consumer_is_curried ok_non_rec_consumer fun_type linear_bits cons_args args (inc prod_index) producers ro ti + = (producers, new_arg++new_args, lb, ti) + | SwitchUnusedFusion + ( ro.ro_transform_fusion + && cons_arg == CUnusedStrict + && isStrictArg fun_type prod_index + ) False + # producers = { producers & [prod_index] = PR_Unused } + # (lb,ti) = case isStrictVar arg of + True -> ([],ti) + _ # (info_ptr, ti_var_heap) = newPtr VI_Empty ti.ti_var_heap + ti = {ti & ti_var_heap = ti_var_heap} + lb = {lb_dst= + { fv_name = { id_name = "dummy_for_strict_unused", id_info = nilPtr } + , fv_info_ptr = info_ptr + , fv_count = 0 + , fv_def_level = NotALevel + } + ,lb_src=arg + ,lb_position=NoPos + } + -> ([(lb,getArgType fun_type prod_index)],ti) + + = (producers, args, lb, ti) ---> ("UnusedStrict",lb,arg,fun_type) + | SwitchUnusedFusion + ( ro.ro_transform_fusion + && cons_arg == CUnusedStrict + && not (isStrictArg fun_type prod_index) + && isStrictVar arg + ) False # producers = { producers & [prod_index] = PR_Unused } - = (producers, args, ti) - #! (producers, new_args, ti) = determineProducers is_applied_to_macro_fun consumer_is_curried ok_non_rec_consumer fun_type linear_bits cons_args args (inc prod_index) producers ro ti - = (producers, [arg : new_args], ti) + = (producers, args, [], ti) ---> ("UnusedMixed",arg,fun_type) + | SwitchUnusedFusion (ro.ro_transform_fusion && cons_arg == CUnusedLazy) False + # producers = { producers & [prod_index] = PR_Unused } + = (producers, args, [], ti) ---> ("UnusedLazy",arg,fun_type) + #! (producers, new_args, lb, ti) = determineProducers is_applied_to_macro_fun consumer_is_curried ok_non_rec_consumer fun_type linear_bits cons_args args (inc prod_index) producers ro ti + = (producers, [arg : new_args], lb, ti) where isProducer PR_Empty = False isProducer _ = True - isLazyArg No _ = True - isLazyArg (Yes {st_args_strictness}) index = not (arg_is_strict (inc index) st_args_strictness) + isStrictArg No _ = False + isStrictArg (Yes {st_args_strictness}) index = arg_is_strict index st_args_strictness + + getArgType (Yes {st_args}) index = st_args!!index + + isStrictVar (Var bv) = not (isEmpty [fv \\ fv <- ro.ro_fun_vars | fv.fv_info_ptr == bv.var_info_ptr]) + isStrictVar _ = False determine_producer is_applied_to_macro_fun consumer_is_curried ok_non_rec_consumer linear_bit arg=:(App app=:{app_info_ptr}) new_args prod_index producers ro ti | isNilPtr app_info_ptr @@ -3337,7 +3448,7 @@ where // assign group_nr to group_members # ti = ti <-!- ("transform_group",group_nr) # ti = foldSt (assign_group group_nr) group_members ti - // store old consumer classification + # (before,ti) = ti!ti_next_fun_nr // transform group_members # ti = foldSt (transform_function common_defs imported_funs) group_members ti @@ -3367,7 +3478,7 @@ where // producer annotation for finished components! # ti = reannotate_producers group_nr group_members ti = (inc group_nr,(reverse new_groups)++acc_groups,ti) - + changed_group_classification [] ti = (False,ti) changed_group_classification [fun:funs] ti @@ -3447,8 +3558,8 @@ where transform_function common_defs imported_funs fun ti # (fun_def, ro_fun, ti) = get_fun_def_and_symb_ident fun ti # ti = ti <-!- ("transform_function",fun,ro_fun,fun_def) - # (Yes {st_args}) = fun_def.fun_type - {fun_body = TransformedBody tb} = fun_def + # (Yes {st_args,st_args_strictness})= fun_def.fun_type + {fun_body = TransformedBody tb} = fun_def ti_var_heap = fold2St store_arg_type_info tb.tb_args st_args ti.ti_var_heap ro = { ro_imported_funs = imported_funs , ro_common_defs = common_defs @@ -3457,6 +3568,7 @@ where , ro_fun_case = ro_fun , ro_fun_orig = ro_fun , ro_fun_args = tb.tb_args + , ro_fun_vars = [arg \\ arg <- tb.tb_args & i <- [0..] | arg_is_strict i st_args_strictness] , ro_fun_geni = (-1,-1) , ro_main_dcl_module_n = main_dcl_module_n , ro_transform_fusion = compile_with_fusion |