Commit 0dd5ac28 authored by Martin Wierich's avatar Martin Wierich
Browse files

fusion works now. The fusion switch in module typesupport is enabled

parent b09775cd
...@@ -23,6 +23,7 @@ where ...@@ -23,6 +23,7 @@ where
kind_list_to_string [] = " ?????? " kind_list_to_string [] = " ?????? "
kind_list_to_string [k] = "* -> *" kind_list_to_string [k] = "* -> *"
kind_list_to_string [k:ks] = "* -> " +++ kind_list_to_string ks kind_list_to_string [k:ks] = "* -> " +++ kind_list_to_string ks
toString ki = "PPPP" //abort ("instance toString KindInfo matcht niet"->>ki)
kindError kind1 kind2 error kindError kind1 kind2 error
......
implementation module convertDynamics implementation module convertDynamics
import syntax, transform, utilities, convertcases import syntax, transform, utilities, convertcases
// XXX
import RWSDebug
:: *ConversionInfo = :: *ConversionInfo =
{ ci_predef_symb :: !*PredefinedSymbols { ci_predef_symb :: !*PredefinedSymbols
......
...@@ -413,7 +413,7 @@ element_appears imported_st element_ident dcl_index ...@@ -413,7 +413,7 @@ element_appears imported_st element_ident dcl_index
# structureInfo = case opt_element_idents of # structureInfo = case opt_element_idents of
No -> SI_DotDot No -> SI_DotDot
Yes element_idents -> (SI_Elements element_idents False) Yes element_idents -> (SI_Elements element_idents False)
newStructure = (struct_id, SI_DotDot, st, (if defined No (Yes dcl_index))) newStructure = (struct_id, structureInfo, st, (if defined No (Yes dcl_index)))
= element_appears imported_st element_ident dcl_index t [newStructure:akku] index modules cs = element_appears imported_st element_ident dcl_index t [newStructure:akku] index modules cs
# (Yes element_idents) = opt_element_idents # (Yes element_idents) = opt_element_idents
oneLess = filter ((<>) element_ident) element_idents oneLess = filter ((<>) element_ident) element_idents
...@@ -475,8 +475,6 @@ element_appears_in_stomm_struct imported_st element_ident dcl_index index type_n ...@@ -475,8 +475,6 @@ element_appears_in_stomm_struct imported_st element_ident dcl_index index type_n
# com_member_def = dcl_module.dcl_common.com_member_defs.[dcl_index] # com_member_def = dcl_module.dcl_common.com_member_defs.[dcl_index]
{glob_object} = com_member_def.me_class {glob_object} = com_member_def.me_class
com_class_def = dcl_module.dcl_common.com_class_defs.[glob_object] com_class_def = dcl_module.dcl_common.com_class_defs.[glob_object]
allMembers = com_class_def.class_members
member_idents = [ ds_ident \\ {ds_ident} <-: allMembers]
appears = com_class_def.class_name.id_name==type_name_string appears = com_class_def.class_name.id_name==type_name_string
= (appears, modules, cs) = (appears, modules, cs)
continuation _ _ _ modules cs continuation _ _ _ modules cs
...@@ -575,7 +573,7 @@ consequences_of count (expl_imp_ident_kind=:(_,expl_imp_kind), (dcl_index, mod_i ...@@ -575,7 +573,7 @@ consequences_of count (expl_imp_ident_kind=:(_,expl_imp_kind), (dcl_index, mod_i
consequences_of_macro count dcl_index f_consequences icl_functions expr_heap consequences_of_macro count dcl_index f_consequences icl_functions expr_heap
# (icl_function, icl_functions) = icl_functions![dcl_index] # (icl_function, icl_functions) = icl_functions![dcl_index]
{fun_symb, fun_type, fun_body} = icl_function {fun_body} = icl_function
result = consequences fun_body result = consequences fun_body
= expand_functions_and_dynamics result [] (f_consequences, icl_functions, expr_heap) = expand_functions_and_dynamics result [] (f_consequences, icl_functions, expr_heap)
where where
...@@ -601,8 +599,6 @@ consequences_of_macro count dcl_index f_consequences icl_functions expr_heap ...@@ -601,8 +599,6 @@ consequences_of_macro count dcl_index f_consequences icl_functions expr_heap
-> ([], expr_heap) -> ([], expr_heap)
(EI_Dynamic (Yes dynamicType)) (EI_Dynamic (Yes dynamicType))
-> (consequences dynamicType, expr_heap) -> (consequences dynamicType, expr_heap)
(EI_Dynamic (Yes dynamicType))
-> (consequences dynamicType, expr_heap)
(EI_DynamicType dynamicType further_dynamic_ptrs) (EI_DynamicType dynamicType further_dynamic_ptrs)
# (further_conseqs, expr_heap) = expand_dynamics further_dynamic_ptrs [] expr_heap # (further_conseqs, expr_heap) = expand_dynamics further_dynamic_ptrs [] expr_heap
-> (further_conseqs++consequences dynamicType, expr_heap) -> (further_conseqs++consequences dynamicType, expr_heap)
......
...@@ -3,6 +3,8 @@ module main ...@@ -3,6 +3,8 @@ module main
import scanner, parse, postparse, check, type, trans, convertcases, utilities, convertDynamics import scanner, parse, postparse, check, type, trans, convertcases, utilities, convertDynamics
import StdEnv import StdEnv
// XXX
import RWSDebug
Start world Start world
# (std_io, world) = stdio world # (std_io, world) = stdio world
...@@ -16,6 +18,17 @@ Start world ...@@ -16,6 +18,17 @@ Start world
(ms.ms_out, ms.ms_files))) world (ms.ms_out, ms.ms_files))) world
= fclose ms_out world = fclose ms_out world
CommandLoop proj ms=:{ms_io}
# answer = "c t5"
(command, argument) = SplitAtLayoutChar (dropWhile isSpace (fromString answer))
| command == []
= CommandLoop proj { ms & ms_io = ms_io}
# (ready, proj, ms) = DoCommand command argument proj { ms & ms_io = ms_io}
| ready
= ms
= ms
/*
CommandLoop proj ms=:{ms_io} CommandLoop proj ms=:{ms_io}
# (answer, ms_io) = freadline (ms_io <<< "> ") # (answer, ms_io) = freadline (ms_io <<< "> ")
(command, argument) = SplitAtLayoutChar (dropWhile isSpace (fromString answer)) (command, argument) = SplitAtLayoutChar (dropWhile isSpace (fromString answer))
...@@ -25,6 +38,7 @@ CommandLoop proj ms=:{ms_io} ...@@ -25,6 +38,7 @@ CommandLoop proj ms=:{ms_io}
| ready | ready
= ms = ms
= CommandLoop proj ms = CommandLoop proj ms
*/
:: MainStateDefs funs funtypes types conses classes instances members selectors = :: MainStateDefs funs funtypes types conses classes instances members selectors =
{ msd_funs :: !funs { msd_funs :: !funs
...@@ -163,19 +177,20 @@ loadModule mod_ident predef_symbols hash_table ms=:{ms_files,ms_error,ms_io,ms_o ...@@ -163,19 +177,20 @@ loadModule mod_ident predef_symbols hash_table ms=:{ms_files,ms_error,ms_io,ms_o
= (No, predef_symbols, { hash_table & hte_symbol_heap = symbol_table}, { ms & ms_files = ms_files, ms_error = ms_error, ms_io = ms_io, ms_out = ms_out }) = (No, predef_symbols, { hash_table & hte_symbol_heap = symbol_table}, { ms & ms_files = ms_files, ms_error = ms_error, ms_io = ms_io, ms_out = ms_out })
# (components, fun_defs) = partitionateFunctions (fun_defs ---> "partitionateFunctions") [ { ir_from = 0, ir_to = nr_of_global_funs }, icl_instances, icl_specials] # (components, fun_defs) = partitionateFunctions (fun_defs ---> "partitionateFunctions") [ { ir_from = 0, ir_to = nr_of_global_funs }, icl_instances, icl_specials]
(components, fun_defs, ms_io) = showTypes components 0 fun_defs ms_io // (components, fun_defs, ms_error) = showTypes components 0 fun_defs ms_error
// (components, fun_defs, ms_out) = showComponents components 0 True fun_defs ms_out (components, fun_defs, ms_error) = showComponents components 0 True fun_defs ms_error
(cleanup_info, acc_args, components, fun_defs, var_heap, expression_heap) (cleanup_info, acc_args, components, fun_defs, var_heap, expression_heap)
= analyseGroups (components ---> "Transform") fun_defs heaps.hp_var_heap heaps.hp_expression_heap = analyseGroups common_defs (components ---> "Transform") fun_defs imported_funs heaps.hp_var_heap heaps.hp_expression_heap
(components, fun_defs, dcl_types, used_conses, var_heap, type_heaps, expression_heap) #!(components, fun_defs, dcl_types, used_conses, var_heap, type_heaps, expression_heap)
= transformGroups cleanup_info components fun_defs acc_args common_defs imported_funs var_heap heaps.hp_type_heaps expression_heap = transformGroups cleanup_info components fun_defs acc_args common_defs imported_funs var_heap heaps.hp_type_heaps expression_heap
/// (components, fun_defs, ms_error) = showComponents components 0 True fun_defs ms_error (components, fun_defs, ms_error) = showComponents components 0 True fun_defs ms_error
// (components, fun_defs, ms_error) = showTypes components 0 fun_defs ms_error
(dcl_types, used_conses, var_heap, type_heaps) = convertIclModule common_defs dcl_types used_conses var_heap type_heaps (dcl_types, used_conses, var_heap, type_heaps) = convertIclModule common_defs dcl_types used_conses var_heap type_heaps
(dcl_types, used_conses, var_heap, type_heaps) = convertDclModule dcl_mods common_defs dcl_types used_conses var_heap type_heaps (dcl_types, used_conses, var_heap, type_heaps) = convertDclModule dcl_mods common_defs dcl_types used_conses var_heap type_heaps
(components, fun_defs, predef_symbols, dcl_types, used_conses, var_heap, type_heaps, expression_heap) (components, fun_defs, predef_symbols, dcl_types, used_conses, var_heap, type_heaps, expression_heap)
= convertDynamicPatternsIntoUnifyAppls type_code_instances common_defs (components ---> "convertDynamics") fun_defs predef_symbols = convertDynamicPatternsIntoUnifyAppls type_code_instances common_defs (components ---> "convertDynamics") fun_defs predef_symbols
dcl_types used_conses var_heap type_heaps expression_heap dcl_types used_conses var_heap type_heaps expression_heap
(components, fun_defs, ms_out) = showComponents components 0 True fun_defs ms_out // (components, fun_defs, ms_out) = showComponents components 0 True fun_defs ms_out
(used_funs, components, fun_defs, dcl_types, used_conses, var_heap, type_heaps, expression_heap) (used_funs, components, fun_defs, dcl_types, used_conses, var_heap, type_heaps, expression_heap)
= convertCasesOfFunctionsIntoPatterns components imported_funs common_defs fun_defs dcl_types used_conses var_heap type_heaps expression_heap = convertCasesOfFunctionsIntoPatterns components imported_funs common_defs fun_defs dcl_types used_conses var_heap type_heaps expression_heap
(dcl_types, var_heap, type_heaps) (dcl_types, var_heap, type_heaps)
...@@ -247,6 +262,8 @@ where ...@@ -247,6 +262,8 @@ where
show_component [] show_types fun_defs file show_component [] show_types fun_defs file
= (fun_defs, file <<< '\n') = (fun_defs, file <<< '\n')
show_component [fun:funs] show_types fun_defs file show_component [fun:funs] show_types fun_defs file
| fun>=size fun_defs
= abort ("YYY "+++toString fun+++" "+++toString (size fun_defs))
#! fun_def = fun_defs.[fun] #! fun_def = fun_defs.[fun]
| show_types | show_types
= show_component funs show_types fun_defs (file <<< '\n' <<< fun_def) = show_component funs show_types fun_defs (file <<< '\n' <<< fun_def)
...@@ -297,9 +314,7 @@ where ...@@ -297,9 +314,7 @@ where
= (fun_defs, file <<< '\n') = (fun_defs, file <<< '\n')
show_types [fun:funs] fun_defs file show_types [fun:funs] fun_defs file
#! fun_def = fun_defs.[fun] #! fun_def = fun_defs.[fun]
# properties = { form_properties = cAttributed bitor cAnnotated, form_attr_position = No } = show_types funs fun_defs (file <<< '\n' <<< fun_def.fun_type)
(Yes ftype) = fun_def.fun_type
= show_types funs fun_defs (file <<< fun_def.fun_symb <<< " :: " <:: (properties, ftype) <<< '\n' )
converFileToListOfStrings file_name files error converFileToListOfStrings file_name files error
# (ok, file, files) = fopen file_name FReadText files # (ok, file, files) = fopen file_name FReadText files
......
...@@ -478,7 +478,12 @@ cIsALocalVar :== False ...@@ -478,7 +478,12 @@ cIsALocalVar :== False
VI_ExpandedType !SymbolType | /* for storing the (expanded) type of an imported function */ VI_ExpandedType !SymbolType | /* for storing the (expanded) type of an imported function */
VI_Record ![AuxiliaryPattern] | VI_Record ![AuxiliaryPattern] |
VI_Pattern !AuxiliaryPattern | VI_Pattern !AuxiliaryPattern |
VI_Default !Int /* used during conversion of dynamics; the Int indiacted the refenrence count */ VI_Default !Int | /* used during conversion of dynamics; the Int indiacted the refenrence count */
VI_Body !SymbIdent !TransformedBody ![FreeVar] | /* used during fusion */
VI_Dictionary !SymbIdent ![Expression] ![Type] | /* used during fusion */
VI_Extended !ExtendedVarInfo !VarInfo
:: ExtendedVarInfo = EVI_VarType !AType
:: ArgumentPosition :== Int :: ArgumentPosition :== Int
...@@ -638,20 +643,16 @@ cNonRecursiveAppl :== False ...@@ -638,20 +643,16 @@ cNonRecursiveAppl :== False
| EI_Default !Expression !AType !ExprInfoPtr | EI_Default !Expression !AType !ExprInfoPtr
| EI_DefaultFunction !SymbIdent ![Expression] | EI_DefaultFunction !SymbIdent ![Expression]
| EI_Extended ![ExtendedExprInfo] !ExprInfo | EI_Extended !ExtendedExprInfo !ExprInfo
:: ExtendedExprInfo :: ExtendedExprInfo
= EEI_ActiveCase !ActiveCaseInfo = EEI_ActiveCase !ActiveCaseInfo
:: ActiveCaseInfo = :: ActiveCaseInfo =
{ aci_arg_pos :: !Int { aci_params :: ![FreeVar]
, aci_opt_unfolder:: !(Optional SymbIdent) , aci_opt_unfolder :: !(Optional SymbIdent)
, aci_free_vars :: !Optional [VarId] , aci_free_vars :: !Optional [BoundVar]
} , aci_linearity_of_patterns :: ![[Bool]]
:: VarId =
{ v_name :: !Ident
, v_info_ptr :: !VarInfoPtr
} }
:: RefCountsInCase = :: RefCountsInCase =
......
...@@ -434,7 +434,12 @@ cIsALocalVar :== False ...@@ -434,7 +434,12 @@ cIsALocalVar :== False
VI_ExpandedType !SymbolType | /* for storing the (expanded) type of an imported function */ VI_ExpandedType !SymbolType | /* for storing the (expanded) type of an imported function */
VI_Record ![AuxiliaryPattern] | VI_Record ![AuxiliaryPattern] |
VI_Pattern !AuxiliaryPattern | VI_Pattern !AuxiliaryPattern |
VI_Default !Int /* used during conversion of dynamics; the Int indiacted the refenrence count */ VI_Default !Int | /* used during conversion of dynamics; the Int indiacted the refenrence count */
VI_Body !SymbIdent !TransformedBody ![FreeVar] | /* used during fusion */
VI_Dictionary !SymbIdent ![Expression] ![Type] | /* used during fusion */
VI_Extended !ExtendedVarInfo !VarInfo
:: ExtendedVarInfo = EVI_VarType !AType
:: ArgumentPosition :== Int :: ArgumentPosition :== Int
...@@ -585,20 +590,16 @@ cNotVarNumber :== -1 ...@@ -585,20 +590,16 @@ cNotVarNumber :== -1
| EI_Default !Expression !AType !ExprInfoPtr | EI_Default !Expression !AType !ExprInfoPtr
| EI_DefaultFunction !SymbIdent ![Expression] | EI_DefaultFunction !SymbIdent ![Expression]
| EI_Extended ![ExtendedExprInfo] !ExprInfo | EI_Extended !ExtendedExprInfo !ExprInfo
:: ExtendedExprInfo :: ExtendedExprInfo
= EEI_ActiveCase !ActiveCaseInfo = EEI_ActiveCase !ActiveCaseInfo
:: ActiveCaseInfo = :: ActiveCaseInfo =
{ aci_arg_pos :: !Int { aci_params :: ![FreeVar]
, aci_opt_unfolder:: !(Optional SymbIdent) , aci_opt_unfolder :: !(Optional SymbIdent)
, aci_free_vars :: !Optional [VarId] , aci_free_vars :: !Optional [BoundVar]
} , aci_linearity_of_patterns :: ![[Bool]]
:: VarId =
{ v_name :: !Ident
, v_info_ptr :: !VarInfoPtr
} }
:: RefCountsInCase = :: RefCountsInCase =
...@@ -1276,7 +1277,7 @@ where ...@@ -1276,7 +1277,7 @@ where
instance <<< BoundVar instance <<< BoundVar
where where
(<<<) file {var_name,var_info_ptr,var_expr_ptr} (<<<) file {var_name,var_info_ptr,var_expr_ptr}
= file <<< var_name <<< '<' <<< ptrToInt var_info_ptr <<< ',' <<< ptrToInt var_expr_ptr <<< '>' = file <<< var_name <<< '<' <<< ptrToInt var_info_ptr /*<<< ',' <<< ptrToInt var_expr_ptr*/ <<< '>'
instance <<< Bind a b | <<< a & <<< b instance <<< Bind a b | <<< a & <<< b
where where
...@@ -1326,8 +1327,10 @@ where ...@@ -1326,8 +1327,10 @@ where
instance <<< Expression instance <<< Expression
where where
(<<<) file (Var ident) = file <<< ident (<<<) file (Var ident) = file <<< ident
(<<<) file (App {app_symb, app_args}) (<<<) file (App {app_symb, app_args, app_info_ptr})
= file <<< app_symb <<< ' ' <<< app_args = file <<< app_symb <<< (if (app_symb.symb_name.id_name=="==" && isNilPtr app_info_ptr) "\"NIL\"" "") <<< ' ' <<< app_args
// was (<<<) file (App {app_symb, app_args})
// = file <<< app_symb <<< ' ' <<< app_args
(<<<) file (f_exp @ a_exp) = file <<< '(' <<< f_exp <<< " @ " <<< a_exp <<< ')' (<<<) file (f_exp @ a_exp) = file <<< '(' <<< f_exp <<< " @ " <<< a_exp <<< ')'
(<<<) file (Let {let_binds, let_expr}) = write_binds (file <<< "let " <<< '\n') let_binds <<< "in\n" <<< let_expr (<<<) file (Let {let_binds, let_expr}) = write_binds (file <<< "let " <<< '\n') let_binds <<< "in\n" <<< let_expr
where where
......
...@@ -10,7 +10,7 @@ cAccumulating :== -3 ...@@ -10,7 +10,7 @@ cAccumulating :== -3
:: CleanupInfo :: CleanupInfo
analyseGroups :: !*{! Group} !*{#FunDef} !*VarHeap !*ExpressionHeap analyseGroups :: !{# CommonDefs} !*{! Group} !*{#FunDef} !*VarHeap !*ExpressionHeap
-> (!CleanupInfo, !*{! ConsClasses}, !*{! Group}, !*{#FunDef}, !*VarHeap, !*ExpressionHeap) -> (!CleanupInfo, !*{! ConsClasses}, !*{! Group}, !*{#FunDef}, !*VarHeap, !*ExpressionHeap)
transformGroups :: !CleanupInfo !*{! Group} !*{#FunDef} !{!.ConsClasses} !{# CommonDefs} !{# {# FunType} } !*VarHeap !*TypeHeaps !*ExpressionHeap transformGroups :: !CleanupInfo !*{! Group} !*{#FunDef} !{!.ConsClasses} !{# CommonDefs} !{# {# FunType} } !*VarHeap !*TypeHeaps !*ExpressionHeap
......
This diff is collapsed.
...@@ -13,11 +13,16 @@ partitionateMacros :: !IndexRange !Index !*{# FunDef} !u:{# DclModule} !*VarHeap ...@@ -13,11 +13,16 @@ partitionateMacros :: !IndexRange !Index !*{# FunDef} !u:{# DclModule} !*VarHeap
-> (!*{# FunDef}, !u:{# DclModule}, !*VarHeap, !*ExpressionHeap, !*SymbolTable, !*ErrorAdmin ) -> (!*{# FunDef}, !u:{# DclModule}, !*VarHeap, !*ExpressionHeap, !*SymbolTable, !*ErrorAdmin )
:: UnfoldState = :: UnfoldState =
{ us_var_heap :: !.VarHeap { us_var_heap :: !.VarHeap
, us_symbol_heap :: !.ExpressionHeap , us_symbol_heap :: !.ExpressionHeap
, us_cleanup_info :: ![ExprInfoPtr] , us_opt_type_heaps :: !.Optional .TypeHeaps
, us_cleanup_info :: ![ExprInfoPtr]
, us_subst_vars :: !Bool
, us_handle_aci_free_vars :: !AciFreeVarHandleMode
} }
:: AciFreeVarHandleMode = LeaveThem | RemoveThem | SubstituteThem
class unfold a :: !a !*UnfoldState -> (!a, !*UnfoldState) class unfold a :: !a !*UnfoldState -> (!a, !*UnfoldState)
instance unfold Expression, CasePatterns instance unfold Expression, CasePatterns
......
...@@ -159,11 +159,16 @@ where ...@@ -159,11 +159,16 @@ where
= ({ pattern & dp_rhs = dp_rhs }, ls) = ({ pattern & dp_rhs = dp_rhs }, ls)
:: UnfoldState = :: UnfoldState =
{ us_var_heap :: !.VarHeap { us_var_heap :: !.VarHeap
, us_symbol_heap :: !.ExpressionHeap , us_symbol_heap :: !.ExpressionHeap
, us_cleanup_info :: ![ExprInfoPtr] , us_opt_type_heaps :: !.Optional .TypeHeaps
, us_cleanup_info :: ![ExprInfoPtr]
, us_subst_vars :: !Bool // XXX currently not used
, us_handle_aci_free_vars :: !AciFreeVarHandleMode
} }
:: AciFreeVarHandleMode = LeaveThem | RemoveThem | SubstituteThem
class unfold a :: !a !*UnfoldState -> (!a, !*UnfoldState) class unfold a :: !a !*UnfoldState -> (!a, !*UnfoldState)
instance unfold [a] | unfold a instance unfold [a] | unfold a
...@@ -183,17 +188,48 @@ where ...@@ -183,17 +188,48 @@ where
= (no, us) = (no, us)
unfoldVariable :: !BoundVar !*UnfoldState -> (!Expression, !*UnfoldState) unfoldVariable :: !BoundVar !*UnfoldState -> (!Expression, !*UnfoldState)
unfoldVariable var=:{var_name,var_info_ptr} us=:{us_var_heap} unfoldVariable var=:{var_name,var_info_ptr} us
#! var_info = sreadPtr var_info_ptr us_var_heap // XXX | not us.us_subst_vars
// = (Var var, us)
#! (var_info, us) = readVarInfo var_info_ptr us
= case var_info of = case var_info of
VI_Expression expr VI_Expression expr
-> (expr, us) -> (expr, us)
VI_Variable var_name var_info_ptr VI_Variable var_name var_info_ptr
# (var_expr_ptr, us_symbol_heap) = newPtr EI_Empty us.us_symbol_heap # (var_expr_ptr, us_symbol_heap) = newPtr EI_Empty us.us_symbol_heap
-> (Var {var_name = var_name, var_info_ptr = var_info_ptr, var_expr_ptr = var_expr_ptr}, { us & us_symbol_heap = us_symbol_heap}) -> (Var {var_name = var_name, var_info_ptr = var_info_ptr, var_expr_ptr = var_expr_ptr}, { us & us_symbol_heap = us_symbol_heap})
VI_Body fun_symb _ vars
-> (App { app_symb = fun_symb,
app_args = [ Var { var_name=fv_name, var_info_ptr=fv_info_ptr, var_expr_ptr=nilPtr }
\\ {fv_name,fv_info_ptr}<-vars],
app_info_ptr = nilPtr }, us)
VI_Dictionary app_symb app_args class_types
# (new_class_types, us_opt_type_heaps) = substitute_class_types class_types us.us_opt_type_heaps
(new_info_ptr, us_symbol_heap) = newPtr (EI_ClassTypes new_class_types) us.us_symbol_heap
-> (App { app_symb = app_symb, app_args = app_args, app_info_ptr = new_info_ptr },
{ us & us_opt_type_heaps = us_opt_type_heaps, us_symbol_heap = us_symbol_heap })
_ _
-> (Var var, us) -> (Var var, us)
where
substitute_class_types class_types no=:No
= (class_types, no)
substitute_class_types class_types (Yes type_heaps)
# (new_class_types, type_heaps) = substitute class_types type_heaps
= (new_class_types, Yes type_heaps)
readVarInfo var_info_ptr us
#! var_info = sreadPtr var_info_ptr us.us_var_heap
= case var_info of
VI_Extended _ original -> (original, us)
_ -> (var_info, us)
writeVarInfo :: VarInfoPtr VarInfo *VarHeap -> *VarHeap
writeVarInfo var_info_ptr new_var_info var_heap
# (old_var_info, var_heap) = readPtr var_info_ptr var_heap
= case old_var_info of
VI_Extended extensions _ -> writePtr var_info_ptr (VI_Extended extensions new_var_info) var_heap
_ -> writePtr var_info_ptr new_var_info var_heap
instance unfold Expression instance unfold Expression
where where
unfold (Var var) us unfold (Var var) us
...@@ -258,12 +294,34 @@ where ...@@ -258,12 +294,34 @@ where
instance unfold App instance unfold App
where where
unfold app=:{app_symb, app_args} us unfold app=:{app_symb, app_args, app_info_ptr} us
# (app_args, us) = unfold app_args us # (new_info_ptr, us)
| is_function_or_macro app_symb.symb_kind = case is_function_or_macro app_symb.symb_kind of
# (new_info_ptr, us_symbol_heap) = newPtr EI_Empty us.us_symbol_heap True # (new_ptr, us_symbol_heap) = newPtr EI_Empty us.us_symbol_heap
= ({ app & app_args = app_args, app_info_ptr = new_info_ptr}, { us & us_symbol_heap = us_symbol_heap }) -> (new_ptr, { us & us_symbol_heap = us_symbol_heap })
= ({ app & app_args = app_args, app_info_ptr = nilPtr }, us) _ -> case (app_symb.symb_kind, isNilPtr app_info_ptr) of
(SK_Constructor _, False)
# (app_info, us_symbol_heap) = readPtr app_info_ptr us.us_symbol_heap
(new_app_info, us_opt_type_heaps) = substitute_EI_ClassTypes app_info us.us_opt_type_heaps
(new_ptr, us_symbol_heap) = newPtr new_app_info us_symbol_heap
-> (new_ptr, { us & us_symbol_heap = us_symbol_heap, us_opt_type_heaps = us_opt_type_heaps })
_ -> (nilPtr, us)
(app_args, us) = unfold app_args us
= ({ app & app_args = app_args, app_info_ptr = new_info_ptr}, us)
/*
unfold app=:{app_symb, app_args, app_info_ptr} us=:{us_symbol_heap}
# (new_info_ptr, us_symbol_heap)
= case is_function_or_macro app_symb.symb_kind of
True -> newPtr EI_Empty us_symbol_heap
_ -> case (app_symb.symb_kind, isNilPtr app_info_ptr) of
(SK_Constructor _, False)
# (app_info, us_symbol_heap) = readPtr app_info_ptr us_symbol_heap
-> newPtr app_info us_symbol_heap
_ -> (nilPtr, us_symbol_heap)
us = { us & us_symbol_heap = us_symbol_heap }
(app_args, us) = unfold app_args us
= ({ app & app_args = app_args, app_info_ptr = new_info_ptr}, us)
*/
where where
is_function_or_macro (SK_Function _) is_function_or_macro (SK_Function _)
= True = True
...@@ -271,8 +329,13 @@ where ...@@ -271,8 +329,13 @@ where
= True = True
is_function_or_macro (SK_OverloadedFunction _) is_function_or_macro (SK_OverloadedFunction _)
= True = True
is_function_or_macro symb_kind is_function_or_macro _
= False = False
substitute_EI_ClassTypes (EI_ClassTypes class_types) (Yes type_heaps)
# (new_class_types, type_heaps) = substitute class_types type_heaps
= (EI_ClassTypes new_class_types, Yes type_heaps)
substitute_EI_ClassTypes x opt_type_heaps
= (x, opt_type_heaps)
instance unfold (Bind a b) | unfold a instance unfold (Bind a b) | unfold a
where where
...@@ -283,14 +346,72 @@ where ...@@ -283,14 +346,72 @@ where
instance unfold Case instance unfold Case
where where
unfold kees=:{ case_expr,case_guards,case_default,case_info_ptr} us=:{us_cleanup_info} unfold kees=:{ case_expr,case_guards,case_default,case_info_ptr} us=:{us_cleanup_info}
# ((case_expr,(case_guards,case_default)), us) = unfold (case_expr,(case_guards,case_default)) us # (old_case_info, us_symbol_heap) = readPtr case_info_ptr us.us_symbol_heap
(old_case_info, us_symbol_heap) = readPtr case_info_ptr us.us_symbol_heap (new_case_info, us_opt_type_heaps) = substitute_let_or_case_type old_case_info us.us_opt_type_heaps
(new_info_ptr, us_symbol_heap) = newPtr old_case_info us_symbol_heap (new_info_ptr, us_symbol_heap) = newPtr new_case_info us_symbol_heap
us_cleanup_info = case old_case_info of us_cleanup_info = case old_case_info of
EI_Extended _ _ -> [new_info_ptr:us_cleanup_info] EI_Extended _ _ -> [new_info_ptr:us_cleanup_info]
_ -> us_cleanup_info _ -> us_cleanup_info
= ({ kees & case_expr = case_expr,case_guards = case_guards, case_default = case_default, case_info_ptr = new_info_ptr}, us = { us & us_symbol_heap = us_symbol_heap, us_opt_type_heaps = us_opt_type_heaps, us_cleanup_info=us_cleanup_info }
{ us & us_symbol_heap = us_symbol_heap, us_cleanup_info=us_cleanup_info }) ((case_guards,case_default), us) = unfold (case_guards,case_default) us
(case_expr, us) = update_active_case_info_and_unfold case_expr new_info_ptr us
= ({ kees & case_expr = case_expr,case_guards = case_guards, case_default = case_default, case_info_ptr = new_info_ptr}, us)
where
update_active_case_info_and_unfold case_expr=:(Var {var_info_ptr}) case_info_ptr us=:{us_handle_aci_free_vars}
#! case_info = sreadPtr case_info_ptr us.us_symbol_heap
= case case_info of
EI_Extended (EEI_ActiveCase aci=:{aci_free_vars}) ei
#!(new_aci_free_vars, us) = case us_handle_aci_free_vars of
LeaveThem -> (aci_free_vars, us)
RemoveThem -> (No, us)
SubstituteThem -> case aci_free_vars of
No -> (No, us)
Yes fvs # (fvs_subst, us) = mapSt unfoldBoundVar fvs us