Commit 3beb0c41 authored by Martin Wierich's avatar Martin Wierich
Browse files

- making array patterns strict (strict lets were not properly handled

   in "convertCasesOfFunctionsIntoPatterns" and "collectVariables")
 - new switch "SwitchUniquenessBug" in module checksupport
 - several bugfixes
parent 6c71d5f6
......@@ -1258,7 +1258,7 @@ checkExpression free_vars (PE_Case case_ident expr alts) e_input e_state e_info
(guards, _, pattern_variables, defaul, free_vars, e_state, e_info, cs) = check_guarded_expressions free_vars alts [] case_ident.id_name e_input e_state e_info cs
(pattern_expr, binds, es_expr_heap) = bind_pattern_variables pattern_variables pattern_expr e_state.es_expr_heap
(case_expr, es_expr_heap) = build_case guards defaul pattern_expr case_ident es_expr_heap
(result_expr, es_expr_heap) = buildLetExpression binds cIsNotStrict case_expr es_expr_heap
(result_expr, es_expr_heap) = buildLetExpression [] binds case_expr es_expr_heap
= (result_expr, free_vars, { e_state & es_expr_heap = es_expr_heap }, e_info, cs)
where
......@@ -1418,7 +1418,7 @@ where
bind_default_variable bind_src bind_dst result_expr expr_heap
# (let_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
= (Let {let_strict_binds = [{ bind_src = bind_src, bind_dst = bind_dst }], let_lazy_binds = [],
= (Let {let_strict_binds = [], let_lazy_binds = [{ bind_src = bind_src, bind_dst = bind_dst }],
let_expr = result_expr, let_info_ptr = let_expr_ptr }, expr_heap)
bind_pattern_variables [] pattern_expr expr_heap
......@@ -1667,14 +1667,12 @@ checkArraySelection glob_select_symb free_vars index_expr e_input e_state e_info
(new_info_ptr, es_expr_heap) = newPtr EI_Empty e_state.es_expr_heap
= (ArraySelection glob_select_symb new_info_ptr index_expr, free_vars, { e_state & es_expr_heap = es_expr_heap }, e_info, cs)
buildLetExpression :: !(Env Expression FreeVar) !Bool !Expression !*ExpressionHeap -> (!Expression, !*ExpressionHeap)
buildLetExpression [] is_strict expr expr_heap
buildLetExpression :: !(Env Expression FreeVar) !(Env Expression FreeVar) !Expression !*ExpressionHeap -> (!Expression, !*ExpressionHeap)
buildLetExpression [] [] expr expr_heap
= (expr, expr_heap)
buildLetExpression binds is_strict expr expr_heap
# (let_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
| is_strict
= (Let {let_strict_binds = binds, let_lazy_binds = [], let_expr = expr, let_info_ptr = let_expr_ptr }, expr_heap)
= (Let {let_strict_binds = [], let_lazy_binds = binds, let_expr = expr, let_info_ptr = let_expr_ptr }, expr_heap)
buildLetExpression let_strict_binds let_lazy_binds expr expr_heap
# (let_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
= (Let {let_strict_binds = let_strict_binds, let_lazy_binds = let_lazy_binds, let_expr = expr, let_info_ptr = let_expr_ptr }, expr_heap)
checkLhssOfLocalDefs def_level mod_index (CollectedLocalDefs {loc_functions={ir_from,ir_to},loc_nodes}) e_state=:{es_var_heap,es_fun_defs} e_info cs
# (loc_defs, accus, {ps_fun_defs,ps_var_heap}, e_info, cs)
......@@ -1694,7 +1692,7 @@ checkRhssAndTransformLocalDefs free_vars [] rhs_expr e_input e_state e_info cs
= (rhs_expr, free_vars, e_state, e_info, cs)
checkRhssAndTransformLocalDefs free_vars loc_defs rhs_expr e_input e_state e_info cs
# (binds, free_vars, e_state, e_info, cs) = checkAndTransformPatternIntoBind free_vars loc_defs e_input e_state e_info cs
(rhs_expr, es_expr_heap) = buildLetExpression binds cIsNotStrict rhs_expr e_state.es_expr_heap
(rhs_expr, es_expr_heap) = buildLetExpression [] binds rhs_expr e_state.es_expr_heap
= (rhs_expr, free_vars, { e_state & es_expr_heap = es_expr_heap }, e_info, cs)
checkAndTransformPatternIntoBind free_vars [{nd_dst,nd_alts,nd_locals} : local_defs] e_input=:{ei_expr_level,ei_mod_index} e_state e_info cs
......@@ -1894,9 +1892,9 @@ where
(let_binds, es_var_heap, es_expr_heap, e_info, cs)
= transfromPatternIntoBind ei_mod_index ei_expr_level pattern_expr src_expr e_state.es_var_heap e_state.es_expr_heap e_info cs
e_state = { e_state & es_var_heap = es_var_heap, es_expr_heap = es_expr_heap }
(_, array_pattern_binds, free_vars, e_state, e_info, cs) // XXX arrays currently not strictly evaluated
(strict_array_pattern_binds, lazy_array_pattern_binds, free_vars, e_state, e_info, cs)
= foldSt (buildSelections e_input) array_patterns ([], [], free_vars, e_state, e_info, cs)
all_binds = [(seq_let.ndwl_strict, let_binds), (nOT_STRICT, array_pattern_binds) : binds] with nOT_STRICT = False
all_binds = [if seq_let.ndwl_strict (let_binds,[]) ([],let_binds), (strict_array_pattern_binds, lazy_array_pattern_binds) : binds]
= (all_binds, loc_envs, max_expr_level, free_vars, e_state, e_info, cs)
check_sequential_lets free_vars [] let_vars_list e_input=:{ei_expr_level} e_state e_info cs
= ([], let_vars_list, ei_expr_level, free_vars, e_state, e_info, cs)
......@@ -1917,14 +1915,13 @@ where
e_state = { e_state & es_var_heap = ps_var_heap, es_expr_heap = hp_expression_heap, es_type_heaps = hp_type_heaps, es_fun_defs = ps_fun_defs }
= (src_expr, pattern, accus, free_vars, e_state, e_info, cs)
build_sequential_lets :: ![(Bool,[Bind Expression FreeVar])] !Expression !*ExpressionHeap -> (!Expression, !*ExpressionHeap)
build_sequential_lets :: ![(![Bind Expression FreeVar],![Bind Expression FreeVar])] !Expression !*ExpressionHeap -> (!Expression, !*ExpressionHeap)
build_sequential_lets [] expr expr_heap
= (expr, expr_heap)
build_sequential_lets [(nd_strict,[]) : seq_lets] expr expr_heap
= build_sequential_lets seq_lets expr expr_heap
build_sequential_lets [(nd_strict,binds) : seq_lets] expr expr_heap
build_sequential_lets [(strict_binds, lazy_binds) : seq_lets] expr expr_heap
# (let_expr, expr_heap) = build_sequential_lets seq_lets expr expr_heap
= buildLetExpression binds nd_strict let_expr expr_heap
= buildLetExpression strict_binds lazy_binds let_expr expr_heap
newVarId name = { id_name = name, id_info = nilPtr }
......@@ -1945,8 +1942,8 @@ convertSubPattern (AP_Variable name var_info (Yes {bind_src,bind_dst})) result_e
# (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
bound_var = { var_name = bind_src, var_info_ptr = bind_dst, var_expr_ptr = var_expr_ptr }
free_var = { fv_name = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 }
(let_expr, expr_heap) = buildLetExpression [{ bind_src = Var bound_var,
bind_dst = { fv_name = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }}] cIsNotStrict result_expr expr_heap
(let_expr, expr_heap) = buildLetExpression [] [{ bind_src = Var bound_var,
bind_dst = { fv_name = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }}] result_expr expr_heap
= (free_var, let_expr, var_store, expr_heap, opt_dynamics, cs)
convertSubPattern (AP_Variable name var_info No) result_expr var_store expr_heap opt_dynamics cs
= ({ fv_name = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }, result_expr, var_store, expr_heap, opt_dynamics, cs)
......@@ -1995,7 +1992,6 @@ typeOfBasicValue (BVS _) cs
= (BT_String (TA (MakeTypeSymbIdent { glob_object = ds_index, glob_module = glob_module } ds_ident ds_arity) []), cs)
// XXX no strict_binds
addArraySelections [] rhs_expr free_vars e_input e_state e_info cs
= (rhs_expr, free_vars, e_state, e_info, cs)
addArraySelections array_patterns rhs_expr free_vars e_input e_state e_info cs
......@@ -2013,21 +2009,21 @@ addArraySelections array_patterns rhs_expr free_vars e_input e_state e_info cs
buildSelections e_input {ap_opt_var, ap_array_var, ap_selections}
(strict_binds, lazy_binds, free_vars, e_state, e_info, cs)
# (ap_array_var, strict_binds, lazy_binds, free_vars, e_state, e_info, cs)
= foldSt (build_sc e_input) ap_selections
(ap_array_var, strict_binds, lazy_binds, free_vars, e_state, e_info, cs)
# (ap_array_var, [last_array_selection:lazy_binds], free_vars, e_state, e_info, cs)
= foldSt (build_sc e_input) (reverse ap_selections) // reverse to make cycle-in-spine behaviour compatible to Clean 1.3
(ap_array_var, lazy_binds, free_vars, e_state, e_info, cs)
(lazy_binds, e_state)
= case ap_opt_var of
Yes { bind_src = opt_var_ident, bind_dst = opt_var_var_info_ptr }
# (bound_array_var, es_expr_heap) = allocate_bound_var ap_array_var e_state.es_expr_heap
free_var = { fv_name = opt_var_ident, fv_info_ptr = opt_var_var_info_ptr, fv_def_level = NotALevel,
fv_count = 0 }
-> ([{ bind_dst = free_var, bind_src = Var bound_array_var } : lazy_binds],
-> ([{ bind_dst = free_var, bind_src = Var bound_array_var }: lazy_binds],
{ e_state & es_expr_heap = es_expr_heap })
no -> (lazy_binds, e_state)
= (strict_binds, lazy_binds, free_vars, e_state, e_info, cs)
= ([last_array_selection:strict_binds], lazy_binds, free_vars, e_state, e_info, cs)
where
build_sc e_input {bind_dst=parsed_index_exprs, bind_src=array_element_var} (ap_array_var, strict_binds, lazy_binds, free_vars, e_state, e_info, cs)
build_sc e_input {bind_dst=parsed_index_exprs, bind_src=array_element_var} (ap_array_var, binds, free_vars, e_state, e_info, cs)
# (var_for_uselect_result, es_var_heap)
= allocate_free_var { id_name = "_x", id_info = nilPtr } e_state.es_var_heap
(new_array_var, es_var_heap)
......@@ -2036,7 +2032,8 @@ buildSelections e_input {ap_opt_var, ap_array_var, ap_selections}
= allocate_bound_var ap_array_var e_state.es_expr_heap
(bound_var_for_uselect_result, es_expr_heap)
= allocate_bound_var var_for_uselect_result es_expr_heap
dimension = length parsed_index_exprs
dimension
= length parsed_index_exprs
(new_expr_ptrs, es_expr_heap)
= mapSt newPtr (repeatn dimension EI_Empty) es_expr_heap
(tuple_cons, cs)
......@@ -2055,11 +2052,10 @@ buildSelections e_input {ap_opt_var, ap_array_var, ap_selections}
selections
= [ ArraySelection glob_select_symb new_expr_ptr index_expr \\ new_expr_ptr<-new_expr_ptrs & index_expr<-index_exprs ]
= ( new_array_var
, strict_binds
, [ {bind_dst = var_for_uselect_result, bind_src = Selection opt_tuple_type (Var bound_array_var) selections}
, {bind_dst = new_array_var, bind_src = TupleSelect tuple_cons.glob_object 1 (Var bound_var_for_uselect_result)}
, {bind_dst = new_array_var, bind_src = TupleSelect tuple_cons.glob_object 1 (Var bound_var_for_uselect_result)}
, {bind_dst = array_element_var, bind_src = TupleSelect tuple_cons.glob_object 0 (Var bound_var_for_uselect_result)}
: lazy_binds
: binds
]
, free_vars
, e_state
......
......@@ -3,6 +3,10 @@ definition module checksupport
import StdEnv
import syntax, predef
SwitchUniquenessBug with_bug without_bug :== with_bug
// temporary switch for compiling the Object I/O library
cIclModIndex :== 0
CS_NotChecked :== -1
......
......@@ -6,6 +6,9 @@ import utilities
:: VarHeap :== Heap VarInfo
SwitchUniquenessBug with_bug without_bug :== with_bug
// temporary switch for compiling the Object I/O library
cIclModIndex :== 0
CS_NotChecked :== -1
......
......@@ -1021,13 +1021,8 @@ where
TA_Var var
-> (TA_RootVar var, error)
_
-> (TA_RootVar undef, error)
/* = case root_attr of
TA_Var var
-> (TA_RootVar var, error)
_
-> (root_attr, error)
*/ check_attribute attr root_attr name error
-> (SwitchUniquenessBug (TA_RootVar (abort "SwitchUniquenessBug is on")) root_attr, error)
check_attribute attr root_attr name error
= (TA_Multi, checkError name "specified attribute not allowed" error)
retrieveKinds :: ![ATypeVar] *TypeVarHeap -> (![TypeKind], !*TypeVarHeap)
......
......@@ -505,7 +505,7 @@ instance t_corresponds TypeAttribute where
t_corresponds (TA_Var dclDef) (TA_Var iclDef)
= t_corresponds dclDef iclDef
t_corresponds (TA_RootVar dclDef) (TA_RootVar iclDef)
= t_corresponds dclDef iclDef
= SwitchUniquenessBug (return True) (t_corresponds dclDef iclDef)
t_corresponds _ TA_Anonymous
= return True
t_corresponds TA_None icl
......
......@@ -486,7 +486,7 @@ where
convert_function group_index dcl_functions common_defs fun (fun_defs, collected_imports, ci)
#! fun_def = fun_defs.[fun]
# {fun_body,fun_type} = fun_def
(fun_body, (collected_imports, ci)) = eliminate_code_sharing_in_function dcl_functions common_defs fun_body /* (fun_body ---> ("convert_function", fun_def.fun_symb, fun_body)) */(collected_imports, ci)
(fun_body, (collected_imports, ci)) = eliminate_code_sharing_in_function dcl_functions common_defs fun_body /* (fun_body ---> ("convert_function", fun_def.fun_symb, fun_body)) */ (collected_imports, ci)
(fun_body, ci) = convert_cases_into_function_patterns fun_body fun_type group_index common_defs ci
= ({fun_defs & [fun] = { fun_def & fun_body = fun_body }}, collected_imports, ci)
......@@ -935,10 +935,10 @@ where
/*
weightedRefCount determines the references counts of variables in an expression. Runtime behaviour of constructs into account:
weightedRefCount determines the reference counts of variables in an expression. Runtime behaviour of constructs is taken into account:
multiple occurrences of variables in different alternatives of the same case clause are counted only once. The outcome
is used to distribute shared expressions (via let declarations) over cases. In this way code sharing is eliminated.
As a side effect, weightedRefCount returns a list of all imported function that have been used iinside the expression.
As a side effect, weightedRefCount returns a list of all imported functions that have been used inside the expression.
*/
......@@ -988,21 +988,21 @@ where
weightedRefCount dcl_functions common_defs depth (fun_expr @ exprs) rc_info
= weightedRefCount dcl_functions common_defs depth (fun_expr, exprs) rc_info
weightedRefCount dcl_functions common_defs depth (Let {let_strict_binds,let_lazy_binds,let_expr, let_info_ptr}) rc_info=:{rc_var_heap}
# let_binds = let_strict_binds ++ let_lazy_binds
# rc_info = weightedRefCount dcl_functions common_defs depth let_expr { rc_info & rc_var_heap = foldSt store_binding let_binds rc_var_heap }
# rc_info = weightedRefCount dcl_functions common_defs depth let_strict_binds { rc_info & rc_var_heap = foldSt store_binding let_lazy_binds rc_var_heap }
rc_info = weightedRefCount dcl_functions common_defs depth let_expr rc_info
(let_info, rc_expr_heap) = readPtr let_info_ptr rc_info.rc_expr_heap
rc_info = { rc_info & rc_expr_heap = rc_expr_heap }
= case let_info of
EI_LetType let_type
# (ref_counts, rc_var_heap) = mapSt get_ref_count let_binds rc_info.rc_var_heap
(rc_free_vars, rc_var_heap) = foldl remove_variable (rc_info.rc_free_vars, rc_var_heap) let_binds
# (ref_counts, rc_var_heap) = mapSt get_ref_count let_lazy_binds rc_info.rc_var_heap
(rc_free_vars, rc_var_heap) = foldl remove_variable (rc_info.rc_free_vars, rc_var_heap) let_lazy_binds
-> { rc_info & rc_free_vars = rc_free_vars, rc_var_heap = rc_var_heap,
rc_expr_heap = rc_info.rc_expr_heap <:= (let_info_ptr, EI_LetTypeAndRefCounts let_type ref_counts)}
// ---> ("weightedRefCount (EI_LetType)", ptrToInt let_info_ptr, [ x.bind_dst \\ x <- let_binds])
// ---> ("weightedRefCount (EI_LetType)", ptrToInt let_info_ptr, [ x.bind_dst \\ x <- let_lazy_binds])
_
# (rc_free_vars, rc_var_heap) = foldl remove_variable (rc_info.rc_free_vars, rc_info.rc_var_heap) let_binds
# (rc_free_vars, rc_var_heap) = foldl remove_variable (rc_info.rc_free_vars, rc_info.rc_var_heap) let_lazy_binds
-> { rc_info & rc_free_vars = rc_free_vars, rc_var_heap = rc_var_heap }
// ---> ("weightedRefCount (_)", ptrToInt let_info_ptr, [ x.bind_dst \\ x <- let_binds])
// ---> ("weightedRefCount (_)", ptrToInt let_info_ptr, [ x.bind_dst \\ x <- let_lazy_binds])
where
remove_variable ([], var_heap) let_bind
= ([], var_heap)
......@@ -1219,9 +1219,9 @@ checkImportedSymbol symb_kind symb_type_ptr (collected_imports, var_heap)
, di_expr_heap :: !.ExpressionHeap
}
/*
distributeLets tries to move shared expressions as close as possible to the location at ewhich they are used.
Case-expression may require unsharing if the shared expression is used in different alternatives. Of course
only if the expreesion is not used in the pattern nor in a surrounding expression.
distributeLets tries to move shared expressions as close as possible to the location at which they are used.
Case-expressions may require unsharing if the shared expression is used in different alternatives. Of course
only if the expression is neither used in the pattern nor in a surrounding expression.
*/
class distributeLets e :: !Int !e !*DistributeInfo -> (!e, !*DistributeInfo)
......@@ -1284,12 +1284,22 @@ where
distributeLets depth (Let lad=:{let_strict_binds,let_lazy_binds,let_expr,let_info_ptr}) dl_info=:{di_expr_heap,di_var_heap}
# (let_info, di_expr_heap) = readPtr let_info_ptr di_expr_heap
# (EI_LetTypeAndRefCounts let_type ref_counts) = let_info
let_binds = [(True, bind) \\ bind <- let_strict_binds] ++ [(False, bind) \\ bind <- let_lazy_binds]
di_var_heap = set_let_expression_info depth let_binds ref_counts let_type di_var_heap
nr_of_strict_lets = length let_strict_binds
let_binds = [(False, bind) \\ bind <- let_lazy_binds]
di_var_heap = set_let_expression_info depth let_binds ref_counts (drop nr_of_strict_lets let_type) di_var_heap
(let_expr, dl_info) = distributeLets depth let_expr { dl_info & di_var_heap = di_var_heap, di_expr_heap = di_expr_heap }
dl_info = foldSt (distribute_lets_in_non_distributed_let depth) let_strict_binds dl_info
(let_strict_binds, dl_info) = distributeLets depth let_strict_binds dl_info
dl_info = foldSt (distribute_lets_in_non_distributed_let depth) let_lazy_binds dl_info
= (let_expr, dl_info)
| nr_of_strict_lets == 0
= (let_expr, dl_info)
= case let_expr of
Let inner_let=:{let_info_ptr=inner_let_info_ptr}
# (EI_LetType strict_inner_types, di_expr_heap) = readPtr inner_let_info_ptr dl_info.di_expr_heap
di_expr_heap = writePtr inner_let_info_ptr (EI_LetType ((take nr_of_strict_lets let_type)++strict_inner_types)) di_expr_heap
-> (Let { inner_let & let_strict_binds = let_strict_binds++inner_let.let_strict_binds},
{dl_info & di_expr_heap = di_expr_heap})
_ -> (Let { lad & let_strict_binds = let_strict_binds, let_expr = let_expr, let_lazy_binds = []},
{dl_info & di_expr_heap = dl_info.di_expr_heap <:= (let_info_ptr, EI_LetType (take nr_of_strict_lets let_type))})
where
set_let_expression_info depth [(let_strict, {bind_src,bind_dst}):binds][ref_count:ref_counts][type:types] var_heap
# (new_info_ptr, var_heap) = newPtr VI_Empty var_heap
......@@ -1385,7 +1395,7 @@ where
mark_local_let_var depth {cv_variable, cv_count} (local_vars, var_heap)
# (VI_LetExpression lei=:{lei_count,lei_depth}, var_heap) = readPtr cv_variable var_heap
| lei_count == cv_count
| lei_count == cv_count
= ([(cv_variable, lei_count, lei_depth) : local_vars ], var_heap <:= (cv_variable, VI_LetExpression { lei & lei_depth = depth}))
==> ("mark_local_let_var ", lei.lei_var.fv_name, cv_variable, (lei.lei_var.fv_info_ptr, cv_count, depth))
= (local_vars, var_heap)
......@@ -1430,16 +1440,21 @@ distributeLetsInLetExpression depth let_var_info_ptr lei=:{lei_expression, lei_s
buildLetExpr :: ![VarInfoPtr] !Expression !*(!*VarHeap, !*ExpressionHeap) -> (!Expression, !(!*VarHeap, !*ExpressionHeap))
buildLetExpr let_vars let_expr (var_heap, expr_heap)
# (strict_binds, strict_bind_types, lazy_binds, lazy_binds_types, var_heap) = foldr build_bind ([], [], [], [], var_heap) let_vars
| isEmpty strict_binds && isEmpty lazy_binds
# (lazy_binds, lazy_binds_types, var_heap) = foldr build_bind ([], [], var_heap) let_vars
| isEmpty lazy_binds
= (let_expr, (var_heap, expr_heap))
# (let_info_ptr, expr_heap) = newPtr (EI_LetType (strict_bind_types ++ lazy_binds_types)) expr_heap
= (Let { let_strict_binds = strict_binds, let_lazy_binds = lazy_binds, let_expr = let_expr, let_info_ptr = let_info_ptr }, (var_heap, expr_heap))
= case let_expr of
Let inner_let=:{let_info_ptr }
# (EI_LetType strict_bind_types, expr_heap) = readPtr let_info_ptr expr_heap
expr_heap = writePtr let_info_ptr (EI_LetType (strict_bind_types ++ lazy_binds_types)) expr_heap
-> (Let { inner_let & let_lazy_binds = lazy_binds }, (var_heap, expr_heap))
_
# (let_info_ptr, expr_heap) = newPtr (EI_LetType lazy_binds_types) expr_heap
-> (Let { let_strict_binds = [], let_lazy_binds = lazy_binds, let_expr = let_expr, let_info_ptr = let_info_ptr }, (var_heap, expr_heap))
where
build_bind :: !VarInfoPtr !(!Env Expression FreeVar, ![AType], !Env Expression FreeVar, ![AType], !*VarHeap)
-> (!Env Expression FreeVar, ![AType], !Env Expression FreeVar, ![AType], !*VarHeap)
build_bind info_ptr (strict_binds, strict_bind_types, lazy_binds, lazy_binds_types, var_heap)
build_bind :: !VarInfoPtr !(!Env Expression FreeVar, ![AType], !*VarHeap)
-> (!Env Expression FreeVar, ![AType], !*VarHeap)
build_bind info_ptr (lazy_binds, lazy_binds_types, var_heap)
# (let_info, var_heap) = readPtr info_ptr var_heap
# (VI_LetExpression lei=:{lei_strict,lei_var,lei_expression,lei_status,lei_type}) = let_info
(LES_Updated updated_expr) = lei_status
......@@ -1447,8 +1462,8 @@ where
var_heap = var_heap <:= (info_ptr, VI_LetExpression { lei & lei_status = LES_Untouched, lei_var = { lei_var & fv_info_ptr = new_info_ptr }})
// ==> (lei_var.fv_name, info_ptr, new_info_ptr)
| lei_strict
= ([{ bind_src = updated_expr, bind_dst = lei_var } : strict_binds], [lei_type : strict_bind_types ], lazy_binds, lazy_binds_types, var_heap)
= (strict_binds, strict_bind_types, [{ bind_src = updated_expr, bind_dst = lei_var } : lazy_binds], [lei_type : lazy_binds_types ], var_heap)
= abort "assertion 1 failed in module convercases"
= ([{ bind_src = updated_expr, bind_dst = lei_var } : lazy_binds], [lei_type : lazy_binds_types ], var_heap)
instance distributeLets Selection
where
......
......@@ -777,15 +777,14 @@ instance consequences Expression
consequences (FreeVar _) = []
consequences (DynamicExpr dynamicExpr) = consequences dynamicExpr
consequences EE = []
// RWS ...
consequences (Update expr1 selections expr2) = consequences expr1++consequences selections++consequences expr2
consequences expr = abort "explicitimports:consequences (Expression) does not match" <<- expr
// ... RWS
instance consequences FunctionBody
where consequences (CheckedBody body) = consequences body
consequences (TransformedBody body) = consequences body
// other alternatives should not occur
consequences (RhsMacroBody body) = consequences body
instance consequences FunType
where
consequences {ft_type} = consequences ft_type
......
......@@ -486,7 +486,7 @@ cIsALocalVar :== False
:: LetExpressionInfo =
{ lei_count :: !Int
, lei_depth :: !Int
, lei_strict :: !Bool
, lei_strict :: !Bool // MW this field seems to be superfluos
, lei_var :: !FreeVar
, lei_expression :: !Expression
// , lei_moved :: !Bool
......
......@@ -1325,12 +1325,13 @@ where
(<<<) file (App {app_symb, app_args, app_info_ptr})
= file <<< app_symb <<< ' ' <<< app_args
(<<<) file (f_exp @ a_exp) = file <<< '(' <<< f_exp <<< " @ " <<< a_exp <<< ')'
(<<<) file (Let {let_info_ptr, let_strict_binds, let_lazy_binds, let_expr}) = write_binds (file <<< "let" <<< '\n') (let_strict_binds++let_lazy_binds) <<< "in\n" <<< let_expr
(<<<) file (Let {let_info_ptr, let_strict_binds, let_lazy_binds, let_expr})
= write_binds "" (write_binds "!" (file <<< "let" <<< '\n') let_strict_binds) let_lazy_binds <<< "in\n" <<< let_expr
where
write_binds file []
write_binds x file []
= file
write_binds file [bind : binds]
= write_binds (file <<< bind <<< '\n') binds
write_binds x file [bind : binds]
= write_binds x (file <<< x <<< " " <<< bind <<< '\n') binds
(<<<) file (Case {case_expr,case_guards,case_default=No})
= file <<< "case " <<< case_expr <<< " of\n" <<< case_guards
(<<<) file (Case {case_expr,case_guards,case_default= Yes def_expr})
......
......@@ -1733,32 +1733,46 @@ determineProducer is_applied_to_macro_fun linear_bit app=:{app_symb = symb=:{sym
= (producers, [App app : new_args ], ti)
# (fun_def, ti_fun_defs) = (ti.ti_fun_defs)![glob_object]
ti = { ti & ti_fun_defs=ti_fun_defs }
is_curried = fun_def.fun_arity<>length app_args
is_good_producer = (implies is_curried is_applied_to_macro_fun) && (implies (not is_curried) (SwitchFusion linear_bit False))
| is_good_producer
// curried applications may be fused with non linear consumers in functions local to a macro
= ({ producers & [prod_index] = PR_Function symb glob_object (length app_args)}, app_args ++ new_args, ti)
= (producers, [App app : new_args ], ti)
nr_of_app_args = length app_args
= determineFunAppProducer fun_def nr_of_app_args (PR_Function symb glob_object nr_of_app_args)
is_applied_to_macro_fun linear_bit app new_args prod_index producers ti
determineProducer is_applied_to_macro_fun linear_bit app=:{app_symb = symb=:{ symb_kind = SK_GeneratedFunction fun_ptr fun_index}, app_args} _
new_args prod_index producers ti
# (FI_Function {gf_fun_def}, ti_fun_heap) = readPtr fun_ptr ti.ti_fun_heap
ti = { ti & ti_fun_heap=ti_fun_heap }
# is_curried = gf_fun_def.fun_arity<>length app_args
is_good_producer = (implies is_curried is_applied_to_macro_fun) && (implies (not is_curried) (SwitchFusion linear_bit False))
| is_good_producer
// curried applications may be fused with non linear consumers in functions local to a macro
= case gf_fun_def.fun_body of
Expanding _ -> (producers, [App app : new_args ], ti)
_ -> ({ producers & [prod_index] = PR_GeneratedFunction symb fun_index (length app_args)}, app_args ++ new_args, ti)
= (producers, [App app : new_args ], ti)
nr_of_app_args = length app_args
= determineFunAppProducer gf_fun_def nr_of_app_args (PR_GeneratedFunction symb fun_index nr_of_app_args)
is_applied_to_macro_fun linear_bit app new_args prod_index producers ti
// XXX determineProducer {app_symb = symb=:{symb_kind = SK_Constructor glob_index}, app_args} new_args prod_index producers ti
// = ({ producers & [prod_index] = PR_Constructor symb app_args}, new_args, ti)
// XXX */
determineProducer _ _ app _ new_args _ producers ti
= (producers, [App app : new_args ], ti)
determineFunAppProducer {fun_body, fun_arity} nr_of_app_args new_producer
is_applied_to_macro_fun linear_bit app=:{app_args} new_args prod_index producers ti
# is_curried = fun_arity<>nr_of_app_args
is_expanding = case fun_body of { Expanding _ -> True; _ -> False }
is_good_producer = not is_expanding
&& (implies is_curried is_applied_to_macro_fun)
&& (implies (not is_curried) (SwitchFusion (linear_bit && is_good_body tb_rhs) False))
// curried applications may be fused with non linear consumers in functions local to a macro
| is_good_producer
= ({ producers & [prod_index] = new_producer}, app_args ++ new_args, ti)
= (producers, [App app : new_args ], ti)
where
(TransformedBody {tb_rhs}) = fun_body
is_good_body (AnyCodeExpr _ _ _) = False
is_good_body (ABCCodeExpr _ _) = False
is_good_body (Let {let_strict_binds}) = isEmpty let_strict_binds
// currently a producer's body must not be a let with strict bindings. The code sharing elimination algorithm assumes that
// all strict let bindings are on the top level expression (see "convertCasesOfFunctionsIntoPatterns"). This assumption
// could otherwise be violated during fusion.
// -> Here is place for optimisation: Either the fusion algorithm or the code sharing elimination algorithm could be
// extended to generate new functions when a strict let ends up during fusion in a non top level position (MW)
is_good_body _ = True
/*
verify_class_members [ App {app_symb, app_args} : mems]
= verify_class_members app_args && verify_class_members mems
......
......@@ -1190,14 +1190,15 @@ where
= (Let {lad & let_strict_binds = let_strict_binds, let_lazy_binds = let_lazy_binds }, free_vars,
{ cos & cos_var_heap = cos_var_heap, cos_error = checkError "" "cyclic let definition" cos.cos_error})
| otherwise
# (let_expr, free_vars, cos) = collectVariables let_expr free_vars { cos & cos_var_heap = cos_var_heap }
(let_strict_binds, free_vars, cos) = collect_variables_in_binds let_strict_binds [] free_vars cos
(let_lazy_binds, free_vars, cos) = collect_variables_in_binds let_lazy_binds [] free_vars cos
# (let_expr, free_vars, cos) = collectVariables let_expr free_vars { cos & cos_var_heap = cos_var_heap }
all_binds = mapAppend (\sb->(True, sb)) let_strict_binds [(False, lb) \\ lb<-let_lazy_binds]
(collected_binds, free_vars, cos) = collect_variables_in_binds all_binds [] free_vars cos
(let_strict_binds, let_lazy_binds) = split collected_binds
| isEmpty let_strict_binds && isEmpty let_lazy_binds
= (let_expr, free_vars, cos)
= (Let {lad & let_expr = let_expr, let_strict_binds = let_strict_binds, let_lazy_binds = let_lazy_binds}, free_vars, cos)
where
/* Set the 'var_info_field' of each bound variable to either 'VI_Alias var' (if
this variable is an alias for 'var') or to 'VI_Count 0 cIsALocalVar' to initialise
the reference count info.
......@@ -1211,7 +1212,7 @@ where
= var_heap
/* Remove all aliases from the list of 'let'-binds. Be carefull with cycles! */
/* Remove all aliases from the list of 'let'-binds. Be careful with cycles! */
detect_cycles_and_remove_alias_binds [] var_heap
= (cContainsNoCycle, [], var_heap)
......@@ -1247,17 +1248,26 @@ where
= collect_variables_in_binds binds collected_binds free_vars cos
= (collected_binds, free_vars, cos)
examine_reachable_binds bind_found [bind=:{bind_dst=fv=:{fv_info_ptr},bind_src} : binds] collected_binds free_vars cos
examine_reachable_binds bind_found [bind=:(is_strict, {bind_dst=fv=:{fv_info_ptr},bind_src}) : binds] collected_binds free_vars cos
# (bind_found, binds, collected_binds, free_vars, cos) = examine_reachable_binds bind_found binds collected_binds free_vars cos
#! var_info = sreadPtr fv_info_ptr cos.cos_var_heap
# (VI_Count count is_global) = var_info
| count > 0
# (bind_src, free_vars, cos) = collectVariables bind_src free_vars cos
= (True, binds, [ { bind_dst = { fv & fv_count = count }, bind_src = bind_src } : collected_binds ], free_vars, cos)
= (True, binds, [ (is_strict, { bind_dst = { fv & fv_count = count }, bind_src = bind_src }) : collected_binds ], free_vars, cos)
= (bind_found, [bind : binds], collected_binds, free_vars, cos)
examine_reachable_binds bind_found [] collected_binds free_vars cos
= (bind_found, [], collected_binds, free_vars, cos)
split :: ![(Bool, x)] -> (![x], ![x])
split []
= ([], [])
split [(p, x):xs]
# (l, r) = split xs
| p
= ([x:l], r)
= (l, [x:r])
collectVariables (Case case_expr) free_vars cos
# (case_expr, free_vars, cos) = collectVariables case_expr free_vars cos
= (Case case_expr, free_vars, cos)
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment