aboutsummaryrefslogtreecommitdiff
path: root/frontend
diff options
context:
space:
mode:
Diffstat (limited to 'frontend')
-rw-r--r--frontend/trans.icl230
1 files changed, 213 insertions, 17 deletions
diff --git a/frontend/trans.icl b/frontend/trans.icl
index cdf2dcb..c2fa7bb 100644
--- a/frontend/trans.icl
+++ b/frontend/trans.icl
@@ -13,7 +13,9 @@ SwitchGeneratedFusion fuse dont_fuse :== fuse
SwitchFunctionFusion fuse dont_fuse :== fuse
SwitchConstructorFusion fuse dont_fuse :== dont_fuse // fuse
SwitchCurriedFusion fuse dont_fuse :== fuse
+SwitchTrivialFusion fuse dont_fuse :== fuse
SwitchUnusedFusion fuse dont_fuse :== fuse
+SwitchTransformConstants tran dont_tran :== dont_tran // can argue that if you want constant functions to be inlined you should define them as a macro
SwitchSpecialFusion fuse dont_fuse :== fuse
(-!->) infix
@@ -2014,19 +2016,37 @@ bind_to_temp_type_var {tv_info_ptr} (next_type_var_nr, th_vars)
bind_to_temp_attr_var {av_info_ptr} (next_attr_var_nr, th_attrs)
= (next_attr_var_nr+1, writePtr av_info_ptr (AVI_Attr (TA_TempVar next_attr_var_nr)) th_attrs)
-//
+transformFunctionApplication :: FunDef InstanceInfo !ConsClasses !App [Expression] ReadOnlyTI !*TransformInfo -> *(Expression,!*TransformInfo)
transformFunctionApplication fun_def instances cc=:{cc_size, cc_args, cc_linear_bits} app=:{app_symb,app_args} extra_args ro ti
# (app_args, extra_args) = complete_application fun_def.fun_arity app_args extra_args
-// | False -!-> ("transformFunctionApplication",app_symb,app_args) = undef
+// | False -!-> ("transformFunctionApplication",app_symb,app_args,extra_args,fun_def.fun_arity,cc_size) = undef
+ | cc_size == 0 && not_expanding_consumer
+ # (fun_def,ti_fun_defs,ti_fun_heap) = get_fun_def app_symb.symb_kind ro.ro_main_dcl_module_n ti.ti_fun_defs ti.ti_fun_heap
+ # ti = {ti & ti_fun_defs = ti_fun_defs, ti_fun_heap = ti_fun_heap}
+ # {fun_body=fun_body=:TransformedBody {tb_rhs}, fun_kind} = fun_def
+ | SwitchTransformConstants (ro.ro_transform_fusion && is_not_caf fun_kind && is_sexy_body tb_rhs) False
+ # us = { us_var_heap = ti.ti_var_heap
+ , us_symbol_heap = ti.ti_symbol_heap
+ , us_opt_type_heaps = Yes ti.ti_type_heaps
+ , us_cleanup_info = ti.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})
+ = unfold tb_rhs ui us
+ ti = { ti & ti_var_heap = us_var_heap, ti_symbol_heap = us_symbol_heap, ti_type_heaps = ti_type_heaps, ti_cleanup_info = us_cleanup_info}
+ | isEmpty extra_args
+ = (tb_rhs, ti)
+ = (tb_rhs @ extra_args, ti)
+ = (build_application { app & app_args = app_args } extra_args, ti)
| cc_size > 0 && not_expanding_consumer
-// | False-!->("determineProducers",(app_symb.symb_name, cc_linear_bits,cc_args,app_args))
-// = undef
# is_applied_to_macro_fun = fun_def.fun_info.fi_properties bitand FI_IsMacroFun <> 0
# consumer_is_curried = cc_size <> length app_args
# (producers, new_args, ti)
= determineProducers is_applied_to_macro_fun consumer_is_curried fun_def.fun_type cc_linear_bits cc_args app_args 0 (createArray cc_size PR_Empty) ro ti
-// | False-!->("results in",II_Node producers nilPtr II_Empty II_Empty)
-// = undef
| containsProducer cc_size producers
# (is_new, fun_def_ptr, instances, ti_fun_heap) = tryToFindInstance producers instances ti.ti_fun_heap
| is_new
@@ -2035,18 +2055,37 @@ transformFunctionApplication fun_def instances cc=:{cc_size, cc_args, cc_linear_
app_symb = { app_symb & symb_kind = SK_GeneratedFunction fun_def_ptr fun_index }
# (app_args, extra_args) = complete_application fun_arity new_args extra_args
= transformApplication { app & app_symb = app_symb, app_args = app_args } extra_args ro ti
- # (FI_Function {gf_fun_index, gf_fun_def}, ti_fun_heap) = readPtr fun_def_ptr ti_fun_heap
- app_symb = { app_symb & symb_kind = SK_GeneratedFunction fun_def_ptr gf_fun_index }
- (app_args, extra_args) = complete_application gf_fun_def.fun_arity new_args extra_args
- # ti = {ti & ti_fun_heap = ti_fun_heap }
- = transformApplication { app & app_symb = app_symb, app_args = app_args } extra_args ro ti
- = (build_application { app & app_symb = app_symb, app_args = app_args } extra_args, ti)
- = (build_application { app & app_symb = app_symb, app_args = app_args } extra_args, ti)
+ # (FI_Function {gf_fun_index, gf_fun_def}, ti_fun_heap) = readPtr fun_def_ptr ti_fun_heap
+ app_symb` = { app_symb & symb_kind = SK_GeneratedFunction fun_def_ptr gf_fun_index }
+ (app_args, extra_args) = complete_application gf_fun_def.fun_arity new_args extra_args
+ # ti = {ti & ti_fun_heap = ti_fun_heap }
+ = transformApplication { app & app_symb = app_symb`, app_args = app_args } extra_args ro ti
+ | SwitchTrivialFusion ro.ro_transform_fusion False
+ = transform_trivial_function app app_args extra_args ro ti
+ = (build_application { app & app_args = app_args } extra_args, ti)
+ = (build_application { app & app_args = app_args } extra_args, ti)
where
not_expanding_consumer = case fun_def.fun_body of
Expanding _ -> False
_ -> True
+ is_not_caf FK_Caf = False
+ is_not_caf _ = True
+
+ transform_trivial_function app=:{app_symb} app_args extra_args ro ti
+ # (fun_def,ti_fun_defs,ti_fun_heap) = get_fun_def app_symb.symb_kind ro.ro_main_dcl_module_n ti.ti_fun_defs ti.ti_fun_heap
+ # {fun_body=fun_body=:TransformedBody {tb_args,tb_rhs},fun_type} = fun_def
+ # (opt_expr, ti_fun_defs, ti_fun_heap, ti_type_heaps, ti_cons_args)
+ = is_trivial_body tb_args tb_rhs app_args fun_type ro ti_fun_defs ti_fun_heap ti.ti_type_heaps ti.ti_cons_args
+ # ti = { ti & ti_fun_defs = ti_fun_defs, ti_fun_heap = ti_fun_heap, ti_type_heaps = ti_type_heaps, ti_cons_args = ti_cons_args }
+ = case opt_expr of
+ No
+ -> (build_application { app & app_symb = app_symb, app_args = app_args } extra_args, ti)
+ (Yes tb_rhs)
+ | isEmpty extra_args
+ -> (tb_rhs, ti)
+ -> (tb_rhs @ extra_args, ti)
+
update_instance_info (SK_Function {glob_object}) instances ti=:{ti_instances}
= { ti & ti_instances = { ti_instances & [glob_object] = instances } }
update_instance_info (SK_LocalMacroFunction glob_object) instances ti=:{ti_instances}
@@ -2057,11 +2096,10 @@ where
# (FI_Function fun_info, ti_fun_heap) = readPtr fun_def_ptr ti_fun_heap
= { ti & ti_fun_heap = ti_fun_heap <:= (fun_def_ptr, FI_Function { fun_info & gf_instance_info = instances })}
- complete_application form_arity args []
- = (args, [])
complete_application form_arity args extra_args
- # arity_diff = min (form_arity - length args) (length extra_args)
- = (args ++ take arity_diff extra_args, drop arity_diff extra_args)
+ = (take form_arity all_args,drop form_arity all_args)
+ where
+ all_args = args ++ extra_args
build_application app []
= App app
@@ -2072,6 +2110,164 @@ is_cons_or_decons_of_UList_or_UTSList glob_object glob_module imported_funs
:== let type = imported_funs.[glob_module].[glob_object].ft_type;
in type.st_arity>0 && not (isEmpty type.st_context);
+//@ is_trivial_body
+
+:: *MatchState =
+ { tvar_map :: ![(TypeVar,TypeVar)]
+ , ms_type_heaps :: !*TypeHeaps
+ , ms_common_defs :: !{# CommonDefs}
+ }
+
+is_trivial_body :: ![FreeVar] !Expression ![Expression] !(Optional SymbolType) !.ReadOnlyTI !*{#FunDef} !*FunctionHeap !*TypeHeaps !*{!ConsClasses}
+ -> (!Optional Expression,!*{#FunDef},!*FunctionHeap,!*TypeHeaps,!*{!ConsClasses})
+is_trivial_body [fv] (Var bv) [arg] type ro fun_defs fun_heap type_heaps cons_args
+ = if (fv.fv_info_ptr == bv.var_info_ptr)
+ (Yes arg, fun_defs, fun_heap, type_heaps, cons_args)
+ (No, fun_defs, fun_heap, type_heaps , cons_args)
+is_trivial_body args (App app) f_args type ro fun_defs fun_heap type_heaps cons_args
+ # (safe_producer, fun_heap, cons_args) = get_producer_class app.app_symb.symb_kind ro fun_heap cons_args
+ | not safe_producer
+ = (No,fun_defs,fun_heap,type_heaps,cons_args)
+ # (type`,fun_defs,fun_heap) = get_producer_type app.app_symb ro fun_defs fun_heap
+ # match = match_args (length f_args) info args app.app_args []
+ = case match of
+ Yes perm
+ # (match, type_heaps) = match_types type type` perm ro.ro_common_defs type_heaps
+ | match
+ # f_args = permute_args f_args (take (length f_args) perm)
+ -> (Yes (App {app & app_args = f_args}),fun_defs,fun_heap,type_heaps,cons_args)
+ -> (No,fun_defs,fun_heap,type_heaps,cons_args)
+ _ -> (No,fun_defs,fun_heap,type_heaps,cons_args)
+where
+ info :: {!VarInfoPtr}
+ info = {v.fv_info_ptr \\ v <- args}
+
+ match_args 0 _ [] [] accu
+ = Yes (reverse accu)
+ match_args 0 info [fv:fvs] [Var bv:bvs] accu
+ | fv.fv_info_ptr == bv.var_info_ptr
+ # index = lookup bv.var_info_ptr info
+ = match_args 0 info fvs bvs [index:accu]
+ = No
+ match_args n info [fv:fvs] [Var bv:bvs] accu
+ # index = lookup bv.var_info_ptr info
+ = match_args (dec n) info fvs bvs [index:accu]
+ match_args _ _ _ _ _ = No
+
+ lookup x d = lookup 0 x d
+ where
+ lookup i x d
+ | d.[i] == x
+ = i
+ = lookup (inc i) x d
+
+ permute_args args perm = [args!!p \\ p <- perm]
+
+ match_types type type` perm common_defs type_heaps
+ | not_ok_perm perm
+ = (False,type_heaps)
+ = case type of
+ No -> (True,type_heaps)
+ Yes type -> match_types type type` perm common_defs type_heaps
+ where
+ not_ok_perm perm = length perm <> size info
+
+ match_types type type` perm common_defs type_heaps
+ | not (match_strictness` (dec type.st_arity) type.st_args_strictness type`.st_args_strictness perm)
+ = (False,type_heaps)
+ # (ok,args,res) = make_args (type`.st_arity) type.st_args type.st_result
+ | not ok = (False,type_heaps)
+ # args` = permute_args args perm
+ # ms = {tvar_map=[], ms_type_heaps = type_heaps,ms_common_defs=common_defs}
+ # (match_ok,ms) = match_arg_types args type`.st_args ms
+ | not match_ok = (False,ms.ms_type_heaps)
+ # (match_ok,ms) = match_res_type res type`.st_result ms
+ | not match_ok = (False,ms.ms_type_heaps)
+ | type.st_context <> [] || type`.st_context <> []
+ = (False,ms.ms_type_heaps)
+ = (True,ms.ms_type_heaps)
+ where
+ make_args n as r
+ # l = length as
+ | n < l = (False,as,r)
+ | n == l = (True,as,r)
+ = move_args (n-l) as r []
+ move_args 0 as r accu = (True,as++(reverse accu),r)
+ move_args n as {at_type = a-->r} accu = move_args (dec n) as r [a:accu]
+ move_args _ as r accu = (False,as,r)
+
+ match_strictness` i s1 s2 p
+ | i < 0 = True
+ = arg_is_strict (p!!i) s1 == arg_is_strict i s2 && match_strictness (dec i) s1 s2
+
+ match_strictness i s1 s2
+ | i < 0 = True
+ = arg_is_strict i s1 == arg_is_strict i s2 && match_strictness (dec i) s1 s2
+
+ match_arg_types [] [] ms
+ = (True,ms)
+ match_arg_types [arg:args] [arg`:args`] ms
+ # (type_ok,ms) = match_type arg.at_type arg.at_attribute arg`.at_type arg`.at_attribute ms
+ | not type_ok = (False,ms)
+ = match_arg_types args args` ms
+ match_arg_types _ _ ms
+ = (False,ms)
+
+ match_res_type res res` ms
+ = match_type res.at_type res.at_attribute res`.at_type res`.at_attribute ms
+
+ match_type (TA tsid types) _ (TA tsid` types`) _ ms
+ | tsid == tsid`
+ = match_arg_types types types` ms
+ match_type (TAS tsid types strictl) _ (TAS tsid` types` strictl`) _ ms
+ | tsid == tsid`
+ | not (match_strictness (dec (length types)) strictl strictl`) = (False,ms)
+ = match_arg_types types types` ms
+ match_type (arg --> res) _ (arg` --> res`) _ ms
+ # (type_ok,ms) = match_type arg.at_type arg.at_attribute arg`.at_type arg`.at_attribute ms
+ | not type_ok = (False,ms)
+ = match_type res.at_type res.at_attribute res`.at_type res`.at_attribute ms
+ match_type (TB bt) _ (TB bt`) _ ms
+ = (bt==bt`,ms)
+ match_type (TV tv) _ (TV tv`) _ ms
+ = match_tvar tv tv` ms
+ match_type t1 a1 t2 a2 ms
+ # type_heaps = ms.ms_type_heaps
+ # (succ1,t1,type_heaps) = tryToExpand t1 a1 ms.ms_common_defs type_heaps
+ # (succ2,t2,type_heaps) = tryToExpand t2 a2 ms.ms_common_defs type_heaps
+ # ms = { ms & ms_type_heaps = type_heaps }
+ | succ1 || succ2 = match_type t1 a1 t2 a2 ms
+ = (False,ms)
+
+ match_tvar x y ms
+ # (r,tvar_map) = match_tvar x y ms.tvar_map
+ = (r, {ms & tvar_map = tvar_map})
+ where
+ match_tvar x y [] = (True,[(x,y)])
+ match_tvar x y ms=:[(x`,y`):t]
+ | x == x` = (y==y`, ms)
+ # (res,t) = match_tvar x y t
+ = (res,[(x`,y`):t])
+
+is_trivial_body args rhs f_args type ro fun_defs fun_heap type_heaps cons_args
+ = (No,fun_defs,fun_heap,type_heaps,cons_args)
+
+get_producer_class (SK_GeneratedFunction fun_ptr _) ro fun_heap cons_args
+ # (FI_Function {gf_cons_args={cc_producer}}, fun_heap) = readPtr fun_ptr fun_heap
+ = (cc_producer, fun_heap, cons_args)
+get_producer_class (SK_LocalMacroFunction glob_object) ro fun_heap cons_args
+ # ({cc_producer},cons_args) = cons_args![glob_object]
+ = (cc_producer, fun_heap, cons_args)
+get_producer_class (SK_Function { glob_module, glob_object }) ro fun_heap cons_args
+ # (max_index,cons_args) = usize cons_args
+ | glob_module <> ro.ro_main_dcl_module_n || glob_object >= max_index
+ = (False, fun_heap, cons_args)
+ # ({cc_producer},cons_args) = cons_args![glob_object]
+ = (cc_producer, fun_heap, cons_args)
+get_producer_class (SK_Constructor {glob_module, glob_object}) ro fun_heap cons_args
+ = (True, fun_heap, cons_args)
+
+//@ transformApplication
transformApplication :: !App ![Expression] !ReadOnlyTI !*TransformInfo -> *(!Expression,!*TransformInfo)
transformApplication app=:{app_symb=symb=:{symb_kind}, app_args} extra_args
ro ti=:{ti_cons_args,ti_instances,ti_fun_defs}