From fe27480261d5a28f20e6ad5445f2f7c2c456c864 Mon Sep 17 00:00:00 2001 From: diederik Date: Tue, 30 Jul 2002 12:26:05 +0000 Subject: specialize when special available git-svn-id: https://svn.cs.ru.nl/repos/clean-compiler/trunk@1180 1f8540f1-abd5-4d5b-9d24-4c5ce8603e2d --- frontend/trans.icl | 126 +++++++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 112 insertions(+), 14 deletions(-) (limited to 'frontend') diff --git a/frontend/trans.icl b/frontend/trans.icl index 9ebf24b..8ead900 100644 --- a/frontend/trans.icl +++ b/frontend/trans.icl @@ -14,6 +14,7 @@ SwitchFunctionFusion fuse dont_fuse :== fuse SwitchConstructorFusion fuse dont_fuse :== dont_fuse // fuse SwitchCurriedFusion fuse dont_fuse :== fuse SwitchUnusedFusion fuse dont_fuse :== fuse +SwitchSpecialFusion fuse dont_fuse :== fuse (-!->) infix (-!->) a b :== a // ---> b @@ -1980,10 +1981,11 @@ transformApplication :: !App ![Expression] !ReadOnlyTI !*TransformInfo -> *(!Exp transformApplication app=:{app_symb=symb=:{symb_kind}, app_args} extra_args ro ti=:{ti_cons_args,ti_instances,ti_fun_defs} | is_SK_Function_or_SK_LocalMacroFunction symb_kind // otherwise GOTO next alternative - # { glob_module, glob_object } + # gi = case symb_kind of SK_Function global_index -> global_index SK_LocalMacroFunction index -> { glob_module = ro.ro_main_dcl_module_n, glob_object = index } + # { glob_module, glob_object } = gi | glob_module == ro.ro_main_dcl_module_n | glob_object < size ti_cons_args #! cons_class = ti_cons_args.[glob_object] @@ -2015,16 +2017,54 @@ transformApplication app=:{app_symb=symb=:{symb_kind}, app_args} extra_args _ -> (expr @ args,ti) // This function is imported - | isEmpty extra_args - = (App app, ti) - # {ft_arity,ft_type} = ro.ro_imported_funs.[glob_module].[glob_object] - form_arity = ft_arity + length ft_type.st_context - ar_diff = form_arity - length app_args - nr_of_extra_args = length extra_args - | nr_of_extra_args <= ar_diff - = (App {app & app_args = app_args ++ extra_args }, ti) - = (App {app & app_args = app_args ++ take ar_diff extra_args } @ drop ar_diff extra_args, ti) + | SwitchSpecialFusion + (not (isEmpty app_args) ) + False + // Check imported overloaded function application for specials... + # {ft_specials} = ro.ro_imported_funs.[glob_module].[glob_object] + # specials = case ft_specials of + (SP_ContextTypes s) -> s + _ -> [] + | not (isEmpty specials) + # (ei,ti_symbol_heap) = mapSt readAppInfo app_args ti.ti_symbol_heap + with + readAppInfo (App {app_info_ptr}) heap + | isNilPtr app_info_ptr + = (EI_Empty,heap) + = readPtr app_info_ptr heap + readAppInfo _ heap = (EI_Empty,heap) + # ti = {ti & ti_symbol_heap = ti_symbol_heap} + # context = ro.ro_imported_funs.[glob_module].[glob_object].ft_type.st_context + # insts = resolveContext context ei + # (num_special_args,special_gi) = findInstInSpecials insts specials + | foundSpecial special_gi + = build_application {app & app_symb.symb_kind = SK_Function gi} (drop num_special_args app_args) extra_args special_gi ti + = build_application app app_args extra_args gi ti + = build_application app app_args extra_args gi ti + = build_application app app_args extra_args gi ti where + build_application app app_args extra_args {glob_module,glob_object} ti + | isEmpty extra_args + = (App {app & app_args = app_args}, ti) + # {ft_arity,ft_type} = ro.ro_imported_funs.[glob_module].[glob_object] + form_arity = ft_arity + length ft_type.st_context + ar_diff = form_arity - length app_args + nr_of_extra_args = length extra_args + | nr_of_extra_args <= ar_diff + = (App {app & app_args = app_args ++ extra_args }, ti) + = (App {app & app_args = app_args ++ take ar_diff extra_args } @ drop ar_diff extra_args, ti) + + build_special_application app app_args extra_args {glob_module,glob_object} ro ti + | isEmpty extra_args + = (App {app & app_args = app_args}, ti) + # {ft_arity,ft_type} = ro.ro_imported_funs.[glob_module].[glob_object] + form_arity = ft_arity + length ft_type.st_context + ar_diff = form_arity - length app_args + nr_of_extra_args = length extra_args + | nr_of_extra_args <= ar_diff + = (App {app & app_args = app_args ++ extra_args }, ti) + = (App {app & app_args = app_args ++ take ar_diff extra_args } @ drop ar_diff extra_args, ti) + find_member_n i member_string a | i file <<< "SP_ParsedSubstitutions" + (SP_Substitutions _) -> file <<< "SP_Substitutions" + (SP_ContextTypes l) -> file <<< "(SP_ContextTypes: " <<< l <<< ")" + (SP_FunIndex i) -> file <<< "(SP_FunIndex: " <<< i <<< ")" + (SP_TypeOffset _) -> file <<< "SP_TypeOffset" + SP_None -> file <<< "SP_None" + +instance <<< Special +where + (<<<) file {spec_index,spec_types,spec_vars,spec_attrs} + = file <<< "spec_index" <<< spec_index <<< "spec_types" <<< spec_types <<< "spec_vars" <<< spec_vars <<< "spec_attrs" <<< spec_attrs + +instance <<< ExprInfo +where + (<<<) file EI_Empty = file <<< "EI_Empty" + (<<<) file (EI_DictionaryType t) = file <<< "" +// (<<<) file (EI_Instance symb exprs) = file <<< symb <<< exprs +// (<<<) file (EI_Selection sels var_ptr exprs) = file <<< sels <<< var_ptr <<< exprs +// (<<<) file (EI_Context exprs) = file <<< exprs + (<<<) file _ = file <<< "EI_Other" + +instance <<< TypeContext +where + (<<<) file co = file <<< co.tc_class <<< " " <<< co.tc_types <<< " <" <<< co.tc_var <<< '>' + +resolveContext :: [TypeContext] [ExprInfo] -> [[Type]] +resolveContext [tc:tcs] [EI_DictionaryType t:eis] + = minimiseContext tc t ++ resolveContext tcs eis +resolveContext _ _ = [] + +minimiseContext {tc_class = TCClass gds} (TA ti ts) + # tc_index = {glob_module = gds.glob_module, glob_object = gds.glob_object.ds_index} + | tc_index == ti.type_index + = [[at_type \\ {at_type} <- ts]] + = [] +minimiseContext _ _ = [] + +findInstInSpecials insts [] + = (0,{glob_object= -1,glob_module = -1}) +findInstInSpecials insts [{spec_types,spec_index}:specials] + | matchTypes insts spec_types + = (length spec_types, spec_index) + = findInstInSpecials insts specials + +matchTypes [] [] = True +matchTypes [l:ls] [r:rs] + = l == r && matchTypes ls rs +matchTypes _ _ = False + +foundSpecial {glob_object= -1,glob_module = -1} = False +foundSpecial _ = True + +// ...SPECIAL -- cgit v1.2.3