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
kind_list_to_string [] = " ?????? "
kind_list_to_string [k] = "* -> *"
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
......
implementation module convertDynamics
import syntax, transform, utilities, convertcases
// XXX
import RWSDebug
:: *ConversionInfo =
{ ci_predef_symb :: !*PredefinedSymbols
......
......@@ -413,7 +413,7 @@ element_appears imported_st element_ident dcl_index
# structureInfo = case opt_element_idents of
No -> SI_DotDot
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
# (Yes element_idents) = opt_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
# com_member_def = dcl_module.dcl_common.com_member_defs.[dcl_index]
{glob_object} = com_member_def.me_class
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, modules, cs)
continuation _ _ _ modules cs
......@@ -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
# (icl_function, icl_functions) = icl_functions![dcl_index]
{fun_symb, fun_type, fun_body} = icl_function
{fun_body} = icl_function
result = consequences fun_body
= expand_functions_and_dynamics result [] (f_consequences, icl_functions, expr_heap)
where
......@@ -601,8 +599,6 @@ consequences_of_macro count dcl_index f_consequences icl_functions expr_heap
-> ([], expr_heap)
(EI_Dynamic (Yes dynamicType))
-> (consequences dynamicType, expr_heap)
(EI_Dynamic (Yes dynamicType))
-> (consequences dynamicType, expr_heap)
(EI_DynamicType dynamicType further_dynamic_ptrs)
# (further_conseqs, expr_heap) = expand_dynamics further_dynamic_ptrs [] expr_heap
-> (further_conseqs++consequences dynamicType, expr_heap)
......
......@@ -3,6 +3,8 @@ module main
import scanner, parse, postparse, check, type, trans, convertcases, utilities, convertDynamics
import StdEnv
// XXX
import RWSDebug
Start world
# (std_io, world) = stdio world
......@@ -16,6 +18,17 @@ Start world
(ms.ms_out, ms.ms_files))) 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}
# (answer, ms_io) = freadline (ms_io <<< "> ")
(command, argument) = SplitAtLayoutChar (dropWhile isSpace (fromString answer))
......@@ -25,6 +38,7 @@ CommandLoop proj ms=:{ms_io}
| ready
= ms
= CommandLoop proj ms
*/
:: MainStateDefs funs funtypes types conses classes instances members selectors =
{ msd_funs :: !funs
......@@ -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 })
# (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_out) = showComponents components 0 True fun_defs ms_out
// (components, fun_defs, ms_error) = showTypes components 0 fun_defs ms_error
(components, fun_defs, ms_error) = showComponents components 0 True fun_defs ms_error
(cleanup_info, acc_args, components, fun_defs, var_heap, expression_heap)
= analyseGroups (components ---> "Transform") fun_defs heaps.hp_var_heap heaps.hp_expression_heap
(components, fun_defs, dcl_types, used_conses, var_heap, type_heaps, 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)
= 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) = 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)
= convertDynamicPatternsIntoUnifyAppls type_code_instances common_defs (components ---> "convertDynamics") fun_defs predef_symbols
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)
= convertCasesOfFunctionsIntoPatterns components imported_funs common_defs fun_defs dcl_types used_conses var_heap type_heaps expression_heap
(dcl_types, var_heap, type_heaps)
......@@ -247,6 +262,8 @@ where
show_component [] show_types fun_defs file
= (fun_defs, file <<< '\n')
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]
| show_types
= show_component funs show_types fun_defs (file <<< '\n' <<< fun_def)
......@@ -297,9 +314,7 @@ where
= (fun_defs, file <<< '\n')
show_types [fun:funs] fun_defs file
#! fun_def = fun_defs.[fun]
# properties = { form_properties = cAttributed bitor cAnnotated, form_attr_position = No }
(Yes ftype) = fun_def.fun_type
= show_types funs fun_defs (file <<< fun_def.fun_symb <<< " :: " <:: (properties, ftype) <<< '\n' )
= show_types funs fun_defs (file <<< '\n' <<< fun_def.fun_type)
converFileToListOfStrings file_name files error
# (ok, file, files) = fopen file_name FReadText files
......
......@@ -478,7 +478,12 @@ cIsALocalVar :== False
VI_ExpandedType !SymbolType | /* for storing the (expanded) type of an imported function */
VI_Record ![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
......@@ -638,20 +643,16 @@ cNonRecursiveAppl :== False
| EI_Default !Expression !AType !ExprInfoPtr
| EI_DefaultFunction !SymbIdent ![Expression]
| EI_Extended ![ExtendedExprInfo] !ExprInfo
| EI_Extended !ExtendedExprInfo !ExprInfo
:: ExtendedExprInfo
= EEI_ActiveCase !ActiveCaseInfo
:: ActiveCaseInfo =
{ aci_arg_pos :: !Int
, aci_opt_unfolder:: !(Optional SymbIdent)
, aci_free_vars :: !Optional [VarId]
}
:: VarId =
{ v_name :: !Ident
, v_info_ptr :: !VarInfoPtr
{ aci_params :: ![FreeVar]
, aci_opt_unfolder :: !(Optional SymbIdent)
, aci_free_vars :: !Optional [BoundVar]
, aci_linearity_of_patterns :: ![[Bool]]
}
:: RefCountsInCase =
......
......@@ -434,7 +434,12 @@ cIsALocalVar :== False
VI_ExpandedType !SymbolType | /* for storing the (expanded) type of an imported function */
VI_Record ![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
......@@ -585,20 +590,16 @@ cNotVarNumber :== -1
| EI_Default !Expression !AType !ExprInfoPtr
| EI_DefaultFunction !SymbIdent ![Expression]
| EI_Extended ![ExtendedExprInfo] !ExprInfo
| EI_Extended !ExtendedExprInfo !ExprInfo
:: ExtendedExprInfo
= EEI_ActiveCase !ActiveCaseInfo
:: ActiveCaseInfo =
{ aci_arg_pos :: !Int
, aci_opt_unfolder:: !(Optional SymbIdent)
, aci_free_vars :: !Optional [VarId]
}
:: VarId =
{ v_name :: !Ident
, v_info_ptr :: !VarInfoPtr
{ aci_params :: ![FreeVar]
, aci_opt_unfolder :: !(Optional SymbIdent)
, aci_free_vars :: !Optional [BoundVar]
, aci_linearity_of_patterns :: ![[Bool]]
}
:: RefCountsInCase =
......@@ -1276,7 +1277,7 @@ where
instance <<< BoundVar
where
(<<<) 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
where
......@@ -1326,8 +1327,10 @@ where
instance <<< Expression
where
(<<<) file (Var ident) = file <<< ident
(<<<) file (App {app_symb, app_args})
= file <<< app_symb <<< ' ' <<< app_args
(<<<) file (App {app_symb, app_args, app_info_ptr})
= 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 (Let {let_binds, let_expr}) = write_binds (file <<< "let " <<< '\n') let_binds <<< "in\n" <<< let_expr
where
......
......@@ -10,7 +10,7 @@ cAccumulating :== -3
:: CleanupInfo
analyseGroups :: !*{! Group} !*{#FunDef} !*VarHeap !*ExpressionHeap
analyseGroups :: !{# CommonDefs} !*{! Group} !*{#FunDef} !*VarHeap !*ExpressionHeap
-> (!CleanupInfo, !*{! ConsClasses}, !*{! Group}, !*{#FunDef}, !*VarHeap, !*ExpressionHeap)
transformGroups :: !CleanupInfo !*{! Group} !*{#FunDef} !{!.ConsClasses} !{# CommonDefs} !{# {# FunType} } !*VarHeap !*TypeHeaps !*ExpressionHeap
......
This diff is collapsed.
......@@ -15,9 +15,14 @@ partitionateMacros :: !IndexRange !Index !*{# FunDef} !u:{# DclModule} !*VarHeap
:: UnfoldState =
{ us_var_heap :: !.VarHeap
, us_symbol_heap :: !.ExpressionHeap
, 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)
instance unfold Expression, CasePatterns
......
......@@ -161,9 +161,14 @@ where
:: UnfoldState =
{ us_var_heap :: !.VarHeap
, us_symbol_heap :: !.ExpressionHeap
, 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)
instance unfold [a] | unfold a
......@@ -183,16 +188,47 @@ where
= (no, us)
unfoldVariable :: !BoundVar !*UnfoldState -> (!Expression, !*UnfoldState)
unfoldVariable var=:{var_name,var_info_ptr} us=:{us_var_heap}
#! var_info = sreadPtr var_info_ptr us_var_heap
unfoldVariable var=:{var_name,var_info_ptr} us
// XXX | not us.us_subst_vars
// = (Var var, us)
#! (var_info, us) = readVarInfo var_info_ptr us
= case var_info of
VI_Expression expr
-> (expr, us)
VI_Variable var_name var_info_ptr
# (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})
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)
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
where
......@@ -258,12 +294,34 @@ where
instance unfold App
where
unfold app=:{app_symb, app_args} us
# (app_args, us) = unfold app_args us
| is_function_or_macro app_symb.symb_kind
# (new_info_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 })
= ({ app & app_args = app_args, app_info_ptr = nilPtr }, us)
unfold app=:{app_symb, app_args, app_info_ptr} us
# (new_info_ptr, us)
= case is_function_or_macro app_symb.symb_kind of
True # (new_ptr, us_symbol_heap) = newPtr EI_Empty us.us_symbol_heap
-> (new_ptr, { us & us_symbol_heap = 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.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
is_function_or_macro (SK_Function _)
= True
......@@ -271,8 +329,13 @@ where
= True
is_function_or_macro (SK_OverloadedFunction _)
= True
is_function_or_macro symb_kind
is_function_or_macro _
= 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
where
......@@ -283,14 +346,72 @@ where
instance unfold Case
where
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
(new_info_ptr, us_symbol_heap) = newPtr old_case_info 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 new_case_info us_symbol_heap
us_cleanup_info = case old_case_info of
EI_Extended _ _ -> [new_info_ptr: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_symbol_heap = us_symbol_heap, us_cleanup_info=us_cleanup_info })
us = { us & us_symbol_heap = us_symbol_heap, us_opt_type_heaps = us_opt_type_heaps, 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
-> (Yes fvs_subst, us)
var_info = sreadPtr var_info_ptr us.us_var_heap
-> case var_info of
VI_Body fun_symb {tb_args, tb_rhs} new_aci_params
# tb_args_ptrs = [ fv_info_ptr \\ {fv_info_ptr}<-tb_args ]
(original_bindings, us_var_heap) = mapSt readPtr tb_args_ptrs us.us_var_heap
us_var_heap = fold2St bind tb_args_ptrs new_aci_params us_var_heap
(tb_rhs, us) = unfold tb_rhs { us & us_var_heap = us_var_heap }
us_var_heap = fold2St writePtr tb_args_ptrs original_bindings us.us_var_heap
new_aci = { aci & aci_params = new_aci_params, aci_opt_unfolder = Yes fun_symb, aci_free_vars = new_aci_free_vars }
new_eei = (EI_Extended (EEI_ActiveCase new_aci) ei)
us_symbol_heap = writePtr case_info_ptr new_eei us.us_symbol_heap
-> (tb_rhs, { us & us_var_heap = us_var_heap, us_symbol_heap = us_symbol_heap })
_ # new_eei = EI_Extended (EEI_ActiveCase { aci & aci_free_vars = new_aci_free_vars }) ei
us_symbol_heap = writePtr case_info_ptr new_eei us.us_symbol_heap
-> unfold case_expr { us & us_symbol_heap = us_symbol_heap }
_ -> unfold case_expr us
where
// XXX consider to store BoundVars in VI_Body
bind fv_info_ptr {fv_name=name, fv_info_ptr=info_ptr} var_heap
= writeVarInfo fv_info_ptr (VI_Expression (Var {var_name=name, var_info_ptr=info_ptr, var_expr_ptr = nilPtr})) var_heap
/*
bind ({fv_info_ptr}, var_bound_var) var_heap
= writeVarInfo fv_info_ptr (VI_Expression var_bound_var) var_heap
*/
/* update_active_case_info_and_unfold case_expr=:(Var {var_info_ptr}) case_info_ptr us
#! var_info = sreadPtr var_info_ptr us.us_var_heap
= case var_info of
VI_Body fun_symb fun_body new_aci_var_info_ptr
# (fun_body, us) = unfold fun_body us
(EI_Extended (EEI_ActiveCase aci) ei, us_symbol_heap) = readPtr case_info_ptr us.us_symbol_heap
new_aci = { aci & aci_var_info_ptr = new_aci_var_info_ptr, aci_opt_unfolder = Yes fun_symb }
us_symbol_heap = writePtr case_info_ptr (EI_Extended (EEI_ActiveCase new_aci) ei) us_symbol_heap
-> (fun_body, { us & us_symbol_heap = us_symbol_heap })
_ -> unfold case_expr us
*/
update_active_case_info_and_unfold case_expr _ us
= unfold case_expr us
unfoldBoundVar {var_info_ptr} us
#!var_info = sreadPtr var_info_ptr us.us_var_heap
# (VI_Expression (Var act_var)) = var_info
= (act_var, us)
instance unfold Let
where
......@@ -298,8 +419,10 @@ where
# (let_binds, us) = copy_bound_vars let_binds us
# ((let_binds,let_expr), us) = unfold (let_binds,let_expr) us
(old_let_info, us_symbol_heap) = readPtr let_info_ptr us.us_symbol_heap
(new_info_ptr, us_symbol_heap) = newPtr old_let_info us_symbol_heap
= ({lad & let_binds = let_binds, let_expr = let_expr, let_info_ptr = new_info_ptr}, { us & us_symbol_heap = us_symbol_heap })
(new_let_info, us_opt_type_heaps) = substitute_let_or_case_type old_let_info us.us_opt_type_heaps
(new_info_ptr, us_symbol_heap) = newPtr new_let_info us_symbol_heap
= ({lad & let_binds = let_binds, let_expr = let_expr, let_info_ptr = new_info_ptr},
{ us & us_symbol_heap = us_symbol_heap, us_opt_type_heaps = us_opt_type_heaps })
where
copy_bound_vars [bind=:{bind_dst} : binds] us
# (bind_dst, us) = unfold bind_dst us
......@@ -308,6 +431,19 @@ where
copy_bound_vars [] us
= ([], us)
substitute_let_or_case_type expr_info No
= (expr_info, No)
substitute_let_or_case_type (EI_Extended extensions expr_info) yes_type_heaps
# (new_expr_info, yes_type_heaps) = substitute_let_or_case_type expr_info yes_type_heaps
= (EI_Extended extensions new_expr_info, yes_type_heaps)
substitute_let_or_case_type (EI_CaseType case_type) (Yes type_heaps)
# (new_case_type, type_heaps) = substitute case_type type_heaps
= (EI_CaseType new_case_type, Yes type_heaps)
// = (EI_CaseType case_type, Yes type_heaps)
substitute_let_or_case_type (EI_LetType let_type) (Yes type_heaps)
# (new_let_type, type_heaps) = substitute let_type type_heaps
= (EI_LetType new_let_type, Yes type_heaps)
instance unfold CasePatterns
where
unfold (AlgebraicPatterns type patterns) us
......@@ -364,7 +500,9 @@ examineFunctionCall {id_info} fc=:{fc_index} (calls, symbol_table)
//unfoldMacro :: !FunDef ![Expression] !*ExpandInfo -> (!Expression, !*ExpandInfo)
unfoldMacro {fun_body = TransformedBody {tb_args,tb_rhs}, fun_info = {fi_calls}} args fun_defs (calls, es=:{es_var_heap,es_symbol_heap, es_symbol_table})
# (let_binds, var_heap) = bind_expressions tb_args args [] es_var_heap
(result_expr, {us_symbol_heap,us_var_heap}) = unfold tb_rhs { us_symbol_heap = es_symbol_heap, us_var_heap = var_heap, us_cleanup_info=[] }
us = { us_symbol_heap = es_symbol_heap, us_var_heap = var_heap, us_opt_type_heaps = No, us_cleanup_info = [],
us_subst_vars = True, us_handle_aci_free_vars = RemoveThem }
(result_expr, {us_symbol_heap,us_var_heap}) = unfold tb_rhs us
(calls, fun_defs, es_symbol_table) = updateFunctionCalls fi_calls calls fun_defs es_symbol_table
| isEmpty let_binds
= (result_expr, fun_defs, (calls, { es & es_var_heap = us_var_heap, es_symbol_heap = us_symbol_heap, es_symbol_table = es_symbol_table }))
......@@ -725,7 +863,9 @@ where
replace_variables [] expr ap_vars var_heap symbol_heap
= (expr, var_heap, symbol_heap)
replace_variables vars expr ap_vars var_heap symbol_heap
# (expr, us) = unfold expr { us_var_heap = build_aliases vars ap_vars var_heap, us_symbol_heap = symbol_heap, us_cleanup_info=[] }
# us = { us_var_heap = build_aliases vars ap_vars var_heap, us_symbol_heap = symbol_heap, us_opt_type_heaps = No,
us_cleanup_info=[], us_subst_vars = True, us_handle_aci_free_vars = RemoveThem }
(expr, us) = unfold expr us
= (expr, us.us_var_heap, us.us_symbol_heap)
build_aliases [var1 : vars1] [ {fv_name,fv_info_ptr} : vars2 ] var_heap
......@@ -1231,9 +1371,10 @@ where
_
-> abort "collectVariables [BoundVar] (transform, 1227)" <<- (var_info ---> var_name)
// XXX
instance <<< FreeVar
where
(<<<) file { fv_name } = file <<< fv_name
(<<<) file { fv_name,fv_info_ptr } = file <<< fv_name <<< "<" <<< fv_info_ptr <<< ">"
instance <<< Ptr a
where
......@@ -1243,3 +1384,7 @@ instance <<< FunCall
where
(<<<) file {fc_index} = file <<< fc_index
instance <<< VarInfo
where
(<<<) file (VI_Expression expr) = file <<< expr
(<<<) file vi = file <<< "VI??"
......@@ -4,6 +4,8 @@ import checksupport, StdCompare
from unitype import Coercions, CoercionTree, AttributePartition
// MW: this switch is used to en(dis)able the fusion algorithm
SwitchFusion fuse dont_fuse :== fuse
errorHeading :: !String !*ErrorAdmin -> *ErrorAdmin
......@@ -54,4 +56,5 @@ updateExpressionTypes :: !SymbolType !SymbolType ![ExprInfoPtr] !*TypeHeaps !*Ex
class substitute a :: !a !*TypeHeaps -> (!a, !*TypeHeaps)
instance substitute AType, Type, TypeContext, AttrInequality, CaseType, [a] | substitute a
instance <<< TempSymbolType
......@@ -3,8 +3,8 @@ implementation module typesupport
import StdEnv, StdCompare
import syntax, parse, check, unitype, utilities, RWSDebug
SwitchFusion x y = y
// MW: this switch is used to en(dis)able the fusion algorithm
SwitchFusion fuse dont_fuse :== fuse
:: Store :== Int
......@@ -380,6 +380,8 @@ instance bindInstances Type
= type_var_heap
bindInstances (CV l1 :@: r1) (CV l2 :@: r2) type_var_heap
= bindInstances r1 r2 (bindInstances (TV l1) (TV l2) type_var_heap)
bindInstances a b tvh
= abort ("abort"--->(a,b))