diff options
| -rw-r--r-- | backend/backendconvert.icl | 19 | ||||
| -rw-r--r-- | backend/backendinterface.icl | 33 | ||||
| -rw-r--r-- | frontend/classify.dcl | 11 | ||||
| -rw-r--r-- | frontend/classify.icl | 348 | ||||
| -rw-r--r-- | frontend/convertDynamics.dcl | 6 | ||||
| -rw-r--r-- | frontend/convertDynamics.icl | 13 | ||||
| -rw-r--r-- | frontend/convertcases.dcl | 7 | ||||
| -rw-r--r-- | frontend/convertcases.icl | 25 | ||||
| -rw-r--r-- | frontend/frontend.dcl | 5 | ||||
| -rw-r--r-- | frontend/frontend.icl | 22 | ||||
| -rw-r--r-- | frontend/partition.dcl | 15 | ||||
| -rw-r--r-- | frontend/partition.icl | 310 | ||||
| -rw-r--r-- | frontend/syntax.dcl | 5 | ||||
| -rw-r--r-- | frontend/trans.dcl | 4 | ||||
| -rw-r--r-- | frontend/trans.icl | 505 |
15 files changed, 681 insertions, 647 deletions
diff --git a/backend/backendconvert.icl b/backend/backendconvert.icl index 357209f..52f2c77 100644 --- a/backend/backendconvert.icl +++ b/backend/backendconvert.icl @@ -6,11 +6,10 @@ implementation module backendconvert import code from library "backend_library" import StdEnv -// import StdDebug - import frontend import backend import backendsupport, backendpreprocess +import partition // trace macro (-*->) infixl @@ -489,7 +488,21 @@ backEndConvertModulesH predefs {fe_icl = = (backEnd -*-> "backend done") where functionIndices - = flatten [[(componentIndex, member) \\ member <- group.group_members] \\ group <-: fe_components & componentIndex <- [1..]] + = function_indices 0 fe_components + + function_indices i components + | i<size components + = function_indices2 components.[i].component_members i components + = [] + + function_indices2 (ComponentMember member members) i components + #! inc_i = i+1 + = [(inc_i,member) : function_indices2 members i components] + function_indices2 (GeneratedComponentMember member _ members) i components + #! inc_i = i+1 + = [(inc_i,member) : function_indices2 members i components] + function_indices2 NoComponentMembers i components + = function_indices (i+1) components declareOtherDclModules :: {#DclModule} Int NumberSet -> BackEnder declareOtherDclModules dcls main_dcl_module_n used_module_numbers diff --git a/backend/backendinterface.icl b/backend/backendinterface.icl index aa7bc00..41c0b1c 100644 --- a/backend/backendinterface.icl +++ b/backend/backendinterface.icl @@ -9,6 +9,7 @@ import frontend import backend import backendpreprocess, backendsupport, backendconvert import Version +import partition checkVersion :: VersionsCompatability *File -> (!Bool, !*File) checkVersion VersionsAreCompatible errorFile @@ -49,7 +50,19 @@ backEndInterface outputFileName commandLineArgs listTypes typesPath predef_symbo # varHeap = backEndPreprocess predefined_idents.[PD_DummyForStrictAliasFun] functionIndices fe_icl var_heap with - functionIndices = flatten [group.group_members \\ group <-: fe_components] + functionIndices = function_indices 0 fe_components + + function_indices i components + | i<size components + = function_indices2 components.[i].component_members i components + = [] + + function_indices2 (ComponentMember member members) i components + = [member : function_indices2 members i components] + function_indices2 (GeneratedComponentMember member _ members) i components + = [member : function_indices2 members i components] + function_indices2 NoComponentMembers i components + = function_indices (i+1) components # backEndFiles = 0 # (backEnd, backEndFiles) @@ -80,18 +93,30 @@ DictionaryToClassInfo iclModuleIndex iclModule dclModules :== , dtci_dclModules = dclModules } -optionallyPrintFunctionTypes :: ListTypesOption {#Char} DictionaryToClassInfo {!Group} {#FunDef} *AttrVarHeap *File !*BackEnd -> (*AttrVarHeap, *File, *BackEnd) +optionallyPrintFunctionTypes :: ListTypesOption {#Char} DictionaryToClassInfo {!Component} {#FunDef} *AttrVarHeap *File !*BackEnd -> (*AttrVarHeap, *File, *BackEnd) optionallyPrintFunctionTypes {lto_listTypesKind, lto_showAttributes} typesPath info components functions attrHeap outFile backEnd | lto_listTypesKind == ListTypesStrictExports || lto_listTypesKind == ListTypesAll = printFunctionTypes (lto_listTypesKind == ListTypesAll) lto_showAttributes info components functions attrHeap outFile backEnd = (attrHeap, outFile, backEnd) -printFunctionTypes :: Bool Bool DictionaryToClassInfo {!Group} {#FunDef} *AttrVarHeap *File *BackEnd -> (*AttrVarHeap, *File, *BackEnd) +printFunctionTypes :: Bool Bool DictionaryToClassInfo {!Component} {#FunDef} *AttrVarHeap *File *BackEnd -> (*AttrVarHeap, *File, *BackEnd) printFunctionTypes all attr info components functions attrHeap file backEnd = foldSt (printFunctionType all attr info) functionIndicesAndFunctions (attrHeap, file, backEnd) where functionIndicesAndFunctions - = [(member,functions.[member]) \\ group <-: components, member <- group.group_members] + = function_indices_and_functions 0 components + + function_indices_and_functions i components + | i<size components + = function_indices_and_functions2 components.[i].component_members i components + = [] + + function_indices_and_functions2 (ComponentMember member members) i components + = [(member,functions.[member]) : function_indices_and_functions2 members i components] + function_indices_and_functions2 (GeneratedComponentMember member _ members) i components + = [(member,functions.[member]) : function_indices_and_functions2 members i components] + function_indices_and_functions2 NoComponentMembers i components + = function_indices_and_functions (i+1) components printFunctionType :: Bool Bool DictionaryToClassInfo (Int, FunDef) (*AttrVarHeap, *File, *BackEnd) -> (*AttrVarHeap, *File, *BackEnd) printFunctionType all attr info (functionIndex, {fun_ident,fun_type=Yes type}) (attrHeap, file, backEnd) diff --git a/frontend/classify.dcl b/frontend/classify.dcl index c8fa829..cd603d0 100644 --- a/frontend/classify.dcl +++ b/frontend/classify.dcl @@ -1,6 +1,7 @@ definition module classify -import syntax, transform +import syntax +from partition import ::Component,::ComponentMembers CUnusedLazy :== -1 CUnusedStrict :== -2 @@ -11,14 +12,14 @@ CVarOfMultimatchCase :== -6 :: CleanupInfo :== [ExprInfoPtr] -analyseGroups :: !{# CommonDefs} !{#{#FunType}} !IndexRange !Int !Int !*{! Group} !*{#FunDef} !*VarHeap !*ExpressionHeap - -> (!CleanupInfo, !*{!ConsClasses}, !*{!Group}, !*{#FunDef}, !*VarHeap, !*ExpressionHeap) +analyseGroups :: !{# CommonDefs} !{#{#FunType}} !IndexRange !Int !Int !*{!Component} !*{#FunDef} !*VarHeap !*ExpressionHeap + -> (!CleanupInfo, !*{!ConsClasses}, !*{!Component}, !*{#FunDef}, !*VarHeap, !*ExpressionHeap) -reanalyseGroups :: !{# CommonDefs} !{#{#FunType}} !Int !Int ![FunctionInfoPtr] ![Group] !*{#FunDef} !*VarHeap !*ExpressionHeap !*FunctionHeap !*{!ConsClasses} +reanalyseGroups :: !{# CommonDefs} !{#{#FunType}} !Int !Int ![Component] !*{#FunDef} !*VarHeap !*ExpressionHeap !*FunctionHeap !*{!ConsClasses} -> (!CleanupInfo, !*{#FunDef}, !*VarHeap, !*ExpressionHeap, !*FunctionHeap, !*{!ConsClasses}, !Bool) :: *PRState = - { prs_group :: ![Int] + { prs_group :: !ComponentMembers , prs_cons_args :: !*{!ConsClasses} , prs_main_dcl_module_n :: !Int , prs_fun_heap :: !*FunctionHeap diff --git a/frontend/classify.icl b/frontend/classify.icl index 63f7590..d7c18bc 100644 --- a/frontend/classify.icl +++ b/frontend/classify.icl @@ -6,7 +6,10 @@ implementation module classify SwitchMultimatchClassification multi no_multi :== multi SwitchNewOld new old :== new -import syntax, transform +import syntax +from trans import ::Component(..),::ComponentMembers(..) +from containers import arg_is_strict +import utilities import StdStrictLists :: CleanupInfo :== [ExprInfoPtr] @@ -22,9 +25,7 @@ setExtendedExprInfo expr_info_ptr extension expr_info_heap is_nil_cons_or_decons_of_UList_or_UTSList glob_object glob_module imported_funs :== not (isEmpty imported_funs.[glob_module].[glob_object].ft_type.st_context); -/* - * ANALYSIS: only determines consumerClass; producerClasses are determined after each group is transformed. - */ +// ANALYSIS: only determines consumerClass; producerClasses are determined after each group is transformed. IsAVariable cons_class :== cons_class >= 0 @@ -117,15 +118,20 @@ replace_global_idx_by_group_idx table 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) + Par i d -> Par i [|replace rc \\ rc <|- d] + Seq i d -> Seq i [|replace rc \\ rc <|- 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] + get_index f x (ComponentMember t ts) + | t == f + = x + = get_index f (x+1) ts + get_index f x (GeneratedComponentMember t _ ts) | t == f = x = get_index f (x+1) ts + get_index f x NoComponentMembers + = abort "classify:get_index: no index for function\n" Max a m [|] = a + m @@ -220,8 +226,8 @@ where unify rc1 (Seq 0 [|]) = rc1 unify rc1 rc2 = Par 0 [|rc1,rc2] -show_counts group_members group_counts - # (_,group_counts) = foldSt show group_members (0,group_counts) +show_counts component_members group_counts + # (_,group_counts) = foldSt show component_members (0,group_counts) = group_counts where show fun (fun_index,group_counts) @@ -253,7 +259,7 @@ where , ai_fun_heap :: !*FunctionHeap , ai_fun_defs :: !*{#FunDef} - , ai_group_members :: ![Int] + , ai_group_members :: !ComponentMembers , ai_group_counts :: !*{!RefCounts} } @@ -413,7 +419,7 @@ instance consumerRequirements App where | glob_module == main_dcl_module_n | glob_object < size ai_cons_class # (fun_class, ai) = ai!ai_cons_class.[glob_object] - | isMember glob_object ai_group_members + | isComponentMember 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 @@ -467,7 +473,7 @@ instance consumerRequirements App where ai=:{ai_cons_class,ai_group_members} | glob_object < size ai_cons_class # (fun_class, ai) = ai!ai_cons_class.[glob_object] - | isMember glob_object ai_group_members + | isComponentMember 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 @@ -479,13 +485,20 @@ instance consumerRequirements App where # (FI_Function {gf_cons_args={cc_args,cc_linear_bits},gf_fun_def}, ai_fun_heap) = readPtr fun_info_ptr ai.ai_fun_heap # ai = {ai & ai_fun_heap = ai_fun_heap} - | isMember index ai_group_members + | isComponentMember 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) +isComponentMember index (ComponentMember member members) + = index==member || isComponentMember index members +isComponentMember index (GeneratedComponentMember member _ members) + = index==member || isComponentMember index members +isComponentMember index NoComponentMembers + = False + instance <<< TypeContext where (<<<) file co = file <<< co.tc_class <<< " " <<< co.tc_types <<< " <" <<< co.tc_var <<< '>' @@ -514,13 +527,14 @@ where 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_ident)) + -> abort "reqs_of_args [BoundVar]" 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) +reqs_of_args _ _ cc xp _ _ _ + = abort "classify:reqs_of_args doesn't match" instance consumerRequirements Case where consumerRequirements kees=:{case_expr,case_guards,case_default,case_info_ptr,case_explicit} @@ -847,8 +861,8 @@ instance consumerRequirements (Bind a b) | consumerRequirements a where //@ Analysis // determine consumerRequirements for functions -analyseGroups :: !{# CommonDefs} !{#{#FunType}} !IndexRange !Int !Int !*{! Group} !*{#FunDef} !*VarHeap !*ExpressionHeap - -> (!CleanupInfo, !*{! ConsClasses}, !*{! Group}, !*{#FunDef}, !*VarHeap, !*ExpressionHeap) +analyseGroups :: !{# CommonDefs} !{#{#FunType}} !IndexRange !Int !Int !*{!Component} !*{#FunDef} !*VarHeap !*ExpressionHeap + -> (!CleanupInfo, !*{! ConsClasses}, !*{!Component}, !*{#FunDef}, !*VarHeap, !*ExpressionHeap) analyseGroups common_defs imported_funs {ir_from, ir_to} main_dcl_module_n stdStrictLists_module_n groups fun_defs var_heap expr_heap #! nr_of_funs = size fun_defs + ir_from - ir_to /* Sjaak */ nr_of_groups = size groups @@ -863,11 +877,10 @@ analyseGroups common_defs imported_funs {ir_from, ir_to} main_dcl_module_n stdSt ([], class_env, 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] + # ({component_members}, groups) = groups![group_nr] # (next_var, nr_of_local_vars, var_heap, class_env, fun_defs) - = foldSt initial_cons_class group_members (0, 0, var_heap, class_env, fun_defs) + = foldComponentMembersSt initial_cons_class component_members (0, 0, var_heap, class_env, fun_defs) # ai = { ai_var_heap = var_heap , ai_cons_class = class_env @@ -878,23 +891,23 @@ where , ai_cases_of_vars_for_function = [] , ai_fun_heap = newHeap , ai_fun_defs = fun_defs - , ai_group_members = group_members - , ai_group_counts = createArray (length group_members) {} + , ai_group_members = component_members + , ai_group_counts = createArray (lengthComponentMembers component_members) {} } # (_,ai_cases_of_vars_for_group, rev_strictness_for_group, ai) - = foldSt (analyse_functions common_defs) group_members (0, [], [], ai) + = foldComponentMembersSt (analyse_function common_defs) component_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 = replace_global_idx_by_group_idx component_members ai_group_counts #! - ai_group_counts = substitute_dep_counts group_members ai_group_counts - ai = { ai & ai_group_counts = ai_group_counts} + ai_group_counts = substitute_dep_counts component_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) + = foldComponentMembersSt set_linearity_info_for_group component_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 + = foldComponentMembersSt (collect_classifications ai.ai_class_subst) component_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, ai.ai_fun_defs, ai.ai_var_heap, expr_heap) @@ -907,15 +920,14 @@ where nr_of_locals = length fun_def.fun_info.fi_local_vars nr_of_local_vars = nr_of_local_vars + nr_of_locals - - # (fresh_vars, next_var, var_heap) - = fresh_variables tb_args 0 next_var var_heap + + # (fresh_vars, next_var, var_heap) = fresh_variables tb_args 0 next_var var_heap # fun_class = { cc_size = 0, cc_args = fresh_vars, cc_linear_bits=[], cc_producer=False} 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 (fun_index, cfvog_accu, strictness_accu, ai) + analyse_function 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 @@ -1009,9 +1021,11 @@ where set_case_expr_info _ _ s = s // ...N-WAY -reanalyseGroups :: !{# CommonDefs} !{#{#FunType}} !Int !Int ![FunctionInfoPtr] ![Group] !*{#FunDef} !*VarHeap !*ExpressionHeap !*FunctionHeap !*{!ConsClasses} +:: FunctionPointerOrIndex = FunctionPointer !FunctionInfoPtr | FunctionIndex !Int + +reanalyseGroups :: !{# CommonDefs} !{#{#FunType}} !Int !Int ![Component] !*{#FunDef} !*VarHeap !*ExpressionHeap !*FunctionHeap !*{!ConsClasses} -> (!CleanupInfo, !*{#FunDef}, !*VarHeap, !*ExpressionHeap, !*FunctionHeap, !*{!ConsClasses}, !Bool) -reanalyseGroups common_defs imported_funs main_dcl_module_n stdStrictLists_module_n new_functions +reanalyseGroups common_defs imported_funs main_dcl_module_n stdStrictLists_module_n groups fun_defs var_heap expr_heap fun_heap class_env # consumerAnalysisRO=ConsumerAnalysisRO { common_defs = common_defs @@ -1019,14 +1033,14 @@ reanalyseGroups common_defs imported_funs main_dcl_module_n stdStrictLists_modul , main_dcl_module_n = main_dcl_module_n , stdStrictLists_module_n = stdStrictLists_module_n } - = foldSt (analyse_group consumerAnalysisRO) groups + = foldSt (reanalyse_group consumerAnalysisRO) groups ([], fun_defs, var_heap, expr_heap, fun_heap, class_env, True) -where - analyse_group common_defs group (cleanup_info, fun_defs, var_heap, expr_heap, fun_heap, class_env, same) - # {group_members} = group +where + reanalyse_group common_defs group (cleanup_info, fun_defs, var_heap, expr_heap, fun_heap, class_env, same) + # {component_members} = group # (next_var, nr_of_local_vars, var_heap, class_env, fun_defs, fun_heap, old_cons_class) - = foldSt initial_cons_class group_members (0, 0, var_heap, class_env, fun_defs, fun_heap, []) + = initial_cons_classes component_members (0, 0, var_heap, class_env, fun_defs, fun_heap, []) # ai = { ai_var_heap = var_heap , ai_cons_class = class_env @@ -1037,96 +1051,74 @@ where , ai_cases_of_vars_for_function = [] , ai_fun_heap = fun_heap , ai_fun_defs = fun_defs - , ai_group_members = group_members - , ai_group_counts = createArray (length group_members) {} + , ai_group_members = component_members + , ai_group_counts = createArray (lengthComponentMembers component_members) {} } - # (_, 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_cases_of_vars_for_group, rev_strictness_for_group, ai) + = reanalyse_functions component_members common_defs (0, [], [], ai) + ai_group_counts = ai.ai_group_counts + ai_group_counts = replace_global_idx_by_group_idx component_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) + ai_group_counts = substitute_dep_counts component_members ai_group_counts + ai = { ai & ai_group_counts = ai_group_counts} + + # ai = set_linearity_info_for_group component_members (0,reverse rev_strictness_for_group,ai) class_env = ai.ai_cons_class fun_heap = ai.ai_fun_heap - (class_env,fun_heap,same,_) - = foldSt (collect_classifications ai.ai_class_subst) group_members (class_env,fun_heap,same,reverse old_cons_class) + (class_env,fun_heap,same) + = collect_classifications component_members ai.ai_class_subst (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, 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... - initial_cons_class fun (next_var, nr_of_local_vars, var_heap, class_env, fun_defs, fun_heap, old_acc) - # (fun_def, fun_defs, fun_heap) = get_fun_def fun fun_defs fun_heap - # (TransformedBody {tb_args,tb_rhs}) = fun_def.fun_body - + initial_cons_classes (ComponentMember fun members) (next_var, nr_of_local_vars, var_heap, class_env, fun_defs, fun_heap, old_acc) + # (fun_def,fun_defs) = fun_defs![fun] + (TransformedBody {tb_args,tb_rhs}) = fun_def.fun_body nr_of_locals = count_locals tb_rhs 0 nr_of_local_vars = nr_of_local_vars + nr_of_locals - - # (fresh_vars, next_var, var_heap) - = fresh_variables tb_args 0 next_var var_heap - # fun_class = { cc_size = 0, cc_args = fresh_vars, cc_linear_bits=[], cc_producer=False} - # (fun_heap,class_env,old_class) = set_fun_class` fun fun_class fun_heap class_env - = (next_var, nr_of_local_vars, var_heap, class_env, fun_defs, fun_heap, [old_class:old_acc]) - - set_fun_class fun fun_class fun_heap class_env - | fun < size class_env - # class_env = { class_env & [fun] = fun_class} - = (fun_heap,class_env) - - # (fun_def_ptr,fun_heap) = lookup_ptr fun new_functions fun_heap - with - lookup_ptr fun [] ti_fun_heap = abort "drat" - lookup_ptr fun [fun_def_ptr:new_functions] ti_fun_heap - # (FI_Function {gf_fun_index}, ti_fun_heap) - = readPtr fun_def_ptr ti_fun_heap - | gf_fun_index == fun - = (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} - # fun_heap = writePtr fun_def_ptr (FI_Function gf) fun_heap - = (fun_heap,class_env) - - set_fun_class` fun fun_class fun_heap class_env - | fun < size class_env - # (old,class_env) = replace class_env fun fun_class - = (fun_heap,class_env,old) - - # (fun_def_ptr,fun_heap) = lookup_ptr fun new_functions fun_heap - with - lookup_ptr fun [] ti_fun_heap = abort "drat" - lookup_ptr fun [fun_def_ptr:new_functions] ti_fun_heap - # (FI_Function {gf_fun_index}, ti_fun_heap) - = readPtr fun_def_ptr ti_fun_heap - | gf_fun_index == fun - = (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 - # (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) + (fresh_vars, next_var, var_heap) = fresh_variables tb_args 0 next_var var_heap + fun_class = {cc_size = 0, cc_args = fresh_vars, cc_linear_bits=[], cc_producer=False} + (old_class,class_env) = replace class_env fun fun_class + old_acc = [old_class:old_acc] + = initial_cons_classes members (next_var, nr_of_local_vars, var_heap, class_env, fun_defs, fun_heap, old_acc) + initial_cons_classes (GeneratedComponentMember fun fun_ptr members) (next_var, nr_of_local_vars, var_heap, class_env, fun_defs, fun_heap, old_acc) + # (FI_Function gf=:{gf_fun_def,gf_cons_args},fun_heap) = readPtr fun_ptr fun_heap + (TransformedBody {tb_args,tb_rhs}) = gf_fun_def.fun_body + nr_of_locals = count_locals tb_rhs 0 + nr_of_local_vars = nr_of_local_vars + nr_of_locals + (fresh_vars, next_var, var_heap) = fresh_variables tb_args 0 next_var var_heap + fun_class = {cc_size = 0, cc_args = fresh_vars, cc_linear_bits=[], cc_producer=False} + old_acc = [gf_cons_args:old_acc] + fun_heap = writePtr fun_ptr (FI_Function {gf & gf_cons_args = fun_class}) fun_heap + = initial_cons_classes members (next_var, nr_of_local_vars, var_heap, class_env, fun_defs, fun_heap, old_acc) + initial_cons_classes NoComponentMembers (next_var, nr_of_local_vars, var_heap, class_env, fun_defs, fun_heap, old_acc) + = (next_var, nr_of_local_vars, var_heap, class_env, fun_defs, fun_heap, old_acc) //determine classification... - 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 + reanalyse_functions (ComponentMember fun members) common_defs (fun_index, cfvog_accu, strictness_accu, ai) + # ({fun_type,fun_body},ai) = ai!ai_fun_defs.[fun] + (cases_of_vars_for_function,strictness_list,ai) + = reanalyse_function fun_body fun_type (FunctionIndex fun) fun_index ai + cfvog_accu = [cases_of_vars_for_function:cfvog_accu] + strictness_accu = [strictness_list:strictness_accu] + = reanalyse_functions members common_defs (fun_index + 1, cfvog_accu, strictness_accu, ai) + reanalyse_functions (GeneratedComponentMember fun fun_ptr members) common_defs (fun_index, cfvog_accu, strictness_accu, ai) + # (FI_Function {gf_fun_def={fun_type,fun_body}}, fun_heap) = readPtr fun_ptr ai.ai_fun_heap + ai = {ai & ai_fun_heap = fun_heap} + (cases_of_vars_for_function,strictness_list,ai) + = reanalyse_function fun_body fun_type (FunctionPointer fun_ptr) fun_index ai + cfvog_accu = [cases_of_vars_for_function:cfvog_accu] + strictness_accu = [strictness_list:strictness_accu] + = reanalyse_functions members common_defs (fun_index + 1, cfvog_accu, strictness_accu, ai) + reanalyse_functions NoComponentMembers common_defs (fun_index, cfvog_accu, strictness_accu, ai) + = (cfvog_accu, strictness_accu, ai) + + reanalyse_function (TransformedBody {tb_args,tb_rhs}) (Yes {st_args_strictness}) function_pointer_or_index fun_index ai + # nr_of_locals = count_locals tb_rhs 0 nr_of_args = length tb_args ai = { ai @@ -1136,36 +1128,46 @@ where // classify (_, _, ai) = consumerRequirements tb_rhs common_defs ai # ai_cur_ref_counts = ai.ai_cur_ref_counts - 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_cases_of_vars_for_function = [] - , ai_cur_ref_counts = {} - , ai_group_counts = {ai.ai_group_counts & [fun_index] = ai_cur_ref_counts} - } - = (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) + cases_of_vars_for_function = [(a,function_pointer_or_index) \\ a <- ai.ai_cases_of_vars_for_function] + strictness_list = st_args_strictness + ai = {ai & ai_cases_of_vars_for_function = [] + , ai_cur_ref_counts = {} + , ai_group_counts = {ai.ai_group_counts & [fun_index] = ai_cur_ref_counts}} + = (cases_of_vars_for_function,strictness_list,ai) + + set_linearity_info_for_group (ComponentMember fun members) (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} + = set_linearity_info_for_group members (fun_index+1,group_strictness,ai) + set_linearity_info_for_group (GeneratedComponentMember fun fun_ptr members) (fun_index,group_strictness,ai=:{ai_group_counts,ai_fun_heap}) + # (FI_Function gf=:{gf_cons_args=fun_cons_class}, ai_fun_heap) = readPtr fun_ptr ai_fun_heap + (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 = writePtr fun_ptr (FI_Function {gf & gf_cons_args = fun_cons_class}) ai_fun_heap + ai = {ai & ai_group_counts = ai_group_counts, ai_fun_heap = ai_fun_heap} + = set_linearity_info_for_group members (fun_index+1,group_strictness,ai) + set_linearity_info_for_group NoComponentMembers (fun_index,group_strictness,ai) + = ai //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]) - # (fun_class,fun_heap,class_env) = get_fun_class fun fun_heap class_env + collect_classifications :: !ComponentMembers !.{#Int} !*(!*{!ConsClasses},!*FunctionHeap,!Bool,![ConsClasses]) -> *(!*{!ConsClasses},!*FunctionHeap,!Bool); + collect_classifications (ComponentMember fun members) class_subst (class_env,fun_heap,same,[old_class:old_acc]) + # (fun_class,class_env) = class_env![fun] + fun_class = determine_classification fun_class class_subst + class_env = {class_env & [fun] = fun_class} + same = same && equalCCs fun_class old_class + = collect_classifications members class_subst (class_env,fun_heap,same,old_acc) + collect_classifications (GeneratedComponentMember fun fun_ptr members) class_subst (class_env,fun_heap,same,[old_class:old_acc]) + # (FI_Function gf=:{gf_cons_args=fun_class}, fun_heap) = readPtr fun_ptr fun_heap fun_class = determine_classification fun_class class_subst - # (fun_heap,class_env) = set_fun_class fun fun_class fun_heap class_env - = (class_env,fun_heap,same && equalCCs fun_class old_class,old_acc) + fun_heap = writePtr fun_ptr (FI_Function {gf & gf_cons_args = fun_class}) fun_heap + same = same && equalCCs fun_class old_class + = collect_classifications members class_subst (class_env,fun_heap,same,old_acc) + collect_classifications NoComponentMembers class_subst (class_env,fun_heap,same,old_acc) + = (class_env,fun_heap,same) equalCCs l r = equalCCArgs l.cc_args r.cc_args && equalCCBits l.cc_size l.cc_linear_bits r.cc_linear_bits @@ -1177,11 +1179,12 @@ where equalCCBits 0 _ _ = True equalCCBits n [l:ls] [r:rs] = l == r && equalCCBits (dec n) ls rs - + set_case_expr_info ((safe,{case_expr=case_expr=:(Var {var_info_ptr}), case_guards, case_info_ptr}),fun_index) (cleanup_acc, class_env, fun_defs, var_heap, expr_heap, fun_heap) # (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 + ({cc_size, cc_args, cc_linear_bits},fun_heap,class_env) + = get_fun_class_using_function_pointer_or_index fun_index fun_heap class_env (aci_linearity_of_patterns, var_heap) = get_linearity_info cc_linear_bits case_guards var_heap | arg_position<cc_size && (arg_position>=cc_size || cc_args!!arg_position==CActive) && cc_linear_bits!!arg_position # aci = @@ -1194,10 +1197,12 @@ where = ([case_info_ptr:cleanup_acc], class_env, fun_defs, var_heap, setExtendedExprInfo case_info_ptr (EEI_ActiveCase aci) expr_heap, fun_heap) = (cleanup_acc, class_env, fun_defs, var_heap, expr_heap, fun_heap) + // N-WAY... set_case_expr_info ((safe,{case_expr=(App _), case_guards, case_info_ptr}),fun_index) (cleanup_acc, class_env, fun_defs, var_heap, expr_heap, fun_heap) - # ({cc_size, cc_args, cc_linear_bits},fun_heap,class_env) = get_fun_class fun_index fun_heap class_env + # ({cc_size, cc_args, cc_linear_bits},fun_heap,class_env) + = get_fun_class_using_function_pointer_or_index fun_index fun_heap class_env (aci_linearity_of_patterns, var_heap) = get_linearity_info cc_linear_bits case_guards var_heap # aci = { aci_params = [] @@ -1211,39 +1216,13 @@ where set_case_expr_info _ s = s // ...N-WAY - get_fun_class fun fun_heap class_env - | fun < size class_env - # (fun_cons_class,class_env) = class_env![fun] - = (fun_cons_class,fun_heap,class_env) - # (fun_def_ptr,fun_heap) = lookup_ptr fun new_functions fun_heap - with - lookup_ptr fun [] ti_fun_heap = abort "drat" - lookup_ptr fun [fun_def_ptr:new_functions] ti_fun_heap - # (FI_Function {gf_fun_index}, ti_fun_heap) - = readPtr fun_def_ptr ti_fun_heap - | gf_fun_index == fun - = (fun_def_ptr, ti_fun_heap) - = lookup_ptr fun new_functions ti_fun_heap - # (FI_Function {gf_cons_args}, fun_heap) = readPtr fun_def_ptr fun_heap + get_fun_class_using_function_pointer_or_index (FunctionIndex fun_index) fun_heap class_env + # (fun_cons_class,class_env) = class_env![fun_index] + = (fun_cons_class,fun_heap,class_env) + get_fun_class_using_function_pointer_or_index (FunctionPointer fun_ptr) fun_heap class_env + # (FI_Function {gf_cons_args}, fun_heap) = readPtr fun_ptr fun_heap = (gf_cons_args, fun_heap, class_env) - get_fun_def fun fun_defs fun_heap - | fun < size fun_defs - # (fun_def, fun_defs) = fun_defs![fun] - = (fun_def, fun_defs, fun_heap) - # (fun_def_ptr, fun_heap) = lookup_ptr fun new_functions fun_heap - with - lookup_ptr fun [] ti_fun_heap = abort "drat" - lookup_ptr fun [fun_def_ptr:new_functions] ti_fun_heap - # (FI_Function {gf_fun_index}, ti_fun_heap) - = readPtr fun_def_ptr ti_fun_heap - | gf_fun_index == fun - = (fun_def_ptr, ti_fun_heap) - = 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) - get_linearity_info cc_linear_bits (AlgebraicPatterns _ algebraic_patterns) var_heap = get_linearity_info_of_patterns cc_linear_bits algebraic_patterns var_heap get_linearity_info cc_linear_bits (OverloadedListPatterns _ _ algebraic_patterns) var_heap @@ -1270,6 +1249,13 @@ set_linearity_info fun fun_index fun_cons_class fun_ref_counts group_strictness cc_args = add_unused_args fun fun_index fun_cons_class.cc_args fun_ref_counts group_strictness = { fun_cons_class & cc_args = cc_args } +foldComponentMembersSt op l st :== fold_ComponentMembers_st l st + where + fold_ComponentMembers_st (ComponentMember a as) st + = fold_ComponentMembers_st as (op a st) + fold_ComponentMembers_st NoComponentMembers st + = st + fresh_variables :: ![.FreeVar] !Int !Int !*(Heap VarInfo) -> *(!.[Int],!Int,!*(Heap VarInfo)) fresh_variables [{fv_info_ptr} : vars] arg_position next_var_number var_heap # var_heap @@ -1415,10 +1401,10 @@ where determine_linear_bits ref_counts = [ score` rc < 2 \\ rc <-: ref_counts] -substitute_dep_counts group_members ai_group_counts +substitute_dep_counts component_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 = subst_non_zero [] 0 0 (lengthComponentMembers component_members) am known ai_group_counts = ai_group_counts where build_known :: !*{!RefCounts} -> (!*{*{#Bool}},!*{!RefCounts}) @@ -1460,10 +1446,16 @@ is_non_zero rc = score rc > 0 is_non_zero` :: !RefCount -> Bool is_non_zero` rc = score` rc > 0 +lengthComponentMembers members = length_ComponentMembers members 0 +where + length_ComponentMembers (ComponentMember _ members) l = length_ComponentMembers members (l+1) + length_ComponentMembers (GeneratedComponentMember _ _ members) l = length_ComponentMembers members (l+1) + length_ComponentMembers NoComponentMembers l = l + //@ producerRequirements :: *PRState = - { prs_group :: ![Int] + { prs_group :: !ComponentMembers , prs_cons_args :: !*{!ConsClasses} , prs_main_dcl_module_n :: !Int , prs_fun_heap :: !*FunctionHeap diff --git a/frontend/convertDynamics.dcl b/frontend/convertDynamics.dcl index abcc431..b44426d 100644 --- a/frontend/convertDynamics.dcl +++ b/frontend/convertDynamics.dcl @@ -4,12 +4,12 @@ definition module convertDynamics import syntax , checksupport -from transform import ::Group +from trans import ::Component :: TypeCodeVariableInfo :: DynamicValueAliasInfo convertDynamicPatternsIntoUnifyAppls :: !{# CommonDefs} !Int {#DclModule} !IclModule [String] !Int !Int - !*{!Group} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap !(Optional *File) + !*{!Component} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap !(Optional *File) -> (!*{#{#CheckedTypeDef}}, - !*{!Group},!*{#FunDef},!*PredefinedSymbols,!*VarHeap,!*TypeHeaps,!*ExpressionHeap,!(Optional *File)) + !*{!Component},!*{#FunDef},!*PredefinedSymbols,!*VarHeap,!*TypeHeaps,!*ExpressionHeap,!(Optional *File)) diff --git a/frontend/convertDynamics.icl b/frontend/convertDynamics.icl index 0704571..7eb5261 100644 --- a/frontend/convertDynamics.icl +++ b/frontend/convertDynamics.icl @@ -83,9 +83,9 @@ where = (wtis_type_heaps,wtis_type_defs,wtis_var_heap) convertDynamicPatternsIntoUnifyAppls :: !{# CommonDefs} !Int {#DclModule} !IclModule [String] !Int !Int - !*{!Group} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap !(Optional *File) + !*{!Component} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap !(Optional *File) -> (!*{#{#CheckedTypeDef}}, - !*{!Group},!*{#FunDef},!*PredefinedSymbols,!*VarHeap,!*TypeHeaps,!*ExpressionHeap,!(Optional *File)) + !*{!Component},!*{#FunDef},!*PredefinedSymbols,!*VarHeap,!*TypeHeaps,!*ExpressionHeap,!(Optional *File)) convertDynamicPatternsIntoUnifyAppls common_defs main_dcl_module_n dcl_mods icl_mod directly_imported_dcl_modules n_types_with_type_functions n_constructors_with_type_functions groups fun_defs predefined_symbols var_heap type_heaps expr_heap tcl_file @@ -121,7 +121,14 @@ where | group_nr == size groups = (groups, fun_defs_and_ci) # (group, groups) = groups![group_nr] - = convert_groups (inc group_nr) groups dynamic_representation (foldSt (convert_function group_nr dynamic_representation) group.group_members fun_defs_and_ci) + = convert_groups (inc group_nr) groups dynamic_representation + (convert_functions group.component_members group_nr dynamic_representation fun_defs_and_ci) + + convert_functions (ComponentMember member members) group_nr dynamic_representation fun_defs_and_ci + # fun_defs_and_ci = convert_function group_nr dynamic_representation member fun_defs_and_ci + = convert_functions members group_nr dynamic_representation fun_defs_and_ci + convert_functions NoComponentMembers group_nr dynamic_representation fun_defs_and_ci + = fun_defs_and_ci convert_function group_nr dynamic_representation fun (fun_defs, ci) # (fun_def, fun_defs) = fun_defs![fun] diff --git a/frontend/convertcases.dcl b/frontend/convertcases.dcl index 243b5d5..6099a65 100644 --- a/frontend/convertcases.dcl +++ b/frontend/convertcases.dcl @@ -3,13 +3,14 @@ */ definition module convertcases -import syntax, transform +import syntax +from trans import ::Component :: LetVarInfo :: LetExpressionInfo :: RefCountsInCase :: SplitsInCase -convertCasesOfFunctions :: !*{! Group} !Int !{# {# FunType} } !{# CommonDefs} !*{#FunDef} !*{#{# CheckedTypeDef}} +convertCasesOfFunctions :: !*{!Component} !Int !{# {# FunType} } !{# CommonDefs} !*{#FunDef} !*{#{# CheckedTypeDef}} !ImportedConstructors !*VarHeap !*TypeHeaps !*ExpressionHeap - -> (!ImportedFunctions, !*{! Group}, !*{#FunDef}, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap) + -> (!ImportedFunctions, !*{!Component}, !*{#FunDef}, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap) diff --git a/frontend/convertcases.icl b/frontend/convertcases.icl index ac2d9dc..9dced2e 100644 --- a/frontend/convertcases.icl +++ b/frontend/convertcases.icl @@ -26,9 +26,9 @@ addLetVars [{lb_dst} : binds] [bind_type : bind_types] bound_vars addLetVars [] [] bound_vars = bound_vars -convertCasesOfFunctions :: !*{!Group} !Int !{#{#FunType}} !{#CommonDefs} +convertCasesOfFunctions :: !*{!Component} !Int !{#{#FunType}} !{#CommonDefs} !*{#FunDef} !*{#{#CheckedTypeDef}} !ImportedConstructors !*VarHeap !*TypeHeaps !*ExpressionHeap - -> (!ImportedFunctions, !*{!Group}, + -> (!ImportedFunctions, !*{!Component}, !*{#FunDef},!*{#{#CheckedTypeDef}},!ImportedConstructors,!*VarHeap,!*TypeHeaps,!*ExpressionHeap) convertCasesOfFunctions groups main_dcl_module_n dcl_functions common_defs fun_defs imported_types imported_conses var_heap type_heaps expr_heap #! nr_of_funs = size fun_defs @@ -47,7 +47,16 @@ where // otherwise # (group, groups) = groups![group_nr] = convert_groups (inc group_nr) groups dcl_functions common_defs main_dcl_module_n - (foldSt (convert_function group_nr dcl_functions common_defs main_dcl_module_n) group.group_members fun_defs_and_ci) + (convert_functions group.component_members group_nr dcl_functions common_defs main_dcl_module_n fun_defs_and_ci) + + convert_functions (ComponentMember member members) group_nr dcl_functions common_defs main_dcl_module_n fun_defs_and_ci + # fun_defs_and_ci = convert_function group_nr dcl_functions common_defs main_dcl_module_n member fun_defs_and_ci + = convert_functions members group_nr dcl_functions common_defs main_dcl_module_n fun_defs_and_ci + convert_functions (GeneratedComponentMember member _ members) group_nr dcl_functions common_defs main_dcl_module_n fun_defs_and_ci + # fun_defs_and_ci = convert_function group_nr dcl_functions common_defs main_dcl_module_n member fun_defs_and_ci + = convert_functions members group_nr dcl_functions common_defs main_dcl_module_n fun_defs_and_ci + convert_functions NoComponentMembers group_nr dcl_functions common_defs main_dcl_module_n fun_defs_and_ci + = fun_defs_and_ci convert_function group_index dcl_functions common_defs main_dcl_module_n fun (fun_defs, collected_imports, cs) # ({fun_body,fun_type}, fun_defs) = fun_defs![fun] @@ -1231,14 +1240,14 @@ newFunctionWithType opt_id fun_bodies local_vars fun_type group_index (cs_next_f 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 = [], cc_producer = False} }))) -addNewFunctionsToGroups :: !{#.CommonDefs} FunctionHeap ![FunctionInfoPtr] !Int !*{! Group} !*{#{# CheckedTypeDef}} !ImportedFunctions !*TypeHeaps !*VarHeap - -> (!*{! Group}, ![FunDef], !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*TypeHeaps, !*VarHeap) +addNewFunctionsToGroups :: !{#.CommonDefs} FunctionHeap ![FunctionInfoPtr] !Int !*{!Component} !*{#{# CheckedTypeDef}} !ImportedFunctions !*TypeHeaps !*VarHeap + -> (!*{!Component}, ![FunDef], !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*TypeHeaps, !*VarHeap) addNewFunctionsToGroups common_defs fun_heap new_functions main_dcl_module_n groups imported_types imported_conses type_heaps var_heap = foldSt (add_new_function_to_group fun_heap common_defs) new_functions (groups, [], imported_types, imported_conses, type_heaps, var_heap) where add_new_function_to_group :: !FunctionHeap !{# CommonDefs} !FunctionInfoPtr - !(!*{! Group}, ![FunDef], !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*TypeHeaps, !*VarHeap) - -> (!*{! Group}, ![FunDef], !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*TypeHeaps, !*VarHeap) + !(!*{!Component}, ![FunDef], !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*TypeHeaps, !*VarHeap) + -> (!*{!Component}, ![FunDef], !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*TypeHeaps, !*VarHeap) add_new_function_to_group fun_heap common_defs fun_ptr (groups, fun_defs, imported_types, imported_conses, type_heaps, var_heap) # (FI_Function {gf_fun_def,gf_fun_index}) = sreadPtr fun_ptr fun_heap {fun_type = Yes ft, fun_info = {fi_group_index, fi_properties}} = gf_fun_def @@ -1246,7 +1255,7 @@ where = convertSymbolType (fi_properties bitand FI_HasTypeSpec == 0) common_defs ft main_dcl_module_n imported_types imported_conses type_heaps var_heap # (group, groups) = groups![fi_group_index] - = ({ groups & [fi_group_index] = { group & group_members = [gf_fun_index : group.group_members]} }, + = ({ groups & [fi_group_index] = { group & component_members = ComponentMember gf_fun_index group.component_members} }, [ { gf_fun_def & fun_type = Yes ft }: fun_defs], imported_types, imported_conses, type_heaps, var_heap) :: ConvertState = diff --git a/frontend/frontend.dcl b/frontend/frontend.dcl index 6a1e0a9..9aa9678 100644 --- a/frontend/frontend.dcl +++ b/frontend/frontend.dcl @@ -5,7 +5,8 @@ definition module frontend from scanner import ::SearchPaths from general import ::Optional (Yes, No) -import checksupport, transform, overloading +import checksupport, overloading +from partition import ::Component(..),::ComponentMembers :: FrontEndOptions = { feo_up_to_phase :: !FrontEndPhase @@ -18,7 +19,7 @@ import checksupport, transform, overloading :: FrontEndSyntaxTree = { fe_icl :: !IclModule , fe_dcls :: !{#DclModule} - , fe_components :: !{!Group} + , fe_components :: !{!Component} , fe_arrayInstances :: !ArrayAndListInstances } diff --git a/frontend/frontend.icl b/frontend/frontend.icl index f31fe1f..7ebdb0e 100644 --- a/frontend/frontend.icl +++ b/frontend/frontend.icl @@ -47,7 +47,7 @@ frontEndInterface options mod_ident search_paths cached_dcl_modules cached_dcl_m #! n_cached_dcl_modules=size cached_dcl_modules - # (ok, icl_mod, dcl_mods, components, cached_dcl_macros,main_dcl_module_n,heaps, predef_symbols, symbol_table, error, directly_imported_dcl_modules) + # (ok, icl_mod, dcl_mods, groups, cached_dcl_macros,main_dcl_module_n,heaps, predef_symbols, symbol_table, error, directly_imported_dcl_modules) = checkModule mod global_fun_range mod_functions support_dynamics dynamic_type_used dcl_module_n_in_cache optional_dcl_mod modules cached_dcl_modules cached_dcl_macros predef_symbols symbol_table error heaps hash_table = { hash_table & hte_symbol_heap = symbol_table} @@ -83,7 +83,7 @@ frontEndInterface options mod_ident search_paths cached_dcl_modules cached_dcl_m | options.feo_up_to_phase == FrontEndPhaseCheck # array_instances = {ali_array_first_instance_indices=[],ali_list_first_instance_indices=[],ali_tail_strict_list_first_instance_indices=[],ali_instances_range={ir_from=0,ir_to=0}} = frontSyntaxTree cached_dcl_macros dcl_mods main_dcl_module_n - predef_symbols hash_table files error io out tcl_file icl_mod dcl_mods fun_defs components array_instances heaps + predef_symbols hash_table files error io out tcl_file icl_mod dcl_mods fun_defs (groups_to_components groups) array_instances heaps # error_admin = {ea_file = error, ea_loc = [], ea_ok = True } /* @@ -130,13 +130,14 @@ frontEndInterface options mod_ident search_paths cached_dcl_modules cached_dcl_m dcl_common_defs dcl_mods = {dcl_common \\ {dcl_common} <-: dcl_mods } - #! (ti_common_defs, components, fun_defs, generic_ranges, td_infos, heaps, hash_table, predef_symbols, dcl_mods, error_admin) + #! (ti_common_defs, groups, fun_defs, generic_ranges, td_infos, heaps, hash_table, predef_symbols, dcl_mods, error_admin) = case options.feo_generics of True - -> convertGenerics main_dcl_module_n icl_used_module_numbers ti_common_defs components fun_defs + -> convertGenerics main_dcl_module_n icl_used_module_numbers ti_common_defs groups fun_defs td_infos heaps hash_table predef_symbols dcl_mods error_admin False - -> (ti_common_defs, components, fun_defs, [], td_infos, heaps, hash_table, predef_symbols, dcl_mods, error_admin) + -> (ti_common_defs, groups, fun_defs, [], td_infos, heaps, hash_table, predef_symbols, dcl_mods, error_admin) + # (icl_common, ti_common_defs) = replace copied_ti_common_defs main_dcl_module_n saved_main_dcl_common with copied_ti_common_defs :: .{#CommonDefs} // needed for Clean 2.0 to disambiguate overloading of replace @@ -161,7 +162,7 @@ frontEndInterface options mod_ident search_paths cached_dcl_modules cached_dcl_m = (No,{},{},main_dcl_module_n,predef_symbols, hash_table, files, error, io, out, tcl_file, heaps) # (ok, fun_defs, array_instances, common_defs, imported_funs, type_def_infos, heaps, predef_symbols, error,out) - = typeProgram components main_dcl_module_n fun_defs icl_function_indices.ifi_specials_indices list_inferred_types icl_common icl_import icl_qualified_imports dcl_mods icl_used_module_numbers td_infos heaps predef_symbols error out + = typeProgram groups main_dcl_module_n fun_defs icl_function_indices.ifi_specials_indices list_inferred_types icl_common icl_import icl_qualified_imports dcl_mods icl_used_module_numbers td_infos heaps predef_symbols error out | not ok = (No,{},{},main_dcl_module_n,predef_symbols, hash_table, files, error, io, out, tcl_file, heaps) @@ -214,8 +215,7 @@ frontEndInterface options mod_ident search_paths cached_dcl_modules cached_dcl_m # exported_functions = exported_global_functions ++ [dcl_instances,dcl_specials,dcl_gencases,dcl_type_funs] # (components, fun_defs, predef_symbols, var_heap, expression_heap, error_admin) = case options.feo_strip_unused of - True -> partitionateFunctions` (fun_defs -*-> "partitionateFunctions`") - exported_functions + True -> partitionateFunctions` fun_defs exported_functions main_dcl_module_n def_min def_max predef_symbols var_heap expression_heap error_admin _ -> case options.feo_fusion of @@ -314,6 +314,12 @@ frontEndInterface options mod_ident search_paths cached_dcl_modules cached_dcl_m = (pds_def, predef_symbols) = (NoIndex, predef_symbols) + groups_to_components groups + = {{component_members=group_members_to_component_members group_members} \\ {group_members}<-:groups} + where + group_members_to_component_members [e:l] = ComponentMember e (group_members_to_component_members l) + group_members_to_component_members [] = NoComponentMembers + newSymbolTable :: !Int -> *{# SymbolTableEntry} newSymbolTable size = createArray size { ste_index = NoIndex, ste_def_level = -1, ste_kind = STE_Empty, ste_previous = abort "PreviousPlaceholder"} diff --git a/frontend/partition.dcl b/frontend/partition.dcl index 4204d6e..adf07cc 100644 --- a/frontend/partition.dcl +++ b/frontend/partition.dcl @@ -2,14 +2,21 @@ definition module partition import syntax, transform -partitionateFunctions :: !*{# FunDef} ![IndexRange] -> (!*{! Group}, !*{# FunDef}) +:: Component = { component_members :: !ComponentMembers } + +:: ComponentMembers + = ComponentMember !Int !ComponentMembers + | GeneratedComponentMember !Int !FunctionInfoPtr !ComponentMembers + | NoComponentMembers + +partitionateFunctions :: !*{# FunDef} ![IndexRange] -> (!*{!Component}, !*{# FunDef}) partitionateFunctions` :: !*{# FunDef} ![IndexRange] !Index !Int !Int !*PredefinedSymbols !*VarHeap !*ExpressionHeap !*ErrorAdmin - -> (!*{! Group}, !*{# FunDef}, !*PredefinedSymbols, !*VarHeap, !*ExpressionHeap, !*ErrorAdmin) + -> (!*{!Component}, !*{# FunDef}, !*PredefinedSymbols, !*VarHeap, !*ExpressionHeap, !*ErrorAdmin) stripStrictLets :: !*{# FunDef} !*PredefinedSymbols !*VarHeap !*ExpressionHeap !*ErrorAdmin -> (!*{# FunDef}, !*PredefinedSymbols, !*VarHeap, !*ExpressionHeap, !*ErrorAdmin) partitionateFunctions`` - :: !Int !Int ![FunctionInfoPtr] !*{# FunDef} ![Int] !Index !Int !Int !*FunctionHeap !*PredefinedSymbols !*VarHeap !*ExpressionHeap !*ErrorAdmin - -> (!Int, ![Group], !*{# FunDef}, !*FunctionHeap, !*PredefinedSymbols, !*VarHeap, !*ExpressionHeap, !*ErrorAdmin) + :: !Int !Int !*{#FunDef} !ComponentMembers !Index !Int !Int !*FunctionHeap !*PredefinedSymbols !*VarHeap !*ExpressionHeap !*ErrorAdmin + -> (!Int, ![Component], !*{#FunDef}, !*FunctionHeap, !*PredefinedSymbols, !*VarHeap, !*ExpressionHeap, !*ErrorAdmin) diff --git a/frontend/partition.icl b/frontend/partition.icl index 63aeeef..0f5f02e 100644 --- a/frontend/partition.icl +++ b/frontend/partition.icl @@ -5,27 +5,25 @@ implementation module partition import syntax, transform -/* - * PARTITIONING - */ +// PARTITIONING -:: PartitioningInfo = +:: PartitioningInfo = { pi_marks :: !.{# Int} , pi_next_num :: !Int , pi_next_group :: !Int - , pi_groups :: ![[Int]] + , pi_groups :: ![ComponentMembers] , pi_deps :: ![Int] } NotChecked :== -1 -partitionateFunctions :: !*{# FunDef} ![IndexRange] -> (!*{! Group}, !*{# FunDef}) +partitionateFunctions :: !*{# FunDef} ![IndexRange] -> (!*{!Component}, !*{# FunDef}) partitionateFunctions fun_defs ranges #! max_fun_nr = size fun_defs # partitioning_info = { pi_marks = createArray max_fun_nr NotChecked, pi_deps = [], pi_next_num = 0, pi_next_group = 0, pi_groups = [] } (fun_defs, {pi_groups,pi_next_group}) = foldSt (partitionate_functions max_fun_nr) ranges (fun_defs, partitioning_info) - groups = { {group_members = group} \\ group <- reverse pi_groups } + groups = { {component_members = group} \\ group <- reverse pi_groups } = (groups, fun_defs) where partitionate_functions :: !Index !IndexRange !(!*{# FunDef}, !*PartitioningInfo) -> (!*{# FunDef}, !*PartitioningInfo) @@ -80,12 +78,12 @@ where try_to_close_group fun_index fun_nr min_dep max_fun_nr fun_defs pi=:{pi_marks, pi_deps, pi_groups, pi_next_group} | fun_nr <= min_dep # (pi_deps, pi_marks, group, fun_defs) - = close_group False False fun_index pi_deps pi_marks [] max_fun_nr pi_next_group fun_defs + = close_group False False fun_index pi_deps pi_marks NoComponentMembers max_fun_nr pi_next_group fun_defs pi = { pi & pi_deps = pi_deps, pi_marks = pi_marks, pi_next_group = inc pi_next_group, pi_groups = [group : pi_groups] } = (max_fun_nr, fun_defs, pi) = (min_dep, fun_defs, pi) where - close_group :: !Bool !Bool !Int ![Int] !*{# Int} ![Int] !Int !Int !*{# FunDef} -> (![Int], !*{# Int}, ![Int], !*{# FunDef}) + close_group :: !Bool !Bool !Int ![Int] !*{# Int} !ComponentMembers !Int !Int !*{# FunDef} -> (![Int], !*{# Int}, !ComponentMembers, !*{# FunDef}) close_group n_r_known non_recursive fun_index [d:ds] marks group max_fun_nr group_number fun_defs # marks = { marks & [d] = max_fun_nr } # (fd,fun_defs) = fun_defs![d] @@ -97,15 +95,14 @@ where # fd = { fd & fun_info.fi_group_index = group_number, fun_info.fi_properties = set_rec_prop non_recursive fd.fun_info.fi_properties} # fun_defs = { fun_defs & [d] = fd} | d == fun_index - = (ds, marks, [d : group], fun_defs) - = close_group True non_recursive fun_index ds marks [d : group] max_fun_nr group_number fun_defs - + = (ds, marks, ComponentMember d group, fun_defs) + = close_group True non_recursive fun_index ds marks (ComponentMember d group) max_fun_nr group_number fun_defs :: PartitioningInfo` = { pi_marks` :: !.{# Int} , pi_next_num` :: !Int , pi_next_group` :: !Int - , pi_groups` :: ![[Int]] + , pi_groups` :: ![ComponentMembers] , pi_deps` :: ![Int] // , pi_predef` :: !PredefSymbolsForTransform @@ -121,14 +118,14 @@ stripStrictLets fun_defs predef_symbols var_heap sym_heap error_admin , cos_symbol_heap = sym_heap , cos_error = error_admin } - # (fun_defs,collect_state) = aMapSt ref_null fun_defs collect_state + # (fun_defs,collect_state) = aMapSt determine_ref_counts fun_defs collect_state = (fun_defs,predef_symbols,collect_state.cos_var_heap, collect_state.cos_symbol_heap, collect_state.cos_error) where aMapSt f a s # (l,s) = mapSt f [e \\ e <-: a] s = ({e \\ e <- l},s) -partitionateFunctions` :: !*{# FunDef} ![IndexRange] !Index !Int !Int !*PredefinedSymbols !*VarHeap !*ExpressionHeap !*ErrorAdmin -> (!*{! Group}, !*{# FunDef}, !*PredefinedSymbols, !*VarHeap, !*ExpressionHeap, !*ErrorAdmin) +partitionateFunctions` :: !*{# FunDef} ![IndexRange] !Index !Int !Int !*PredefinedSymbols !*VarHeap !*ExpressionHeap !*ErrorAdmin -> (!*{!Component}, !*{# FunDef}, !*PredefinedSymbols, !*VarHeap, !*ExpressionHeap, !*ErrorAdmin) partitionateFunctions` fun_defs ranges main_dcl_module_n def_min def_max predef_symbols var_heap sym_heap error_admin #! max_fun_nr = size fun_defs # (cs_predef,predef_symbols) = get_predef_symbols_for_transform predef_symbols @@ -148,7 +145,7 @@ partitionateFunctions` fun_defs ranges main_dcl_module_n def_min def_max predef_ } (fun_defs, {pi_groups`,pi_next_group`,pi_collect`}) = foldSt (partitionate_functions max_fun_nr) ranges (fun_defs, partitioning_info) - groups = { {group_members = group} \\ group <- reverse pi_groups` } + groups = { {component_members = group} \\ group <- reverse pi_groups` } = (groups, fun_defs, predef_symbols, pi_collect`.cos_var_heap, pi_collect`.cos_symbol_heap, pi_collect`.cos_error) where partitionate_functions :: !Index !IndexRange !(!*{# FunDef}, !*PartitioningInfo`) -> (!*{# FunDef}, !*PartitioningInfo`) @@ -163,8 +160,7 @@ where partitionate_function :: !Int !Int !*{# FunDef} !*PartitioningInfo` -> *(!Int, !*{# FunDef}, !*PartitioningInfo`) partitionate_function fun_index max_fun_nr fun_defs pi=:{pi_next_num`,pi_collect`} # (fd, fun_defs) = fun_defs![fun_index] -// # {fi_calls} = fd.fun_info - # (fd,pi_collect`) = ref_null fd pi_collect` + # (fd,pi_collect`) = determine_ref_counts fd pi_collect` # pi = {pi & pi_collect` = pi_collect`} # fc_state = find_calls { main_dcl_module_n=main_dcl_module_n @@ -216,12 +212,12 @@ where try_to_close_group fun_index fun_nr min_dep max_fun_nr fun_defs pi=:{pi_marks`, pi_deps`, pi_groups`, pi_next_group`} | fun_nr <= min_dep # (pi_deps`, pi_marks`, group, fun_defs) - = close_group False False fun_index pi_deps` pi_marks` [] max_fun_nr pi_next_group` fun_defs + = close_group False False fun_index pi_deps` pi_marks` NoComponentMembers max_fun_nr pi_next_group` fun_defs pi = { pi & pi_deps` = pi_deps`, pi_marks` = pi_marks`, pi_next_group` = inc pi_next_group`, pi_groups` = [group : pi_groups`] } = (max_fun_nr, fun_defs, pi) = (min_dep, fun_defs, pi) where - close_group :: !Bool !Bool !Int ![Int] !*{# Int} ![Int] !Int !Int !*{# FunDef} -> (![Int], !*{# Int}, ![Int], !*{# FunDef}) + close_group :: !Bool !Bool !Int ![Int] !*{# Int} !ComponentMembers !Int !Int !*{# FunDef} -> (![Int], !*{# Int}, !ComponentMembers, !*{# FunDef}) close_group n_r_known non_recursive fun_index [d:ds] marks group max_fun_nr group_number fun_defs # marks = { marks & [d] = max_fun_nr } # (fd,fun_defs) = fun_defs![d] @@ -233,15 +229,15 @@ where # fd = { fd & fun_info.fi_group_index = group_number, fun_info.fi_properties = set_rec_prop non_recursive fd.fun_info.fi_properties} # fun_defs = { fun_defs & [d] = fd} | d == fun_index - = (ds, marks, [d : group], fun_defs) - = close_group True non_recursive fun_index ds marks [d : group] max_fun_nr group_number fun_defs + = (ds, marks, ComponentMember d group, fun_defs) + = close_group True non_recursive fun_index ds marks (ComponentMember d group) max_fun_nr group_number fun_defs :: PartitioningInfo`` = { pi_marks`` :: !.Marks , pi_next_num`` :: !Int , pi_next_group`` :: !Int - , pi_groups`` :: ![[Int]] - , pi_deps`` :: ![Int] + , pi_groups`` :: ![ComponentMembers] + , pi_deps`` :: !ComponentMembers , pi_collect`` :: !.CollectState } @@ -251,9 +247,16 @@ where create_marks max_fun_nr functions // # marks = createArray max_fun_nr max_fun_nr -// # marks = {marks & [i] = NotChecked \\ i <- functions} -// = marks - = {{m_fun = fun, m_mark = NotChecked} \\ fun <- functions} +// = {marks & [i] = NotChecked \\ i <- functions} + = {{m_fun = fun, m_mark = NotChecked} \\ fun <- component_members_to_list functions} + +component_members_to_list (ComponentMember member members) + = [member : component_members_to_list members] +component_members_to_list (GeneratedComponentMember member _ members) + = [member : component_members_to_list members] +component_members_to_list NoComponentMembers + = [] + get_mark max_fun_nr marks fun // :== marks.[fun] :== case [m_mark \\ {m_fun,m_mark} <-: marks | m_fun == fun] of @@ -263,10 +266,10 @@ set_mark marks fun val // :== { marks & [fun] = val} // :== { if (m_fun==fun) {m & m_mark = val} m \\ m=:{m_fun=m_fun} <-: marks} :== { if (m.m_fun==fun) {m & m_mark = val} m \\ m <-: marks} - -partitionateFunctions`` :: !Int !Int ![FunctionInfoPtr] !*{# FunDef} ![Int] !Index !Int !Int !*FunctionHeap !*PredefinedSymbols !*VarHeap !*ExpressionHeap !*ErrorAdmin - -> (!Int, ![Group], !*{# FunDef}, !*FunctionHeap, !*PredefinedSymbols, !*VarHeap, !*ExpressionHeap, !*ErrorAdmin) -partitionateFunctions`` max_fun_nr next_group new_functions fun_defs functions main_dcl_module_n def_min def_max fun_heap predef_symbols var_heap sym_heap error_admin + +partitionateFunctions`` :: !Int !Int !*{#FunDef} !ComponentMembers !Index !Int !Int !*FunctionHeap !*PredefinedSymbols !*VarHeap !*ExpressionHeap !*ErrorAdmin + -> (!Int, ![Component], !*{#FunDef}, !*FunctionHeap, !*PredefinedSymbols, !*VarHeap, !*ExpressionHeap, !*ErrorAdmin) +partitionateFunctions`` max_fun_nr next_group fun_defs functions main_dcl_module_n def_min def_max fun_heap predef_symbols var_heap sym_heap error_admin # marks = create_marks max_fun_nr functions # (cs_predef,predef_symbols) = get_predef_symbols_for_transform predef_symbols # collect_state = @@ -277,128 +280,127 @@ partitionateFunctions`` max_fun_nr next_group new_functions fun_defs functions m } # partitioning_info = { pi_marks`` = marks - , pi_deps`` = [] + , pi_deps`` = NoComponentMembers , pi_next_num`` = 0 , pi_next_group`` = next_group , pi_groups`` = [] , pi_collect`` = collect_state } - (fun_defs, fun_heap, {pi_groups``,pi_next_group``,pi_collect``}) = - foldSt (partitionate_functions max_fun_nr) functions (fun_defs, fun_heap, partitioning_info) - groups = [ {group_members = group} \\ group <- reverse pi_groups`` ] + (fun_defs, fun_heap, {pi_groups``,pi_next_group``,pi_collect``}) + = partitionate_component functions max_fun_nr (fun_defs, fun_heap, partitioning_info) + groups = [ {component_members = group} \\ group <- reverse pi_groups`` ] = (pi_next_group``,groups, fun_defs, fun_heap, predef_symbols, pi_collect``.cos_var_heap, pi_collect``.cos_symbol_heap, pi_collect``.cos_error) where - partitionate_functions :: !Index !Int !(!*{# FunDef}, !*FunctionHeap, !*PartitioningInfo``) -> (!*{# FunDef}, !*FunctionHeap, !*PartitioningInfo``) - partitionate_functions max_fun_nr fun (fun_defs, fun_heap, pi=:{pi_marks``}) - | get_mark max_fun_nr pi_marks`` fun == NotChecked - # (_, fun_defs, fun_heap, pi) = partitionate_function fun max_fun_nr fun_defs fun_heap pi - = (fun_defs, fun_heap, pi) - = (fun_defs, fun_heap, pi) + partitionate_component :: !ComponentMembers !Index !(!*{# FunDef}, !*FunctionHeap, !*PartitioningInfo``) -> (!*{# FunDef}, !*FunctionHeap, !*PartitioningInfo``) + partitionate_component (ComponentMember member members) max_fun_nr (fun_defs, fun_heap, pi=:{pi_marks``}) + | get_mark max_fun_nr pi_marks`` member == NotChecked + # (_, fun_defs, fun_heap, pi) = partitionate_function member max_fun_nr fun_defs fun_heap pi + = partitionate_component members max_fun_nr (fun_defs, fun_heap, pi) + = partitionate_component members max_fun_nr (fun_defs, fun_heap, pi) + partitionate_component (GeneratedComponentMember member fun_ptr members) max_fun_nr (fun_defs, fun_heap, pi=:{pi_marks``}) + | get_mark max_fun_nr pi_marks`` member == NotChecked + # (_, fun_defs, fun_heap, pi) = partitionate_generated_function member fun_ptr max_fun_nr fun_defs fun_heap pi + = partitionate_component members max_fun_nr (fun_defs, fun_heap, pi) + = partitionate_component members max_fun_nr (fun_defs, fun_heap, pi) + partitionate_component NoComponentMembers max_fun_nr (fun_defs, fun_heap, pi) + = (fun_defs, fun_heap, pi) partitionate_function :: !Int !Int !*{# FunDef} !*FunctionHeap !*PartitioningInfo`` -> *(!Int, !*{# FunDef}, !*FunctionHeap, !*PartitioningInfo``) partitionate_function fun_index max_fun_nr fun_defs fun_heap pi=:{pi_next_num``,pi_collect``} -// # (fd, fun_defs) = fun_defs![fun_index] - # (fd, fun_defs, fun_heap) = get_fun_def fun_index new_functions fun_defs fun_heap - # (fd,pi_collect``) = ref_null fd pi_collect`` - # pi = {pi & pi_collect`` = pi_collect``} - # fc_state = find_calls - { main_dcl_module_n=main_dcl_module_n - , def_min=def_min - , def_max=def_max - , fun_index=fun_index - } fd.fun_body {fun_calls = []} + # (fd,fun_defs) = fun_defs![fun_index] + (fd,pi_collect``) = determine_ref_counts fd pi_collect`` + pi = {pi & pi_collect`` = pi_collect``} + fc_state = find_calls {main_dcl_module_n=main_dcl_module_n, def_min=def_min, def_max=def_max, fun_index=fun_index} fd.fun_body {fun_calls = []} fi_calls = fc_state.fun_calls - fd = {fd & fun_info.fi_calls = fi_calls} - # (fun_defs, fun_heap) = set_fun_def fun_index fd new_functions fun_defs fun_heap + fd = {fd & fun_info.fi_calls = fi_calls} + fun_defs = {fun_defs & [fun_index] = fd} pi = push_on_dep_stack fun_index pi - (min_dep, fun_defs, fun_heap, pi) = visit_functions fi_calls max_fun_nr max_fun_nr fun_defs fun_heap pi - with - visit_functions :: ![FunCall] !Int !Int !*{# FunDef} !*FunctionHeap !*PartitioningInfo`` -> *(!Int, !*{# FunDef}, !*FunctionHeap, !*PartitioningInfo``) - visit_functions [FunCall fc_index _:funs] min_dep max_fun_nr fun_defs fun_heap pi=:{pi_marks``} - #! mark = get_mark max_fun_nr pi_marks`` fc_index - | mark == NotChecked - # (mark, fun_defs, fun_heap, pi) = partitionate_function fc_index max_fun_nr fun_defs fun_heap pi - = visit_functions funs (min min_dep mark) max_fun_nr fun_defs fun_heap pi - = visit_functions funs (min min_dep mark) max_fun_nr fun_defs fun_heap pi - - visit_functions [MacroCall module_index fc_index _:funs] min_dep max_fun_nr fun_defs fun_heap pi - = abort ("visit_functions "+++toString fd.fun_ident+++" "+++toString module_index+++" "+++toString fc_index) - - visit_functions [DclFunCall module_index fc_index:funs] min_dep max_fun_nr fun_defs fun_heap pi - = visit_functions funs min_dep max_fun_nr fun_defs fun_heap pi + = visit_functions_and_try_to_close_group fi_calls fun_index pi_next_num`` max_fun_nr fun_defs fun_heap pi + + partitionate_generated_function :: !Int !FunctionInfoPtr !Int !*{# FunDef} !*FunctionHeap !*PartitioningInfo`` -> *(!Int, !*{# FunDef}, !*FunctionHeap, !*PartitioningInfo``) + partitionate_generated_function fun_index fun_ptr max_fun_nr fun_defs fun_heap pi=:{pi_next_num``,pi_collect``} + # (FI_Function gf=:{gf_fun_def=fd}, fun_heap) = readPtr fun_ptr fun_heap + (fd,pi_collect``) = determine_ref_counts fd pi_collect`` + pi = {pi & pi_collect`` = pi_collect``} + fc_state = find_calls {main_dcl_module_n=main_dcl_module_n, def_min=def_min, def_max=def_max, fun_index=fun_index} fd.fun_body {fun_calls = []} + fi_calls = fc_state.fun_calls + fd = {fd & fun_info.fi_calls = fi_calls} + fun_heap = writePtr fun_ptr (FI_Function {gf & gf_fun_def = fd}) fun_heap + pi = push_generated_function_on_dep_stack fun_index fun_ptr pi + = visit_functions_and_try_to_close_group fi_calls fun_index pi_next_num`` max_fun_nr fun_defs fun_heap pi - visit_functions [] min_dep max_fun_nr fun_defs fun_heap pi - = (min_dep, fun_defs, fun_heap, pi) + visit_functions_and_try_to_close_group :: ![FunCall] !Int !Int !Int !*{#FunDef} !*FunctionHeap !*PartitioningInfo`` -> *(!Int,!*{#FunDef},!*FunctionHeap,!*PartitioningInfo``) + visit_functions_and_try_to_close_group fi_calls fun_index pi_next_num`` max_fun_nr fun_defs fun_heap pi + # (min_dep, fun_defs, fun_heap, pi) = visit_functions fi_calls max_fun_nr max_fun_nr fun_defs fun_heap pi = try_to_close_group fun_index pi_next_num`` min_dep max_fun_nr fun_defs fun_heap pi + visit_functions :: ![FunCall] !Int !Int !*{# FunDef} !*FunctionHeap !*PartitioningInfo`` -> *(!Int, !*{# FunDef}, !*FunctionHeap, !*PartitioningInfo``) + visit_functions [FunCall fc_index _:funs] min_dep max_fun_nr fun_defs fun_heap pi=:{pi_marks``} + #! mark = get_mark max_fun_nr pi_marks`` fc_index + | mark == NotChecked + # (mark, fun_defs, fun_heap, pi) = partitionate_function fc_index max_fun_nr fun_defs fun_heap pi + = visit_functions funs (min min_dep mark) max_fun_nr fun_defs fun_heap pi + = visit_functions funs (min min_dep mark) max_fun_nr fun_defs fun_heap pi + visit_functions [GeneratedFunCall fc_index fun_ptr:funs] min_dep max_fun_nr fun_defs fun_heap pi=:{pi_marks``} + #! mark = get_mark max_fun_nr pi_marks`` fc_index + | mark == NotChecked + # (mark, fun_defs, fun_heap, pi) = partitionate_generated_function fc_index fun_ptr max_fun_nr fun_defs fun_heap pi + = visit_functions funs (min min_dep mark) max_fun_nr fun_defs fun_heap pi + = visit_functions funs (min min_dep mark) max_fun_nr fun_defs fun_heap pi + visit_functions [DclFunCall module_index fc_index:funs] min_dep max_fun_nr fun_defs fun_heap pi + = visit_functions funs min_dep max_fun_nr fun_defs fun_heap pi + visit_functions [] min_dep max_fun_nr fun_defs fun_heap pi + = (min_dep, fun_defs, fun_heap, pi) + push_on_dep_stack :: !Int !*PartitioningInfo`` -> *PartitioningInfo``; - push_on_dep_stack fun_index pi=:{pi_deps``,pi_marks``,pi_next_num``} = - { pi - & pi_deps`` = [fun_index : pi_deps``] - , pi_marks`` = set_mark pi_marks`` fun_index pi_next_num`` - , pi_next_num`` = inc pi_next_num`` - } + push_on_dep_stack fun_index pi=:{pi_deps``,pi_marks``,pi_next_num``} + = {pi & pi_deps`` = ComponentMember fun_index pi_deps`` + , pi_marks`` = set_mark pi_marks`` fun_index pi_next_num`` + , pi_next_num`` = inc pi_next_num`` } + push_generated_function_on_dep_stack :: !Int !FunctionInfoPtr !*PartitioningInfo`` -> *PartitioningInfo``; + push_generated_function_on_dep_stack fun_index fun_ptr pi=:{pi_deps``,pi_marks``,pi_next_num``} + = {pi & pi_deps`` = GeneratedComponentMember fun_index fun_ptr pi_deps`` + , pi_marks`` = set_mark pi_marks`` fun_index pi_next_num`` + , pi_next_num`` = inc pi_next_num`` } try_to_close_group :: !Int !Int !Int !Int !*{# FunDef} !*FunctionHeap !*PartitioningInfo`` -> *(!Int, !*{# FunDef}, !*FunctionHeap, !*PartitioningInfo``) try_to_close_group fun_index fun_nr min_dep max_fun_nr fun_defs fun_heap pi=:{pi_marks``, pi_deps``, pi_groups``, pi_next_group``} | fun_nr <= min_dep # (pi_deps``, pi_marks``, group, fun_defs, fun_heap) - = close_group False False fun_index pi_deps`` pi_marks`` [] max_fun_nr pi_next_group`` fun_defs fun_heap + = close_group False False fun_index pi_deps`` pi_marks`` NoComponentMembers max_fun_nr pi_next_group`` fun_defs fun_heap pi = { pi & pi_deps`` = pi_deps``, pi_marks`` = pi_marks``, pi_next_group`` = inc pi_next_group``, pi_groups`` = [group : pi_groups``] } = (max_fun_nr, fun_defs, fun_heap, pi) = (min_dep, fun_defs, fun_heap, pi) where - close_group :: !Bool !Bool !Int ![Int] !*Marks ![Int] !Int !Int !*{# FunDef} !*FunctionHeap -> (![Int], !*Marks, ![Int], !*{# FunDef}, !*FunctionHeap) - close_group n_r_known non_recursive fun_index [d:ds] marks group max_fun_nr group_number fun_defs fun_heap + close_group :: !Bool !Bool !Int !ComponentMembers !*Marks !ComponentMembers !Int !Int !*{# FunDef} !*FunctionHeap -> (!ComponentMembers, !*Marks, !ComponentMembers, !*{# FunDef}, !*FunctionHeap) + close_group n_r_known non_recursive fun_index (ComponentMember d ds) marks group max_fun_nr group_number fun_defs fun_heap # marks = set_mark marks d max_fun_nr - # (fd, fun_defs, fun_heap) = get_fun_def d new_functions fun_defs fun_heap - # non_recursive = case n_r_known of - True -> non_recursive - _ -> case fun_index == d of - True -> isEmpty [fc \\ fc <- fd.fun_info.fi_calls | case fc of FunCall idx _ -> idx == d; _ -> False] - _ -> False - # fd = { fd & fun_info.fi_group_index = group_number, fun_info.fi_properties = set_rec_prop non_recursive fd.fun_info.fi_properties} - # (fun_defs, fun_heap) = set_fun_def d fd new_functions fun_defs fun_heap + (fun_info,fun_defs) = fun_defs![d].fun_info + non_recursive = determine_if_function_non_recursive n_r_known fun_index d fun_info.fi_calls non_recursive + fun_info = {fun_info & fi_group_index = group_number, fi_properties = set_rec_prop non_recursive fun_info.fi_properties} + fun_defs = {fun_defs & [d].fun_info = fun_info} | d == fun_index - = (ds, marks, [d : group], fun_defs, fun_heap) - = close_group True non_recursive fun_index ds marks [d : group] max_fun_nr group_number fun_defs fun_heap - - get_fun_def fun new_functions fun_defs fun_heap - | fun < size fun_defs - # (fun_def, fun_defs) = fun_defs![fun] - = (fun_def, fun_defs, fun_heap) - # (fun_def_ptr, fun_heap) = lookup_ptr fun new_functions fun_heap - with - lookup_ptr fun [] ti_fun_heap = abort "drat" - lookup_ptr fun [fun_def_ptr:new_functions] ti_fun_heap - # (FI_Function {gf_fun_index}, ti_fun_heap) - = readPtr fun_def_ptr ti_fun_heap - | gf_fun_index == fun - = (fun_def_ptr, ti_fun_heap) - = 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) - - set_fun_def fun fun_def new_functions fun_defs fun_heap - | fun < size fun_defs - = ({fun_defs & [fun] = fun_def}, fun_heap) - # (fun_def_ptr, fun_heap) = lookup_ptr fun new_functions fun_heap - with - lookup_ptr fun [] ti_fun_heap = abort "drat" - lookup_ptr fun [fun_def_ptr:new_functions] ti_fun_heap - # (FI_Function {gf_fun_index}, ti_fun_heap) - = readPtr fun_def_ptr ti_fun_heap - | gf_fun_index == fun - = (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 - # fun_heap = writePtr fun_def_ptr (FI_Function {gf & gf_fun_def = fun_def}) fun_heap - = (fun_defs, fun_heap) - -//~~~~~~~~~~~~~~ + = (ds, marks, ComponentMember d group, fun_defs, fun_heap) + = close_group True non_recursive fun_index ds marks (ComponentMember d group) max_fun_nr group_number fun_defs fun_heap + close_group n_r_known non_recursive fun_index (GeneratedComponentMember d fun_ptr ds) marks group max_fun_nr group_number fun_defs fun_heap + # marks = set_mark marks d max_fun_nr + (FI_Function gf=:{gf_fun_def={fun_info}}, fun_heap) = readPtr fun_ptr fun_heap + non_recursive = determine_if_function_non_recursive n_r_known fun_index d fun_info.fi_calls non_recursive + fun_info = {fun_info & fi_group_index = group_number, fi_properties = set_rec_prop non_recursive fun_info.fi_properties} + fun_heap = writePtr fun_ptr (FI_Function {gf & gf_fun_def.fun_info=fun_info}) fun_heap + | d == fun_index + = (ds, marks, GeneratedComponentMember d fun_ptr group, fun_defs, fun_heap) + = close_group True non_recursive fun_index ds marks (GeneratedComponentMember d fun_ptr group) max_fun_nr group_number fun_defs fun_heap + + determine_if_function_non_recursive :: !Bool !Index !Index ![FunCall] !Bool -> Bool + determine_if_function_non_recursive n_r_known fun_index d fi_calls non_recursive + | n_r_known + = non_recursive + | fun_index == d + = isEmpty [fc \\ fc <- fi_calls + | case fc of FunCall idx _ -> idx == d; GeneratedFunCall idx _ -> idx == d; _ -> False] + = False :: FindCallsInfo = { main_dcl_module_n :: !Index @@ -454,31 +456,18 @@ where = find_calls fc_info expr fc_state find_calls fc_info (BasicExpr _) fc_state = fc_state - find_calls fc_info (Conditional _) fc_state - = abort "Conditional" find_calls fc_info (AnyCodeExpr _ _ _) fc_state = fc_state find_calls fc_info (ABCCodeExpr _ _) fc_state = fc_state find_calls fc_info (MatchExpr _ expr) fc_state = find_calls fc_info expr fc_state - find_calls fc_info (FreeVar _) fc_state - = abort "FreeVar" - find_calls fc_info (Constant _ _ _) fc_state - = abort "Constant" - find_calls fc_info (ClassVariable _) fc_state - = abort "ClassVariable" - find_calls fc_info (DynamicExpr _) fc_state - = abort "DynamicExpr" - find_calls fc_info (TypeCodeExpression _) fc_state - = abort "TypeCodeExpression" - find_calls fc_info (EE) fc_state - = fc_state //abort "EE" + find_calls fc_info EE fc_state + = fc_state find_calls fc_info (NoBind _) fc_state = fc_state find_calls fc_info (FailExpr _) fc_state = fc_state - find_calls _ u _ = abort ("Undefined pattern in Expression\n") instance find_calls App where @@ -491,30 +480,11 @@ where = {fc_state & fun_calls = [FunCall glob_object 0: fc_state.fun_calls]} = {fc_state & fun_calls = [DclFunCall glob_module glob_object: fc_state.fun_calls]} get_index (SK_Constructor idx) fc_state - = fc_state - get_index (SK_Unknown) fc_state - = abort "SK_Unknown" - get_index (SK_IclMacro _) fc_state - = abort "SK_IclMacro" + = fc_state get_index (SK_LocalMacroFunction idx) fc_state - = {fc_state & fun_calls = [FunCall idx 0: fc_state.fun_calls]} -// = fc_state - get_index (SK_DclMacro _) fc_state - = abort "SK_DclMacro" - get_index (SK_LocalDclMacroFunction _) fc_state - = abort "SK_LocalDclMacroFunction" - get_index (SK_OverloadedFunction _) fc_state - = abort "SK_OverloadedFunction" - get_index (SK_GeneratedFunction _ idx) fc_state - = {fc_state & fun_calls = [FunCall idx 0: fc_state.fun_calls]} -// = fc_state -// get_index (SK_GeneratedCaseFunction _ idx) fc_state -// = {fc_state & fun_calls = [FunCall idx 0: fc_state.fun_calls]} - get_index (SK_Generic _ _) fc_state - = abort "SK_Generic" - get_index (SK_TypeCode) fc_state - = abort "SK_TypeCode" - get_index u _ = abort "Undefined pattern in get_index\n" + = {fc_state & fun_calls = [FunCall idx 0: fc_state.fun_calls]} + get_index (SK_GeneratedFunction fun_ptr idx) fc_state + = {fc_state & fun_calls = [GeneratedFunCall idx fun_ptr : fc_state.fun_calls]} instance find_calls Let where @@ -575,17 +545,17 @@ where //////////////////////// import StdDebug -ref_null fd=:{fun_body=TransformedBody {tb_args,tb_rhs}} pi_collect +determine_ref_counts fd=:{fun_body=TransformedBody {tb_args,tb_rhs}} pi_collect // | not (fst (ferror (stderr <<< fd))) -// # tb_args = tb_args ---> ("ref_null",fd.fun_ident,tb_args,tb_rhs) +// # tb_args = tb_args ---> ("determine_ref_counts",fd.fun_ident,tb_args,tb_rhs) # (new_rhs, new_args, _, _, pi_collect) = determineVariablesAndRefCounts tb_args tb_rhs pi_collect # fd = {fd & fun_body=TransformedBody {tb_args=new_args,tb_rhs=new_rhs}} = (fd,pi_collect) -ref_null fd pi_collect +determine_ref_counts fd pi_collect = (fd, pi_collect) -/////////////// from check.icl //////////////////// +// from check.icl get_predef_symbols_for_transform :: *PredefinedSymbols -> (!PredefSymbolsForTransform,!.PredefinedSymbols) // clean 2.0 does not allow this, clean 1.3 does: @@ -608,6 +578,6 @@ dummy_predef_symbols = } set_rec_prop non_recursive fi_properties - = case non_recursive of - True -> fi_properties bitor FI_IsNonRecursive - _ -> fi_properties bitand (bitnot FI_IsNonRecursive) + | non_recursive + = fi_properties bitor FI_IsNonRecursive + = fi_properties bitand (bitnot FI_IsNonRecursive) diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index 11b13b2..ddd6ef0 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -588,7 +588,10 @@ NoGlobalIndex :== {gi_module=NoIndex,gi_index=NoIndex} :: ModuleIndex:==Index; :: DclFunctionIndex:==Index; -:: FunCall = FunCall !Index !Level | MacroCall !ModuleIndex !Index Level | DclFunCall !ModuleIndex !DclFunctionIndex; +:: FunCall = FunCall !Index !Level + | MacroCall !ModuleIndex !Index Level + | DclFunCall !ModuleIndex !DclFunctionIndex + | GeneratedFunCall !Index !FunctionInfoPtr; FI_IsMacroFun :== 1 // whether the function is a local function of a macro FI_HasTypeSpec :== 2 // whether the function has u user defined type diff --git a/frontend/trans.dcl b/frontend/trans.dcl index beff8bb..96f17c7 100644 --- a/frontend/trans.dcl +++ b/frontend/trans.dcl @@ -5,9 +5,9 @@ import StdEnv import syntax, transform import classify, partition -transformGroups :: !CleanupInfo !Int !Int !Int !Int !*{!Group} !*{#FunDef} !*{!.ConsClasses} !{# CommonDefs} !{# {# FunType} } +transformGroups :: !CleanupInfo !Int !Int !Int !Int !*{!Component} !*{#FunDef} !*{!.ConsClasses} !{# CommonDefs} !{# {# FunType} } !*ImportedTypes !*TypeDefInfos !*VarHeap !*TypeHeaps !*ExpressionHeap !Bool !*File !*PredefinedSymbols - -> (!*{!Group}, !*{#FunDef}, !*ImportedTypes, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap, !*File, !*PredefinedSymbols) + -> (!*{!Component}, !*{#FunDef}, !*ImportedTypes, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap, !*File, !*PredefinedSymbols) convertSymbolType :: !Bool !{# CommonDefs} !SymbolType !Int !*ImportedTypes !ImportedConstructors !*TypeHeaps !*VarHeap -> (!SymbolType, !*ImportedTypes, !ImportedConstructors, !*TypeHeaps, !*VarHeap) diff --git a/frontend/trans.icl b/frontend/trans.icl index 440e778..a9aa72d 100644 --- a/frontend/trans.icl +++ b/frontend/trans.icl @@ -3566,28 +3566,27 @@ add_let_binds free_vars rhss original_binds //@ transformGroups -transformGroups :: !CleanupInfo !Int !Int !Int !Int !*{!Group} !*{#FunDef} !*{!.ConsClasses} !{# CommonDefs} !{# {# FunType} } +transformGroups :: !CleanupInfo !Int !Int !Int !Int !*{!Component} !*{#FunDef} !*{!.ConsClasses} !{# CommonDefs} !{# {# FunType} } !*ImportedTypes !*TypeDefInfos !*VarHeap !*TypeHeaps !*ExpressionHeap !Bool !*File !*PredefinedSymbols - -> (!*{!Group}, !*{#FunDef}, !*ImportedTypes, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap, !*File, !*PredefinedSymbols) + -> (!*{!Component}, !*{#FunDef}, !*ImportedTypes, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap, !*File, !*PredefinedSymbols) transformGroups cleanup_info main_dcl_module_n ro_StdStrictLists_module_n def_min def_max groups fun_defs cons_args common_defs imported_funs imported_types type_def_infos var_heap type_heaps symbol_heap compile_with_fusion error predef_symbols #! nr_of_funs = size fun_defs - # initial_ti = - { ti_fun_defs = fun_defs - , ti_instances = createArray nr_of_funs II_Empty - , ti_cons_args = cons_args - , ti_new_functions = [] - , ti_fun_heap = newHeap - , ti_var_heap = var_heap - , ti_symbol_heap = symbol_heap - , ti_type_heaps = type_heaps - , ti_type_def_infos = type_def_infos - , ti_next_fun_nr = nr_of_funs - , ti_cleanup_info = cleanup_info - , ti_recursion_introduced = No - , ti_error_file = error - , ti_predef_symbols = predef_symbols - } + # initial_ti = { ti_fun_defs = fun_defs + , ti_instances = createArray nr_of_funs II_Empty + , ti_cons_args = cons_args + , ti_new_functions = [] + , ti_fun_heap = newHeap + , ti_var_heap = var_heap + , ti_symbol_heap = symbol_heap + , ti_type_heaps = type_heaps + , ti_type_def_infos = type_def_infos + , ti_next_fun_nr = nr_of_funs + , ti_cleanup_info = cleanup_info + , ti_recursion_introduced = No + , ti_error_file = error + , ti_predef_symbols = predef_symbols } + # groups = [group \\ group <-: groups] # (groups, imported_types, collected_imports, fun_indices_with_abs_syn_types, ti) = transform_groups 0 groups [] common_defs imported_funs imported_types [] [] initial_ti @@ -3605,253 +3604,228 @@ transformGroups cleanup_info main_dcl_module_n ro_StdStrictLists_module_n def_mi fun_defs = { fundef \\ fundef <- [ fundef \\ fundef <-: fun_defs ] ++ new_fun_defs } = (groups, fun_defs, imported_types, collected_imports, var_heap, type_heaps, symbol_heap, ti.ti_error_file, ti.ti_predef_symbols) where - transform_groups :: !Int ![.Group] !u:[Group] !{#CommonDefs} !{#{#FunType}} !*{#{#(TypeDef .TypeRhs)}} ![(Global Int)] !v:[Int] !*TransformInfo -> *(!w:[Group],!.{#{#(TypeDef .TypeRhs)}},![(Global Int)],!x:[Int],!*TransformInfo), [u <= w,v <= x] + transform_groups :: !Int ![Component] !u:[Component] !{#CommonDefs} !{#{#FunType}} !*{#{#CheckedTypeDef}} ![(Global Int)] !v:[Int] !*TransformInfo -> *(!w:[Component],!.{#{#CheckedTypeDef}},![(Global Int)],!x:[Int],!*TransformInfo), [u <= w,v <= x] + transform_groups group_nr [group:groups] acc_groups common_defs imported_funs imported_types collected_imports fun_indices_with_abs_syn_types ti + # {component_members} = group + # (ti_fun_defs, imported_types, collected_imports, fun_indices_with_abs_syn_types, ti_type_heaps, ti_var_heap) + = convert_function_types component_members common_defs + (ti.ti_fun_defs, imported_types, collected_imports, fun_indices_with_abs_syn_types, ti.ti_type_heaps, ti.ti_var_heap) + # ti = { ti & ti_fun_defs = ti_fun_defs, ti_type_heaps = ti_type_heaps, ti_var_heap = ti_var_heap } + # (group_nr,acc_groups,ti) = transform_group common_defs imported_funs group_nr component_members acc_groups ti + = transform_groups group_nr groups acc_groups common_defs imported_funs imported_types collected_imports fun_indices_with_abs_syn_types ti transform_groups group_nr [] acc_groups common_defs imported_funs imported_types collected_imports fun_indices_with_abs_syn_types ti = (acc_groups, imported_types, collected_imports, fun_indices_with_abs_syn_types, ti) - transform_groups group_nr [group:groups] acc_groups common_defs imported_funs imported_types collected_imports fun_indices_with_abs_syn_types ti - # {group_members} = group - # (ti_fun_defs, imported_types, collected_imports, fun_indices_with_abs_syn_types, ti_type_heaps, ti_var_heap) - = foldSt (convert_function_type common_defs) group_members - (ti.ti_fun_defs, imported_types, collected_imports, fun_indices_with_abs_syn_types, ti.ti_type_heaps, ti.ti_var_heap) - # ti = { ti & ti_fun_defs = ti_fun_defs, ti_type_heaps = ti_type_heaps, ti_var_heap = ti_var_heap } - # (group_nr,acc_groups,ti) = transform_group common_defs imported_funs group_nr group_members acc_groups ti - = transform_groups group_nr groups acc_groups common_defs imported_funs imported_types collected_imports fun_indices_with_abs_syn_types ti - - transform_groups` :: !{#CommonDefs} !{#{#FunType}} !Int ![Group] !u:[Group] !*TransformInfo -> *(!Int,!u:[Group],!*TransformInfo) - transform_groups` common_defs imported_funs group_nr [] acc_groups ti + + convert_function_types (ComponentMember member members) common_defs s + # s = convert_function_type common_defs member s + = convert_function_types members common_defs s + convert_function_types NoComponentMembers common_defs s + = s + + transform_groups_again :: !Int ![Component] ![Component] !{#CommonDefs} !{#{#FunType}} !*TransformInfo -> *(![Component],!*TransformInfo) + transform_groups_again group_nr [group:groups] acc_groups common_defs imported_funs ti + # {component_members} = group + # (group_nr,acc_groups,ti) = transform_group common_defs imported_funs group_nr component_members acc_groups ti + = transform_groups_again group_nr groups acc_groups common_defs imported_funs ti + transform_groups_again group_nr [] acc_groups common_defs imported_funs ti + = (acc_groups, ti) + + transform_group :: !{#CommonDefs} !{#{#FunType}} !Int !ComponentMembers !u:[Component] !*TransformInfo -> *(!Int,!u:[Component],!*TransformInfo) + transform_group common_defs imported_funs group_nr component_members acc_groups ti + // assign group_nr to component_members + # ti = assign_groups component_members group_nr ti + + # (before,ti) = ti!ti_next_fun_nr + // transform component_members + # ti = transform_functions component_members common_defs imported_funs ti + // partitionate group: need to know added functions for this... + # (after,ti) = ti!ti_next_fun_nr + + | not (compile_with_fusion || after > before) + = (inc group_nr,[{component_members=component_members}:acc_groups],ti) + + # (ti_new_functions,ti) = ti!ti_new_functions + + # (new_functions_in_component,ti_fun_heap) + = determine_new_functions_in_component (after-before) ti_new_functions before after ti.ti_fun_heap + # ti = {ti & ti_fun_heap=ti_fun_heap} + # (new_groups,ti) = partition_group group_nr (append_ComponentMembers component_members new_functions_in_component) ti + // reanalyse consumers + # (cleanup,ti_fun_defs,ti_var_heap,ti_symbol_heap,ti_fun_heap,ti_cons_args,same) + = reanalyseGroups common_defs imported_funs main_dcl_module_n ro_StdStrictLists_module_n + new_groups + ti.ti_fun_defs ti.ti_var_heap ti.ti_symbol_heap ti.ti_fun_heap ti.ti_cons_args + # ti = {ti + & ti_cleanup_info = cleanup ++ ti.ti_cleanup_info + , ti_fun_defs = ti_fun_defs + , ti_var_heap = ti_var_heap + , ti_symbol_heap = ti_symbol_heap + , ti_fun_heap = ti_fun_heap + , ti_cons_args = ti_cons_args + } + // if wanted reapply transform_group to all found groups + | after>before || length new_groups > 1 || not same + = transform_groups` common_defs imported_funs group_nr new_groups acc_groups ti + // producer annotation for finished components! + # ti = reannotate_producers group_nr component_members ti + = (inc group_nr,(reverse new_groups)++acc_groups,ti) + where + transform_groups` :: !{#CommonDefs} !{#{#FunType}} !Int ![Component] !u:[Component] !*TransformInfo -> *(!Int,!u:[Component],!*TransformInfo) + transform_groups` common_defs imported_funs group_nr [] acc_groups ti = (group_nr, acc_groups, ti) - transform_groups` common_defs imported_funs group_nr [{group_members}:groups] acc_groups ti - # (group_nr,acc_groups,ti) = transform_group common_defs imported_funs group_nr group_members acc_groups ti + transform_groups` common_defs imported_funs group_nr [{component_members}:groups] acc_groups ti + # (group_nr,acc_groups,ti) = transform_group common_defs imported_funs group_nr component_members acc_groups ti = transform_groups` common_defs imported_funs group_nr groups acc_groups ti - transform_group :: !{#CommonDefs} !{#{#FunType}} !Int ![Int] !u:[Group] !*TransformInfo -> *(!Int,!u:[Group],!*TransformInfo) - transform_group common_defs imported_funs group_nr group_members acc_groups ti - // assign group_nr to group_members - # ti = ti <-!- ("transform_group",group_nr) - # ti = foldSt (assign_group group_nr) group_members ti - - # (before,ti) = ti!ti_next_fun_nr - // transform group_members - # ti = foldSt (transform_function common_defs imported_funs) group_members ti - // partitionate group: need to know added functions for this... - # (after,ti) = ti!ti_next_fun_nr - - | not (compile_with_fusion || after > before) - = (inc group_nr,[{group_members=group_members}:acc_groups],ti) - - # (new_groups,ti) = partition_group group_nr (group_members++[before..after-1]) ti - // reanalyse consumers - # (cleanup,ti_fun_defs,ti_var_heap,ti_symbol_heap,ti_fun_heap,ti_cons_args,same) - = reanalyseGroups common_defs imported_funs main_dcl_module_n ro_StdStrictLists_module_n ti.ti_new_functions - new_groups - ti.ti_fun_defs ti.ti_var_heap ti.ti_symbol_heap ti.ti_fun_heap ti.ti_cons_args - # ti = {ti - & ti_cleanup_info = cleanup ++ ti.ti_cleanup_info - , ti_fun_defs = ti_fun_defs - , ti_var_heap = ti_var_heap - , ti_symbol_heap = ti_symbol_heap - , ti_fun_heap = ti_fun_heap - , ti_cons_args = ti_cons_args - } - // if wanted reapply transform_group to all found groups - | (after>before) || (length new_groups > 1) || not same - = transform_groups` common_defs imported_funs group_nr new_groups acc_groups ti - // 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 - = (False,ti) - - assign_group :: !.Int !.Int !*TransformInfo -> *TransformInfo - assign_group group_number fun ti - # (fd,ti) = get_fun_def fun ti - # fd = { fd & fun_info.fi_group_index = group_number } - # ti = set_fun_def fun fd ti - = ti - - get_fun_def :: !.Int !*TransformInfo -> *(!FunDef,!*TransformInfo) - get_fun_def fun ti=:{ti_fun_defs} - | fun < size ti_fun_defs - # (fun_def, ti) = ti!ti_fun_defs.[fun] - = (fun_def,ti) - # (fun_def_ptr,ti_fun_heap) = lookup_ptr fun ti.ti_new_functions ti.ti_fun_heap - with - lookup_ptr fun [] ti_fun_heap = abort "drat" - lookup_ptr fun [fun_def_ptr:new_functions] ti_fun_heap - # (FI_Function {gf_fun_index}, ti_fun_heap) - = readPtr fun_def_ptr ti_fun_heap - | gf_fun_index == fun - = (fun_def_ptr, ti_fun_heap) - = lookup_ptr fun new_functions ti_fun_heap - # (FI_Function {gf_fun_def}, ti_fun_heap) - = readPtr fun_def_ptr ti_fun_heap - ti = { ti & ti_fun_heap = ti_fun_heap } - = (gf_fun_def,ti) - - set_fun_def :: !.Int !.FunDef !*TransformInfo -> *TransformInfo - set_fun_def fun fun_def ti=:{ti_fun_defs} - | fun < size ti_fun_defs - = {ti & ti_fun_defs.[fun] = fun_def} - # (fun_def_ptr,ti_fun_heap) = lookup_ptr fun ti.ti_new_functions ti.ti_fun_heap - with - lookup_ptr fun [] ti_fun_heap = abort "drat" - lookup_ptr fun [fun_def_ptr:new_functions] ti_fun_heap - # (FI_Function {gf_fun_index}, ti_fun_heap) - = readPtr fun_def_ptr ti_fun_heap - | gf_fun_index == fun - = (fun_def_ptr, ti_fun_heap) - = lookup_ptr fun new_functions ti_fun_heap - # (FI_Function gf, ti_fun_heap) - = readPtr fun_def_ptr ti_fun_heap - # ti_fun_heap = writePtr fun_def_ptr (FI_Function {gf & gf_fun_def = fun_def}) ti_fun_heap - = { ti & ti_fun_heap = ti_fun_heap } - - partition_group :: !.Int ![.Int] !*TransformInfo -> *(![Group],!*TransformInfo) - partition_group group_nr group_members ti - # fun_defs = ti.ti_fun_defs - # fun_heap = ti.ti_fun_heap - # max_fun_nr = ti.ti_next_fun_nr - # new_functions = ti.ti_new_functions - # main_dcl_module_n = main_dcl_module_n - # next_group = group_nr - # predef_symbols = ti.ti_predef_symbols - # var_heap = ti.ti_var_heap - # expression_heap = ti.ti_symbol_heap - # error_admin = {ea_file = ti.ti_error_file, ea_loc = [], ea_ok = True } - # (_,groups,fun_defs,fun_heap,predef_symbols,var_heap,expression_heap,error_admin) - = partitionateFunctions`` max_fun_nr next_group new_functions fun_defs group_members main_dcl_module_n def_min def_max fun_heap predef_symbols var_heap expression_heap error_admin - # ti = - { ti - & ti_fun_defs = fun_defs - , ti_fun_heap = fun_heap - , ti_predef_symbols = predef_symbols - , ti_var_heap = var_heap - , ti_symbol_heap = expression_heap - , ti_error_file = error_admin.ea_file - } - = (groups,ti) - - transform_function :: !{#.CommonDefs} !{#{#.FunType}} !.Int !*TransformInfo -> *TransformInfo - 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) - (ro_StdGeneric_module_n,ti) = ti!ti_predef_symbols.[PD_StdGeneric].pds_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 - tfi = { tfi_root = ro_fun - , tfi_case = ro_fun - , tfi_orig = ro_fun - , tfi_args = tb.tb_args - , tfi_vars = [arg \\ arg <- tb.tb_args & i <- [0..] | arg_is_strict i st_args_strictness] - , tfi_geni = (-1,-1) - } - ro = { ro_imported_funs = imported_funs - , ro_common_defs = common_defs - , ro_root_case_mode = get_root_case_mode tb - , ro_tfi = tfi - , ro_main_dcl_module_n = main_dcl_module_n - , ro_transform_fusion = compile_with_fusion - , ro_StdStrictLists_module_n = ro_StdStrictLists_module_n - , ro_StdGeneric_module_n = ro_StdGeneric_module_n - } - ti = { ti & ti_var_heap = ti_var_heap } // <--- ("transform_function",fun,ro.ro_root_case_mode) - (fun_rhs, ti) = transform tb.tb_rhs ro ti - fun_def = { fun_def & fun_body = TransformedBody { tb & tb_rhs = fun_rhs }} - # ti = set_fun_def fun fun_def ti - = ti - where - store_arg_type_info {fv_info_ptr} a_type ti_var_heap - = setExtendedVarInfo fv_info_ptr (EVI_VarType a_type) ti_var_heap + changed_group_classification [] ti + = (False,ti) + changed_group_classification [fun:funs] ti + = (False,ti) + + assign_groups :: !ComponentMembers !Int !*TransformInfo -> *TransformInfo + assign_groups (ComponentMember member members) group_nr ti + # ti = {ti & ti_fun_defs.[member].fun_info.fi_group_index = group_nr} + = assign_groups members group_nr ti + assign_groups (GeneratedComponentMember member fun_ptr members) group_nr ti=:{ti_fun_heap} + # (FI_Function gf=:{gf_fun_def=fd}, ti_fun_heap) = readPtr fun_ptr ti_fun_heap + # fd = {fd & fun_info.fi_group_index = group_nr} + # ti_fun_heap = writePtr fun_ptr (FI_Function {gf & gf_fun_def=fd}) ti_fun_heap + # ti = {ti & ti_fun_heap=ti_fun_heap} + = assign_groups members group_nr ti + assign_groups NoComponentMembers group_nr ti + = ti - fun_def_to_symb_ident fun_index fsize {fun_ident} - | fun_index < fsize - = { symb_ident=fun_ident, symb_kind=SK_Function {glob_object=fun_index, glob_module=main_dcl_module_n } } - - get_root_case_mode {tb_rhs=Case _} = RootCase - get_root_case_mode _ = NotRootCase - - get_fun_def_and_symb_ident fun ti=:{ti_fun_defs} - | fun < size ti_fun_defs - # (fun_def, ti) = ti!ti_fun_defs.[fun] - # si = { symb_ident=fun_def.fun_ident, symb_kind=SK_Function {glob_object=fun, glob_module=main_dcl_module_n } } - = (fun_def,si,ti) - # (fun_def_ptr,ti_fun_heap) = lookup_ptr fun ti.ti_new_functions ti.ti_fun_heap - with - lookup_ptr fun [] ti_fun_heap = abort "drat" - lookup_ptr fun [fun_def_ptr:new_functions] ti_fun_heap - # (FI_Function {gf_fun_index}, ti_fun_heap) - = readPtr fun_def_ptr ti_fun_heap - | gf_fun_index == fun - = (fun_def_ptr, ti_fun_heap) - = lookup_ptr fun new_functions ti_fun_heap - # (FI_Function {gf_fun_def}, ti_fun_heap) - = readPtr fun_def_ptr ti_fun_heap - # si = { symb_ident=gf_fun_def.fun_ident, symb_kind=SK_GeneratedFunction fun_def_ptr fun } - ti = { ti & ti_fun_heap = ti_fun_heap } - = (gf_fun_def,si,ti) - - reannotate_producers group_nr group_members ti + partition_group :: !.Int !ComponentMembers !*TransformInfo -> *(![Component],!*TransformInfo) + partition_group group_nr component_members ti + # {ti_fun_defs=fun_defs, ti_fun_heap=fun_heap, ti_next_fun_nr=max_fun_nr, + ti_predef_symbols=predef_symbols, ti_var_heap=var_heap, ti_symbol_heap=expression_heap, ti_error_file} = ti + # next_group = group_nr + # error_admin = {ea_file = ti_error_file, ea_loc = [], ea_ok = True } + # (_,groups,fun_defs,fun_heap,predef_symbols,var_heap,expression_heap,error_admin) + = partitionateFunctions`` max_fun_nr next_group fun_defs component_members main_dcl_module_n def_min def_max fun_heap predef_symbols var_heap expression_heap error_admin + # ti = { ti & ti_fun_defs = fun_defs + , ti_fun_heap = fun_heap + , ti_predef_symbols = predef_symbols + , ti_var_heap = var_heap + , ti_symbol_heap = expression_heap + , ti_error_file = error_admin.ea_file } + = (groups,ti) + + transform_functions :: !ComponentMembers !{#CommonDefs} !{#{#FunType}} !*TransformInfo -> *TransformInfo + transform_functions (ComponentMember member members) common_defs imported_funs ti + # (fun_def, ti) = ti!ti_fun_defs.[member] + fun_symb = {symb_ident=fun_def.fun_ident, symb_kind=SK_Function {glob_object=member, glob_module=main_dcl_module_n}} + (fun_body,ti) + = transform_function fun_def.fun_type fun_def.fun_body fun_symb common_defs imported_funs ti + fun_def = {fun_def & fun_body=fun_body} + ti = {ti & ti_fun_defs.[member] = fun_def} + = transform_functions members common_defs imported_funs ti + transform_functions (GeneratedComponentMember member fun_ptr members) common_defs imported_funs ti + # (FI_Function gf=:{gf_fun_def},ti_fun_heap) = readPtr fun_ptr ti.ti_fun_heap + fun_symb = {symb_ident=gf_fun_def.fun_ident, symb_kind=SK_GeneratedFunction fun_ptr member } + ti = {ti & ti_fun_heap = ti_fun_heap} + (fun_body,ti) + = transform_function gf_fun_def.fun_type gf_fun_def.fun_body fun_symb common_defs imported_funs ti + gf_fun_def = {gf_fun_def & fun_body=fun_body} + ti_fun_heap = writePtr fun_ptr (FI_Function {gf & gf_fun_def=gf_fun_def}) ti.ti_fun_heap + ti = {ti & ti_fun_heap = ti_fun_heap} + = transform_functions members common_defs imported_funs ti + transform_functions NoComponentMembers common_defs imported_funs ti + = ti + + transform_function :: !(Optional SymbolType) !FunctionBody !SymbIdent !{#CommonDefs} !{#{#FunType}} !*TransformInfo -> (!FunctionBody,!*TransformInfo) + transform_function (Yes {st_args,st_args_strictness}) (TransformedBody tb) fun_symb common_defs imported_funs ti + # (ro_StdGeneric_module_n,ti) = ti!ti_predef_symbols.[PD_StdGeneric].pds_def + ti_var_heap = fold2St store_arg_type_info tb.tb_args st_args ti.ti_var_heap + tfi = { tfi_root = fun_symb + , tfi_case = fun_symb + , tfi_orig = fun_symb + , tfi_args = tb.tb_args + , tfi_vars = [arg \\ arg <- tb.tb_args & i <- [0..] | arg_is_strict i st_args_strictness] + , tfi_geni = (-1,-1) + } + ro = { ro_imported_funs = imported_funs + , ro_common_defs = common_defs + , ro_root_case_mode = get_root_case_mode tb + , ro_tfi = tfi + , ro_main_dcl_module_n = main_dcl_module_n + , ro_transform_fusion = compile_with_fusion + , ro_StdStrictLists_module_n = ro_StdStrictLists_module_n + , ro_StdGeneric_module_n = ro_StdGeneric_module_n + } + ti = {ti & ti_var_heap = ti_var_heap} + + (fun_rhs, ti) = transform tb.tb_rhs ro ti + = (TransformedBody {tb & tb_rhs = fun_rhs},ti) + where + store_arg_type_info {fv_info_ptr} a_type ti_var_heap + = setExtendedVarInfo fv_info_ptr (EVI_VarType a_type) ti_var_heap + + fun_def_to_symb_ident fun_index fsize {fun_ident} + | fun_index < fsize + = { symb_ident=fun_ident, symb_kind=SK_Function {glob_object=fun_index, glob_module=main_dcl_module_n } } + + get_root_case_mode {tb_rhs=Case _} = RootCase + get_root_case_mode _ = NotRootCase + + reannotate_producers group_nr component_members ti // determine if safe group - # (safe,ti) = safe_producers group_nr group_members group_members main_dcl_module_n ti + # (safe,ti) = safe_producers group_nr component_members component_members main_dcl_module_n ti | safe // if safe mark all members as safe - = foldSt mark_producer_safe group_members ti + = mark_producers_safe component_members ti = ti - safe_producers :: Int [Int] [Int] Int *TransformInfo -> *(!Bool,!*TransformInfo) - safe_producers group_nr group_members [] main_dcl_module_n ti - = (True,ti) - safe_producers group_nr group_members [fun:funs] main_dcl_module_n ti - // look for occurrence of group_members in safe argument position of fun RHS + safe_producers :: Int ComponentMembers ComponentMembers Int *TransformInfo -> *(!Bool,!*TransformInfo) + safe_producers group_nr component_members (ComponentMember fun funs) main_dcl_module_n ti + // look for occurrence of component_members in safe argument position of fun RHS // i.e. linearity ok && ... - #! (fun_def, ti) = get_fun_def fun ti - {fun_body = TransformedBody tb} - = fun_def - fun_body = tb.tb_rhs - - #! 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 - , prs_fun_defs = ti.ti_fun_defs - , prs_group_index = group_nr - } - # (safe,prs) = producerRequirements fun_body prs -// # prs = prs ---> ("producerRequirements",fun_def.fun_ident,fun,group_nr,safe,fun_body) + # (fun_def,fun_defs) = (ti.ti_fun_defs)![fun] + {fun_body = TransformedBody {tb_rhs}} = fun_def + prs = { prs_group = component_members + , prs_cons_args = ti.ti_cons_args + , prs_main_dcl_module_n = main_dcl_module_n + , prs_fun_heap = ti.ti_fun_heap + , prs_fun_defs = fun_defs + , prs_group_index = group_nr } + # (safe,prs) = producerRequirements tb_rhs prs #! ti = {ti & ti_fun_defs = prs.prs_fun_defs, ti_fun_heap = prs.prs_fun_heap, ti_cons_args = prs.prs_cons_args} // put back prs info into ti? | safe - = safe_producers group_nr group_members funs main_dcl_module_n ti + = safe_producers group_nr component_members funs main_dcl_module_n ti = (False,ti) - - mark_producer_safe fun ti=:{ti_fun_defs} - // update cc_prod for fun - | fun < size ti_fun_defs - = {ti & ti_cons_args.[fun].cc_producer = pIsSafe} - # (fun_def_ptr,ti_fun_heap) = lookup_ptr fun ti.ti_new_functions ti.ti_fun_heap - with - lookup_ptr fun [] ti_fun_heap = abort "drat" - lookup_ptr fun [fun_def_ptr:new_functions] ti_fun_heap - # (FI_Function {gf_fun_index}, ti_fun_heap) - = readPtr fun_def_ptr ti_fun_heap - | gf_fun_index == fun - = (fun_def_ptr, ti_fun_heap) - = lookup_ptr fun new_functions ti_fun_heap - # (FI_Function gf, ti_fun_heap) - = readPtr fun_def_ptr ti_fun_heap - # ti_fun_heap = writePtr fun_def_ptr (FI_Function {gf & gf_cons_args.cc_producer = pIsSafe}) ti_fun_heap - ti = { ti & ti_fun_heap = ti_fun_heap } + safe_producers group_nr component_members (GeneratedComponentMember fun fun_ptr funs) main_dcl_module_n ti + # (FI_Function {gf_fun_def}, ti_fun_heap) = readPtr fun_ptr ti.ti_fun_heap + ti = {ti & ti_fun_heap=ti_fun_heap} + {fun_body = TransformedBody {tb_rhs}} = gf_fun_def + prs = { prs_group = component_members + , prs_cons_args = ti.ti_cons_args + , prs_main_dcl_module_n = main_dcl_module_n + , prs_fun_heap = ti.ti_fun_heap + , prs_fun_defs = ti.ti_fun_defs + , prs_group_index = group_nr } + (safe,prs) = producerRequirements tb_rhs prs + #! ti = {ti & ti_fun_defs = prs.prs_fun_defs, ti_fun_heap = prs.prs_fun_heap, ti_cons_args = prs.prs_cons_args} + | safe + = safe_producers group_nr component_members funs main_dcl_module_n ti + = (False,ti) + safe_producers group_nr component_members NoComponentMembers main_dcl_module_n ti + = (True,ti) + + mark_producers_safe (ComponentMember member members) ti + # ti = {ti & ti_cons_args.[member].cc_producer = pIsSafe} + = mark_producers_safe members ti + mark_producers_safe (GeneratedComponentMember member fun_ptr members) ti + # (FI_Function gf,ti_fun_heap) = readPtr fun_ptr ti.ti_fun_heap + ti_fun_heap = writePtr fun_ptr (FI_Function {gf & gf_cons_args.cc_producer = pIsSafe}) ti_fun_heap + ti = {ti & ti_fun_heap = ti_fun_heap} + = mark_producers_safe members ti + mark_producers_safe NoComponentMembers ti = ti -// ... DvA - add_new_function_to_group :: !{# CommonDefs} !FunctionHeap !FunctionInfoPtr - !(!*{!Group}, ![FunDef], !*ImportedTypes, !ImportedConstructors, !*TypeHeaps, !*VarHeap) - -> (!*{!Group}, ![FunDef], !*ImportedTypes, !ImportedConstructors, !*TypeHeaps, !*VarHeap) + add_new_function_to_group :: !{# CommonDefs} !FunctionHeap !FunctionInfoPtr + !(!*{!Component}, ![FunDef], !*ImportedTypes, !ImportedConstructors, !*TypeHeaps, !*VarHeap) + -> (!*{!Component}, ![FunDef], !*ImportedTypes, !ImportedConstructors, !*TypeHeaps, !*VarHeap) add_new_function_to_group common_defs fun_heap fun_ptr (groups, fun_defs, imported_types, collected_imports, type_heaps, var_heap) # (FI_Function {gf_fun_def,gf_fun_index}) = sreadPtr fun_ptr fun_heap {fun_type = Yes ft=:{st_args,st_result}, fun_info = {fi_group_index,fi_properties}} = gf_fun_def @@ -3868,13 +3842,20 @@ where # ft = { ft & st_result = st_result, st_args = st_args } | fi_group_index >= size groups = abort ("add_new_function_to_group "+++ toString fi_group_index+++ "," +++ toString (size groups) +++ "," +++ toString gf_fun_index) - + # (group, groups) = groups![fi_group_index] - | not (isMember gf_fun_index group.group_members) + | not (isComponentMember gf_fun_index group.component_members) = abort ("add_new_function_to_group INSANE!\n" +++ toString gf_fun_index +++ "," +++ toString fi_group_index) # groups = {groups & [fi_group_index] = group} - # gf_fun_def = { gf_fun_def & fun_type = Yes ft} + # gf_fun_def = {gf_fun_def & fun_type = Yes ft} = (groups, [gf_fun_def : fun_defs], ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap) + where + isComponentMember index (ComponentMember member members) + = index==member || isComponentMember index members + isComponentMember index (GeneratedComponentMember member _ members) + = index==member || isComponentMember index members + isComponentMember index NoComponentMembers + = False convert_function_type common_defs fun_index (fun_defs, imported_types, collected_imports, fun_indices_with_abs_syn_types, type_heaps, var_heap) # (fun_def=:{fun_type = Yes fun_type, fun_info = {fi_properties}}, fun_defs) @@ -3888,7 +3869,7 @@ where = (fun_defs, imported_types, collected_imports, [fun_index : fun_indices_with_abs_syn_types], type_heaps, var_heap) = (fun_defs, imported_types, collected_imports, fun_indices_with_abs_syn_types, type_heaps, var_heap) - expand_abstract_syn_types_in_function_type :: !{#.CommonDefs} !.Int !*(!*{#FunDef},!*{#{#.(TypeDef .TypeRhs)}},![(Global .Int)],!*TypeHeaps,!*(Heap VarInfo)) -> (!*{#FunDef},!.{#{#(TypeDef .TypeRhs)}},![(Global Int)],!.TypeHeaps,!.(Heap VarInfo)) + expand_abstract_syn_types_in_function_type :: !{#.CommonDefs} !.Int !*(!*{#FunDef},!*{#{#CheckedTypeDef}},![(Global .Int)],!*TypeHeaps,!*(Heap VarInfo)) -> (!*{#FunDef},!.{#{#CheckedTypeDef}},![(Global Int)],!.TypeHeaps,!.(Heap VarInfo)) expand_abstract_syn_types_in_function_type common_defs fun_index (fun_defs, imported_types, collected_imports, type_heaps, var_heap) # (fun_def=:{fun_type = Yes fun_type, fun_info = {fi_properties}}, fun_defs) = fun_defs![fun_index] @@ -3899,6 +3880,23 @@ where fun_defs = { fun_defs & [fun_index] = fun_def } = (fun_defs, imported_types, collected_imports, type_heaps, var_heap) + append_ComponentMembers :: !ComponentMembers !ComponentMembers -> ComponentMembers + append_ComponentMembers (ComponentMember member members) component_members_to_append + = ComponentMember member (append_ComponentMembers members component_members_to_append) + append_ComponentMembers (GeneratedComponentMember member fun_ptr members) component_members_to_append + = GeneratedComponentMember member fun_ptr (append_ComponentMembers members component_members_to_append) + append_ComponentMembers NoComponentMembers component_members_to_append + = component_members_to_append + + determine_new_functions_in_component :: !Int ![FunctionInfoPtr] !Int !Int !*FunctionHeap -> (ComponentMembers,!*FunctionHeap) + determine_new_functions_in_component 0 new_functions before after fun_heap + = (NoComponentMembers,fun_heap) + determine_new_functions_in_component n_functions [fun_ptr:new_functions] before after fun_heap + # (FI_Function {gf_fun_index},fun_heap) = readPtr fun_ptr fun_heap + | gf_fun_index>=before && gf_fun_index<after + # (members,fun_heap) = determine_new_functions_in_component (n_functions-1) new_functions before after fun_heap + = (GeneratedComponentMember gf_fun_index fun_ptr members,fun_heap) + RemoveAnnotationsMask:==1 ExpandAbstractSynTypesMask:==2 DontCollectImportedConstructors:==4 @@ -4440,11 +4438,12 @@ get_fun_def_and_cons_args (SK_GeneratedFunction fun_info_ptr fun_index) cons_arg = (gf_fun_def, gf_cons_args, cons_args, fun_defs, fun_heap) //@ <<< - +/* instance <<< Group where (<<<) file {group_members} = file <<< "Group: " <<< group_members - +*/ + instance <<< RootCaseMode where (<<<) file mode = case mode of NotRootCase -> file <<< "NotRootCase"; RootCase -> file <<< "RootCase"; RootCaseOfZombie -> file <<< "RootCaseOfZombie"; |