diff options
| -rw-r--r-- | frontend/partition.icl | 4 | ||||
| -rw-r--r-- | frontend/syntax.dcl | 5 | ||||
| -rw-r--r-- | frontend/trans.icl | 185 | ||||
| -rw-r--r-- | frontend/type.icl | 2 |
4 files changed, 102 insertions, 94 deletions
diff --git a/frontend/partition.icl b/frontend/partition.icl index c8ffcad..46a0288 100644 --- a/frontend/partition.icl +++ b/frontend/partition.icl @@ -609,10 +609,6 @@ dummy_predef_symbols = , predef_or = dummy_predef_symbol } -///// FI_IsNonRecursive - -FI_IsNonRecursive :== 4 - set_rec_prop non_recursive fi_properties = case non_recursive of True -> fi_properties bitor FI_IsNonRecursive diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index 3ab1a5a..62923d4 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -500,10 +500,10 @@ NoGlobalIndex :== {gi_module=NoIndex,gi_index=NoIndex} :: FunCall = FunCall !Index !Level | MacroCall !ModuleIndex !Index Level | DclFunCall !ModuleIndex !DclFunctionIndex; -/* Sjaak 19-3-2001 ... */ - FI_IsMacroFun :== 1 // whether the function is a local function of a macro FI_HasTypeSpec :== 2 // whether the function has u user defined type +FI_IsNonRecursive :== 4 // used in trans.icl and partition.icl +FI_IsUnboxedListOfRecordsConsOrNil :== 8 :: FunInfo = { fi_calls :: ![FunCall] @@ -514,7 +514,6 @@ FI_HasTypeSpec :== 2 // whether the function has u user defined type , fi_dynamics :: ![ExprInfoPtr] , fi_properties :: !BITVECT } -/* ... Sjaak 19-3-2001 */ :: ParsedBody = { pb_args :: ![ParsedExpr] diff --git a/frontend/trans.icl b/frontend/trans.icl index 6f3b23b..b7d6e76 100644 --- a/frontend/trans.icl +++ b/frontend/trans.icl @@ -377,7 +377,7 @@ where = (No, ti) possiblyFoldOuterCase final guard_expr outer_case ro ti - | SwitchAutoFoldCaseInCase (isFoldExpression guard_expr) False // otherwise GOTO next alternative + | SwitchAutoFoldCaseInCase (isFoldExpression guard_expr ti.ti_fun_defs ti.ti_cons_args) False // otherwise GOTO next alternative | False -!-> ("possiblyFoldOuterCase","Case",bef < 0 || act < 0,ro.ro_fun_args,aci.aci_params) = undef | bef < 0 || act < 0 = possiblyFoldOuterCase` final guard_expr outer_case ro ti //abort "possiblyFoldOuterCase: unexpected!\n" @@ -393,21 +393,26 @@ where // = transformApplication { app_symb = folder, app_args = folder_args, app_info_ptr = nilPtr } [] ro ti // where - isFoldExpression (App app) = isFoldSymbol app.app_symb.symb_kind + isFoldExpression (App app) ti_fun_defs ti_cons_args = isFoldSymbol app.app_symb.symb_kind where isFoldSymbol (SK_Function {glob_module,glob_object}) | glob_module==ro.ro_stdStrictLists_module_n # type_arity = ro.ro_imported_funs.[glob_module].[glob_object].ft_type.st_arity | type_arity==0 || (type_arity==2 && case app.app_args of [_:_] -> True; _ -> False) = False - = True + = True + | glob_module==ro.ro_main_dcl_module_n && glob_object>=size ti_cons_args && + (ti_fun_defs.[glob_object].fun_info.fi_properties bitand FI_IsUnboxedListOfRecordsConsOrNil<>0) && + (case ti_fun_defs.[glob_object].fun_type of + Yes type ->(type.st_arity==0 || (type.st_arity==2 && case app.app_args of [_:_] -> True; _ -> False))) + = False = True isFoldSymbol (SK_LocalMacroFunction _) = True isFoldSymbol (SK_GeneratedFunction _ _) = True isFoldSymbol _ = False - isFoldExpression (Var _) = True -// isFoldExpression (Case _) = True - isFoldExpression _ = False + isFoldExpression (Var _) ti_fun_defs ti_cons_args = True +// isFoldExpression (Case _) ti_fun_defs ti_cons_args = True + isFoldExpression _ ti_fun_defs ti_cons_args = False folder = ro.ro_fun_orig folder_args = f_a_before` ++ [guard_expr:f_a_after`] @@ -453,14 +458,13 @@ transCase is_active opt_aci this_case=:{case_expr = case_expr=:(App app=:{app_sy (let type = ro.ro_imported_funs.[glob_module].[glob_object].ft_type in (type.st_arity==0 || (type.st_arity==2 && case app_args of [_:_] -> True; _ -> False))) # type = ro.ro_imported_funs.[glob_module].[glob_object].ft_type - | type.st_arity==0 - # (may_be_match_expr, ti) = match_and_instantiate_overloaded_nil case_guards case_default ro ti - -> expr_or_never_matching_case may_be_match_expr case_ident ti - # aci_linearity_of_patterns = case opt_aci of - Yes aci -> aci.aci_linearity_of_patterns - (may_be_match_expr, ti) = match_and_instantiate_overloaded_cons type aci_linearity_of_patterns app_args case_guards case_default ro ti - -> expr_or_never_matching_case may_be_match_expr case_ident ti - + -> trans_case_of_overloaded_nil_or_cons type ti + | glob_module==ro.ro_main_dcl_module_n && glob_object>=size ti.ti_cons_args && + (ti.ti_fun_defs.[glob_object].fun_info.fi_properties bitand FI_IsUnboxedListOfRecordsConsOrNil)<>0 && is_active && + (case ti.ti_fun_defs.[glob_object].fun_type of + Yes type ->(type.st_arity==0 || (type.st_arity==2 && case app_args of [_:_] -> True; _ -> False))) + # (Yes type,ti) = ti!ti_fun_defs.[glob_object].fun_type + -> trans_case_of_overloaded_nil_or_cons type ti // otherwise it's a function application _ -> case opt_aci of Yes aci=:{ aci_params, aci_opt_unfolder } @@ -578,75 +582,84 @@ where match_and_instantiate_overloaded_list _ cons_index app_args [] case_default ro ti = transform case_default { ro & ro_root_case_mode = NotRootCase } ti - match_and_instantiate_overloaded_nil (OverloadedListPatterns _ _ algebraicPatterns) case_default ro ti - = match_and_instantiate_nil algebraicPatterns case_default ro ti - match_and_instantiate_overloaded_nil (AlgebraicPatterns _ algebraicPatterns) case_default ro ti - = match_and_instantiate_nil algebraicPatterns case_default ro ti - - match_and_instantiate_nil [{ap_symbol={glob_module,glob_object={ds_index}},ap_expr} : guards] case_default ro ti - | glob_module==cPredefinedModuleIndex - # index=ds_index+FirstConstructorPredefinedSymbolIndex - | index==PD_NilSymbol || index==PD_StrictNilSymbol || index==PD_TailStrictNilSymbol || index==PD_StrictTailStrictNilSymbol || - index==PD_OverloadedNilSymbol || index==PD_UnboxedNilSymbol || index==PD_UnboxedTailStrictNilSymbol - = instantiate [] [] [] ap_expr NotStrict [] ti - = match_and_instantiate_nil guards case_default ro ti - match_and_instantiate_nil [] case_default ro ti - = transform case_default { ro & ro_root_case_mode = NotRootCase } ti - - match_and_instantiate_overloaded_cons cons_function_type linearities app_args (AlgebraicPatterns _ algebraicPatterns) case_default ro ti - = match_and_instantiate_overloaded_cons_boxed_match linearities app_args algebraicPatterns case_default ro ti - where - match_and_instantiate_overloaded_cons_boxed_match [linearity:linearities] app_args - [{ap_symbol={glob_module,glob_object={ds_index}}, ap_vars, ap_expr} : guards] - case_default ro ti - | glob_module==cPredefinedModuleIndex - # index=ds_index+FirstConstructorPredefinedSymbolIndex - | index==PD_ConsSymbol || index==PD_StrictConsSymbol || index==PD_TailStrictConsSymbol || index==PD_StrictTailStrictConsSymbol - # {cons_type} = ro.ro_common_defs.[glob_module].com_cons_defs.[ds_index] - = instantiate linearity app_args ap_vars ap_expr cons_type.st_args_strictness cons_type.st_args ti - // | index==PD_NilSymbol || index==PD_StrictNilSymbol || index==PD_TailStrictNilSymbol || index==PD_StrictTailStrictNilSymbol - = match_and_instantiate_overloaded_cons_boxed_match linearities app_args guards case_default ro ti - // = abort "match_and_instantiate_overloaded_cons_boxed_match" - match_and_instantiate_overloaded_cons_boxed_match _ app_args [] case_default ro ti - = transform case_default { ro & ro_root_case_mode = NotRootCase } ti - match_and_instantiate_overloaded_cons cons_function_type linearities app_args (OverloadedListPatterns _ _ algebraicPatterns) case_default ro ti - = match_and_instantiate_overloaded_cons_overloaded_match linearities app_args algebraicPatterns case_default ro ti - where - match_and_instantiate_overloaded_cons_overloaded_match [linearity:linearities] app_args - [{ap_symbol={glob_module,glob_object={ds_index}}, ap_vars, ap_expr} : guards] - case_default ro ti - | glob_module==cPredefinedModuleIndex - # index=ds_index+FirstConstructorPredefinedSymbolIndex - | index==PD_UnboxedConsSymbol || index==PD_UnboxedTailStrictConsSymbol || index==PD_OverloadedConsSymbol - = instantiate linearity app_args ap_vars ap_expr cons_function_type.st_args_strictness cons_function_type.st_args ti - // | index==PD_UnboxedNilSymbol || index==PD_UnboxedTailStrictNilSymbol || index==PD_OverloadedNilSymbol - = match_and_instantiate_overloaded_cons_overloaded_match linearities app_args guards case_default ro ti - // = abort "match_and_instantiate_overloaded_cons_overloaded_match" - match_and_instantiate_overloaded_cons_overloaded_match _ app_args [] case_default ro ti - = transform case_default { ro & ro_root_case_mode = NotRootCase } ti - - /* - match_and_instantiate_overloaded_cons linearities app_args (OverloadedListPatterns _ (App {app_args=[],app_symb={symb_kind=SK_Function {glob_module=decons_module,glob_object=deconsindex}}}) algebraicPatterns) case_default ro ti - = match_and_instantiate_overloaded_cons_overloaded_match linearities app_args algebraicPatterns case_default ro ti - where - match_and_instantiate_overloaded_cons_overloaded_match [linearity:linearities] app_args - [{ap_symbol={glob_module,glob_object={ds_index}}, ap_vars, ap_expr} : guards] - case_default ro ti - | glob_module==cPredefinedModuleIndex - # index=ds_index+FirstConstructorPredefinedSymbolIndex - | index==PD_UnboxedConsSymbol || index==PD_UnboxedTailStrictConsSymbol || index==PD_OverloadedConsSymbol - # (argument_types,strictness) = case ro.ro_imported_funs.[decons_module].[deconsindex].ft_type.st_result.at_type of - TA _ args=:[arg1,arg2] -> (args,NotStrict) - TAS _ args=:[arg1,arg2] strictness -> (args,strictness) - = instantiate linearity app_args ap_vars ap_expr strictness argument_types ti - | index==PD_UnboxedNilSymbol || index==PD_UnboxedTailStrictNilSymbol || index==PD_OverloadedNilSymbol - = match_and_instantiate_overloaded_cons_overloaded_match linearities app_args guards case_default ro ti - = abort "match_and_instantiate_overloaded_cons_overloaded_match" - match_and_instantiate_overloaded_cons_overloaded_match [linearity:linearities] app_args [guard : guards] case_default ro ti - = match_and_instantiate_overloaded_cons_overloaded_match linearities app_args guards case_default ro ti - match_and_instantiate_overloaded_cons_overloaded_match _ app_args [] case_default ro ti - = transform case_default { ro & ro_root_case_mode = NotRootCase } ti - */ + trans_case_of_overloaded_nil_or_cons type ti + | type.st_arity==0 + # (may_be_match_expr, ti) = match_and_instantiate_overloaded_nil case_guards case_default ro ti + = expr_or_never_matching_case may_be_match_expr case_ident ti + # aci_linearity_of_patterns = case opt_aci of + Yes aci -> aci.aci_linearity_of_patterns + (may_be_match_expr, ti) = match_and_instantiate_overloaded_cons type aci_linearity_of_patterns app_args case_guards case_default ro ti + = expr_or_never_matching_case may_be_match_expr case_ident ti + where + match_and_instantiate_overloaded_nil (OverloadedListPatterns _ _ algebraicPatterns) case_default ro ti + = match_and_instantiate_nil algebraicPatterns case_default ro ti + match_and_instantiate_overloaded_nil (AlgebraicPatterns _ algebraicPatterns) case_default ro ti + = match_and_instantiate_nil algebraicPatterns case_default ro ti + + match_and_instantiate_nil [{ap_symbol={glob_module,glob_object={ds_index}},ap_expr} : guards] case_default ro ti + | glob_module==cPredefinedModuleIndex + # index=ds_index+FirstConstructorPredefinedSymbolIndex + | index==PD_NilSymbol || index==PD_StrictNilSymbol || index==PD_TailStrictNilSymbol || index==PD_StrictTailStrictNilSymbol || + index==PD_OverloadedNilSymbol || index==PD_UnboxedNilSymbol || index==PD_UnboxedTailStrictNilSymbol + = instantiate [] [] [] ap_expr NotStrict [] ti + = match_and_instantiate_nil guards case_default ro ti + match_and_instantiate_nil [] case_default ro ti + = transform case_default { ro & ro_root_case_mode = NotRootCase } ti + + match_and_instantiate_overloaded_cons cons_function_type linearities app_args (AlgebraicPatterns _ algebraicPatterns) case_default ro ti + = match_and_instantiate_overloaded_cons_boxed_match linearities app_args algebraicPatterns case_default ro ti + where + match_and_instantiate_overloaded_cons_boxed_match [linearity:linearities] app_args + [{ap_symbol={glob_module,glob_object={ds_index}}, ap_vars, ap_expr} : guards] + case_default ro ti + | glob_module==cPredefinedModuleIndex + # index=ds_index+FirstConstructorPredefinedSymbolIndex + | index==PD_ConsSymbol || index==PD_StrictConsSymbol || index==PD_TailStrictConsSymbol || index==PD_StrictTailStrictConsSymbol + # {cons_type} = ro.ro_common_defs.[glob_module].com_cons_defs.[ds_index] + = instantiate linearity app_args ap_vars ap_expr cons_type.st_args_strictness cons_type.st_args ti + // | index==PD_NilSymbol || index==PD_StrictNilSymbol || index==PD_TailStrictNilSymbol || index==PD_StrictTailStrictNilSymbol + = match_and_instantiate_overloaded_cons_boxed_match linearities app_args guards case_default ro ti + // = abort "match_and_instantiate_overloaded_cons_boxed_match" + match_and_instantiate_overloaded_cons_boxed_match _ app_args [] case_default ro ti + = transform case_default { ro & ro_root_case_mode = NotRootCase } ti + match_and_instantiate_overloaded_cons cons_function_type linearities app_args (OverloadedListPatterns _ _ algebraicPatterns) case_default ro ti + = match_and_instantiate_overloaded_cons_overloaded_match linearities app_args algebraicPatterns case_default ro ti + where + match_and_instantiate_overloaded_cons_overloaded_match [linearity:linearities] app_args + [{ap_symbol={glob_module,glob_object={ds_index}}, ap_vars, ap_expr} : guards] + case_default ro ti + | glob_module==cPredefinedModuleIndex + # index=ds_index+FirstConstructorPredefinedSymbolIndex + | index==PD_UnboxedConsSymbol || index==PD_UnboxedTailStrictConsSymbol || index==PD_OverloadedConsSymbol + = instantiate linearity app_args ap_vars ap_expr cons_function_type.st_args_strictness cons_function_type.st_args ti + // | index==PD_UnboxedNilSymbol || index==PD_UnboxedTailStrictNilSymbol || index==PD_OverloadedNilSymbol + = match_and_instantiate_overloaded_cons_overloaded_match linearities app_args guards case_default ro ti + // = abort "match_and_instantiate_overloaded_cons_overloaded_match" + match_and_instantiate_overloaded_cons_overloaded_match _ app_args [] case_default ro ti + = transform case_default { ro & ro_root_case_mode = NotRootCase } ti + + /* + match_and_instantiate_overloaded_cons linearities app_args (OverloadedListPatterns _ (App {app_args=[],app_symb={symb_kind=SK_Function {glob_module=decons_module,glob_object=deconsindex}}}) algebraicPatterns) case_default ro ti + = match_and_instantiate_overloaded_cons_overloaded_match linearities app_args algebraicPatterns case_default ro ti + where + match_and_instantiate_overloaded_cons_overloaded_match [linearity:linearities] app_args + [{ap_symbol={glob_module,glob_object={ds_index}}, ap_vars, ap_expr} : guards] + case_default ro ti + | glob_module==cPredefinedModuleIndex + # index=ds_index+FirstConstructorPredefinedSymbolIndex + | index==PD_UnboxedConsSymbol || index==PD_UnboxedTailStrictConsSymbol || index==PD_OverloadedConsSymbol + # (argument_types,strictness) = case ro.ro_imported_funs.[decons_module].[deconsindex].ft_type.st_result.at_type of + TA _ args=:[arg1,arg2] -> (args,NotStrict) + TAS _ args=:[arg1,arg2] strictness -> (args,strictness) + = instantiate linearity app_args ap_vars ap_expr strictness argument_types ti + | index==PD_UnboxedNilSymbol || index==PD_UnboxedTailStrictNilSymbol || index==PD_OverloadedNilSymbol + = match_and_instantiate_overloaded_cons_overloaded_match linearities app_args guards case_default ro ti + = abort "match_and_instantiate_overloaded_cons_overloaded_match" + match_and_instantiate_overloaded_cons_overloaded_match [linearity:linearities] app_args [guard : guards] case_default ro ti + = match_and_instantiate_overloaded_cons_overloaded_match linearities app_args guards case_default ro ti + match_and_instantiate_overloaded_cons_overloaded_match _ app_args [] case_default ro ti + = transform case_default { ro & ro_root_case_mode = NotRootCase } ti + */ instantiate linearity app_args ap_vars ap_expr cons_type_args_strictness cons_type_args ti # zipped = zip2 ap_vars app_args @@ -2327,7 +2340,7 @@ transformFunctionApplication fun_def instances cc=:{cc_size, cc_args, cc_linear_ # is_applied_to_macro_fun = fun_def.fun_info.fi_properties bitand FI_IsMacroFun <> 0 # consumer_is_curried = cc_size <> length app_args # non_rec_consumer - = (fun_def.fun_info.fi_properties bitand FI_IsNonRecursive) <> 0 with FI_IsNonRecursive = 4 + = (fun_def.fun_info.fi_properties bitand FI_IsNonRecursive) <> 0 # safe_args = isEmpty [arg \\ arg <- app_args & cc_arg <- cc_args | unsafe cc_arg && non_var arg] with @@ -3024,7 +3037,7 @@ determineProducer is_applied_to_macro_fun consumer_is_curried ok_non_rec_consume -!-> ("Produce1cc_hnr",symb.symb_name) // NON-REC... # non_rec_producer - = (fun_info.fi_properties bitand FI_IsNonRecursive) <> 0 with FI_IsNonRecursive = 4 + = (fun_info.fi_properties bitand FI_IsNonRecursive) <> 0 # ok_non_rec = case fun_body of Expanding _ @@ -3078,7 +3091,7 @@ determineProducer is_applied_to_macro_fun consumer_is_curried ok_non_rec_consume -!-> ("Produce2cc_ho",symb.symb_name) // NON-REC... # non_rec_producer - = (fun_info.fi_properties bitand FI_IsNonRecursive) <> 0 with FI_IsNonRecursive = 4 + = (fun_info.fi_properties bitand FI_IsNonRecursive) <> 0 # ok_non_rec = case fun_body of Expanding _ diff --git a/frontend/type.icl b/frontend/type.icl index 4262256..20e5e07 100644 --- a/frontend/type.icl +++ b/frontend/type.icl @@ -2768,7 +2768,7 @@ where , fun_pos = me_pos , fun_kind = FK_Unknown , fun_lifted = 0 - , fun_info = EmptyFunInfo + , fun_info = {EmptyFunInfo & fi_properties=FI_IsUnboxedListOfRecordsConsOrNil} } = ({fun_defs & [fun_index]=fun}, type_heaps, error) |