diff options
Diffstat (limited to 'frontend')
| -rw-r--r-- | frontend/trans.icl | 599 |
1 files changed, 316 insertions, 283 deletions
diff --git a/frontend/trans.icl b/frontend/trans.icl index 6dedfdf..0095497 100644 --- a/frontend/trans.icl +++ b/frontend/trans.icl @@ -139,6 +139,7 @@ readExtendedVarInfo var_info_ptr var_heap # (var_info, var_heap) = readPtr var_info_ptr var_heap = case var_info of VI_Extended extensions _ -> (extensions, var_heap) + _ -> abort "sanity check 'readExtendedVarInfo' failed in module trans.\n" writeVarInfo :: VarInfoPtr VarInfo *VarHeap -> *VarHeap writeVarInfo var_info_ptr new_var_info var_heap @@ -258,10 +259,12 @@ where store_type_info_of_bindings_in_heap {let_strict_binds, let_lazy_binds,let_info_ptr} ti # let_binds = let_strict_binds ++ let_lazy_binds # (EI_LetType var_types, ti_symbol_heap) = readExprInfo let_info_ptr ti.ti_symbol_heap - ti_var_heap = foldSt (\(var_type, {lb_dst={fv_info_ptr}}) var_heap - ->setExtendedVarInfo fv_info_ptr (EVI_VarType var_type) var_heap) + ti_var_heap = foldSt store_type_info_let_bind (zip2 var_types let_binds) ti.ti_var_heap = { ti & ti_symbol_heap = ti_symbol_heap, ti_var_heap = ti_var_heap } + store_type_info_let_bind (var_type, {lb_dst={fv_info_ptr}}) var_heap + = setExtendedVarInfo fv_info_ptr (EVI_VarType var_type) var_heap + transform (Case kees) ro ti # ti = store_type_info_of_patterns_in_heap kees ti = transformCase kees ro ti @@ -269,20 +272,24 @@ where store_type_info_of_patterns_in_heap {case_guards,case_info_ptr} ti = case case_guards of AlgebraicPatterns _ patterns - # (EI_CaseType {ct_cons_types},ti_symbol_heap) = readExprInfo case_info_ptr ti.ti_symbol_heap + # (EI_CaseType {ct_cons_types},ti_symbol_heap) + = readExprInfo case_info_ptr ti.ti_symbol_heap ti_var_heap = foldSt store_type_info_of_alg_pattern (zip2 ct_cons_types patterns) ti.ti_var_heap -> { ti & ti_symbol_heap = ti_symbol_heap, ti_var_heap = ti_var_heap } BasicPatterns _ _ -> ti // no variables occur OverloadedListPatterns _ _ patterns - # (EI_CaseType {ct_cons_types},ti_symbol_heap) = readExprInfo case_info_ptr ti.ti_symbol_heap + # (EI_CaseType {ct_cons_types},ti_symbol_heap) + = readExprInfo case_info_ptr ti.ti_symbol_heap ti_var_heap = foldSt store_type_info_of_alg_pattern (zip2 ct_cons_types patterns) ti.ti_var_heap -> { ti & ti_symbol_heap = ti_symbol_heap, ti_var_heap = ti_var_heap } NoPattern -> ti store_type_info_of_alg_pattern (var_types,{ap_vars}) var_heap - = foldSt (\(var_type, {fv_info_ptr}) var_heap - ->setExtendedVarInfo fv_info_ptr (EVI_VarType var_type) var_heap) (zip2 var_types ap_vars) var_heap + = foldSt store_type_info_of_pattern_var (zip2 var_types ap_vars) var_heap + store_type_info_of_pattern_var (var_type, {fv_info_ptr}) var_heap + = setExtendedVarInfo fv_info_ptr (EVI_VarType var_type) var_heap + transform (Selection opt_type expr selectors) ro ti # (expr, ti) = transform expr ro ti = transformSelection opt_type selectors expr ti @@ -335,7 +342,9 @@ instance transform DynamicExpr where = ({dyn & dyn_expr = dyn_expr}, ti) transformCase this_case=:{case_expr,case_guards,case_default,case_ident,case_info_ptr} ro ti - | SwitchCaseFusion (not ro.ro_transform_fusion) True -!-> ("transformCase",Case this_case) + | SwitchCaseFusion (not ro.ro_transform_fusion) True + = skip_over this_case ro ti + | isNilPtr case_info_ptr // encountered neverMatchingCase?! = skip_over this_case ro ti # (case_info, ti_symbol_heap) = readPtr case_info_ptr ti.ti_symbol_heap ti = { ti & ti_symbol_heap=ti_symbol_heap } @@ -349,238 +358,246 @@ transformCase this_case=:{case_expr,case_guards,case_default,case_ident,case_inf _ -> transCase False No this_case ro ti ti = { ti & ti_symbol_heap = remove_aci_free_vars_info case_info_ptr ti.ti_symbol_heap } = (removeNeverMatchingSubcases result_expr, ti) - where - skip_over this_case=:{case_expr,case_guards,case_default} ro ti - # ro_lost_root = { ro & ro_root_case_mode = NotRootCase } - (new_case_expr, ti) = transform case_expr ro_lost_root ti - (new_case_guards, ti) = transform case_guards ro_lost_root ti - (new_case_default, ti) = transform case_default ro_lost_root ti - = (Case { this_case & case_expr=new_case_expr, case_guards=new_case_guards, case_default=new_case_default }, ti) - +where is_variable (Var _) = True is_variable _ = False - transCase is_active opt_aci this_case=:{case_expr,case_guards,case_default,case_ident,case_info_ptr} ro ti -// | False -!-> ("transCase",Case this_case) -// = undef - = case case_expr of - Case case_in_case - | is_active - -> lift_case case_in_case this_case ro ti - -> skip_over this_case ro ti - App app=:{app_symb,app_args} - -> case app_symb.symb_kind of - SK_Constructor cons_index - | not is_active - -> skip_over this_case ro ti // XXX currently only active cases are matched at runtime (multimatch problem) - # algebraicPatterns = getAlgebraicPatterns case_guards - aci = case opt_aci of - Yes aci -> aci - (may_be_match_expr, ti) = match_and_instantiate aci.aci_linearity_of_patterns cons_index app_args algebraicPatterns case_default ro ti - -> case may_be_match_expr of - Yes match_expr - -> (match_expr, ti) - No - -> (Case neverMatchingCase, ti) - // otherwise it's a function application - _ -> case opt_aci of - Yes aci=:{ aci_params, aci_opt_unfolder } - -> case aci_opt_unfolder of - No -> skip_over this_case ro ti - Yes unfolder - | not (equal app_symb.symb_kind unfolder.symb_kind) - // in this case a third function could be fused in - -> skip_over this_case ro ti - # variables = [ Var {var_name=fv_name, var_info_ptr=fv_info_ptr, var_expr_ptr=nilPtr} - \\ {fv_name, fv_info_ptr} <- ro.ro_fun_args ] - (ti_next_fun_nr, ti) = ti!ti_next_fun_nr - (new_next_fun_nr, app_symb) - = case ro.ro_root_case_mode of - RootCaseOfZombie - # (ro_fun=:{symb_kind=SK_GeneratedFunction fun_info_ptr _}) = ro.ro_fun_case - -> (inc ti_next_fun_nr, - { ro_fun & symb_kind=SK_GeneratedFunction fun_info_ptr ti_next_fun_nr }) - RootCase - -> (ti_next_fun_nr, ro.ro_fun_root) - ti = { ti & ti_next_fun_nr = new_next_fun_nr, ti_recursion_introduced = Yes ti_next_fun_nr } - app_args1 = replace_arg [ fv_info_ptr \\ {fv_info_ptr}<-aci_params ] app_args variables - (app_args2, ti) = transform app_args1 { ro & ro_root_case_mode = NotRootCase } ti - -> (App {app_symb=app_symb, app_args=app_args2, app_info_ptr=nilPtr}, ti) - No -> skip_over this_case ro ti - BasicExpr basic_value - | not is_active - -> skip_over this_case ro ti // XXX currently only active cases are matched at runtime (multimatch problem) - # basicPatterns = getBasicPatterns case_guards - may_be_match_pattern = dropWhile (\{bp_value} -> bp_value<>basic_value) basicPatterns - | isEmpty may_be_match_pattern - -> case case_default of - Yes default_expr-> transform default_expr { ro & ro_root_case_mode = NotRootCase } ti - No -> (Case neverMatchingCase, ti) - -> transform (hd may_be_match_pattern).bp_expr { ro & ro_root_case_mode = NotRootCase } ti - Let lad - | not is_active - -> skip_over this_case ro ti - # ro_not_root = { ro & ro_root_case_mode = NotRootCase } - (new_let_strict_binds, ti) = transform lad.let_strict_binds ro_not_root ti - (new_let_lazy_binds, ti) = transform lad.let_lazy_binds ro_not_root ti - (new_let_expr, ti) = transform (Case { this_case & case_expr = lad.let_expr }) ro ti - -> (Let { lad & let_expr = new_let_expr, let_strict_binds = new_let_strict_binds, let_lazy_binds = new_let_lazy_binds }, ti) - _ -> skip_over this_case ro ti - where - equal (SK_Function glob_index1) (SK_Function glob_index2) - = glob_index1==glob_index2 - equal (SK_LocalMacroFunction glob_index1) (SK_LocalMacroFunction glob_index2) - = glob_index1==glob_index2 - equal (SK_GeneratedFunction _ index1) (SK_GeneratedFunction _ index2) - = index1==index2 - equal _ _ - = False - - replace_arg producer_vars=:[fv_info_ptr:_] act_pars form_pars=:[h_form_pars=:(Var {var_info_ptr}):t_form_pars] - | fv_info_ptr<>var_info_ptr - = [h_form_pars:replace_arg producer_vars act_pars t_form_pars] - = replacement producer_vars act_pars form_pars - where - replacement producer_vars [] form_pars - = form_pars - replacement producer_vars _ [] - = [] - replacement producer_vars [h_act_pars:t_act_pars] [form_par=:(Var {var_info_ptr}):form_pars] - | isMember var_info_ptr producer_vars - = [h_act_pars:replacement producer_vars t_act_pars form_pars] - = replacement producer_vars t_act_pars form_pars - - getAlgebraicPatterns (AlgebraicPatterns _ algebraicPatterns) - = algebraicPatterns - getAlgebraicPatterns (OverloadedListPatterns _ _ algebraicPatterns) - = algebraicPatterns +skip_over this_case=:{case_expr,case_guards,case_default} ro ti + # ro_lost_root = { ro & ro_root_case_mode = NotRootCase } + (new_case_expr, ti) = transform case_expr ro_lost_root ti + (new_case_guards, ti) = transform case_guards ro_lost_root ti + (new_case_default, ti) = transform case_default ro_lost_root ti + = (Case { this_case & case_expr=new_case_expr, case_guards=new_case_guards, case_default=new_case_default }, ti) - getBasicPatterns (BasicPatterns _ basicPatterns) - = basicPatterns +transCase is_active opt_aci this_case=:{case_expr = Case case_in_case} ro ti + | is_active + = lift_case case_in_case this_case ro ti + = skip_over this_case ro ti +where + lift_case nested_case=:{case_guards,case_default} outer_case ro ti + | isNilPtr nested_case.case_info_ptr // neverMatchingCase ?! + = skip_over outer_case ro ti + # default_exists = case case_default of + Yes _ -> True + No -> False + (case_guards, ti) = lift_patterns default_exists case_guards outer_case ro ti + (case_default, ti) = lift_default case_default outer_case ro ti + (EI_CaseType outer_case_type, ti_symbol_heap) = readExprInfo outer_case.case_info_ptr ti.ti_symbol_heap + // the result type of the nested case becomes the result type of the outer case + ti_symbol_heap = overwrite_result_type nested_case.case_info_ptr outer_case_type.ct_result_type ti_symbol_heap + // after this transformation the aci_free_vars information doesn't hold anymore + ti_symbol_heap = remove_aci_free_vars_info nested_case.case_info_ptr ti_symbol_heap + ti = { ti & ti_symbol_heap = ti_symbol_heap } + = (Case {nested_case & case_guards = case_guards, case_default = case_default}, ti) + where + overwrite_result_type case_info_ptr new_result_type ti_symbol_heap + #! (EI_CaseType case_type, ti_symbol_heap) = readExprInfo case_info_ptr ti_symbol_heap + = writeExprInfo case_info_ptr (EI_CaseType { case_type & ct_result_type = new_result_type}) ti_symbol_heap + + lift_patterns default_exists (AlgebraicPatterns type case_guards) outer_case ro ti + # guard_exprs = [ ap_expr \\ {ap_expr} <- case_guards ] + # (guard_exprs_with_case, ti) = lift_patterns_2 default_exists guard_exprs outer_case ro ti + = (AlgebraicPatterns type [ { case_guard & ap_expr=guard_expr } \\ case_guard<-case_guards & guard_expr<-guard_exprs_with_case], ti) + lift_patterns default_exists (BasicPatterns basic_type case_guards) outer_case ro ti + # guard_exprs = [ bp_expr \\ {bp_expr} <- case_guards ] + # (guard_exprs_with_case, ti) = lift_patterns_2 default_exists guard_exprs outer_case ro ti + = (BasicPatterns basic_type [ { case_guard & bp_expr=guard_expr } \\ case_guard<-case_guards & guard_expr<-guard_exprs_with_case], ti) + lift_patterns default_exists (OverloadedListPatterns type decons_expr case_guards) outer_case ro ti + # guard_exprs = [ ap_expr \\ {ap_expr} <- case_guards ] + # (guard_exprs_with_case, ti) = lift_patterns_2 default_exists guard_exprs outer_case ro ti + = (OverloadedListPatterns type decons_expr [ { case_guard & ap_expr=guard_expr } \\ case_guard<-case_guards & guard_expr<-guard_exprs_with_case], ti) + lift_patterns _ _ _ _ _ + = abort "lift_patterns does not match" + + lift_patterns_2 False [guard_expr] outer_case ro ti + // if no default pattern exists, then the outer case expression does not have to be copied for the last pattern + # (guard_expr, ti) = transformCase {outer_case & case_expr = guard_expr} ro ti + = ([guard_expr], ti) + lift_patterns_2 default_exists [guard_expr : guard_exprs] outer_case ro ti + # us = { us_var_heap = ti.ti_var_heap, us_symbol_heap = ti.ti_symbol_heap, us_opt_type_heaps = No + ,us_cleanup_info=ti.ti_cleanup_info, us_local_macro_functions = No } + ui = {ui_handle_aci_free_vars = LeaveThem, ui_convert_module_n= -1,ui_conversion_table=No } + (outer_guards, us=:{us_cleanup_info}) = unfold outer_case.case_guards ui us + (expr_info, ti_symbol_heap) = readPtr outer_case.case_info_ptr us.us_symbol_heap + (new_info_ptr, ti_symbol_heap) = newPtr expr_info ti_symbol_heap + new_cleanup_info = case expr_info of + EI_Extended _ _ + -> [new_info_ptr:us_cleanup_info] + _ -> us_cleanup_info + ti = { ti & ti_var_heap = us.us_var_heap, ti_symbol_heap = ti_symbol_heap, ti_cleanup_info=new_cleanup_info } + new_case = { outer_case & case_expr = guard_expr, case_guards=outer_guards, case_info_ptr=new_info_ptr } + (guard_expr, ti) = transformCase new_case ro ti + (guard_exprs, ti) = lift_patterns_2 default_exists guard_exprs outer_case ro ti + = ([guard_expr : guard_exprs], ti) + lift_patterns_2 _ [] _ _ ti + = ([], ti) - lift_case nested_case=:{case_guards,case_default} outer_case ro ti - # default_exists = case case_default of - Yes _ -> True - No -> False - (case_guards, ti) = lift_patterns default_exists case_guards outer_case ro ti - (case_default, ti) = lift_default case_default outer_case ro ti - (EI_CaseType outer_case_type, ti_symbol_heap) = readExprInfo outer_case.case_info_ptr ti.ti_symbol_heap - // the result type of the nested case becomes the result type of the outer case - ti_symbol_heap = overwrite_result_type nested_case.case_info_ptr outer_case_type.ct_result_type ti_symbol_heap - // after this transformation the aci_free_vars information doesn't hold anymore - ti_symbol_heap = remove_aci_free_vars_info nested_case.case_info_ptr ti_symbol_heap - ti = { ti & ti_symbol_heap = ti_symbol_heap } - = (Case {nested_case & case_guards = case_guards, case_default = case_default}, ti) - where - overwrite_result_type case_info_ptr new_result_type ti_symbol_heap - #! (EI_CaseType case_type, ti_symbol_heap) = readExprInfo case_info_ptr ti_symbol_heap - = writeExprInfo case_info_ptr (EI_CaseType { case_type & ct_result_type = new_result_type}) ti_symbol_heap - - lift_patterns default_exists (AlgebraicPatterns type case_guards) outer_case ro ti - # guard_exprs = [ ap_expr \\ {ap_expr} <- case_guards ] - # (guard_exprs_with_case, ti) = lift_patterns_2 default_exists guard_exprs outer_case ro ti - = (AlgebraicPatterns type [ { case_guard & ap_expr=guard_expr } \\ case_guard<-case_guards & guard_expr<-guard_exprs_with_case], ti) - lift_patterns default_exists (BasicPatterns basic_type case_guards) outer_case ro ti - # guard_exprs = [ bp_expr \\ {bp_expr} <- case_guards ] - # (guard_exprs_with_case, ti) = lift_patterns_2 default_exists guard_exprs outer_case ro ti - = (BasicPatterns basic_type [ { case_guard & bp_expr=guard_expr } \\ case_guard<-case_guards & guard_expr<-guard_exprs_with_case], ti) - lift_patterns default_exists (OverloadedListPatterns type decons_expr case_guards) outer_case ro ti - # guard_exprs = [ ap_expr \\ {ap_expr} <- case_guards ] - # (guard_exprs_with_case, ti) = lift_patterns_2 default_exists guard_exprs outer_case ro ti - = (OverloadedListPatterns type decons_expr [ { case_guard & ap_expr=guard_expr } \\ case_guard<-case_guards & guard_expr<-guard_exprs_with_case], ti) - - lift_patterns_2 False [guard_expr] outer_case ro ti - // if no default pattern exists, then the outer case expression does not have to be copied for the last pattern - # (guard_expr, ti) = transformCase {outer_case & case_expr = guard_expr} ro ti - = ([guard_expr], ti) - lift_patterns_2 default_exists [guard_expr : guard_exprs] outer_case ro ti - # us = { us_var_heap = ti.ti_var_heap, us_symbol_heap = ti.ti_symbol_heap, us_opt_type_heaps = No - ,us_cleanup_info=ti.ti_cleanup_info, us_local_macro_functions = No } - ui = {ui_handle_aci_free_vars = LeaveThem, ui_convert_module_n= -1,ui_conversion_table=No } - (outer_guards, us=:{us_cleanup_info}) = unfold outer_case.case_guards ui us - (expr_info, ti_symbol_heap) = readPtr outer_case.case_info_ptr us.us_symbol_heap - (new_info_ptr, ti_symbol_heap) = newPtr expr_info ti_symbol_heap - new_cleanup_info = case expr_info of - EI_Extended _ _ - -> [new_info_ptr:us_cleanup_info] - _ -> us_cleanup_info - ti = { ti & ti_var_heap = us.us_var_heap, ti_symbol_heap = ti_symbol_heap, ti_cleanup_info=new_cleanup_info } - new_case = { outer_case & case_expr = guard_expr, case_guards=outer_guards, case_info_ptr=new_info_ptr } - (guard_expr, ti) = transformCase new_case ro ti - (guard_exprs, ti) = lift_patterns_2 default_exists guard_exprs outer_case ro ti - = ([guard_expr : guard_exprs], ti) - lift_patterns_2 _ [] _ _ ti - = ([], ti) - - lift_default (Yes default_expr) outer_case ro ti - # (default_expr, ti) = transformCase { outer_case & case_expr = default_expr } ro ti - = (Yes default_expr, ti) - lift_default No _ _ ti - = (No, ti) - - match_and_instantiate [linearity:linearities] cons_index app_args - [{ap_symbol={glob_module,glob_object={ds_index}}, ap_vars, ap_expr} : guards] case_default ro ti - | cons_index.glob_module == glob_module && cons_index.glob_object == ds_index - # zipped = zip2 ap_vars app_args - {cons_type} = ro.ro_common_defs.[glob_module].com_cons_defs.[ds_index] - unfoldables = [ ((not (arg_is_strict i cons_type.st_args_strictness)) && linear) || in_normal_form app_arg \\ linear <- linearity & app_arg <- app_args & i <- [0..]] - unfoldable_args = filterWith unfoldables zipped - not_unfoldable = map not unfoldables - non_unfoldable_args = filterWith not_unfoldable zipped - ti_var_heap = foldSt (\({fv_info_ptr}, arg) -> writeVarInfo fv_info_ptr (VI_Expression arg)) unfoldable_args ti.ti_var_heap - (new_expr, ti_symbol_heap) = possibly_add_let non_unfoldable_args ap_expr not_unfoldable glob_module ds_index ro ti.ti_symbol_heap - unfold_state = { us_var_heap = ti_var_heap, us_symbol_heap = ti_symbol_heap, us_opt_type_heaps = No,us_cleanup_info=ti.ti_cleanup_info, - us_local_macro_functions = No } - ui= {ui_handle_aci_free_vars = LeaveThem, ui_convert_module_n= -1,ui_conversion_table=No } - (unfolded_expr, unfold_state) = unfold new_expr ui unfold_state - (final_expr, ti) = transform unfolded_expr - { ro & ro_root_case_mode = NotRootCase } - { ti & ti_var_heap = unfold_state.us_var_heap, ti_symbol_heap = unfold_state.us_symbol_heap,ti_cleanup_info=unfold_state.us_cleanup_info } - = (Yes final_expr, ti) - = match_and_instantiate linearities cons_index app_args guards case_default ro ti - where - in_normal_form (Var _) = True - in_normal_form (BasicExpr _) = True - in_normal_form _ = False - - filterWith [True:t2] [h1:t1] - = [h1:filterWith t2 t1] - filterWith [False:t2] [h1:t1] - = filterWith t2 t1 - filterWith _ _ - = [] - - possibly_add_let [] ap_expr _ _ _ _ ti_symbol_heap - = (ap_expr, ti_symbol_heap) - possibly_add_let non_unfoldable_args ap_expr not_unfoldable glob_module glob_index ro ti_symbol_heap - # {cons_type} = ro.ro_common_defs.[glob_module].com_cons_defs.[glob_index] - let_type = filterWith not_unfoldable cons_type.st_args - (new_info_ptr, ti_symbol_heap) = newPtr (EI_LetType let_type) ti_symbol_heap + lift_default (Yes default_expr) outer_case ro ti + # (default_expr, ti) = transformCase { outer_case & case_expr = default_expr } ro ti + = (Yes default_expr, ti) + lift_default No _ _ ti + = (No, ti) + +transCase is_active opt_aci this_case=:{case_expr = (App app=:{app_symb,app_args}),case_guards,case_default,case_explicit} ro ti + = case app_symb.symb_kind of + SK_Constructor cons_index + | not is_active + -> skip_over this_case ro ti // XXX currently only active cases are matched at runtime (multimatch problem) + # algebraicPatterns = getAlgebraicPatterns case_guards + aci = case opt_aci of + Yes aci -> aci + (may_be_match_expr, ti) = match_and_instantiate aci.aci_linearity_of_patterns cons_index app_args algebraicPatterns case_default ro ti + -> case may_be_match_expr of + Yes match_expr + -> (match_expr, ti) + No + -> (Case neverMatchingCase, ti) + // otherwise it's a function application + _ -> case opt_aci of + Yes aci=:{ aci_params, aci_opt_unfolder } + -> case aci_opt_unfolder of + No -> skip_over this_case ro ti //---> ("transCase","No opt unfolder") + Yes unfolder + | not (equal app_symb.symb_kind unfolder.symb_kind) + // in this case a third function could be fused in + -> skip_over this_case ro ti //---> ("transCase","Diff opt unfolder",app_symb,unfolder) + # variables = [ Var {var_name=fv_name, var_info_ptr=fv_info_ptr, var_expr_ptr=nilPtr} + \\ {fv_name, fv_info_ptr} <- ro.ro_fun_args ] + (ti_next_fun_nr, ti) = ti!ti_next_fun_nr //---> ("transCase","Yes opt unfolder") + (new_next_fun_nr, app_symb) + = case ro.ro_root_case_mode of + RootCaseOfZombie + # (ro_fun=:{symb_kind=SK_GeneratedFunction fun_info_ptr _}) = ro.ro_fun_case + -> (inc ti_next_fun_nr, + { ro_fun & symb_kind=SK_GeneratedFunction fun_info_ptr ti_next_fun_nr }) + RootCase + -> (ti_next_fun_nr, ro.ro_fun_root) + ti = { ti & ti_next_fun_nr = new_next_fun_nr, ti_recursion_introduced = Yes ti_next_fun_nr } + app_args1 = replace_arg [ fv_info_ptr \\ {fv_info_ptr}<-aci_params ] app_args variables + (app_args2, ti) = transform app_args1 { ro & ro_root_case_mode = NotRootCase } ti + -> (App {app_symb=app_symb, app_args=app_args2, app_info_ptr=nilPtr}, ti) + No -> skip_over this_case ro ti +where + equal (SK_Function glob_index1) (SK_Function glob_index2) + = glob_index1==glob_index2 + equal (SK_LocalMacroFunction glob_index1) (SK_LocalMacroFunction glob_index2) + = glob_index1==glob_index2 + equal (SK_GeneratedFunction _ index1) (SK_GeneratedFunction _ index2) + = index1==index2 + equal _ _ + = False + + replace_arg [] _ f + = f + replace_arg producer_vars=:[fv_info_ptr:_] act_pars form_pars=:[h_form_pars=:(Var {var_info_ptr}):t_form_pars] + | fv_info_ptr<>var_info_ptr + = [h_form_pars:replace_arg producer_vars act_pars t_form_pars] + = replacement producer_vars act_pars form_pars + where + replacement producer_vars [] form_pars + = form_pars + replacement producer_vars _ [] + = [] + replacement producer_vars [h_act_pars:t_act_pars] [form_par=:(Var {var_info_ptr}):form_pars] + | isMember var_info_ptr producer_vars + = [h_act_pars:replacement producer_vars t_act_pars form_pars] + = replacement producer_vars t_act_pars form_pars + + getAlgebraicPatterns (AlgebraicPatterns _ algebraicPatterns) + = algebraicPatterns + getAlgebraicPatterns (OverloadedListPatterns _ _ algebraicPatterns) + = algebraicPatterns + + match_and_instantiate [linearity:linearities] cons_index app_args + [{ap_symbol={glob_module,glob_object={ds_index}}, ap_vars, ap_expr} : guards] + case_default ro ti + | cons_index.glob_module == glob_module && cons_index.glob_object == ds_index + # zipped = zip2 ap_vars app_args + {cons_type} = ro.ro_common_defs.[glob_module].com_cons_defs.[ds_index] + unfoldables = [ ((not (arg_is_strict i cons_type.st_args_strictness)) && linear) || in_normal_form app_arg \\ linear <- linearity & app_arg <- app_args & i <- [0..]] + unfoldable_args = filterWith unfoldables zipped + not_unfoldable = map not unfoldables + non_unfoldable_args = filterWith not_unfoldable zipped + ti_var_heap = foldSt (\({fv_info_ptr}, arg) -> writeVarInfo fv_info_ptr (VI_Expression arg)) unfoldable_args ti.ti_var_heap + (new_expr, ti_symbol_heap) = possibly_add_let non_unfoldable_args ap_expr not_unfoldable glob_module ds_index ro ti.ti_symbol_heap + unfold_state = { us_var_heap = ti_var_heap, us_symbol_heap = ti_symbol_heap, us_opt_type_heaps = No,us_cleanup_info=ti.ti_cleanup_info, + us_local_macro_functions = No } + ui= {ui_handle_aci_free_vars = LeaveThem, ui_convert_module_n= -1,ui_conversion_table=No } + (unfolded_expr, unfold_state) = unfold new_expr ui unfold_state + (final_expr, ti) = transform unfolded_expr + { ro & ro_root_case_mode = NotRootCase } + { ti & ti_var_heap = unfold_state.us_var_heap, ti_symbol_heap = unfold_state.us_symbol_heap,ti_cleanup_info=unfold_state.us_cleanup_info } + = (Yes final_expr, ti) + = match_and_instantiate linearities cons_index app_args guards case_default ro ti + where + in_normal_form (Var _) = True + in_normal_form (BasicExpr _) = True + in_normal_form _ = False + + filterWith [True:t2] [h1:t1] + = [h1:filterWith t2 t1] + filterWith [False:t2] [h1:t1] + = filterWith t2 t1 + filterWith _ _ + = [] + + possibly_add_let [] ap_expr _ _ _ _ ti_symbol_heap + = (ap_expr, ti_symbol_heap) + possibly_add_let non_unfoldable_args ap_expr not_unfoldable glob_module glob_index ro ti_symbol_heap + # {cons_type} = ro.ro_common_defs.[glob_module].com_cons_defs.[glob_index] + let_type = filterWith not_unfoldable cons_type.st_args + (new_info_ptr, ti_symbol_heap) = newPtr (EI_LetType let_type) ti_symbol_heap /* DvA... STRICT_LET - = ( Let { let_strict_binds = [ {lb_src=lb_src, lb_dst=lb_dst, lb_position = NoPos} - \\ (lb_dst,lb_src)<-non_unfoldable_args - & type <- let_type | type.at_annotation == AN_Strict - ] - , let_lazy_binds = [ {lb_src=lb_src, lb_dst=lb_dst, lb_position = NoPos} - \\ (lb_dst,lb_src)<-non_unfoldable_args - & type <- let_type | type.at_annotation == AN_None - ] + = ( Let { let_strict_binds = [ {lb_src=lb_src, lb_dst=lb_dst, lb_position = NoPos} + \\ (lb_dst,lb_src)<-non_unfoldable_args + & type <- let_type | type.at_annotation == AN_Strict + ] + , let_lazy_binds = [ {lb_src=lb_src, lb_dst=lb_dst, lb_position = NoPos} + \\ (lb_dst,lb_src)<-non_unfoldable_args + & type <- let_type | type.at_annotation == AN_None + ] ...DvA */ - = ( Let { let_strict_binds = [] - , let_lazy_binds = [ {lb_src=lb_src, lb_dst=lb_dst, lb_position = NoPos} - \\ (lb_dst,lb_src)<-non_unfoldable_args] - , let_expr = ap_expr - , let_info_ptr = new_info_ptr - , let_expr_position = NoPos - } - , ti_symbol_heap - ) - - match_and_instantiate [linearity:linearities] cons_index app_args [guard : guards] case_default ro ti - = match_and_instantiate linearities cons_index app_args guards case_default ro ti - match_and_instantiate _ cons_index app_args [] default_expr ro ti - = transform default_expr { ro & ro_root_case_mode = NotRootCase } ti + = ( Let { let_strict_binds = [] + , let_lazy_binds = [ {lb_src=lb_src, lb_dst=lb_dst, lb_position = NoPos} + \\ (lb_dst,lb_src)<-non_unfoldable_args] + , let_expr = ap_expr + , let_info_ptr = new_info_ptr + , let_expr_position = NoPos + } + , ti_symbol_heap + ) + + match_and_instantiate [linearity:linearities] cons_index app_args [guard : guards] case_default ro ti + = match_and_instantiate linearities cons_index app_args guards case_default ro ti + match_and_instantiate _ cons_index app_args [] default_expr ro ti + = transform default_expr { ro & ro_root_case_mode = NotRootCase } ti + +transCase is_active opt_aci this_case=:{case_expr = (BasicExpr basic_value),case_guards,case_default} ro ti + | not is_active + = skip_over this_case ro ti // XXX currently only active cases are matched at runtime (multimatch problem) + # basicPatterns = getBasicPatterns case_guards + may_be_match_pattern = dropWhile (\{bp_value} -> bp_value<>basic_value) basicPatterns + | isEmpty may_be_match_pattern + = case case_default of + Yes default_expr-> transform default_expr { ro & ro_root_case_mode = NotRootCase } ti + No -> (Case neverMatchingCase, ti) + = transform (hd may_be_match_pattern).bp_expr { ro & ro_root_case_mode = NotRootCase } ti +where + getBasicPatterns (BasicPatterns _ basicPatterns) + = basicPatterns +transCase is_active opt_aci this_case=:{case_expr = (Let lad)} ro ti + | not is_active + = skip_over this_case ro ti + # ro_not_root = { ro & ro_root_case_mode = NotRootCase } + (new_let_strict_binds, ti) = transform lad.let_strict_binds ro_not_root ti + (new_let_lazy_binds, ti) = transform lad.let_lazy_binds ro_not_root ti + (new_let_expr, ti) = transform (Case { this_case & case_expr = lad.let_expr }) ro ti + = (Let { lad & let_expr = new_let_expr, let_strict_binds = new_let_strict_binds, let_lazy_binds = new_let_lazy_binds }, ti) + +transCase is_active opt_aci this_case ro ti + = skip_over this_case ro ti + possibly_generate_case_function :: !Case !ActiveCaseInfo !ReadOnlyTI !*TransformInfo -> *(!Expression, !*TransformInfo) possibly_generate_case_function kees=:{case_info_ptr} aci=:{aci_free_vars} ro ti=:{ti_recursion_introduced=old_ti_recursion_introduced} // | False -!-> ("possibly_generate_case_function",ro.ro_fun_root.symb_name.id_name,ro.ro_fun_case.symb_name.id_name,ro.ro_root_case_mode) @@ -773,6 +790,7 @@ removeNeverMatchingSubcases keesExpr=:(Case kees) | is_default_only filtered_default filtered_case_guards -> fromYes case_default -> Case {kees & case_guards = OverloadedListPatterns i decons_expr filtered_case_guards, case_default = filtered_default } + _ -> abort "removeNeverMatchingSubcases does not match" where get_filtered_default y=:(Yes c_default) | is_never_matching_case c_default @@ -832,6 +850,10 @@ where # (patterns, ti) = transform patterns ro ti # (decons_expr, ti) = transform decons_expr ro ti = (OverloadedListPatterns type decons_expr patterns, ti) + transform NoPattern ro ti + = (NoPattern, ti) + transform _ ro ti + = abort "transform CasePatterns does not match" instance transform (Optional a) | transform a where @@ -1227,15 +1249,20 @@ generateFunction fd=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_info = {fi _ -> (i+1, writePtr tv_info_ptr (TVI_Type subst.[i]) th_vars)) all_type_vars (0, ti_type_heaps.th_vars) - us - = { us_var_heap = ti_var_heap, us_symbol_heap = ti_symbol_heap, - us_opt_type_heaps = Yes { ti_type_heaps & th_vars = th_vars }, - us_cleanup_info=ti_cleanup_info,us_local_macro_functions=No } - ui - = {ui_handle_aci_free_vars = RemoveThem, ui_convert_module_n= -1,ui_conversion_table=No } - (tb_rhs, {us_var_heap,us_symbol_heap,us_opt_type_heaps=Yes ti_type_heaps, us_cleanup_info}) + us = { us_var_heap = ti_var_heap + , us_symbol_heap = ti_symbol_heap + , us_opt_type_heaps = Yes { ti_type_heaps & th_vars = th_vars } + , us_cleanup_info = ti_cleanup_info + , us_local_macro_functions = No + } + ui = { ui_handle_aci_free_vars = RemoveThem + , ui_convert_module_n = -1 + , ui_conversion_table = No + } +// | False ---> ("before unfold:", tb_rhs) = undef + # (tb_rhs, {us_var_heap,us_symbol_heap,us_opt_type_heaps=Yes ti_type_heaps, us_cleanup_info}) = unfold tb_rhs ui us -// | False -!-> ("unfolded:", tb_rhs) = undef +// | False ---> ("unfolded:", tb_rhs) = undef # ro_fun= { symb_name = fd.fun_symb, symb_kind = SK_GeneratedFunction fun_def_ptr ti_next_fun_nr } # ro = { ro & ro_root_case_mode = case tb_rhs of Case _ @@ -1361,34 +1388,6 @@ where = get_producer_type symbol ro ti_fun_defs ti_fun_heap -> ([Yes symbol_type:type_accu], ti_fun_defs, ti_fun_heap) -// get_producer_type retrieves the type of symbol - get_producer_type {symb_kind=SK_Function {glob_module, glob_object}} ro fun_defs fun_heap - | glob_module == ro.ro_main_dcl_module_n -// Sjaak ... - # ({fun_type=Yes symbol_type, fun_info={fi_properties}}, fun_defs) = fun_defs![glob_object] - | fi_properties bitand FI_HasTypeSpec <> 0 - # (_, symbol_type) = removeAnnotations symbol_type - = (symbol_type, fun_defs, fun_heap) - = (symbol_type, fun_defs, fun_heap) - # {ft_type} = ro.ro_imported_funs.[glob_module].[glob_object] - (_, ft_type=:{st_args,st_args_strictness}) = removeAnnotations ft_type - new_st_args = addTypesOfDictionaries ro.ro_common_defs ft_type.st_context st_args - new_st_arity = length new_st_args - new_st_args_strictness = insert_n_strictness_values_at_beginning (new_st_arity-length st_args) st_args_strictness - = ({ft_type & st_args = new_st_args, st_args_strictness = new_st_args_strictness, st_arity = new_st_arity, st_context = [] }, fun_defs, fun_heap) -// ... Sjaak - get_producer_type {symb_kind=SK_LocalMacroFunction glob_object} ro fun_defs fun_heap - # ({fun_type=Yes symbol_type}, fun_defs) = fun_defs![glob_object] - = (symbol_type, fun_defs, fun_heap) - get_producer_type {symb_kind=SK_GeneratedFunction fun_ptr _} ro fun_defs fun_heap - # (FI_Function {gf_fun_def={fun_type=Yes symbol_type}}, fun_heap) = readPtr fun_ptr fun_heap - = (symbol_type, fun_defs, fun_heap) - get_producer_type {symb_kind=SK_Constructor {glob_module, glob_object}} ro fun_defs fun_heap - # cons_defs = ro.ro_common_defs.[glob_module].com_cons_defs - # {cons_type} = cons_defs.[glob_object] - # (_,cons_type) = removeAnnotations cons_type // necessary??? - = (cons_type, fun_defs, fun_heap) - collectPropagatingConsVars type th_vars # th_vars = performOnTypeVars initializeToTVI_Empty type th_vars @@ -1422,7 +1421,7 @@ where -> (subst, coercions, ti_type_def_infos, ti_type_heaps) // expand_type converts 'pointer' type representation to 'integer' type representation -// inverse of class replaceIntegers +// inverse of class replaceIntegers? expand_type ro_common_defs cons_vars atype (coercions, subst, ti_type_heaps, ti_type_def_infos) | is_dictionary atype ti_type_def_infos # (_, atype, subst) = arraySubst atype subst @@ -1441,6 +1440,33 @@ where = cs = (btype, (coercions, subst, ti_type_heaps, ti_type_def_infos)) +// get_producer_type retrieves the type of symbol +get_producer_type :: !SymbIdent !.ReadOnlyTI !*{#FunDef} !*FunctionHeap -> (!SymbolType,!*{#FunDef},!*FunctionHeap) +get_producer_type {symb_kind=SK_Function {glob_module, glob_object}} ro fun_defs fun_heap + | glob_module == ro.ro_main_dcl_module_n + # ({fun_type=Yes symbol_type, fun_info={fi_properties}}, fun_defs) = fun_defs![glob_object] + | fi_properties bitand FI_HasTypeSpec <> 0 + # (_, symbol_type) = removeAnnotations symbol_type + = (symbol_type, fun_defs, fun_heap) + = (symbol_type, fun_defs, fun_heap) + # {ft_type} = ro.ro_imported_funs.[glob_module].[glob_object] + (_, ft_type=:{st_args,st_args_strictness}) = removeAnnotations ft_type + new_st_args = addTypesOfDictionaries ro.ro_common_defs ft_type.st_context st_args + new_st_arity = length new_st_args + new_st_args_strictness = insert_n_strictness_values_at_beginning (new_st_arity-length st_args) st_args_strictness + = ({ft_type & st_args = new_st_args, st_args_strictness = new_st_args_strictness, st_arity = new_st_arity, st_context = [] }, fun_defs, fun_heap) +get_producer_type {symb_kind=SK_LocalMacroFunction glob_object} ro fun_defs fun_heap + # ({fun_type=Yes symbol_type}, fun_defs) = fun_defs![glob_object] + = (symbol_type, fun_defs, fun_heap) +get_producer_type {symb_kind=SK_GeneratedFunction fun_ptr _} ro fun_defs fun_heap + # (FI_Function {gf_fun_def={fun_type=Yes symbol_type}}, fun_heap) = readPtr fun_ptr fun_heap + = (symbol_type, fun_defs, fun_heap) +get_producer_type {symb_kind=SK_Constructor {glob_module, glob_object}} ro fun_defs fun_heap + # cons_defs = ro.ro_common_defs.[glob_module].com_cons_defs + # {cons_type} = cons_defs.[glob_object] + # (_,cons_type) = removeAnnotations cons_type // necessary??? + = (cons_type, fun_defs, fun_heap) + //@ determine_args :: *DetermineArgsState = { das_vars :: ![FreeVar] @@ -2282,7 +2308,7 @@ transformGroups cleanup_info main_dcl_module_n stdStrictLists_module_n groups fu symbol_heap = foldSt cleanup_attributes ti_cleanup_info ti_symbol_heap fun_defs = { fundef \\ fundef <- [ fundef \\ fundef <-: fun_defs ] ++ new_fun_defs } = (groups, fun_defs, imported_types, collected_imports, var_heap, type_heaps, symbol_heap, ti_cons_args) - where +where transform_groups group_nr groups common_defs imported_funs imported_types collected_imports fun_indices_with_abs_syn_types ti | group_nr < size groups # (group, groups) = groups![group_nr] @@ -2386,10 +2412,17 @@ transformGroups cleanup_info main_dcl_module_n stdStrictLists_module_n groups fu add_new_function_to_group common_defs fun_heap fun_ptr (groups, fun_defs, imported_types, collected_imports, type_heaps, var_heap) # (FI_Function {gf_fun_def,gf_fun_index}) = sreadPtr fun_ptr fun_heap {fun_type = Yes ft=:{st_args,st_result}, fun_info = {fi_group_index,fi_properties}} = gf_fun_def + ets = + { ets_type_defs = imported_types + , ets_collected_conses = collected_imports + , ets_type_heaps = type_heaps + , ets_var_heap = var_heap + , ets_main_dcl_module_n = main_dcl_module_n + , ets_contains_unexpanded_abs_syn_type = False + } (_,(st_result,st_args), {ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap}) - = expandSynTypes (if (fi_properties bitand FI_HasTypeSpec == 0) (RemoveAnnotationsMask bitor ExpandAbstractSynTypesMask) ExpandAbstractSynTypesMask) common_defs (st_result,st_args) - { ets_type_defs = imported_types, ets_collected_conses = collected_imports, ets_type_heaps = type_heaps, ets_var_heap = var_heap, - ets_main_dcl_module_n=main_dcl_module_n, ets_contains_unexpanded_abs_syn_type=False} + = expandSynTypes (if (fi_properties bitand FI_HasTypeSpec == 0) (RemoveAnnotationsMask bitor ExpandAbstractSynTypesMask) ExpandAbstractSynTypesMask) common_defs (st_result,st_args) ets + # ft = { ft & st_result = st_result, st_args = st_args } # (group, groups) = groups![fi_group_index] = ({ groups & [fi_group_index] = { group & group_members = [gf_fun_index : group.group_members]} }, @@ -2456,15 +2489,6 @@ convertSymbolType_ rem_annots common_defs st main_dcl_module_n imported_types c = ets = (st, ets_contains_unexpanded_abs_syn_type, ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap) -:: ExpandTypeState = - { ets_type_defs :: !.{#{#CheckedTypeDef}} - , ets_collected_conses :: !ImportedConstructors - , ets_type_heaps :: !.TypeHeaps - , ets_var_heap :: !.VarHeap - , ets_main_dcl_module_n :: !Int - , ets_contains_unexpanded_abs_syn_type :: !Bool - } - //@ addTypesOfDictionaries addTypesOfDictionaries :: !{#CommonDefs} ![TypeContext] ![AType] -> [AType] @@ -2502,12 +2526,21 @@ where tc_types class_cons_vars))} -class expandSynTypes a :: !Int !{# CommonDefs} !a !*ExpandTypeState -> (!Bool,!a, !*ExpandTypeState) - lowest_bit int :== int bitand 1 <> 0 //@ expandSynTypes +:: ExpandTypeState = + { ets_type_defs :: !.{#{#CheckedTypeDef}} + , ets_collected_conses :: !ImportedConstructors + , ets_type_heaps :: !.TypeHeaps + , ets_var_heap :: !.VarHeap + , ets_main_dcl_module_n :: !Int + , ets_contains_unexpanded_abs_syn_type :: !Bool + } + +class expandSynTypes a :: !Int !{# CommonDefs} !a !*ExpandTypeState -> (!Bool,!a, !*ExpandTypeState) + instance expandSynTypes Type where expandSynTypes rem_annots common_defs type=:(arg_type --> res_type) ets |