Skip to content
GitLab
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
Expand all Hide whitespace changes
Inline Side-by-side
frontend/analtypes.icl
View file @ 0dd5ac28
......@@ -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
......
frontend/convertDynamics.icl
View file @ 0dd5ac28
implementation module convertDynamics
import syntax, transform, utilities, convertcases
// XXX
import RWSDebug
:: *ConversionInfo =
{ ci_predef_symb :: !*PredefinedSymbols
......
frontend/explicitimports.icl
View file @ 0dd5ac28
......@@ -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)
......
frontend/main.icl
View file @ 0dd5ac28
......@@ -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
......
frontend/syntax.dcl
View file @ 0dd5ac28
......@@ -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 =
......
frontend/syntax.icl
View file @ 0dd5ac28
......@@ -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
......
frontend/trans.dcl
View file @ 0dd5ac28
......@@ -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
......
frontend/trans.icl
View file @ 0dd5ac28
This diff is collapsed.
frontend/transform.dcl
View file @ 0dd5ac28
......@@ -13,11 +13,16 @@ partitionateMacros :: !IndexRange !Index !*{# FunDef} !u:{# DclModule} !*VarHeap
-> (!*{# FunDef}, !u:{# DclModule}, !*VarHeap, !*ExpressionHeap, !*SymbolTable, !*ErrorAdmin )
:: UnfoldState =
{ us_var_heap :: !.VarHeap
, us_symbol_heap :: !.ExpressionHeap
, us_cleanup_info :: ![ExprInfoPtr]
{ 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
......
frontend/transform.icl
View file @ 0dd5ac28
......@@ -159,11 +159,16 @@ where
= ({ pattern & dp_rhs = dp_rhs }, ls)
:: UnfoldState =
{ us_var_heap :: !.VarHeap
, us_symbol_heap :: !.ExpressionHeap
, us_cleanup_info :: ![ExprInfoPtr]
{ 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,17 +188,48 @@ 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_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
unfold (Var var) us
......@@ -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??"
frontend/typesupport.dcl
View file @ 0dd5ac28
......@@ -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
frontend/typesupport.icl
View file @ 0dd5ac28
......@@ -3,8 +3,8 @@ implementation module typesupport
import StdEnv, StdCompare
import syntax, parse, check, unitype, utilities, RWSDebug