Commit 84ff9ad7 authored by Ronny Wichers Schreur's avatar Ronny Wichers Schreur 🏢
Browse files

reordered functions to reflect order within convertcases

parent 335d9ec7
......@@ -10,1297 +10,1298 @@ exactZip [] []
exactZip [x:xs][y:ys]
= [(x,y) : exactZip xs ys]
:: ConvertState =
{ cs_new_functions :: ![FunctionInfoPtr]
, cs_fun_heap :: !.FunctionHeap
, cs_var_heap :: !.VarHeap
, cs_expr_heap :: !.ExpressionHeap
, cs_next_fun_nr :: !Index
}
:: ConvertInfo =
{ ci_bound_vars :: ![(FreeVar, AType)]
, ci_group_index :: !Index
, ci_common_defs :: !{#CommonDefs}
}
getIdent (Yes ident) fun_nr
= ident
getIdent No fun_nr
= { id_name = "_f" +++ toString fun_nr, id_info = nilPtr }
class convertCases a :: !ConvertInfo !a !*ConvertState -> (!a, !*ConvertState)
instance convertCases [a] | convertCases a
where
convertCases ci l cs = mapSt (convertCases ci) l cs
instance convertCases (a,b) | convertCases a & convertCases b
where
convertCases ci t cs
= app2St (convertCases ci, convertCases ci) t cs
instance convertCases LetBind
where
convertCases ci bind=:{lb_src} cs
# (lb_src, cs) = convertCases ci lb_src cs
= ({ bind & lb_src = lb_src }, cs)
instance convertCases (Bind a b) | convertCases a
where
convertCases ci bind=:{bind_src} cs
# (bind_src, cs) = convertCases ci bind_src cs
= ({ bind & bind_src = bind_src }, cs)
instance convertCases Let
where
convertCases ci lad=:{let_strict_binds,let_lazy_binds,let_expr,let_info_ptr} cs=:{cs_expr_heap}
# (let_info, cs_expr_heap) = readPtr let_info_ptr cs_expr_heap
cs = { cs & cs_expr_heap = cs_expr_heap }
= case let_info of
EI_LetType let_type
# ci = {ci & ci_bound_vars=addLetVars (let_strict_binds ++ let_lazy_binds) let_type ci.ci_bound_vars}
# (let_strict_binds, cs) = convertCases ci let_strict_binds cs
# (let_lazy_binds, cs) = convertCases ci let_lazy_binds cs
# (let_expr, cs) = convertCases ci let_expr cs
-> ({ lad & let_strict_binds = let_strict_binds, let_lazy_binds = let_lazy_binds, let_expr = let_expr }, cs)
_
-> abort "convertCases [Let] (convertcases 53)" // <<- let_info
addLetVars [{lb_dst} : binds] [bind_type : bind_types] bound_vars
= addLetVars binds bind_types [ (lb_dst, bind_type) : bound_vars ]
addLetVars [] _ bound_vars
= bound_vars
instance convertCases Expression
where
convertCases ci (App app=:{app_args}) cs
# (app_args, cs) = convertCases ci app_args cs
= (App {app & app_args = app_args}, cs)
convertCases ci (fun_expr @ exprs) cs
# ((fun_expr, exprs), cs) = convertCases ci (fun_expr, exprs) cs
= (fun_expr @ exprs, cs)
convertCases ci (Let lad) cs
# (lad, cs) = convertCases ci lad cs
= (Let lad, cs)
convertCases ci (MatchExpr opt_tuple constructor expr) cs
# (expr, cs) = convertCases ci expr cs
= (MatchExpr opt_tuple constructor expr, cs)
convertCases ci (Selection is_unique expr selectors) cs
# (expr, cs) = convertCases ci expr cs
(selectors, cs) = convertCases ci selectors cs
= (Selection is_unique expr selectors, cs)
convertCases ci (Update expr1 selectors expr2) cs
# (expr1, cs) = convertCases ci expr1 cs
(selectors, cs) = convertCases ci selectors cs
(expr2, cs) = convertCases ci expr2 cs
= (Update expr1 selectors expr2, cs)
convertCases ci (RecordUpdate cons_symbol expression expressions) cs
# (expression, cs) = convertCases ci expression cs
(expressions, cs) = convertCases ci expressions cs
= (RecordUpdate cons_symbol expression expressions, cs)
convertCases ci (TupleSelect tuple_symbol arg_nr expr) cs
# (expr, cs) = convertCases ci expr cs
= (TupleSelect tuple_symbol arg_nr expr, cs)
convertCases ci (Case case_expr) cs
= convertCasesInCaseExpression ci cHasNoDefault case_expr cs
convertCases ci expr cs
= (expr, cs)
instance convertCases Selection
convertCasesOfFunctions :: !*{! Group} !Int !{# {# FunType} } !{# CommonDefs} !*{#FunDef} !*{#{# CheckedTypeDef}}
!ImportedConstructors !*VarHeap !*TypeHeaps !*ExpressionHeap
-> (!ImportedFunctions, !*{! Group}, !*{#FunDef}, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap)
convertCasesOfFunctions groups main_dcl_module_n dcl_functions common_defs fun_defs imported_types imported_conses var_heap type_heaps expr_heap
#! nr_of_funs = size fun_defs
# (groups, (fun_defs, collected_imports, {cs_new_functions, cs_var_heap, cs_expr_heap, cs_fun_heap}))
= convert_groups 0 groups dcl_functions common_defs
(fun_defs, [], { cs_new_functions = [], cs_fun_heap = newHeap, cs_var_heap = var_heap, cs_expr_heap = expr_heap, cs_next_fun_nr = nr_of_funs })
(groups, new_fun_defs, imported_types, imported_conses, type_heaps, cs_var_heap)
= addNewFunctionsToGroups common_defs cs_fun_heap cs_new_functions main_dcl_module_n groups imported_types imported_conses type_heaps cs_var_heap
// = foldSt (add_new_function_to_group cs_fun_heap common_defs) cs_new_functions (groups, [], imported_types, imported_conses, type_heaps, cs_var_heap)
(imported_functions, imported_conses) = foldSt split collected_imports ([], imported_conses)
= (imported_functions, groups, { fundef \\ fundef <- [ fundef \\ fundef <-: fun_defs ] ++ new_fun_defs },
imported_types, imported_conses, cs_var_heap, type_heaps, cs_expr_heap)
where
convertCases ci (DictionarySelection record selectors expr_ptr index_expr) cs
# (index_expr, cs) = convertCases ci index_expr cs
(selectors, cs) = convertCases ci selectors cs
= (DictionarySelection record selectors expr_ptr index_expr, cs)
convertCases ci (ArraySelection selector expr_ptr index_expr) cs
# (index_expr, cs) = convertCases ci index_expr cs
= (ArraySelection selector expr_ptr index_expr, cs)
convertCases ci selector cs
= (selector, cs)
convert_groups group_nr groups dcl_functions common_defs fun_defs_and_ci
| group_nr == size groups
= (groups, fun_defs_and_ci)
# (group, groups) = groups![group_nr]
= convert_groups (inc group_nr) groups dcl_functions common_defs
(foldSt (convert_function group_nr dcl_functions common_defs) group.group_members fun_defs_and_ci)
cHasNoDefault :== nilPtr
convert_function group_index dcl_functions common_defs fun (fun_defs, collected_imports, cs)
# (fun_def, fun_defs) = fun_defs![fun]
# {fun_body,fun_type} = fun_def
(fun_body, (collected_imports, cs)) = eliminate_code_sharing_in_function dcl_functions common_defs fun_body /* (fun_body ---> ("convert_function", fun_def.fun_symb, fun_body)) */ (collected_imports, cs)
(fun_body, cs) = convert_cases_into_function_patterns fun_body fun_type group_index common_defs cs
= ({fun_defs & [fun] = { fun_def & fun_body = fun_body }}, collected_imports, cs)
convertDefaultToExpression default_ptr (EI_Default expr type prev_default) ci cs=:{cs_var_heap}
# cs_var_heap = foldSt (\({fv_info_ptr}, type) -> writePtr fv_info_ptr (VI_BoundVar type)) ci.ci_bound_vars cs_var_heap
(expression, {cp_free_vars, cp_var_heap, cp_local_vars}) = copy expr { cp_free_vars = [], cp_var_heap = cs_var_heap, cp_local_vars = [] }
(act_args, free_typed_vars, cs_var_heap) = foldSt retrieveVariable cp_free_vars ([], [], cp_var_heap)
(fun_symb, cs) = new_default_function free_typed_vars cp_local_vars expression type prev_default ci.ci_group_index ci.ci_common_defs { cs & cs_var_heap = cs_var_heap }
= (App { app_symb = fun_symb, app_args = act_args, app_info_ptr = nilPtr },
{ cs & cs_expr_heap = cs.cs_expr_heap <:= (default_ptr, EI_DefaultFunction fun_symb act_args)})
where
new_default_function free_vars local_vars rhs_expr result_type prev_default group_index common_defs cs
# (guarded_exprs, cs) = convertPatternExpression [] [free_vars] group_index common_defs prev_default rhs_expr cs
fun_bodies = map build_pattern guarded_exprs
arg_types = map (\(_,type) -> type) free_vars
(fun_symb, (cs_next_fun_nr, cs_new_functions, cs_fun_heap))
= newFunction No (BackendBody fun_bodies) local_vars arg_types result_type group_index
(cs.cs_next_fun_nr, cs.cs_new_functions, cs.cs_fun_heap)
= (fun_symb, { cs & cs_fun_heap = cs_fun_heap, cs_next_fun_nr = cs_next_fun_nr, cs_new_functions = cs_new_functions })
convert_cases_into_function_patterns (TransformedBody {tb_args,tb_rhs=Case {case_expr = Var var=:{var_info_ptr}, case_guards, case_default, case_info_ptr}})
(Yes {st_result,st_args}) group_index common_defs cs=:{cs_expr_heap}
# (EI_CaseTypeAndRefCounts case_type _, cs_expr_heap) = readPtr case_info_ptr cs_expr_heap
(default_ptr, cs_expr_heap) = makePtrToDefault case_default st_result cHasNoDefault cs_expr_heap
vars_with_types = exactZip tb_args st_args
(form_var_with_type, left_vars, right_vars) = split_vars var_info_ptr vars_with_types
(fun_bodies, cs) = convertPatterns case_guards case_type.ct_cons_types (Yes form_var_with_type) left_vars right_vars default_ptr group_index common_defs
{ cs & cs_expr_heap = cs_expr_heap }
(fun_bodies, cs) = convertDefault default_ptr (Yes form_var_with_type) left_vars right_vars group_index common_defs (fun_bodies, cs)
= (BackendBody fun_bodies, cs)
where
split_vars var_info_ptr [ form_var_with_type=:({fv_info_ptr},_) : free_vars]
| var_info_ptr == fv_info_ptr
= (form_var_with_type, [], free_vars)
# (form_var, left, right) = split_vars var_info_ptr free_vars
= (form_var, [form_var_with_type : left], right)
convert_cases_into_function_patterns (TransformedBody {tb_args,tb_rhs}) (Yes {st_result,st_args}) group_index common_defs cs
# (tb_rhs, cs) = convertRootExpression {ci_bound_vars=exactZip tb_args st_args, ci_group_index=group_index, ci_common_defs=common_defs} cHasNoDefault tb_rhs cs
= (BackendBody [ { bb_args = map FP_Variable tb_args, bb_rhs = tb_rhs }], cs)
build_pattern ([ right_patterns : _ ], bb_rhs)
= { bb_args = right_patterns, bb_rhs = bb_rhs }
eliminate_code_sharing_in_function dcl_functions common_defs (TransformedBody body=:{tb_rhs}) (collected_imports, cs=:{cs_expr_heap,cs_var_heap})
# {rc_var_heap, rc_expr_heap, rc_imports} = weightedRefCount dcl_functions common_defs 1 tb_rhs
{ rc_var_heap = cs_var_heap, rc_expr_heap = cs_expr_heap, rc_free_vars = [], rc_imports = collected_imports,rc_main_dcl_module_n=main_dcl_module_n}
// ---> ("eliminate_code_sharing_in_function (weightedRefCount)", tb_rhs)
(tb_rhs, {di_lets,di_var_heap,di_expr_heap}) = distributeLets 1 tb_rhs { di_lets = [], di_var_heap = rc_var_heap, di_expr_heap = rc_expr_heap}
(tb_rhs, (var_heap, expr_heap)) = buildLetExpr di_lets tb_rhs (di_var_heap,di_expr_heap)
= (TransformedBody { body & tb_rhs = tb_rhs }, (rc_imports, { cs & cs_var_heap = var_heap, cs_expr_heap = expr_heap }))
==> ("eliminate_code_sharing_in_function (distributeLets)", tb_rhs)
convertDefaultToExpression default_ptr (EI_DefaultFunction fun_symb act_args) ci cs
= (App { app_symb = fun_symb, app_args = act_args, app_info_ptr = nilPtr }, cs)
split (SK_Function fun_symb) (collected_functions, collected_conses)
= ([fun_symb : collected_functions], collected_conses)
split (SK_Constructor cons_symb) (collected_functions, collected_conses)
= (collected_functions, [ cons_symb : collected_conses])
combineDefaults default_ptr guards No ci cs=:{cs_expr_heap}
| isNilPtr default_ptr
= (No, cs)
| case_is_partial guards ci.ci_common_defs
# (default_info, cs_expr_heap) = readPtr default_ptr cs_expr_heap
(default_expr, cs) = convertDefaultToExpression default_ptr default_info ci { cs & cs_expr_heap = cs_expr_heap }
= (Yes default_expr, cs)
= (No, cs)
where
case_is_partial (AlgebraicPatterns {glob_module, glob_object} patterns) common_defs
# {td_rhs} = common_defs.[glob_module].com_type_defs.[glob_object]
= length patterns < nr_of_alternatives td_rhs || has_partial_pattern patterns
where
nr_of_alternatives (AlgType conses)
= length conses
nr_of_alternatives _
= 1
has_partial_pattern []
= False
has_partial_pattern [{ap_expr} : patterns]
= is_partial_expression ap_expr common_defs || has_partial_pattern patterns
case_is_partial (BasicPatterns BT_Bool bool_patterns) common_defs
= length bool_patterns < 2 || has_partial_basic_pattern bool_patterns
where
has_partial_basic_pattern []
= False
has_partial_basic_pattern [{bp_expr} : patterns]
= is_partial_expression bp_expr common_defs || has_partial_basic_pattern patterns
case_is_partial patterns common_defs
= True
is_partial_expression (Case {case_guards,case_default=No}) common_defs
= case_is_partial case_guards common_defs
is_partial_expression (Case {case_guards,case_default=Yes case_default}) common_defs
= is_partial_expression case_default common_defs && case_is_partial case_guards common_defs
is_partial_expression (Let {let_expr}) common_defs
= is_partial_expression let_expr common_defs
is_partial_expression _ _
= False
/*
combineDefaults default_ptr guards this_default ci cs
= (this_default, cs)
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 functions that have been used inside the expression.
*/
:: TypedVariable =
{ tv_free_var :: !FreeVar
, tv_type :: !AType
:: RCInfo =
{ rc_free_vars :: ![VarInfoPtr]
, rc_imports :: ![SymbKind]
, rc_var_heap :: !.VarHeap
, rc_expr_heap :: !.ExpressionHeap
, rc_main_dcl_module_n :: !Int
}
copyExpression :: ![TypedVariable] !Expression !*VarHeap -> (![Expression], ![TypedVariable], ![FreeVar], !Expression, !*VarHeap)
copyExpression bound_vars expression var_heap
# var_heap = foldSt (\{tv_free_var={fv_info_ptr},tv_type} -> writePtr fv_info_ptr (VI_BoundVar tv_type)) bound_vars var_heap
(expression, {cp_free_vars, cp_var_heap, cp_local_vars}) = copy expression { cp_free_vars = [], cp_var_heap = var_heap, cp_local_vars = [] }
(bound_vars, free_typed_vars, var_heap) = foldSt retrieve_variable cp_free_vars ([], [], cp_var_heap)
= (bound_vars, free_typed_vars, cp_local_vars, expression, var_heap)
where
retrieve_variable (var_info_ptr, type) (bound_vars, free_typed_vars, var_heap)
# (VI_FreeVar name new_ptr count type, var_heap) = readPtr var_info_ptr var_heap
= ( [Var { var_name = name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr} : bound_vars],
[{tv_free_var = { fv_def_level = NotALevel, fv_name = name, fv_info_ptr = new_ptr, fv_count = count }, tv_type = type} : free_typed_vars], var_heap)
checkImportedSymbol symb_kind symb_type_ptr (collected_imports, var_heap)
#! type_info = sreadPtr symb_type_ptr var_heap
= case type_info of
VI_Used
-> (collected_imports, var_heap)
_
-> ([symb_kind : collected_imports ], var_heap <:= (symb_type_ptr, VI_Used))
retrieveVariable (var_info_ptr, type) (bound_vars, free_typed_vars, var_heap)
# (VI_FreeVar name new_ptr count type, var_heap) = readPtr var_info_ptr var_heap
= ( [Var { var_name = name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr} : bound_vars],
[({ fv_def_level = NotALevel, fv_name = name, fv_info_ptr = new_ptr, fv_count = count }, type) : free_typed_vars], var_heap)
convertCasesInCaseExpression ci default_ptr { case_expr, case_guards, case_default, case_ident, case_info_ptr} cs
# (case_default, cs) = combineDefaults default_ptr case_guards case_default ci cs
(case_expr, cs) = convertCases ci case_expr cs
(EI_CaseTypeAndRefCounts case_type ref_counts, cs_expr_heap) = readPtr case_info_ptr cs.cs_expr_heap
(act_vars, form_vars, opt_free_var, local_vars, (case_guards, case_default), cs_var_heap)
= copy_case_expression ci.ci_bound_vars (get_variable case_expr case_type.ct_pattern_type) (case_guards,case_default) cs.cs_var_heap
(fun_symb, cs) = new_case_function case_ident case_guards case_default case_type opt_free_var form_vars local_vars
ci.ci_group_index ci.ci_common_defs default_ptr { cs & cs_var_heap = cs_var_heap, cs_expr_heap = cs_expr_heap }
= (App { app_symb = fun_symb, app_args = [ case_expr : act_vars ], app_info_ptr = nilPtr }, cs)
weightedRefCountOfVariable depth var_info_ptr lvi=:{lvi_count,lvi_var,lvi_depth,lvi_previous,lvi_new} ref_count new_vars
| lvi_depth < depth
= (True, {lvi & lvi_count = ref_count, lvi_depth = depth, lvi_new = True, lvi_previous =
[{plvi_count = lvi_count, plvi_depth = lvi_depth, plvi_new = lvi_new } : lvi_previous]}, [var_info_ptr : new_vars])
// ==> (lvi_var, " PUSHED ",lvi_depth)
| lvi_count == 0
= (True, { lvi & lvi_count = ref_count }, [var_info_ptr : new_vars])
= (lvi_new, { lvi & lvi_count = lvi_count + ref_count }, new_vars)
class weightedRefCount e :: !{# {# FunType} } !{# CommonDefs} !Int !e !*RCInfo -> *RCInfo
instance weightedRefCount BoundVar
where
get_variable (Var var) pattern_type
= Yes (var, pattern_type)
get_variable _ _
= No
copy_case_expression bound_vars opt_variable guards_and_default var_heap
# var_heap = foldSt (\({fv_name,fv_info_ptr},type) -> writePtr fv_info_ptr (VI_BoundVar type)) bound_vars var_heap
(opt_copied_var, var_heap) = copy_variable opt_variable var_heap
(expression, {cp_free_vars, cp_var_heap, cp_local_vars}) = copy guards_and_default { cp_free_vars = [], cp_var_heap = var_heap, cp_local_vars = [] }
(bound_vars, free_typed_vars, var_heap) = foldSt retrieveVariable cp_free_vars ([], [], cp_var_heap)
(opt_free_var, var_heap) = toOptionalFreeVar opt_copied_var var_heap
= (bound_vars, free_typed_vars, opt_free_var, cp_local_vars, expression, var_heap)
weightedRefCount dcl_functions common_defs depth {var_name,var_info_ptr} rc_info=:{rc_var_heap,rc_free_vars}
#! var_info = sreadPtr var_info_ptr rc_var_heap
= case var_info of
VI_LetVar lvi
# (is_new, lvi=:{lvi_expression}, rc_free_vars) = weightedRefCountOfVariable depth var_info_ptr lvi 1 rc_free_vars
| is_new
# rc_info = weightedRefCount dcl_functions common_defs depth lvi_expression
{ rc_info & rc_free_vars = rc_free_vars,
rc_var_heap = rc_info.rc_var_heap <:= (var_info_ptr, VI_LetVar {lvi & lvi_expression = EE, lvi_new = False})}
(VI_LetVar lvi, rc_var_heap) = readPtr var_info_ptr rc_info.rc_var_heap
-> { rc_info & rc_var_heap = rc_var_heap <:= (var_info_ptr, VI_LetVar { lvi & lvi_expression = lvi_expression }) }
// ==> (var_name, var_info_ptr, depth, lvi.lvi_count)
-> { rc_info & rc_var_heap = rc_info.rc_var_heap <:= (var_info_ptr, VI_LetVar lvi) }
_
-> rc_info
instance weightedRefCount Expression
where
weightedRefCount dcl_functions common_defs depth (Var var) rc_info
= weightedRefCount dcl_functions common_defs depth var rc_info
weightedRefCount dcl_functions common_defs depth (App app) rc_info
= weightedRefCount dcl_functions common_defs depth app 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}
# 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_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_lazy_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_lazy_binds])
where
remove_variable ([], var_heap) let_bind
= ([], var_heap)
remove_variable ([var_ptr : var_ptrs], var_heap) bind=:{lb_dst={fv_name,fv_info_ptr}}
| fv_info_ptr == var_ptr
# (VI_LetVar {lvi_count,lvi_depth}, var_heap) = readPtr fv_info_ptr var_heap
= (var_ptrs, var_heap)
// ==> ("remove_variable (lvi_count,lvi_dpeth) ", fv_name, lvi_count, lvi_depth)
# (var_ptrs, var_heap) = remove_variable (var_ptrs, var_heap) bind
= ([var_ptr : var_ptrs], var_heap)
copy_variable (Yes (var=:{var_name,var_info_ptr}, var_type)) var_heap
# (new_info, var_heap) = newPtr VI_Empty var_heap
= (Yes (var_info_ptr, var_type), var_heap <:= (var_info_ptr, VI_FreeVar var_name new_info 0 var_type))
copy_variable No var_heap
= (No, var_heap)
store_binding {lb_dst={fv_name,fv_info_ptr},lb_src} var_heap
= var_heap <:= (fv_info_ptr, VI_LetVar {lvi_count = 0, lvi_depth = depth, lvi_previous = [],
lvi_new = True, lvi_expression = lb_src, lvi_var = fv_name})
new_case_function opt_id patterns case_default {ct_result_type,ct_pattern_type,ct_cons_types} opt_var free_vars local_vars
group_index common_defs prev_default cs=:{cs_expr_heap}
# (default_ptr, cs_expr_heap) = makePtrToDefault case_default ct_result_type prev_default cs_expr_heap
(fun_bodies, cs) = convertPatterns patterns ct_cons_types opt_var [] free_vars default_ptr group_index common_defs { cs & cs_expr_heap = cs_expr_heap }
(fun_bodies, cs) = convertDefault default_ptr opt_var [] free_vars group_index common_defs (fun_bodies, cs)
(fun_symb, (cs_next_fun_nr, cs_new_functions, cs_fun_heap))
= newFunction opt_id (BackendBody fun_bodies) local_vars [ct_pattern_type : [ type \\ (_, type) <- free_vars]] ct_result_type group_index
(cs.cs_next_fun_nr, cs.cs_new_functions, cs.cs_fun_heap)
= (fun_symb, { cs & cs_fun_heap = cs_fun_heap, cs_next_fun_nr = cs_next_fun_nr, cs_new_functions = cs_new_functions })
get_ref_count {lb_dst={fv_name,fv_info_ptr}} var_heap
# (VI_LetVar {lvi_count}, var_heap) = readPtr fv_info_ptr var_heap
= (lvi_count, var_heap)
// ==> (fv_name,fv_info_ptr,lvi_count)
weightedRefCount dcl_functions common_defs depth (Case case_expr) rc_info=:{rc_expr_heap}
# (case_info, rc_expr_heap) = readPtr case_expr.case_info_ptr rc_expr_heap
= weightedRefCountOfCase dcl_functions common_defs depth case_expr case_info { rc_info & rc_expr_heap = rc_expr_heap }
weightedRefCount dcl_functions common_defs depth expr=:(BasicExpr _ _) rc_info
= rc_info
weightedRefCount dcl_functions common_defs depth (MatchExpr _ constructor expr) rc_info
= weightedRefCount dcl_functions common_defs depth expr rc_info
weightedRefCount dcl_functions common_defs depth (Selection opt_tuple expr selections) rc_info
= weightedRefCount dcl_functions common_defs depth (expr, selections) rc_info
weightedRefCount dcl_functions common_defs depth (Update expr1 selections expr2) rc_info
= weightedRefCount dcl_functions common_defs depth (expr1, (selections, expr2)) rc_info
weightedRefCount dcl_functions common_defs depth (RecordUpdate cons_symbol expression expressions) rc_info
= weightedRefCount dcl_functions common_defs depth (expression, expressions) rc_info
weightedRefCount dcl_functions common_defs depth (TupleSelect tuple_symbol arg_nr expr) rc_info
= weightedRefCount dcl_functions common_defs depth expr rc_info
weightedRefCount dcl_functions common_defs depth (AnyCodeExpr _ _ _) rc_info
= rc_info
weightedRefCount dcl_functions common_defs depth (ABCCodeExpr _ _) rc_info
= rc_info
weightedRefCount dcl_functions common_defs depth (TypeCodeExpression type_code_expr) rc_info
= weightedRefCount dcl_functions common_defs depth type_code_expr rc_info
weightedRefCount dcl_functions common_defs depth EE rc_info
= rc_info
weightedRefCount dcl_functions common_defs depth (NoBind ptr) rc_info
= rc_info
weightedRefCount dcl_functions common_defs depth expr rc_info
= abort ("weightedRefCount [Expression] (convertcases, 864))" ---> expr)
addPatternVariable depth {cv_variable = var_info_ptr, cv_count = ref_count} (free_vars, var_heap)
#! var_info = sreadPtr var_info_ptr var_heap
= case var_info of
VI_LetVar lvi
# (_, lvi, free_vars) = weightedRefCountOfVariable depth var_info_ptr lvi ref_count free_vars
-> (free_vars, var_heap <:= (var_info_ptr, VI_LetVar lvi))
_
-> (free_vars, var_heap)
weightedRefCountOfCase dcl_functions common_defs depth this_case=:{case_expr, case_guards, case_default, case_info_ptr} (EI_CaseType case_type)
rc_info=:{ rc_var_heap, rc_expr_heap, rc_imports,rc_main_dcl_module_n }
# (local_vars, vars_and_heaps) = weighted_ref_count_in_case_patterns dcl_functions common_defs (inc depth) case_guards rc_imports rc_var_heap rc_expr_heap
(default_vars, (all_vars, rc_imports, var_heap, expr_heap)) = weighted_ref_count_in_default dcl_functions common_defs (inc depth) case_default vars_and_heaps
rc_info = weightedRefCount dcl_functions common_defs depth case_expr { rc_info & rc_var_heap = var_heap, rc_expr_heap = expr_heap, rc_imports = rc_imports }
(rc_free_vars, rc_var_heap) = foldSt (addPatternVariable depth) all_vars (rc_info.rc_free_vars, rc_info.rc_var_heap)
rc_expr_heap = rc_info.rc_expr_heap <:= (case_info_ptr, EI_CaseTypeAndRefCounts case_type
{ rcc_all_variables = all_vars, rcc_default_variables = default_vars, rcc_pattern_variables = local_vars })
= { rc_info & rc_var_heap = rc_var_heap, rc_expr_heap = rc_expr_heap, rc_free_vars = rc_free_vars }
// ---> ("weightedRefCountOfCase", ptrToInt case_info_ptr, case_expr)
where
weighted_ref_count_in_default dcl_functions common_defs depth (Yes expr) info
= weightedRefCountInPatternExpr rc_main_dcl_module_n dcl_functions common_defs depth expr info
weighted_ref_count_in_default dcl_functions common_defs depth No info
= ([], info)
weighted_ref_count_in_case_patterns dcl_functions common_defs depth (AlgebraicPatterns type patterns) collected_imports var_heap expr_heap
= mapSt (weighted_ref_count_in_algebraic_pattern dcl_functions common_defs depth) patterns ([], collected_imports, var_heap, expr_heap)
where
weighted_ref_count_in_algebraic_pattern dcl_functions common_defs depth {ap_expr,ap_symbol={glob_module, glob_object={ds_index}}} wrc_state
# (free_vars_with_rc, (all_free_vars, collected_imports, var_heap, expr_heap))
= weightedRefCountInPatternExpr rc_main_dcl_module_n dcl_functions common_defs depth ap_expr wrc_state
| glob_module <> rc_main_dcl_module_n
# {cons_type_ptr} = common_defs.[glob_module].com_cons_defs.[ds_index]
(collected_imports, var_heap) = checkImportedSymbol (SK_Constructor {glob_module = glob_module, glob_object = ds_index})
cons_type_ptr (collected_imports, var_heap)
= (free_vars_with_rc, (all_free_vars, collected_imports, var_heap, expr_heap))
= (free_vars_with_rc, (all_free_vars, collected_imports, var_heap, expr_heap))
makePtrToDefault (Yes default_expr) type prev_default_ptr expr_heap
= newPtr (EI_Default default_expr type prev_default_ptr) expr_heap
makePtrToDefault No type prev_default_ptr expr_heap
= (cHasNoDefault, expr_heap)
weighted_ref_count_in_case_patterns dcl_functions common_defs depth (BasicPatterns type patterns) collected_imports var_heap expr_heap
= mapSt (\{bp_expr} -> weightedRefCountInPatternExpr rc_main_dcl_module_n dcl_functions common_defs depth bp_expr) patterns ([], collected_imports, var_heap, expr_heap)
weighted_ref_count_in_case_patterns dcl_functions common_defs depth (DynamicPatterns patterns) collected_imports var_heap expr_heap
= mapSt (\{dp_rhs} -> weightedRefCountInPatternExpr rc_main_dcl_module_n dcl_functions common_defs depth dp_rhs) patterns ([], collected_imports, var_heap, expr_heap)
weightedRefCountOfCase dcl_functions common_defs depth this_case=:{case_expr, case_guards, case_default, case_info_ptr} (EI_CaseTypeAndRefCounts case_type {rcc_all_variables})
rc_info=:{ rc_var_heap, rc_expr_heap, rc_imports }
# rc_info = weightedRefCount dcl_functions common_defs depth case_expr rc_info
(rc_free_vars, rc_var_heap) = foldSt (addPatternVariable depth) rcc_all_variables (rc_info.rc_free_vars, rc_info.rc_var_heap)
= { rc_info & rc_var_heap = rc_var_heap, rc_free_vars = rc_free_vars }
// ---> ("weightedRefCountOfCase 2", ptrToInt case_info_ptr, case_expr)
convertDefault default_ptr opt_var left_vars right_vars group_index common_defs (fun_bodies, cs)
| isNilPtr default_ptr
= (fun_bodies, cs)
# (default_info, cs_expr_heap) = readPtr default_ptr cs.cs_expr_heap
= convert_default default_info opt_var left_vars right_vars group_index common_defs (fun_bodies, { cs & cs_expr_heap = cs_expr_heap})
instance weightedRefCount Selection
where
convert_default (EI_Default default_expr type prev_default) opt_var left_vars right_vars group_index common_defs (fun_bodies, cs)
# (bb_rhs, cs) = convertRootExpression {ci_bound_vars=left_vars ++ consOptional opt_var right_vars, ci_group_index=group_index, ci_common_defs=common_defs} prev_default default_expr cs
bb_args = build_args opt_var left_vars right_vars
= (fun_bodies ++ [{ bb_args = bb_args, bb_rhs = bb_rhs }], cs)
convert_default (EI_DefaultFunction fun_symb act_args) opt_var left_vars right_vars group_index common_defs (fun_bodies, cs)
# bb_args = build_args opt_var left_vars right_vars
bb_rhs = App { app_symb = fun_symb, app_args = act_args, app_info_ptr = nilPtr }
= (fun_bodies ++ [{ bb_args = bb_args, bb_rhs = bb_rhs }], cs)
weightedRefCount dcl_functions common_defs depth (ArraySelection {glob_module,glob_object={ds_index}} _ index_expr) rc_info
# rc_info = weightedRefCount dcl_functions common_defs depth index_expr rc_info
= checkImportOfDclFunction dcl_functions common_defs glob_module ds_index rc_info
weightedRefCount dcl_functions common_defs depth (DictionarySelection _ selectors _ index_expr) rc_info
# rc_info = weightedRefCount dcl_functions common_defs depth index_expr rc_info
= weightedRefCount dcl_functions common_defs depth selectors rc_info
weightedRefCount dcl_functions common_defs depth (RecordSelection selector _) rc_info
= checkRecordSelector common_defs selector rc_info
build_args (Yes (var,type)) left_vars right_vars
= mapAppend typed_free_var_to_pattern left_vars [FP_Variable var : map typed_free_var_to_pattern right_vars]
build_args No left_vars right_vars
= mapAppend typed_free_var_to_pattern left_vars [FP_Empty : map typed_free_var_to_pattern right_vars]
weightedRefCountInPatternExpr main_dcl_module_n dcl_functions common_defs depth pattern_expr (previous_free_vars, collected_imports, var_heap, expr_heap)
# {rc_free_vars,rc_var_heap,rc_imports,rc_expr_heap} = weightedRefCount dcl_functions common_defs depth pattern_expr
{ rc_var_heap = var_heap, rc_expr_heap = expr_heap, rc_free_vars = [], rc_imports = collected_imports,rc_main_dcl_module_n=main_dcl_module_n}
(free_vars_with_rc, rc_var_heap) = mapSt get_ref_count rc_free_vars rc_var_heap
(previous_free_vars, rc_var_heap) = foldSt (select_unused_free_variable depth) previous_free_vars ([], rc_var_heap)
(all_free_vars, rc_var_heap) = foldSt (collect_free_variable depth) rc_free_vars (previous_free_vars, rc_var_heap)
// ==> ("remove_vars ", depth, free_vars_with_rc)
= (free_vars_with_rc, (all_free_vars, rc_imports, rc_var_heap, rc_expr_heap))
where
select_unused_free_variable depth var=:{cv_variable = var_ptr, cv_count = var_count} (collected_vars, var_heap)
# (VI_LetVar info=:{lvi_count,lvi_depth}, var_heap) = readPtr var_ptr var_heap
| lvi_depth == depth && lvi_count > 0
= (collected_vars, var_heap <:= (var_ptr, VI_LetVar {info & lvi_count = max lvi_count var_count}))
= ([ var : collected_vars], var_heap)