From e6ab6e85c56ccd1d8bc9998479fa2523ed06dbfb Mon Sep 17 00:00:00 2001 From: johnvg Date: Tue, 11 Sep 2001 13:05:59 +0000 Subject: reduced memory usage of expandSynTypes git-svn-id: https://svn.cs.ru.nl/repos/clean-compiler/trunk@767 1f8540f1-abd5-4d5b-9d24-4c5ce8603e2d --- frontend/trans.icl | 88 ++++++++++++++++++++++++++++++++---------------------- 1 file changed, 52 insertions(+), 36 deletions(-) (limited to 'frontend') diff --git a/frontend/trans.icl b/frontend/trans.icl index 249c9db..890d596 100644 --- a/frontend/trans.icl +++ b/frontend/trans.icl @@ -2470,7 +2470,7 @@ transformGroups cleanup_info main_dcl_module_n stdStrictLists_module_n groups fu # (FI_Function {gf_fun_def,gf_fun_index}) = sreadPtr fun_ptr ti_fun_heap // Sjaak {fun_type = Yes ft=:{st_args,st_result}, fun_info = {fi_group_index,fi_properties}} = gf_fun_def - ((st_result,st_args), {ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap}) + (_,(st_result,st_args), {ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap}) = expandSynTypes (fi_properties bitand FI_HasTypeSpec == 0) common_defs (st_result,st_args) { ets_type_defs = imported_types, ets_collected_conses = collected_imports, ets_type_heaps = type_heaps, ets_var_heap = var_heap, ets_main_dcl_module_n=main_dcl_module_n } @@ -2501,7 +2501,7 @@ set_extended_expr_info expr_info_ptr extension expr_info_heap convertSymbolType :: !Bool !{# CommonDefs} !SymbolType !Int !*{#{# CheckedTypeDef}} !ImportedConstructors !*TypeHeaps !*VarHeap -> (!SymbolType, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*TypeHeaps, !*VarHeap) convertSymbolType rem_annots common_defs st main_dcl_module_n imported_types collected_imports type_heaps var_heap - # (st, {ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap}) = expandSynTypes rem_annots common_defs st + # (st, {ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap}) = expandSynTypesInSymbolType rem_annots common_defs st { ets_type_defs = imported_types, ets_collected_conses = collected_imports, ets_type_heaps= type_heaps, ets_var_heap = var_heap, ets_main_dcl_module_n=main_dcl_module_n } = (st, ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap) @@ -2532,49 +2532,59 @@ where ) tc_types class_cons_vars))} - -class expandSynTypes a :: !Bool !{# CommonDefs} !a !*ExpandTypeState -> (!a, !*ExpandTypeState) - -instance expandSynTypes SymbolType -where - expandSynTypes rem_annots common_defs st=:{st_args,st_result,st_context} ets - # ((st_args,st_result), ets) = expandSynTypes rem_annots common_defs (st_args,st_result) ets - st_args = addTypesOfDictionaries common_defs st_context st_args - = ({st & st_args = st_args, st_result = st_result, st_arity = length st_args, st_context = [] }, ets) +expandSynTypesInSymbolType rem_annots common_defs st=:{st_args,st_result,st_context} ets + # (_,(st_args,st_result), ets) = expandSynTypes rem_annots common_defs (st_args,st_result) ets + st_args = addTypesOfDictionaries common_defs st_context st_args + = ({st & st_args = st_args, st_result = st_result, st_arity = length st_args, st_context = [] }, ets) + +class expandSynTypes a :: !Bool !{# CommonDefs} !a !*ExpandTypeState -> (!Bool,!a, !*ExpandTypeState) instance expandSynTypes Type where - expandSynTypes rem_annots common_defs (arg_type --> res_type) ets - # ((arg_type, res_type), ets) = expandSynTypes rem_annots common_defs (arg_type, res_type) ets - = (arg_type --> res_type, ets) + expandSynTypes rem_annots common_defs type=:(arg_type --> res_type) ets + # (changed,(arg_type, res_type), ets) = expandSynTypes rem_annots common_defs (arg_type, res_type) ets + | changed + = (True,arg_type --> res_type, ets) + = (False,type, ets) expandSynTypes rem_annots common_defs type=:(TB _) ets - = (type, ets) - expandSynTypes rem_annots common_defs (cons_var :@: types) ets - # (types, ets) = expandSynTypes rem_annots common_defs types ets - = (cons_var :@: types, ets) + = (False,type, ets) + expandSynTypes rem_annots common_defs type=:(cons_var :@: types) ets + # (changed,types, ets) = expandSynTypes rem_annots common_defs types ets + | changed + = (True,cons_var :@: types, ets) + = (False,type, ets) expandSynTypes rem_annots common_defs type=:(TA type_symb types) ets = expand_syn_types_in_TA rem_annots common_defs type TA_Multi ets // Sjaak 240801 ... - expandSynTypes rem_annots common_defs (TFA vars type) ets - # (type, ets) = expandSynTypes rem_annots common_defs type ets - = (TFA vars type, ets) + expandSynTypes rem_annots common_defs tfa_type=:(TFA vars type) ets + # (changed,type, ets) = expandSynTypes rem_annots common_defs type ets + | changed + = (True,TFA vars type, ets) + = (False,tfa_type, ets) // ... Sjaak expandSynTypes rem_annots common_defs type ets - = (type, ets) + = (False,type, ets) instance expandSynTypes [a] | expandSynTypes a where - expandSynTypes rem_annots common_defs list ets - = mapSt (expandSynTypes rem_annots common_defs) list ets - + expandSynTypes rem_annots common_defs [] ets + = (False,[],ets) + expandSynTypes rem_annots common_defs t=:[type:types] ets + # (changed_type,type,ets) = expandSynTypes rem_annots common_defs type ets + # (changed_types,types,ets) = expandSynTypes rem_annots common_defs types ets + | changed_type || changed_types + = (True,[type:types],ets) + = (False,t,ets) instance expandSynTypes (a,b) | expandSynTypes a & expandSynTypes b where - expandSynTypes rem_annots common_defs tuple ets - = app2St (expandSynTypes rem_annots common_defs, expandSynTypes rem_annots common_defs) tuple ets + expandSynTypes rem_annots common_defs (type1,type2) ets + # (changed_type1,type1,ets) = expandSynTypes rem_annots common_defs type1 ets + # (changed_type2,type2,ets) = expandSynTypes rem_annots common_defs type2 ets + = (changed_type1 || changed_type2,(type1,type2),ets) -expand_syn_types_in_TA rem_annots common_defs (TA type_symb=:{type_index={glob_object,glob_module},type_name} types) attribute ets=:{ets_type_defs} +expand_syn_types_in_TA rem_annots common_defs ta_type=:(TA type_symb=:{type_index={glob_object,glob_module},type_name} types) attribute ets=:{ets_type_defs} # ({td_rhs,td_name,td_args,td_attribute},ets_type_defs) = ets_type_defs![glob_module].[glob_object] ets = { ets & ets_type_defs = ets_type_defs } = case td_rhs of @@ -2582,12 +2592,14 @@ expand_syn_types_in_TA rem_annots common_defs (TA type_symb=:{type_index={glob_o # ets_type_heaps = bind_attr td_attribute attribute ets.ets_type_heaps ets_type_heaps = (fold2St bind_var_and_attr td_args types ets_type_heaps) (_, type, ets_type_heaps) = substitute_rhs rem_annots rhs_type.at_type ets_type_heaps - -> expandSynTypes rem_annots common_defs type { ets & ets_type_heaps = ets_type_heaps } + # (_,type,ets) = expandSynTypes rem_annots common_defs type { ets & ets_type_heaps = ets_type_heaps } + -> (True,type,ets) _ - # (types, ets) = expandSynTypes rem_annots common_defs types ets + # (changed,types, ets) = expandSynTypes rem_annots common_defs types ets + # ta_type = if changed (TA type_symb types) ta_type | glob_module == ets.ets_main_dcl_module_n - -> ( TA type_symb types, ets) - -> ( TA type_symb types, collect_imported_constructors common_defs glob_module td_rhs ets) + -> (changed,ta_type, ets) + -> (changed,ta_type, collect_imported_constructors common_defs glob_module td_rhs ets) where bind_var_and_attr { atv_attribute = TA_Var {av_info_ptr}, atv_variable = {tv_info_ptr} } {at_attribute,at_type} type_heaps=:{th_vars,th_attrs} = { type_heaps & th_vars = th_vars <:= (tv_info_ptr, TVI_Type at_type), th_attrs = th_attrs <:= (av_info_ptr, AVI_Attr at_attribute) } @@ -2633,11 +2645,15 @@ where = expand_syn_types_in_a_type rem_annots common_defs atype ets where expand_syn_types_in_a_type rem_annots common_defs atype=:{at_type = at_type=: TA type_symb types,at_attribute} ets - # (at_type, ets) = expand_syn_types_in_TA rem_annots common_defs at_type at_attribute ets - = ({ atype & at_type = at_type }, ets) + # (changed,at_type, ets) = expand_syn_types_in_TA rem_annots common_defs at_type at_attribute ets + | changed + = (True,{ atype & at_type = at_type }, ets) + = (False,atype,ets) expand_syn_types_in_a_type rem_annots common_defs atype ets - # (at_type, ets) = expandSynTypes rem_annots common_defs atype.at_type ets - = ({ atype & at_type = at_type }, ets) + # (changed,at_type, ets) = expandSynTypes rem_annots common_defs atype.at_type ets + | changed + = (True,{ atype & at_type = at_type }, ets) + = (False,atype,ets) :: FreeVarInfo = { fvi_var_heap :: !.VarHeap -- cgit v1.2.3