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 ...@@ -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 (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 (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 (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) = (result_expr, free_vars, { e_state & es_expr_heap = es_expr_heap }, e_info, cs)
where where
...@@ -1418,7 +1418,7 @@ where ...@@ -1418,7 +1418,7 @@ where
bind_default_variable bind_src bind_dst result_expr expr_heap bind_default_variable bind_src bind_dst result_expr expr_heap
# (let_expr_ptr, expr_heap) = newPtr EI_Empty 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) let_expr = result_expr, let_info_ptr = let_expr_ptr }, expr_heap)
bind_pattern_variables [] pattern_expr 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 ...@@ -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 (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) = (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 :: !(Env Expression FreeVar) !(Env Expression FreeVar) !Expression !*ExpressionHeap -> (!Expression, !*ExpressionHeap)
buildLetExpression [] is_strict expr expr_heap buildLetExpression [] [] expr expr_heap
= (expr, expr_heap) = (expr, expr_heap)
buildLetExpression binds is_strict expr expr_heap buildLetExpression let_strict_binds let_lazy_binds expr expr_heap
# (let_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap # (let_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
| is_strict = (Let {let_strict_binds = let_strict_binds, let_lazy_binds = let_lazy_binds, let_expr = expr, let_info_ptr = let_expr_ptr }, expr_heap)
= (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)
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 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) # (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 ...@@ -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) = (rhs_expr, free_vars, e_state, e_info, cs)
checkRhssAndTransformLocalDefs free_vars loc_defs rhs_expr e_input 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 # (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) = (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 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 ...@@ -1894,9 +1892,9 @@ where
(let_binds, es_var_heap, es_expr_heap, e_info, cs) (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 = 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 } 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) = 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) = (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 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) = ([], let_vars_list, ei_expr_level, free_vars, e_state, e_info, cs)
...@@ -1917,14 +1915,13 @@ where ...@@ -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 } 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) = (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 build_sequential_lets [] expr expr_heap
= (expr, expr_heap) = (expr, expr_heap)
build_sequential_lets [(nd_strict,[]) : seq_lets] expr expr_heap build_sequential_lets [(strict_binds, lazy_binds) : seq_lets] expr expr_heap
= build_sequential_lets seq_lets expr expr_heap
build_sequential_lets [(nd_strict,binds) : seq_lets] expr expr_heap
# (let_expr, expr_heap) = build_sequential_lets 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 } 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 ...@@ -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 # (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 } 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 } 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, (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 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) = (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 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) = ({ 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 ...@@ -1995,7 +1992,6 @@ typeOfBasicValue (BVS _) cs
= (BT_String (TA (MakeTypeSymbIdent { glob_object = ds_index, glob_module = glob_module } ds_ident ds_arity) []), 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 addArraySelections [] rhs_expr free_vars e_input e_state e_info cs
= (rhs_expr, free_vars, 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 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 ...@@ -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} buildSelections e_input {ap_opt_var, ap_array_var, ap_selections}
(strict_binds, lazy_binds, free_vars, e_state, e_info, cs) (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) # (ap_array_var, [last_array_selection:lazy_binds], free_vars, e_state, e_info, cs)
= foldSt (build_sc e_input) ap_selections = foldSt (build_sc e_input) (reverse ap_selections) // reverse to make cycle-in-spine behaviour compatible to Clean 1.3
(ap_array_var, strict_binds, lazy_binds, free_vars, e_state, e_info, cs) (ap_array_var, lazy_binds, free_vars, e_state, e_info, cs)
(lazy_binds, e_state) (lazy_binds, e_state)
= case ap_opt_var of = case ap_opt_var of
Yes { bind_src = opt_var_ident, bind_dst = opt_var_var_info_ptr } 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 # (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, free_var = { fv_name = opt_var_ident, fv_info_ptr = opt_var_var_info_ptr, fv_def_level = NotALevel,
fv_count = 0 } 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 }) { e_state & es_expr_heap = es_expr_heap })
no -> (lazy_binds, e_state) 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 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) # (var_for_uselect_result, es_var_heap)
= allocate_free_var { id_name = "_x", id_info = nilPtr } e_state.es_var_heap = allocate_free_var { id_name = "_x", id_info = nilPtr } e_state.es_var_heap
(new_array_var, es_var_heap) (new_array_var, es_var_heap)
...@@ -2036,7 +2032,8 @@ buildSelections e_input {ap_opt_var, ap_array_var, ap_selections} ...@@ -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 = allocate_bound_var ap_array_var e_state.es_expr_heap
(bound_var_for_uselect_result, es_expr_heap) (bound_var_for_uselect_result, es_expr_heap)
= allocate_bound_var 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) (new_expr_ptrs, es_expr_heap)
= mapSt newPtr (repeatn dimension EI_Empty) es_expr_heap = mapSt newPtr (repeatn dimension EI_Empty) es_expr_heap
(tuple_cons, cs) (tuple_cons, cs)
...@@ -2055,11 +2052,10 @@ buildSelections e_input {ap_opt_var, ap_array_var, ap_selections} ...@@ -2055,11 +2052,10 @@ buildSelections e_input {ap_opt_var, ap_array_var, ap_selections}
selections selections
= [ ArraySelection glob_select_symb new_expr_ptr index_expr \\ new_expr_ptr<-new_expr_ptrs & index_expr<-index_exprs ] = [ ArraySelection glob_select_symb new_expr_ptr index_expr \\ new_expr_ptr<-new_expr_ptrs & index_expr<-index_exprs ]
= ( new_array_var = ( new_array_var
, strict_binds
, [ {bind_dst = var_for_uselect_result, bind_src = Selection opt_tuple_type (Var bound_array_var) selections} , [ {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)} , {bind_dst = array_element_var, bind_src = TupleSelect tuple_cons.glob_object 0 (Var bound_var_for_uselect_result)}
: lazy_binds : binds
] ]
, free_vars , free_vars
, e_state , e_state
......
...@@ -3,6 +3,10 @@ definition module checksupport ...@@ -3,6 +3,10 @@ definition module checksupport
import StdEnv import StdEnv
import syntax, predef import syntax, predef
SwitchUniquenessBug with_bug without_bug :== with_bug
// temporary switch for compiling the Object I/O library
cIclModIndex :== 0 cIclModIndex :== 0
CS_NotChecked :== -1 CS_NotChecked :== -1
......
...@@ -6,6 +6,9 @@ import utilities ...@@ -6,6 +6,9 @@ import utilities
:: VarHeap :== Heap VarInfo :: VarHeap :== Heap VarInfo
SwitchUniquenessBug with_bug without_bug :== with_bug
// temporary switch for compiling the Object I/O library
cIclModIndex :== 0 cIclModIndex :== 0
CS_NotChecked :== -1 CS_NotChecked :== -1
......
...@@ -1021,13 +1021,8 @@ where ...@@ -1021,13 +1021,8 @@ where
TA_Var var TA_Var var
-> (TA_RootVar var, error) -> (TA_RootVar var, error)
_ _
-> (TA_RootVar undef, error) -> (SwitchUniquenessBug (TA_RootVar (abort "SwitchUniquenessBug is on")) root_attr, error)
/* = case root_attr of check_attribute attr root_attr name error
TA_Var var
-> (TA_RootVar var, error)
_
-> (root_attr, error)
*/ check_attribute attr root_attr name error
= (TA_Multi, checkError name "specified attribute not allowed" error) = (TA_Multi, checkError name "specified attribute not allowed" error)
retrieveKinds :: ![ATypeVar] *TypeVarHeap -> (![TypeKind], !*TypeVarHeap) retrieveKinds :: ![ATypeVar] *TypeVarHeap -> (![TypeKind], !*TypeVarHeap)
......
...@@ -505,7 +505,7 @@ instance t_corresponds TypeAttribute where ...@@ -505,7 +505,7 @@ instance t_corresponds TypeAttribute where
t_corresponds (TA_Var dclDef) (TA_Var iclDef) t_corresponds (TA_Var dclDef) (TA_Var iclDef)
= t_corresponds dclDef iclDef = t_corresponds dclDef iclDef
t_corresponds (TA_RootVar dclDef) (TA_RootVar iclDef) t_corresponds (TA_RootVar dclDef) (TA_RootVar iclDef)
= t_corresponds dclDef iclDef = SwitchUniquenessBug (return True) (t_corresponds dclDef iclDef)
t_corresponds _ TA_Anonymous t_corresponds _ TA_Anonymous
= return True = return True
t_corresponds TA_None icl t_corresponds TA_None icl
......
...@@ -486,7 +486,7 @@ where ...@@ -486,7 +486,7 @@ where
convert_function group_index dcl_functions common_defs fun (fun_defs, collected_imports, ci) convert_function group_index dcl_functions common_defs fun (fun_defs, collected_imports, ci)
#! fun_def = fun_defs.[fun] #! fun_def = fun_defs.[fun]
# {fun_body,fun_type} = fun_def # {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_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) = ({fun_defs & [fun] = { fun_def & fun_body = fun_body }}, collected_imports, ci)
...@@ -935,10 +935,10 @@ where ...@@ -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 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. 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 ...@@ -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 (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} 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_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 & rc_var_heap = foldSt store_binding let_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 (let_info, rc_expr_heap) = readPtr let_info_ptr rc_info.rc_expr_heap
rc_info = { rc_info & rc_expr_heap = rc_expr_heap } rc_info = { rc_info & rc_expr_heap = rc_expr_heap }
= case let_info of = case let_info of
EI_LetType let_type EI_LetType let_type
# (ref_counts, rc_var_heap) = mapSt get_ref_count let_binds rc_info.rc_var_heap # (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_binds (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_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)} 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 } -> { 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 where
remove_variable ([], var_heap) let_bind remove_variable ([], var_heap) let_bind
= ([], var_heap) = ([], var_heap)
...@@ -1219,9 +1219,9 @@ checkImportedSymbol symb_kind symb_type_ptr (collected_imports, var_heap) ...@@ -1219,9 +1219,9 @@ checkImportedSymbol symb_kind symb_type_ptr (collected_imports, var_heap)
, di_expr_heap :: !.ExpressionHeap , di_expr_heap :: !.ExpressionHeap
} }
/* /*
distributeLets tries to move shared expressions as close as possible to the location at ewhich they are used. distributeLets tries to move shared expressions as close as possible to the location at which they are used.
Case-expression may require unsharing if the shared expression is used in different alternatives. Of course Case-expressions 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. only if the expression is neither used in the pattern nor in a surrounding expression.
*/ */
class distributeLets e :: !Int !e !*DistributeInfo -> (!e, !*DistributeInfo) class distributeLets e :: !Int !e !*DistributeInfo -> (!e, !*DistributeInfo)
...@@ -1284,12 +1284,22 @@ where ...@@ -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} 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 # (let_info, di_expr_heap) = readPtr let_info_ptr di_expr_heap
# (EI_LetTypeAndRefCounts let_type ref_counts) = let_info # (EI_LetTypeAndRefCounts let_type ref_counts) = let_info
let_binds = [(True, bind) \\ bind <- let_strict_binds] ++ [(False, bind) \\ bind <- let_lazy_binds] nr_of_strict_lets = length let_strict_binds
di_var_heap = set_let_expression_info depth let_binds ref_counts let_type di_var_heap 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 } (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 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 where
set_let_expression_info depth [(let_strict, {bind_src,bind_dst}):binds][ref_count:ref_counts][type:types] var_heap 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 # (new_info_ptr, var_heap) = newPtr VI_Empty var_heap
...@@ -1385,7 +1395,7 @@ where ...@@ -1385,7 +1395,7 @@ where
mark_local_let_var depth {cv_variable, cv_count} (local_vars, var_heap) 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 # (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})) = ([(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)) ==> ("mark_local_let_var ", lei.lei_var.fv_name, cv_variable, (lei.lei_var.fv_info_ptr, cv_count, depth))
= (local_vars, var_heap) = (local_vars, var_heap)
...@@ -1430,16 +1440,21 @@ distributeLetsInLetExpression depth let_var_info_ptr lei=:{lei_expression, lei_s ...@@ -1430,16 +1440,21 @@ distributeLetsInLetExpression depth let_var_info_ptr lei=:{lei_expression, lei_s
buildLetExpr :: ![VarInfoPtr] !Expression !*(!*VarHeap, !*ExpressionHeap) -> (!Expression, !(!*VarHeap, !*ExpressionHeap)) buildLetExpr :: ![VarInfoPtr] !Expression !*(!*VarHeap, !*ExpressionHeap) -> (!Expression, !(!*VarHeap, !*ExpressionHeap))
buildLetExpr let_vars let_expr (var_heap, expr_heap) 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 # (lazy_binds, lazy_binds_types, var_heap) = foldr build_bind ([], [], var_heap) let_vars
| isEmpty strict_binds && isEmpty lazy_binds | isEmpty lazy_binds
= (let_expr, (var_heap, expr_heap)) = (let_expr, (var_heap, expr_heap))
# (let_info_ptr, expr_heap) = newPtr (EI_LetType (strict_bind_types ++ lazy_binds_types)) expr_heap = case let_expr of
= (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)) 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 where
build_bind :: !VarInfoPtr !(!Env Expression FreeVar, ![AType], !Env Expression FreeVar, ![AType], !*VarHeap) build_bind :: !VarInfoPtr !(!Env Expression FreeVar, ![AType], !*VarHeap)
-> (!Env Expression FreeVar, ![AType], !Env Expression FreeVar, ![AType], !*VarHeap) -> (!Env Expression FreeVar, ![AType], !*VarHeap)
build_bind info_ptr (strict_binds, strict_bind_types, lazy_binds, lazy_binds_types, var_heap) build_bind info_ptr (lazy_binds, lazy_binds_types, var_heap)
# (let_info, var_heap) = readPtr info_ptr 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 # (VI_LetExpression lei=:{lei_strict,lei_var,lei_expression,lei_status,lei_type}) = let_info
(LES_Updated updated_expr) = lei_status (LES_Updated updated_expr) = lei_status
...@@ -1447,8 +1462,8 @@ where ...@@ -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 }}) 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_var.fv_name, info_ptr, new_info_ptr)
| lei_strict | lei_strict
= ([{ bind_src = updated_expr, bind_dst = lei_var } : strict_binds], [lei_type : strict_bind_types ], lazy_binds, lazy_binds_types, var_heap) = abort "assertion 1 failed in module convercases"
= (strict_binds, strict_bind_types, [{ bind_src = updated_expr, bind_dst = lei_var } : lazy_binds], [lei_type : lazy_binds_types ], var_heap) = ([{ bind_src = updated_expr, bind_dst = lei_var } : lazy_binds], [lei_type : lazy_binds_types ], var_heap)
instance distributeLets Selection instance distributeLets Selection
where where
......
...@@ -777,15 +777,14 @@ instance consequences Expression ...@@ -777,15 +777,14 @@ instance consequences Expression
consequences (FreeVar _) = [] consequences (FreeVar _) = []
consequences (DynamicExpr dynamicExpr) = consequences dynamicExpr consequences (DynamicExpr dynamicExpr) = consequences dynamicExpr
consequences EE = [] consequences EE = []
// RWS ...
consequences (Update expr1 selections expr2) = consequences expr1++consequences selections++consequences expr2 consequences (Update expr1 selections expr2) = consequences expr1++consequences selections++consequences expr2
consequences expr = abort "explicitimports:consequences (Expression) does not match" <<- expr consequences expr = abort "explicitimports:consequences (Expression) does not match" <<- expr
// ... RWS
instance consequences FunctionBody instance consequences FunctionBody
where consequences (CheckedBody body) = consequences body where consequences (CheckedBody body) = consequences body
consequences (TransformedBody body) = consequences body consequences (TransformedBody body) = consequences body
// other alternatives should not occur consequences (RhsMacroBody body) = consequences body
instance consequences FunType instance consequences FunType
where where
consequences {ft_type} = consequences ft_type consequences {ft_type} = consequences ft_type
......
...@@ -486,7 +486,7 @@ cIsALocalVar :== False ...@@ -486,7 +486,7 @@ cIsALocalVar :== False
:: LetExpressionInfo = :: LetExpressionInfo =
{ lei_count :: !Int { lei_count :: !Int
, lei_depth :: !Int , lei_depth :: !Int
, lei_strict :: !Bool , lei_strict :: !Bool // MW this field seems to be superfluos
, lei_var :: !FreeVar , lei_var :: !FreeVar
, lei_expression :: !Expression , lei_expression :: !Expression
// , lei_moved :: !Bool // , lei_moved :: !Bool
......
...@@ -1325,12 +1325,13 @@ where ...@@ -1325,12 +1325,13 @@ where
(<<<) file (App {app_symb, app_args, app_info_ptr}) (<<<) file (App {app_symb, app_args, app_info_ptr})
= file <<< 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_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 where
write_binds file [] write_binds x file []
= file = file
write_binds file [bind : binds] write_binds x file [bind : binds]
= write_binds (file <<< bind <<< '\n') binds