From 53c639bfe17d38507d024ec3075d3b114d530438 Mon Sep 17 00:00:00 2001 From: johnvg Date: Wed, 9 Oct 2013 12:33:14 +0000 Subject: restore tv_info_pointer values in function convertSymbolTypeWithoutCollectingImportedConstructors, this is necessary because in module type_io these pointers point to TVI_Normalized values that could be overwritten by this function git-svn-id: https://svn.cs.ru.nl/repos/clean-compiler/trunk@2290 1f8540f1-abd5-4d5b-9d24-4c5ce8603e2d --- frontend/expand_types.icl | 87 ++++++++++++++++++++++++++++++----------------- 1 file changed, 55 insertions(+), 32 deletions(-) (limited to 'frontend') diff --git a/frontend/expand_types.icl b/frontend/expand_types.icl index 609f6a7..b12613b 100644 --- a/frontend/expand_types.icl +++ b/frontend/expand_types.icl @@ -47,7 +47,7 @@ writeVarInfo var_info_ptr new_var_info var_heap RemoveAnnotationsMask:==1 ExpandAbstractSynTypesMask:==2 -DontCollectImportedConstructors:==4 +DontCollectImportedConstructorsAndRestorePointers:==4 convertSymbolType :: !Bool !{#CommonDefs} !SymbolType !Int !*ImportedTypes !ImportedConstructors !*TypeHeaps !*VarHeap -> (!SymbolType, !*ImportedTypes,!ImportedConstructors,!*TypeHeaps,!*VarHeap) @@ -65,8 +65,12 @@ convertSymbolTypeWithoutExpandingAbstractSynTypes rem_annots common_defs st main convertSymbolTypeWithoutCollectingImportedConstructors :: !Bool !{#CommonDefs} !SymbolType !Int !*ImportedTypes !*TypeHeaps !*VarHeap -> (!SymbolType,!*ImportedTypes,!*TypeHeaps,!*VarHeap) convertSymbolTypeWithoutCollectingImportedConstructors rem_annots common_defs st main_dcl_module_n imported_types type_heaps var_heap + # rem_annots + = if rem_annots + (RemoveAnnotationsMask bitor ExpandAbstractSynTypesMask bitor DontCollectImportedConstructorsAndRestorePointers) + (ExpandAbstractSynTypesMask bitor DontCollectImportedConstructorsAndRestorePointers) # (st, ets_contains_unexpanded_abs_syn_type,ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap) - = convertSymbolType_ (if rem_annots (RemoveAnnotationsMask bitor ExpandAbstractSynTypesMask bitor DontCollectImportedConstructors) (ExpandAbstractSynTypesMask bitor DontCollectImportedConstructors)) common_defs st main_dcl_module_n imported_types [] type_heaps var_heap + = convertSymbolType_ rem_annots common_defs st main_dcl_module_n imported_types [] type_heaps var_heap = (st, ets_type_defs, ets_type_heaps, ets_var_heap) convertSymbolType_ :: !Int !{# CommonDefs} !SymbolType !Int !*ImportedTypes !ImportedConstructors !*TypeHeaps !*VarHeap @@ -215,15 +219,10 @@ expand_syn_types_in_TA rem_annots common_defs ta_type attribute ets=:{ets_type_d ets = { ets & ets_type_defs = ets_type_defs } = case td_rhs of SynType rhs_type - # (type,ets_type_heaps) = bind_and_substitute_before_expand types td_args td_attribute rhs_type rem_annots attribute ets.ets_type_heaps - # (_,type,ets) = expandSynTypes rem_annots common_defs type { ets & ets_type_heaps = ets_type_heaps } - -> (True,type,ets) + -> expand_type types td_args td_attribute rhs_type rem_annots attribute ets AbstractSynType _ rhs_type | (rem_annots bitand ExpandAbstractSynTypesMask)<>0 - # (type,ets_type_heaps) = bind_and_substitute_before_expand types td_args td_attribute rhs_type rem_annots attribute ets.ets_type_heaps - # (_,type,ets) = expandSynTypes rem_annots common_defs type { ets & ets_type_heaps = ets_type_heaps } - -> (True,type,ets) - + -> expand_type types td_args td_attribute rhs_type rem_annots attribute ets # ets = {ets & ets_contains_unexpanded_abs_syn_type=True } #! (changed,types, ets) = expandSynTypes rem_annots common_defs types ets # ta_type = if changed @@ -236,9 +235,7 @@ expand_syn_types_in_TA rem_annots common_defs ta_type attribute ets=:{ets_type_d -> (changed,ta_type, collect_imported_constructors common_defs glob_module td_rhs ets) NewType {ds_index} # {cons_type={st_args=[arg_type:_]}} = common_defs.[glob_module].com_cons_defs.[ds_index]; - # (type,ets_type_heaps) = bind_and_substitute_before_expand types td_args td_attribute arg_type rem_annots attribute ets.ets_type_heaps - # (_,type,ets) = expandSynTypes rem_annots common_defs type { ets & ets_type_heaps = ets_type_heaps } - -> (True,type,ets) + -> expand_type types td_args td_attribute arg_type rem_annots attribute ets _ #! (changed,types, ets) = expandSynTypes rem_annots common_defs types ets # ta_type = if changed @@ -246,32 +243,58 @@ expand_syn_types_in_TA rem_annots common_defs ta_type attribute ets=:{ets_type_d TA type_symb _ -> TA type_symb types TAS type_symb _ strictness -> TAS type_symb types strictness ) ta_type - | glob_module == ets.ets_main_dcl_module_n || (rem_annots bitand DontCollectImportedConstructors)<>0 + | glob_module == ets.ets_main_dcl_module_n || (rem_annots bitand DontCollectImportedConstructorsAndRestorePointers)<>0 -> (changed,ta_type, ets) -> (changed,ta_type, collect_imported_constructors common_defs glob_module td_rhs ets) where - bind_and_substitute_before_expand types td_args td_attribute rhs_type rem_annots attribute ets_type_heaps - # ets_type_heaps = bind_attr td_attribute attribute ets_type_heaps - ets_type_heaps = fold2St bind_var_and_attr td_args types ets_type_heaps - = substitute_rhs rem_annots rhs_type.at_type ets_type_heaps + expand_type types td_args td_attribute rhs_type rem_annots attribute ets + | (rem_annots bitand DontCollectImportedConstructorsAndRestorePointers)==0 + # (type,ets_type_heaps) = bind_and_substitute_before_expand types td_args td_attribute rhs_type rem_annots attribute ets.ets_type_heaps + (_,type,ets) = expandSynTypes rem_annots common_defs type {ets & ets_type_heaps = ets_type_heaps} + = (True,type,ets) + # (type,rev_tv_infos,ets_type_heaps) = bind_save_and_substitute_before_expand types td_args td_attribute rhs_type rem_annots attribute ets.ets_type_heaps + (_,type,ets=:{ets_type_heaps}) = expandSynTypes rem_annots common_defs type {ets & ets_type_heaps = ets_type_heaps} + th_vars = fold2St restore_tv_info (reverse rev_tv_infos) td_args ets_type_heaps.th_vars + = (True,type,{ets & ets_type_heaps = {ets_type_heaps & th_vars=th_vars}}) + where + bind_and_substitute_before_expand types td_args td_attribute rhs_type rem_annots attribute ets_type_heaps + # ets_type_heaps = bind_attr td_attribute attribute ets_type_heaps + ets_type_heaps = fold2St bind_var_and_attr td_args types ets_type_heaps + = substitute_rhs rem_annots rhs_type.at_type ets_type_heaps 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) } - bind_var_and_attr { atv_variable = {tv_info_ptr}} {at_type} type_heaps=:{th_vars} - = { type_heaps & th_vars = th_vars <:= (tv_info_ptr, TVI_Type at_type) } + 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)} + bind_var_and_attr {atv_variable = {tv_info_ptr}} {at_type} type_heaps=:{th_vars} + = {type_heaps & th_vars = th_vars <:= (tv_info_ptr, TVI_Type at_type)} - bind_attr (TA_Var {av_info_ptr}) attribute type_heaps=:{th_attrs} - = { type_heaps & th_attrs = th_attrs <:= (av_info_ptr, AVI_Attr attribute) } - bind_attr _ attribute type_heaps - = type_heaps + bind_save_and_substitute_before_expand types td_args td_attribute rhs_type rem_annots attribute ets_type_heaps + # ets_type_heaps=:{th_vars,th_attrs} = bind_attr td_attribute attribute ets_type_heaps + (rev_tv_infos,th_vars,th_attrs) = fold2St bind_and_save_var_and_attr td_args types ([],th_vars,th_attrs) + (type,heaps) = substitute_rhs rem_annots rhs_type.at_type {ets_type_heaps & th_vars=th_vars,th_attrs=th_attrs} + = (type,rev_tv_infos,heaps) + where + bind_and_save_var_and_attr {atv_attribute = TA_Var {av_info_ptr}, atv_variable = {tv_info_ptr}} {at_attribute,at_type} (rev_tv_infos,th_vars,th_attrs) + # (tv_info,th_vars) = readPtr tv_info_ptr th_vars + = ([tv_info:rev_tv_infos],th_vars <:= (tv_info_ptr, TVI_Type at_type), th_attrs <:= (av_info_ptr, AVI_Attr at_attribute)) + bind_and_save_var_and_attr {atv_variable = {tv_info_ptr}} {at_type} (rev_tv_infos,th_vars,th_attrs) + # (tv_info,th_vars) = readPtr tv_info_ptr th_vars + = ([tv_info:rev_tv_infos],th_vars <:= (tv_info_ptr, TVI_Type at_type),th_attrs) - substitute_rhs rem_annots rhs_type type_heaps - | rem_annots bitand RemoveAnnotationsMask<>0 - # (_, rhs_type) = removeAnnotations rhs_type - # (_,type,heaps) = substitute rhs_type type_heaps - = (type,heaps) - # (_,type,heaps) = substitute rhs_type type_heaps - = (type,heaps) + restore_tv_info tv_info {atv_variable={tv_info_ptr}} th_vars + = writePtr tv_info_ptr tv_info th_vars + + bind_attr (TA_Var {av_info_ptr}) attribute type_heaps=:{th_attrs} + = {type_heaps & th_attrs = th_attrs <:= (av_info_ptr, AVI_Attr attribute)} + bind_attr _ attribute type_heaps + = type_heaps + + substitute_rhs rem_annots rhs_type type_heaps + | rem_annots bitand RemoveAnnotationsMask<>0 + # (_, rhs_type) = removeAnnotations rhs_type + # (_,type,heaps) = substitute rhs_type type_heaps + = (type,heaps) + # (_,type,heaps) = substitute rhs_type type_heaps + = (type,heaps) collect_imported_constructors :: !{#.CommonDefs} !.Int !.TypeRhs !*ExpandTypeState -> .ExpandTypeState collect_imported_constructors common_defs mod_index (RecordType {rt_constructor}) ets=:{ets_collected_conses,ets_var_heap} -- cgit v1.2.3