diff options
| -rw-r--r-- | frontend/convertcases.icl | 480 |
1 files changed, 240 insertions, 240 deletions
diff --git a/frontend/convertcases.icl b/frontend/convertcases.icl index 57e7484..a1f2fa4 100644 --- a/frontend/convertcases.icl +++ b/frontend/convertcases.icl @@ -10,12 +10,12 @@ exactZip [] [] exactZip [x:xs][y:ys] = [(x,y) : exactZip xs ys] -:: ConvertState = - { ci_new_functions :: ![FunctionInfoPtr] - , ci_fun_heap :: !.FunctionHeap - , ci_var_heap :: !.VarHeap - , ci_expr_heap :: !.ExpressionHeap - , ci_next_fun_nr :: !Index +:: ConversionInfo = + { cs_new_functions :: ![FunctionInfoPtr] + , cs_fun_heap :: !.FunctionHeap + , cs_var_heap :: !.VarHeap + , cs_expr_heap :: !.ExpressionHeap + , cs_next_fun_nr :: !Index } getIdent (Yes ident) fun_nr @@ -28,43 +28,43 @@ class convertCases a :: ![(FreeVar, AType)] !Index !{# CommonDefs } !a !*Conver instance convertCases [a] | convertCases a where - convertCases bound_vars group_index common_defs l ci = mapSt (convertCases bound_vars group_index common_defs) l ci + convertCases bound_vars group_index common_defs l cs = mapSt (convertCases bound_vars group_index common_defs) l cs instance convertCases (a,b) | convertCases a & convertCases b where - convertCases bound_vars group_index common_defs t ci - = app2St (convertCases bound_vars group_index common_defs, convertCases bound_vars group_index common_defs) t ci + convertCases bound_vars group_index common_defs t cs + = app2St (convertCases bound_vars group_index common_defs, convertCases bound_vars group_index common_defs) t cs instance convertCases LetBind where - convertCases bound_vars group_index common_defs bind=:{lb_src} ci - # (lb_src, ci) = convertCases bound_vars group_index common_defs lb_src ci - = ({ bind & lb_src = lb_src }, ci) + convertCases bound_vars group_index common_defs bind=:{lb_src} cs + # (lb_src, cs) = convertCases bound_vars group_index common_defs lb_src cs + = ({ bind & lb_src = lb_src }, cs) instance convertCases (Bind a b) | convertCases a where - convertCases bound_vars group_index common_defs bind=:{bind_src} ci - # (bind_src, ci) = convertCases bound_vars group_index common_defs bind_src ci - = ({ bind & bind_src = bind_src }, ci) + convertCases bound_vars group_index common_defs bind=:{bind_src} cs + # (bind_src, cs) = convertCases bound_vars group_index common_defs bind_src cs + = ({ bind & bind_src = bind_src }, cs) instance convertCases DynamicExpr where - convertCases bound_vars group_index common_defs dynamik=:{dyn_expr} ci - # (dyn_expr, ci) = convertCases bound_vars group_index common_defs dyn_expr ci - = ({ dynamik & dyn_expr = dyn_expr }, ci) + convertCases bound_vars group_index common_defs dynamik=:{dyn_expr} cs + # (dyn_expr, cs) = convertCases bound_vars group_index common_defs dyn_expr cs + = ({ dynamik & dyn_expr = dyn_expr }, cs) instance convertCases Let where - convertCases bound_vars group_index common_defs lad=:{let_strict_binds,let_lazy_binds,let_expr,let_info_ptr} ci=:{ci_expr_heap} - # (let_info, ci_expr_heap) = readPtr let_info_ptr ci_expr_heap - ci = { ci & ci_expr_heap = ci_expr_heap } + convertCases bound_vars group_index common_defs 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 # bound_vars = addLetVars (let_strict_binds ++ let_lazy_binds) let_type bound_vars - # (let_strict_binds, ci) = convertCases bound_vars group_index common_defs let_strict_binds ci - # (let_lazy_binds, ci) = convertCases bound_vars group_index common_defs let_lazy_binds ci - # (let_expr, ci) = convertCases bound_vars group_index common_defs let_expr ci - -> ({ lad & let_strict_binds = let_strict_binds, let_lazy_binds = let_lazy_binds, let_expr = let_expr }, ci) + # (let_strict_binds, cs) = convertCases bound_vars group_index common_defs let_strict_binds cs + # (let_lazy_binds, cs) = convertCases bound_vars group_index common_defs let_lazy_binds cs + # (let_expr, cs) = convertCases bound_vars group_index common_defs 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 @@ -77,89 +77,89 @@ addLetVars [] _ bound_vars instance convertCases Expression where - convertCases bound_vars group_index common_defs (App app=:{app_args}) ci - # (app_args, ci) = convertCases bound_vars group_index common_defs app_args ci - = (App {app & app_args = app_args}, ci) - convertCases bound_vars group_index common_defs (fun_expr @ exprs) ci - # ((fun_expr, exprs), ci) = convertCases bound_vars group_index common_defs (fun_expr, exprs) ci - = (fun_expr @ exprs, ci) - convertCases bound_vars group_index common_defs (Let lad) ci - # (lad, ci) = convertCases bound_vars group_index common_defs lad ci - = (Let lad, ci) - convertCases bound_vars group_index common_defs (MatchExpr opt_tuple constructor expr) ci - # (expr, ci) = convertCases bound_vars group_index common_defs expr ci - = (MatchExpr opt_tuple constructor expr, ci) - convertCases bound_vars group_index common_defs (Selection is_unique expr selectors) ci - # (expr, ci) = convertCases bound_vars group_index common_defs expr ci - (selectors, ci) = convertCases bound_vars group_index common_defs selectors ci - = (Selection is_unique expr selectors, ci) - convertCases bound_vars group_index common_defs (Update expr1 selectors expr2) ci - # (expr1, ci) = convertCases bound_vars group_index common_defs expr1 ci - (selectors, ci) = convertCases bound_vars group_index common_defs selectors ci - (expr2, ci) = convertCases bound_vars group_index common_defs expr2 ci - = (Update expr1 selectors expr2, ci) - convertCases bound_vars group_index common_defs (RecordUpdate cons_symbol expression expressions) ci - # (expression, ci) = convertCases bound_vars group_index common_defs expression ci - (expressions, ci) = convertCases bound_vars group_index common_defs expressions ci - = (RecordUpdate cons_symbol expression expressions, ci) - convertCases bound_vars group_index common_defs (TupleSelect tuple_symbol arg_nr expr) ci - # (expr, ci) = convertCases bound_vars group_index common_defs expr ci - = (TupleSelect tuple_symbol arg_nr expr, ci) - convertCases bound_vars group_index common_defs (Case case_expr) ci - = convertCasesInCaseExpression bound_vars group_index common_defs cHasNoDefault case_expr ci + convertCases bound_vars group_index common_defs (App app=:{app_args}) cs + # (app_args, cs) = convertCases bound_vars group_index common_defs app_args cs + = (App {app & app_args = app_args}, cs) + convertCases bound_vars group_index common_defs (fun_expr @ exprs) cs + # ((fun_expr, exprs), cs) = convertCases bound_vars group_index common_defs (fun_expr, exprs) cs + = (fun_expr @ exprs, cs) + convertCases bound_vars group_index common_defs (Let lad) cs + # (lad, cs) = convertCases bound_vars group_index common_defs lad cs + = (Let lad, cs) + convertCases bound_vars group_index common_defs (MatchExpr opt_tuple constructor expr) cs + # (expr, cs) = convertCases bound_vars group_index common_defs expr cs + = (MatchExpr opt_tuple constructor expr, cs) + convertCases bound_vars group_index common_defs (Selection is_unique expr selectors) cs + # (expr, cs) = convertCases bound_vars group_index common_defs expr cs + (selectors, cs) = convertCases bound_vars group_index common_defs selectors cs + = (Selection is_unique expr selectors, cs) + convertCases bound_vars group_index common_defs (Update expr1 selectors expr2) cs + # (expr1, cs) = convertCases bound_vars group_index common_defs expr1 cs + (selectors, cs) = convertCases bound_vars group_index common_defs selectors cs + (expr2, cs) = convertCases bound_vars group_index common_defs expr2 cs + = (Update expr1 selectors expr2, cs) + convertCases bound_vars group_index common_defs (RecordUpdate cons_symbol expression expressions) cs + # (expression, cs) = convertCases bound_vars group_index common_defs expression cs + (expressions, cs) = convertCases bound_vars group_index common_defs expressions cs + = (RecordUpdate cons_symbol expression expressions, cs) + convertCases bound_vars group_index common_defs (TupleSelect tuple_symbol arg_nr expr) cs + # (expr, cs) = convertCases bound_vars group_index common_defs expr cs + = (TupleSelect tuple_symbol arg_nr expr, cs) + convertCases bound_vars group_index common_defs (Case case_expr) cs + = convertCasesInCaseExpression bound_vars group_index common_defs cHasNoDefault case_expr cs /* - convertCases bound_vars group_index common_defs (DynamicExpr dynamik) ci - # (dynamik, ci) = convertCases bound_vars group_index common_defs dynamik ci - = (DynamicExpr dynamik, ci) + convertCases bound_vars group_index common_defs (DynamicExpr dynamik) cs + # (dynamik, cs) = convertCases bound_vars group_index common_defs dynamik cs + = (DynamicExpr dynamik, cs) */ - convertCases bound_vars group_index common_defs expr ci - = (expr, ci) + convertCases bound_vars group_index common_defs expr cs + = (expr, cs) instance convertCases Selection where - convertCases bound_vars group_index common_defs (DictionarySelection record selectors expr_ptr index_expr) ci - # (index_expr, ci) = convertCases bound_vars group_index common_defs index_expr ci - (selectors, ci) = convertCases bound_vars group_index common_defs selectors ci - = (DictionarySelection record selectors expr_ptr index_expr, ci) - convertCases bound_vars group_index common_defs (ArraySelection selector expr_ptr index_expr) ci - # (index_expr, ci) = convertCases bound_vars group_index common_defs index_expr ci - = (ArraySelection selector expr_ptr index_expr, ci) - convertCases bound_vars group_index common_defs selector ci - = (selector, ci) + convertCases bound_vars group_index common_defs (DictionarySelection record selectors expr_ptr index_expr) cs + # (index_expr, cs) = convertCases bound_vars group_index common_defs index_expr cs + (selectors, cs) = convertCases bound_vars group_index common_defs selectors cs + = (DictionarySelection record selectors expr_ptr index_expr, cs) + convertCases bound_vars group_index common_defs (ArraySelection selector expr_ptr index_expr) cs + # (index_expr, cs) = convertCases bound_vars group_index common_defs index_expr cs + = (ArraySelection selector expr_ptr index_expr, cs) + convertCases bound_vars group_index common_defs selector cs + = (selector, cs) cHasNoDefault :== nilPtr -convertDefaultToExpression default_ptr (EI_Default expr type prev_default) bound_vars group_index common_defs ci=:{ci_var_heap} - # ci_var_heap = foldSt (\({fv_info_ptr}, type) -> writePtr fv_info_ptr (VI_BoundVar type)) bound_vars ci_var_heap - (expression, {cp_free_vars, cp_var_heap, cp_local_vars}) = copy expr { cp_free_vars = [], cp_var_heap = ci_var_heap, cp_local_vars = [] } - (act_args, free_typed_vars, ci_var_heap) = foldSt retrieveVariable cp_free_vars ([], [], cp_var_heap) - (fun_symb, ci) = new_default_function free_typed_vars cp_local_vars expression type prev_default group_index common_defs { ci & ci_var_heap = ci_var_heap } +convertDefaultToExpression default_ptr (EI_Default expr type prev_default) bound_vars group_index common_defs cs=:{cs_var_heap} + # cs_var_heap = foldSt (\({fv_info_ptr}, type) -> writePtr fv_info_ptr (VI_BoundVar type)) 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 group_index common_defs { cs & cs_var_heap = cs_var_heap } = (App { app_symb = fun_symb, app_args = act_args, app_info_ptr = nilPtr }, - { ci & ci_expr_heap = ci.ci_expr_heap <:= (default_ptr, EI_DefaultFunction fun_symb act_args)}) + { 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 ci - # (guarded_exprs, ci) = convertPatternExpression [] [free_vars] group_index common_defs prev_default rhs_expr ci + 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, (ci_next_fun_nr, ci_new_functions, ci_fun_heap)) + (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 - (ci.ci_next_fun_nr, ci.ci_new_functions, ci.ci_fun_heap) - = (fun_symb, { ci & ci_fun_heap = ci_fun_heap, ci_next_fun_nr = ci_next_fun_nr, ci_new_functions = ci_new_functions }) + (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 }) build_pattern ([ right_patterns : _ ], bb_rhs) = { bb_args = right_patterns, bb_rhs = bb_rhs } -convertDefaultToExpression default_ptr (EI_DefaultFunction fun_symb act_args) bound_vars group_index common_defs ci - = (App { app_symb = fun_symb, app_args = act_args, app_info_ptr = nilPtr }, ci) +convertDefaultToExpression default_ptr (EI_DefaultFunction fun_symb act_args) bound_vars group_index common_defs cs + = (App { app_symb = fun_symb, app_args = act_args, app_info_ptr = nilPtr }, cs) -combineDefaults default_ptr No bound_vars guards group_index common_defs ci=:{ci_expr_heap} +combineDefaults default_ptr No bound_vars guards group_index common_defs cs=:{cs_expr_heap} | isNilPtr default_ptr - = (No, ci) + = (No, cs) | case_is_partial guards common_defs - # (default_info, ci_expr_heap) = readPtr default_ptr ci_expr_heap - (default_expr, ci) = convertDefaultToExpression default_ptr default_info bound_vars group_index common_defs { ci & ci_expr_heap = ci_expr_heap } - = (Yes default_expr, ci) - = (No, ci) + # (default_info, cs_expr_heap) = readPtr default_ptr cs_expr_heap + (default_expr, cs) = convertDefaultToExpression default_ptr default_info bound_vars group_index common_defs { 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] @@ -193,8 +193,8 @@ where is_partial_expression _ = False -combineDefaults default_ptr this_default bound_vars guards group_index common_defs ci - = (this_default, ci) +combineDefaults default_ptr this_default bound_vars guards group_index common_defs cs + = (this_default, cs) :: TypedVariable = @@ -219,15 +219,15 @@ retrieveVariable (var_info_ptr, type) (bound_vars, free_typed_vars, 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 bound_vars group_index common_defs default_ptr { case_expr, case_guards, case_default, case_ident, case_info_ptr} ci - # (case_default, ci) = combineDefaults default_ptr case_default bound_vars case_guards group_index common_defs ci - (case_expr, ci) = convertCases bound_vars group_index common_defs case_expr ci - (EI_CaseTypeAndRefCounts case_type ref_counts, ci_expr_heap) = readPtr case_info_ptr ci.ci_expr_heap - (act_vars, form_vars, opt_free_var, local_vars, (case_guards, case_default), ci_var_heap) - = copy_case_expression bound_vars (get_variable case_expr case_type.ct_pattern_type) (case_guards,case_default) ci.ci_var_heap - (fun_symb, ci) = new_case_function case_ident case_guards case_default case_type opt_free_var form_vars local_vars - group_index common_defs default_ptr { ci & ci_var_heap = ci_var_heap, ci_expr_heap = ci_expr_heap } - = (App { app_symb = fun_symb, app_args = [ case_expr : act_vars ], app_info_ptr = nilPtr }, ci) +convertCasesInCaseExpression bound_vars group_index common_defs default_ptr { case_expr, case_guards, case_default, case_ident, case_info_ptr} cs + # (case_default, cs) = combineDefaults default_ptr case_default bound_vars case_guards group_index common_defs cs + (case_expr, cs) = convertCases bound_vars group_index common_defs 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 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 + group_index 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) where get_variable (Var var) pattern_type = Yes (var, pattern_type) @@ -249,14 +249,14 @@ where = (No, var_heap) 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 ci=:{ci_expr_heap} - # (default_ptr, ci_expr_heap) = makePtrToDefault case_default ct_result_type prev_default ci_expr_heap - (fun_bodies, ci) = convertPatterns patterns ct_cons_types opt_var [] free_vars default_ptr group_index common_defs { ci & ci_expr_heap = ci_expr_heap } - (fun_bodies, ci) = convertDefault default_ptr opt_var [] free_vars group_index common_defs (fun_bodies, ci) - (fun_symb, (ci_next_fun_nr, ci_new_functions, ci_fun_heap)) + 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 - (ci.ci_next_fun_nr, ci.ci_new_functions, ci.ci_fun_heap) - = (fun_symb, { ci & ci_fun_heap = ci_fun_heap, ci_next_fun_nr = ci_next_fun_nr, ci_new_functions = ci_new_functions }) + (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 }) @@ -266,20 +266,20 @@ makePtrToDefault No type prev_default_ptr expr_heap = (cHasNoDefault, expr_heap) -convertDefault default_ptr opt_var left_vars right_vars group_index common_defs (fun_bodies, ci) +convertDefault default_ptr opt_var left_vars right_vars group_index common_defs (fun_bodies, cs) | isNilPtr default_ptr - = (fun_bodies, ci) - # (default_info, ci_expr_heap) = readPtr default_ptr ci.ci_expr_heap - = convert_default default_info opt_var left_vars right_vars group_index common_defs (fun_bodies, { ci & ci_expr_heap = ci_expr_heap}) + = (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}) where - convert_default (EI_Default default_expr type prev_default) opt_var left_vars right_vars group_index common_defs (fun_bodies, ci) - # (bb_rhs, ci) = convertRootExpression (left_vars ++ consOptional opt_var right_vars) group_index common_defs prev_default default_expr ci + 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 (left_vars ++ consOptional opt_var right_vars) group_index 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 }], ci) - convert_default (EI_DefaultFunction fun_symb act_args) opt_var left_vars right_vars group_index common_defs (fun_bodies, ci) + = (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 }], ci) + = (fun_bodies ++ [{ bb_args = bb_args, bb_rhs = bb_rhs }], cs) 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] @@ -291,9 +291,9 @@ where newFunction :: !(Optional Ident) !FunctionBody ![FreeVar] ![AType] !AType !Int !(!Int, ![FunctionInfoPtr],!*FunctionHeap) -> (! SymbIdent, !(!Int, ![FunctionInfoPtr],!*FunctionHeap)) -newFunction opt_id fun_bodies local_vars arg_types result_type group_index (ci_next_fun_nr, ci_new_functions, ci_fun_heap) - # (fun_def_ptr, ci_fun_heap) = newPtr FI_Empty ci_fun_heap - fun_id = getIdent opt_id ci_next_fun_nr +newFunction opt_id fun_bodies local_vars arg_types result_type group_index (cs_next_fun_nr, cs_new_functions, cs_fun_heap) + # (fun_def_ptr, cs_fun_heap) = newPtr FI_Empty cs_fun_heap + fun_id = getIdent opt_id cs_next_fun_nr arity = length arg_types fun_type = { st_vars = [] @@ -317,10 +317,10 @@ newFunction opt_id fun_bodies local_vars arg_types result_type group_index (ci_n , fun_lifted = 0 , fun_info = { EmptyFunInfo & fi_group_index = group_index, fi_local_vars = local_vars } } - = ({ symb_name = fun_id, symb_kind = SK_GeneratedFunction fun_def_ptr ci_next_fun_nr, symb_arity = arity }, - (inc ci_next_fun_nr, [fun_def_ptr : ci_new_functions], - ci_fun_heap <:= (fun_def_ptr, FI_Function { gf_fun_def = fun_def, gf_instance_info = II_Empty, - gf_fun_index = ci_next_fun_nr, gf_cons_args = {cc_size=0, cc_args = [], cc_linear_bits = []} }))) + = ({ symb_name = fun_id, symb_kind = SK_GeneratedFunction fun_def_ptr cs_next_fun_nr, symb_arity = arity }, + (inc cs_next_fun_nr, [fun_def_ptr : cs_new_functions], + cs_fun_heap <:= (fun_def_ptr, FI_Function { gf_fun_def = fun_def, gf_instance_info = II_Empty, + gf_fun_index = cs_next_fun_nr, gf_cons_args = {cc_size=0, cc_args = [], cc_linear_bits = []} }))) consOptional (Yes x) xs = [x : xs] @@ -337,30 +337,30 @@ optionalToListofLists No hasOption (Yes _) = True hasOption No = False -convertPatterns :: CasePatterns [[AType]] (Optional (FreeVar,AType)) [.(FreeVar,AType)] [(FreeVar,AType)] (Ptr ExprInfo) Index {#CommonDefs} *ConvertState -> *(!.[BackendBody],!*ConvertState); -convertPatterns (AlgebraicPatterns algtype patterns) cons_types opt_var left_vars right_vars default_ptr group_index common_defs ci - # (guarded_exprs_list, ci) = mapSt (convert_algebraic_guard_into_function_pattern opt_var left_vars right_vars - group_index common_defs default_ptr) (exactZip patterns cons_types) ci - = (flatten guarded_exprs_list, ci) +convertPatterns :: CasePatterns [[AType]] (Optional (FreeVar,AType)) [.(FreeVar,AType)] [(FreeVar,AType)] (Ptr ExprInfo) Index {#CommonDefs} *ConversionInfo -> *(!.[BackendBody],!*ConversionInfo); +convertPatterns (AlgebraicPatterns algtype patterns) cons_types opt_var left_vars right_vars default_ptr group_index common_defs cs + # (guarded_exprs_list, cs) = mapSt (convert_algebraic_guard_into_function_pattern opt_var left_vars right_vars + group_index common_defs default_ptr) (exactZip patterns cons_types) cs + = (flatten guarded_exprs_list, cs) where - convert_algebraic_guard_into_function_pattern opt_var left_vars right_vars group_index common_defs default_ptr ({ap_symbol, ap_vars, ap_expr}, cons_arg_types) ci + convert_algebraic_guard_into_function_pattern opt_var left_vars right_vars group_index common_defs default_ptr ({ap_symbol, ap_vars, ap_expr}, cons_arg_types) cs # pattern_vars = exactZip ap_vars cons_arg_types - (guarded_exprs, ci) - = convertPatternExpression (consOptional opt_var left_vars) [pattern_vars, right_vars] group_index common_defs default_ptr ap_expr ci - = (map (complete_pattern left_vars ap_symbol (getOptionalFreeVar opt_var)) guarded_exprs, ci) + (guarded_exprs, cs) + = convertPatternExpression (consOptional opt_var left_vars) [pattern_vars, right_vars] group_index common_defs default_ptr ap_expr cs + = (map (complete_pattern left_vars ap_symbol (getOptionalFreeVar opt_var)) guarded_exprs, cs) where complete_pattern left_vars cons_symbol optional_var ([ pattern_args, right_patterns : _ ], bb_rhs) # bb_args = mapAppend selectFreeVar left_vars [FP_Algebraic cons_symbol pattern_args optional_var : right_patterns ] = { bb_args = bb_args, bb_rhs = bb_rhs } -convertPatterns (BasicPatterns bastype patterns) cons_types opt_var left_vars right_vars default_ptr group_index common_defs ci - # (guarded_exprs_list, ci) = mapSt (convert_basic_guard_into_function_pattern opt_var left_vars right_vars - group_index common_defs default_ptr) patterns ci - = (flatten guarded_exprs_list, ci) +convertPatterns (BasicPatterns bastype patterns) cons_types opt_var left_vars right_vars default_ptr group_index common_defs cs + # (guarded_exprs_list, cs) = mapSt (convert_basic_guard_into_function_pattern opt_var left_vars right_vars + group_index common_defs default_ptr) patterns cs + = (flatten guarded_exprs_list, cs) where - convert_basic_guard_into_function_pattern opt_var left_vars right_vars group_index common_defs default_ptr {bp_value, bp_expr} ci - # (guarded_exprs, ci) - = convertPatternExpression (consOptional opt_var left_vars) [right_vars] group_index common_defs default_ptr bp_expr ci - = (map (complete_pattern left_vars bp_value (getOptionalFreeVar opt_var)) guarded_exprs, ci) + convert_basic_guard_into_function_pattern opt_var left_vars right_vars group_index common_defs default_ptr {bp_value, bp_expr} cs + # (guarded_exprs, cs) + = convertPatternExpression (consOptional opt_var left_vars) [right_vars] group_index common_defs default_ptr bp_expr cs + = (map (complete_pattern left_vars bp_value (getOptionalFreeVar opt_var)) guarded_exprs, cs) where complete_pattern left_vars value optional_var ([ right_patterns : _ ], bb_rhs) # bb_args = mapAppend selectFreeVar left_vars [FP_Basic value optional_var : right_patterns ] @@ -369,24 +369,24 @@ where convertPatternExpression :: ![(FreeVar,AType)] ![[(FreeVar,AType)]] !Index !{#CommonDefs} !ExprInfoPtr !Expression !*ConvertState -> *(![([[FunctionPattern]], !Expression)], !*ConvertState) convertPatternExpression left_vars right_vars group_index common_defs default_ptr - case_expr=:(Case {case_expr = Var var=:{var_info_ptr}, case_guards, case_default, case_info_ptr}) ci + case_expr=:(Case {case_expr = Var var=:{var_info_ptr}, case_guards, case_default, case_info_ptr}) cs | list_contains_variable var_info_ptr right_vars = case case_guards of BasicPatterns type basic_patterns # split_result = split_list_of_vars var_info_ptr [] right_vars - (default_patterns, ci) = convert_default left_vars split_result group_index common_defs case_default ci - (guarded_exprs, ci) = mapSt (convert_basic_guard_into_function_pattern left_vars split_result group_index common_defs) basic_patterns ci - -> (flatten guarded_exprs ++ default_patterns, ci) + (default_patterns, cs) = convert_default left_vars split_result group_index common_defs case_default cs + (guarded_exprs, cs) = mapSt (convert_basic_guard_into_function_pattern left_vars split_result group_index common_defs) basic_patterns cs + -> (flatten guarded_exprs ++ default_patterns, cs) AlgebraicPatterns type algebraic_patterns - # (EI_CaseTypeAndRefCounts {ct_cons_types} _, ci_expr_heap) = readPtr case_info_ptr ci.ci_expr_heap + # (EI_CaseTypeAndRefCounts {ct_cons_types} _, cs_expr_heap) = readPtr case_info_ptr cs.cs_expr_heap split_result = split_list_of_vars var_info_ptr [] right_vars - (default_patterns, ci) = convert_default left_vars split_result group_index common_defs case_default { ci & ci_expr_heap = ci_expr_heap } - (guarded_exprs, ci) = mapSt (convert_algebraic_guard_into_function_pattern left_vars split_result group_index common_defs case_info_ptr) - (exactZip algebraic_patterns ct_cons_types) ci - -> (flatten guarded_exprs ++ default_patterns, ci) + (default_patterns, cs) = convert_default left_vars split_result group_index common_defs case_default { cs & cs_expr_heap = cs_expr_heap } + (guarded_exprs, cs) = mapSt (convert_algebraic_guard_into_function_pattern left_vars split_result group_index common_defs case_info_ptr) + (exactZip algebraic_patterns ct_cons_types) cs + -> (flatten guarded_exprs ++ default_patterns, cs) _ - -> convertToRhsExpression left_vars right_vars group_index common_defs default_ptr case_expr ci - = convertToRhsExpression left_vars right_vars group_index common_defs default_ptr case_expr ci + -> convertToRhsExpression left_vars right_vars group_index common_defs default_ptr case_expr cs + = convertToRhsExpression left_vars right_vars group_index common_defs default_ptr case_expr cs where list_contains_variable var_info_ptr [] = False @@ -398,30 +398,30 @@ where contains_variable var_info_ptr [ ({fv_info_ptr},_) : right_vars ] = var_info_ptr == fv_info_ptr || contains_variable var_info_ptr right_vars - convert_default left_vars ((fv,fv_type), list_of_left, list_of_right) group_index common_defs (Yes default_expr) ci - # (guarded_exprs, ci) - = convertPatternExpression (left_vars ++ [ (fv,fv_type) : flatten list_of_left ]) list_of_right group_index common_defs default_ptr default_expr ci - = (map (complete_pattern list_of_left fv) guarded_exprs, ci) + convert_default left_vars ((fv,fv_type), list_of_left, list_of_right) group_index common_defs (Yes default_expr) cs + # (guarded_exprs, cs) + = convertPatternExpression (left_vars ++ [ (fv,fv_type) : flatten list_of_left ]) list_of_right group_index common_defs default_ptr default_expr cs + = (map (complete_pattern list_of_left fv) guarded_exprs, cs) where complete_pattern list_of_left this_var (list_of_patterns, expr) = (complete_patterns list_of_left (FP_Variable this_var) list_of_patterns, expr) - convert_default left_vars ((fv,fv_type), list_of_left, list_of_right) group_index common_defs No ci - = ([], ci) + convert_default left_vars ((fv,fv_type), list_of_left, list_of_right) group_index common_defs No cs + = ([], cs) - convert_basic_guard_into_function_pattern left_vars ((fv,fv_type), list_of_left, list_of_right) group_index common_defs {bp_value, bp_expr} ci - # (guarded_exprs, ci) - = convertPatternExpression (left_vars ++ [ (fv,fv_type) : flatten list_of_left ]) list_of_right group_index common_defs default_ptr bp_expr ci - = (map (complete_pattern list_of_left bp_value (Yes fv)) guarded_exprs, ci) + convert_basic_guard_into_function_pattern left_vars ((fv,fv_type), list_of_left, list_of_right) group_index common_defs {bp_value, bp_expr} cs + # (guarded_exprs, cs) + = convertPatternExpression (left_vars ++ [ (fv,fv_type) : flatten list_of_left ]) list_of_right group_index common_defs default_ptr bp_expr cs + = (map (complete_pattern list_of_left bp_value (Yes fv)) guarded_exprs, cs) where complete_pattern list_of_left value opt_var (list_of_patterns, expr) = (complete_patterns list_of_left (FP_Basic value opt_var) list_of_patterns, expr) convert_algebraic_guard_into_function_pattern left_vars ((fv,fv_type), list_of_left, list_of_right) group_index common_defs case_info_ptr - ({ap_symbol, ap_vars, ap_expr}, arg_types) ci=:{ci_expr_heap} - # (guarded_exprs, ci) + ({ap_symbol, ap_vars, ap_expr}, arg_types) cs=:{cs_expr_heap} + # (guarded_exprs, cs) = convertPatternExpression (left_vars ++ [ (fv,fv_type) : flatten list_of_left ]) [ exactZip ap_vars arg_types : list_of_right ] - group_index common_defs default_ptr ap_expr { ci & ci_expr_heap = ci_expr_heap } - = (map (complete_pattern list_of_left ap_symbol (Yes fv)) guarded_exprs, ci) + group_index common_defs default_ptr ap_expr { cs & cs_expr_heap = cs_expr_heap } + = (map (complete_pattern list_of_left ap_symbol (Yes fv)) guarded_exprs, cs) where complete_pattern :: ![[(FreeVar,a)]] !(Global DefinedSymbol) !(Optional !FreeVar) !([[FunctionPattern]], !b) -> (![[FunctionPattern]], !b) complete_pattern list_of_left cons_symbol opt_var ([ patterns : list_of_patterns], expr) @@ -450,12 +450,12 @@ where add_free_vars [] right_vars = right_vars -convertPatternExpression left_vars right_vars group_index common_defs default_ptr expr ci - = convertToRhsExpression left_vars right_vars group_index common_defs default_ptr expr ci +convertPatternExpression left_vars right_vars group_index common_defs default_ptr expr cs + = convertToRhsExpression left_vars right_vars group_index common_defs default_ptr expr cs -convertToRhsExpression left_vars right_vars group_index common_defs default_ptr expr ci - # (bb_rhs, ci) = convertRootExpression (left_vars ++ flatten right_vars) group_index common_defs default_ptr expr ci - = ([(map (map selectFreeVar) right_vars, bb_rhs)], ci) +convertToRhsExpression left_vars right_vars group_index common_defs default_ptr expr cs + # (bb_rhs, cs) = convertRootExpression (left_vars ++ flatten right_vars) group_index common_defs default_ptr expr cs + = ([(map (map selectFreeVar) right_vars, bb_rhs)], cs) selectFreeVar (fv,_) = FP_Variable fv @@ -499,15 +499,15 @@ convertCasesOfFunctions :: !*{! Group} !Int !{# {# FunType} } !{# CommonDefs} !* -> (!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, {ci_new_functions, ci_var_heap, ci_expr_heap, ci_fun_heap})) + # (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, [], { ci_new_functions = [], ci_fun_heap = newHeap, ci_var_heap = var_heap, ci_expr_heap = expr_heap, ci_next_fun_nr = nr_of_funs }) - (groups, new_fun_defs, imported_types, imported_conses, type_heaps, ci_var_heap) - = addNewFunctionsToGroups common_defs ci_fun_heap ci_new_functions main_dcl_module_n groups imported_types imported_conses type_heaps ci_var_heap -// = foldSt (add_new_function_to_group ci_fun_heap common_defs) ci_new_functions (groups, [], imported_types, imported_conses, type_heaps, ci_var_heap) + (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, ci_var_heap, type_heaps, ci_expr_heap) + imported_types, imported_conses, cs_var_heap, type_heaps, cs_expr_heap) where convert_groups group_nr groups dcl_functions common_defs fun_defs_and_ci | group_nr == size groups @@ -517,40 +517,40 @@ where (foldSt (convert_function group_nr dcl_functions common_defs) group.group_members fun_defs_and_ci) - 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, cs) # (fun_def, fun_defs) = 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, 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_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) 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 ci=:{ci_expr_heap} - # (EI_CaseTypeAndRefCounts case_type _, ci_expr_heap) = readPtr case_info_ptr ci_expr_heap - (default_ptr, ci_expr_heap) = makePtrToDefault case_default st_result cHasNoDefault ci_expr_heap + (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, ci) = convertPatterns case_guards case_type.ct_cons_types (Yes form_var_with_type) left_vars right_vars default_ptr group_index common_defs - { ci & ci_expr_heap = ci_expr_heap } - (fun_bodies, ci) = convertDefault default_ptr (Yes form_var_with_type) left_vars right_vars group_index common_defs (fun_bodies, ci) - = (BackendBody fun_bodies, ci) + (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 ci - # (tb_rhs, ci) = convertRootExpression (exactZip tb_args st_args) group_index common_defs cHasNoDefault tb_rhs ci - = (BackendBody [ { bb_args = map FP_Variable tb_args, bb_rhs = tb_rhs }], ci) + convert_cases_into_function_patterns (TransformedBody {tb_args,tb_rhs}) (Yes {st_result,st_args}) group_index common_defs cs + # (tb_rhs, cs) = convertRootExpression (exactZip tb_args st_args) group_index common_defs cHasNoDefault tb_rhs cs + = (BackendBody [ { bb_args = map FP_Variable tb_args, bb_rhs = tb_rhs }], cs) - eliminate_code_sharing_in_function dcl_functions common_defs (TransformedBody body=:{tb_rhs}) (collected_imports, ci=:{ci_expr_heap,ci_var_heap}) + 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 = ci_var_heap, rc_expr_heap = ci_expr_heap, rc_free_vars = [], rc_imports = collected_imports,rc_main_dcl_module_n=main_dcl_module_n} + { 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, { ci & ci_var_heap = var_heap, ci_expr_heap = 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) split (SK_Function fun_symb) (collected_functions, collected_conses) @@ -558,48 +558,48 @@ where split (SK_Constructor cons_symb) (collected_functions, collected_conses) = (collected_functions, [ cons_symb : collected_conses]) -convertRootExpression bound_vars group_index common_defs default_ptr (Let lad=:{let_strict_binds,let_lazy_binds,let_expr,let_info_ptr}) ci=:{ci_expr_heap} - # (EI_LetType let_type, ci_expr_heap) = readPtr let_info_ptr ci_expr_heap +convertRootExpression bound_vars group_index common_defs default_ptr (Let lad=:{let_strict_binds,let_lazy_binds,let_expr,let_info_ptr}) cs=:{cs_expr_heap} + # (EI_LetType let_type, cs_expr_heap) = readPtr let_info_ptr cs_expr_heap bound_vars = addLetVars (let_strict_binds ++ let_lazy_binds) let_type bound_vars - (let_strict_binds, ci) = convertCases bound_vars group_index common_defs let_strict_binds { ci & ci_expr_heap = ci_expr_heap } - (let_lazy_binds, ci) = convertCases bound_vars group_index common_defs let_lazy_binds ci - (let_expr, ci) = convertRootExpression bound_vars group_index common_defs default_ptr let_expr ci - = (Let { lad & let_strict_binds = let_strict_binds, let_lazy_binds = let_lazy_binds, let_expr = let_expr }, ci) -convertRootExpression bound_vars group_index common_defs default_ptr (Case kees=:{case_expr, case_guards, case_default, case_info_ptr}) ci + (let_strict_binds, cs) = convertCases bound_vars group_index common_defs let_strict_binds { cs & cs_expr_heap = cs_expr_heap } + (let_lazy_binds, cs) = convertCases bound_vars group_index common_defs let_lazy_binds cs + (let_expr, cs) = convertRootExpression bound_vars group_index common_defs default_ptr let_expr cs + = (Let { lad & let_strict_binds = let_strict_binds, let_lazy_binds = let_lazy_binds, let_expr = let_expr }, cs) +convertRootExpression bound_vars group_index common_defs default_ptr (Case kees=:{case_expr, case_guards, case_default, case_info_ptr}) cs = case case_guards of BasicPatterns BT_Bool patterns - -> convert_boolean_case_into_guard bound_vars group_index common_defs default_ptr case_expr patterns case_default case_info_ptr ci + -> convert_boolean_case_into_guard bound_vars group_index common_defs default_ptr case_expr patterns case_default case_info_ptr cs _ - -> convertCasesInCaseExpression bound_vars group_index common_defs default_ptr kees ci + -> convertCasesInCaseExpression bound_vars group_index common_defs default_ptr kees cs where /* - convert_boolean_case_into_guard bound_vars group_index common_defs default_ptr guard [ alt : alts ] case_default case_info_ptr ci - # (guard, ci) = convertRootExpression bound_vars group_index common_defs cHasNoDefault guard ci + convert_boolean_case_into_guard bound_vars group_index common_defs default_ptr guard [ alt : alts ] case_default case_info_ptr cs + # (guard, cs) = convertRootExpression bound_vars group_index common_defs cHasNoDefault guard cs (then_bool, then_expr, opt_else_expr) = check_reachability alt alts = case opt_else_expr of Yes else_expr - # (then_expr, ci) = convertRootExpression bound_vars group_index common_defs cHasNoDefault then_expr ci - (else_expr, ci) = convertRootExpression bound_vars group_index common_defs cHasNoDefault else_expr ci - -> (build_conditional then_bool guard then_expr else_expr, ci) + # (then_expr, cs) = convertRootExpression bound_vars group_index common_defs cHasNoDefault then_expr cs + (else_expr, cs) = convertRootExpression bound_vars group_index common_defs cHasNoDefault else_expr cs + -> (build_conditional then_bool guard then_expr else_expr, cs) No -> case case_default of Yes default_expr - # (EI_CaseTypeAndRefCounts case_type ref_counts, ci_expr_heap) = readPtr case_info_ptr ci.ci_expr_heap - (default_ptr, ci_expr_heap) = makePtrToDefault case_default case_type.ct_result_type default_ptr ci_expr_heap - (then_expr, ci) = convertRootExpression bound_vars group_index common_defs default_ptr then_expr { ci & ci_expr_heap = ci_expr_heap } - (default_info, ci_expr_heap) = readPtr default_ptr ci.ci_expr_heap - (else_expr, ci) = convertDefaultToExpression default_ptr default_info bound_vars group_index common_defs - { ci & ci_expr_heap = ci_expr_heap } - -> (build_conditional then_bool guard then_expr else_expr, ci) + # (EI_CaseTypeAndRefCounts case_type ref_counts, cs_expr_heap) = readPtr case_info_ptr cs.cs_expr_heap + (default_ptr, cs_expr_heap) = makePtrToDefault case_default case_type.ct_result_type default_ptr cs_expr_heap + (then_expr, cs) = convertRootExpression bound_vars group_index common_defs default_ptr then_expr { cs & cs_expr_heap = cs_expr_heap } + (default_info, cs_expr_heap) = readPtr default_ptr cs.cs_expr_heap + (else_expr, cs) = convertDefaultToExpression default_ptr default_info bound_vars group_index common_defs + { cs & cs_expr_heap = cs_expr_heap } + -> (build_conditional then_bool guard then_expr else_expr, cs) No - # (then_expr, ci) = convertRootExpression bound_vars group_index common_defs default_ptr then_expr ci + # (then_expr, cs) = convertRootExpression bound_vars group_index common_defs default_ptr then_expr cs | isNilPtr default_ptr - -> (Conditional { if_cond = convert_guard then_bool guard, if_then = then_expr, if_else = No }, ci) - # (default_info, ci_expr_heap) = readPtr default_ptr ci.ci_expr_heap - (else_expr, ci) = convertDefaultToExpression default_ptr default_info bound_vars group_index common_defs - { ci & ci_expr_heap = ci_expr_heap } - -> (build_conditional then_bool guard then_expr else_expr, ci) + -> (Conditional { if_cond = convert_guard then_bool guard, if_then = then_expr, if_else = No }, cs) + # (default_info, cs_expr_heap) = readPtr default_ptr cs.cs_expr_heap + (else_expr, cs) = convertDefaultToExpression default_ptr default_info bound_vars group_index common_defs + { cs & cs_expr_heap = cs_expr_heap } + -> (build_conditional then_bool guard then_expr else_expr, cs) convert_guard guard_bool guard | guard_bool @@ -623,15 +623,15 @@ where = Yes bp_expr */ -// convert_boolean_case_into_guard bound_vars group_index common_defs default_ptr guard [ alt : alts ] case_default case_info_ptr ci - convert_boolean_case_into_guard bound_vars group_index common_defs has_default guard [ alt=:{bp_value=BVB sign_of_then_part,bp_expr} : alts ] case_default case_info_ptr ci - # (guard, ci) = convertRootExpression bound_vars group_index common_defs cHasNoDefault guard ci - # (EI_CaseTypeAndRefCounts case_type _, ci_expr_heap) = readPtr case_info_ptr ci.ci_expr_heap - # (default_ptr, ci_expr_heap) = makePtrToDefault case_default case_type.ct_result_type has_default ci_expr_heap - # (then_part, ci) = convertRootExpression bound_vars group_index common_defs default_ptr bp_expr {ci &ci_expr_heap=ci_expr_heap} - # (opt_else_part, ci) = convert_to_else_part bound_vars group_index common_defs default_ptr sign_of_then_part alts case_default ci -// = (Conditional { if_cond = { con_positive = sign_of_then_part, con_expression = guard }, if_then = then_part, if_else = opt_else_part }, ci) - = (build_conditional sign_of_then_part guard then_part opt_else_part, ci) +// convert_boolean_case_into_guard bound_vars group_index common_defs default_ptr guard [ alt : alts ] case_default case_info_ptr cs + convert_boolean_case_into_guard bound_vars group_index common_defs has_default guard [ alt=:{bp_value=BVB sign_of_then_part,bp_expr} : alts ] case_default case_info_ptr cs + # (guard, cs) = convertRootExpression bound_vars group_index common_defs cHasNoDefault guard cs + # (EI_CaseTypeAndRefCounts case_type _, cs_expr_heap) = readPtr case_info_ptr cs.cs_expr_heap + # (default_ptr, cs_expr_heap) = makePtrToDefault case_default case_type.ct_result_type has_default cs_expr_heap + # (then_part, cs) = convertRootExpression bound_vars group_index common_defs default_ptr bp_expr {cs &cs_expr_heap=cs_expr_heap} + # (opt_else_part, cs) = convert_to_else_part bound_vars group_index common_defs default_ptr sign_of_then_part alts case_default cs +// = (Conditional { if_cond = { con_positive = sign_of_then_part, con_expression = guard }, if_then = then_part, if_else = opt_else_part }, cs) + = (build_conditional sign_of_then_part guard then_part opt_else_part, cs) where build_conditional True guard then_expr opt_else_expr = Conditional { if_cond = guard, if_then = then_expr, if_else = opt_else_expr } @@ -641,19 +641,19 @@ where = Conditional { if_cond = Conditional { if_cond = guard, if_then = BasicExpr (BVB False) BT_Bool, if_else = Yes (BasicExpr (BVB True) BT_Bool) }, if_then = then_expr, if_else = No } - convert_to_else_part bound_vars group_index common_defs default_ptr sign_of_then_part [ alt=:{bp_value=BVB sign_of_else_part,bp_expr} : alts ] case_default ci - # (else_part, ci) = convertRootExpression bound_vars group_index common_defs default_ptr bp_expr ci + convert_to_else_part bound_vars group_index common_defs default_ptr sign_of_then_part [ alt=:{bp_value=BVB sign_of_else_part,bp_expr} : alts ] case_default cs + # (else_part, cs) = convertRootExpression bound_vars group_index common_defs default_ptr bp_expr cs | sign_of_then_part == sign_of_else_part - = convert_to_else_part bound_vars group_index common_defs default_ptr sign_of_then_part alts case_default ci - = (Yes else_part, ci) - convert_to_else_part bound_vars group_index common_defs default_ptr sign_of_then_part [ ] (Yes else_part) ci - # (else_part, ci) = convertRootExpression bound_vars group_index common_defs has_default else_part ci - = (Yes else_part, ci) - convert_to_else_part bound_vars group_index common_defs default_ptr sign_of_then_part [ ] No ci - = (No, ci) - -convertRootExpression bound_vars group_index common_defs _ expr ci - = convertCases bound_vars group_index common_defs expr ci + = convert_to_else_part bound_vars group_index common_defs default_ptr sign_of_then_part alts case_default cs + = (Yes else_part, cs) + convert_to_else_part bound_vars group_index common_defs default_ptr sign_of_then_part [ ] (Yes else_part) cs + # (else_part, cs) = convertRootExpression bound_vars group_index common_defs has_default else_part cs + = (Yes else_part, cs) + convert_to_else_part bound_vars group_index common_defs default_ptr sign_of_then_part [ ] No cs + = (No, cs) + +convertRootExpression bound_vars group_index common_defs _ expr cs + = convertCases bound_vars group_index common_defs expr cs :: CopyInfo = |