Commit c68c87d6 authored by John van Groningen's avatar John van Groningen
Browse files

optimize fusion, reduce memory used of fusion (from iTask branch):

allow integers and strings as consumer for generic functions (to optimize use of generic info).
use PR_CurriedFunction instead of PR_Curried for local macro functions that are good producers.
check the arity of the function to be generated already in determineProducer,
if too large, don't yield a producer which will be rejected later,
to allow optimization of producers in subsequent arguments.
optimize trivial function calls (with arguments) before optimizing arguments,
treat constant function as trivial function.
if a function call has two identical arguments,
generate a specialized function that shares these parameters.
specialize functions with zero arity constructor arguments,
if the function is a generic function, or the constructor is a generic constructor.
parent 2080238b
......@@ -3044,6 +3044,8 @@ where
(fun_def,local_fun_defs,next_fun_index,fun_defs,dcl_macros,var_heap,expression_heap)
= copy_macro_and_local_functions macro fun_index fun_defs dcl_macros var_heap expression_heap
fun_def & fun_info.fi_properties = fun_def.fun_info.fi_properties bitor FI_GenericFun
dcl_macros = restore_unexpanded_dcl_macros unexpanded_dcl_macros dcl_macros
heaps & hp_var_heap=var_heap,hp_expression_heap=expression_heap
......@@ -3085,6 +3087,7 @@ where
add_functions [(function_n,fun_def):sorted_functions_with_numbers] fun_index funs
| function_n==fun_index
# fun_def & fun_info.fi_properties = fun_def.fun_info.fi_properties bitor FI_GenericFun
= add_functions sorted_functions_with_numbers (fun_index+1) [fun_def:funs]
add_functions [] fun_index funs
= funs
......@@ -5193,7 +5196,7 @@ makeFunction ident group_index arg_vars body_expr opt_sym_type main_dcl_module_n
, fi_free_vars = []
, fi_local_vars = local_vars
, fi_dynamics = []
, fi_properties = 0
, fi_properties = FI_GenericFun
}
}
......
......@@ -663,6 +663,9 @@ FI_HasTypeSpec :== 2 // whether the function has u user defined type
FI_IsNonRecursive :== 4 // used in trans.icl and partition.icl
FI_IsUnboxedListOfRecordsConsOrNil :== 8
FI_MemberInstanceRequiresTypeInDefMod :== 16
FI_GenericFun :== 32
FI_Unused :== 64 // used in module trans
FI_UnusedUsed :== 128 // used in module trans
:: FunInfo =
{ fi_calls :: ![FunCall]
......@@ -866,6 +869,10 @@ cNotVarNumber :== -1
| PR_Curried !SymbIdent !Int
| PR_Unused
| PR_CurriedFunction !SymbIdent !Int !Index
| PR_String !{#Char}
| PR_Int !Int
| PR_Equal !Int
| PR_EqualRemove !Int
:: InstanceInfo = II_Empty | II_Node !{! Producer} !FunctionInfoPtr !InstanceInfo !InstanceInfo
......@@ -1080,6 +1087,8 @@ cNotVarNumber :== -1
| TGenericFunctionInDictionary !(Global DefinedSymbol) !TypeKind !GlobalIndex /*GenericDict*/
| TLiftedSubst !Type // Auxiliary, used during fusion when generating a new function type
| TE
:: ConsVariable = CV !TypeVar
......
This diff is collapsed.
......@@ -52,7 +52,12 @@ tryToMakeUnique :: !Int !*Coercions -> (!Bool, !*Coercions)
uniquenessErrorVar :: !FreeVar !FunctionBody !String !*ErrorAdmin -> *ErrorAdmin
liftSubstitution :: !*{! Type} !{# CommonDefs }!{# BOOLVECT } !Int !*TypeHeaps !*TypeDefInfos -> (*{! Type}, !Int, !*TypeHeaps, !*TypeDefInfos)
liftOfferedSubstitutions :: !AType !AType !{#CommonDefs} !{#BOOLVECT} !Int !*{!Type} !*TypeDefInfos !*TypeHeaps
-> (!Int,!*{!Type},!*TypeDefInfos,!*TypeHeaps)
liftSubstitution :: !*{!Type} !{#CommonDefs}!{#BOOLVECT} !Int !*TypeHeaps !*TypeDefInfos -> (*{!Type}, !Int, !*TypeHeaps, !*TypeDefInfos)
liftRemainingSubstitutions :: !*{!Type} !{#CommonDefs }!{#BOOLVECT} !Int !*TypeHeaps !*TypeDefInfos -> (*{!Type}, !Int, !*TypeHeaps, !*TypeDefInfos)
:: ExpansionState =
{ es_type_heaps :: !.TypeHeaps
......
implementation module unitype
import StdEnv, compare_types
import StdEnv, StdStrictLists, compare_types
from StdOverloadedList import Any
import syntax, analunitypes, type, utilities, checktypes
AttrUni :== 0
......@@ -214,6 +214,9 @@ liftTempTypeVariable modules cons_vars tv_number subst ls
= case type of
TE
-> (False, TempV tv_number, subst, ls)
TLiftedSubst type
# (_, type, subst, ls) = lift modules cons_vars type subst ls
-> (True, type, subst, ls)
_
# (_, type, subst, ls) = lift modules cons_vars type subst ls
-> (True, type, subst, ls)
......@@ -420,6 +423,8 @@ expandTempTypeVariable tv_number (subst, es)
= case type of
TE
-> (False, TempV tv_number, (subst, es))
TLiftedSubst type
-> (True, type, (subst, es))
_
-> (True, type, (subst, es))
......@@ -1151,3 +1156,235 @@ where
= find_var_position_in_selections selections
find_var_position_in_selections []
= (False,NoPos)
liftOfferedSubstitutions :: !AType !AType !{#CommonDefs} !{#BOOLVECT} !Int !*{!Type} !*TypeDefInfos !*TypeHeaps
-> (!Int,!*{!Type},!*TypeDefInfos,!*TypeHeaps)
liftOfferedSubstitutions off_type dem_type common_defs cons_vars next_attr_n subst td_infos type_heaps
# ls = {ls_next_attr = next_attr_n, ls_td_infos = td_infos, ls_type_heaps = type_heaps}
# (subst,ls) = lift_offered_substitutions off_type dem_type common_defs cons_vars subst ls
= (ls.ls_next_attr, subst, ls.ls_td_infos, ls.ls_type_heaps)
lift_offered_substitutions :: !AType !AType !{#CommonDefs} !{#BOOLVECT} !*{!Type} !*LiftState
-> (!*{!Type},!*LiftState)
lift_offered_substitutions {at_type=TA off_cons off_args} {at_type=TA {type_index,type_arity} dem_args} common_defs cons_vars subst ls
= lift_offered_substitutions_type_application off_cons.type_index off_args type_index dem_args type_arity common_defs cons_vars subst ls
lift_offered_substitutions {at_type=TA off_cons off_args} {at_type=TAS {type_index,type_arity} dem_args _} common_defs cons_vars subst ls
= lift_offered_substitutions_type_application off_cons.type_index off_args type_index dem_args type_arity common_defs cons_vars subst ls
lift_offered_substitutions {at_type=TAS off_cons off_args _} {at_type=TA {type_index,type_arity} dem_args} common_defs cons_vars subst ls
= lift_offered_substitutions_type_application off_cons.type_index off_args type_index dem_args type_arity common_defs cons_vars subst ls
lift_offered_substitutions {at_type=TAS off_cons off_args _} {at_type=TAS {type_index,type_arity} dem_args _} common_defs cons_vars subst ls
= lift_offered_substitutions_type_application off_cons.type_index off_args type_index dem_args type_arity common_defs cons_vars subst ls
lift_offered_substitutions {at_type=_ --> atype1} {at_type=_ --> atype2} common_defs cons_vars subst ls
= lift_offered_substitutions atype1 atype2 common_defs cons_vars subst ls
lift_offered_substitutions {at_type=TempV _} {at_type=TempV _} common_defs cons_vars subst ls
= (subst,ls)
lift_offered_substitutions {at_type=off_type} {at_type=TempV tv_number} common_defs cons_vars subst ls
# (subst_type,subst) = subst![tv_number]
= case subst_type of
TLiftedSubst _
-> (subst,ls)
_
# (changed, lifted_subst_type, subst, ls) = lift_pos_type_with_offered_type common_defs cons_vars off_type subst_type subst ls
#! lifted_subst_type = lifted_subst_type
# subst & [tv_number] = TLiftedSubst lifted_subst_type
-> (subst,ls)
lift_offered_substitutions {at_type=TempV _} _ common_defs cons_vars subst ls
= (subst,ls)
lift_offered_substitutions {at_type=TV {tv_info_ptr},at_attribute} dem_type common_defs cons_vars subst ls=:{ls_type_heaps}
# (TVI_Type type, th_vars) = readPtr tv_info_ptr ls_type_heaps.th_vars
ls & ls_type_heaps = {ls_type_heaps & th_vars = th_vars}
= lift_offered_substitutions {at_type=type,at_attribute=at_attribute} dem_type common_defs cons_vars subst ls
lift_offered_substitutions off_type {at_type=TV {tv_info_ptr},at_attribute} common_defs cons_vars subst ls=:{ls_type_heaps}
# (TVI_Type type, th_vars) = readPtr tv_info_ptr ls_type_heaps.th_vars
ls & ls_type_heaps = {ls_type_heaps & th_vars = th_vars}
= lift_offered_substitutions off_type {at_type=type,at_attribute=at_attribute} common_defs cons_vars subst ls
lift_offered_substitutions {at_type=TB _} {at_type=TB _} common_defs cons_vars subst ls
= (subst,ls)
lift_offered_substitutions off_type dem_type common_defs cons_vars subst ls
= (subst,ls)
has_no_ArrowKind :: ![TypeKind] -> Bool
has_no_ArrowKind kinds
= not (Any IsArrowKind kinds)
lift_offered_substitutions_type_application :: (Global Int) [AType] (Global Int) [AType] Int !{#CommonDefs} !{#Int} !*{!Type} !*LiftState
-> *(!*{!Type},!*LiftState)
lift_offered_substitutions_type_application off_type_index off_args dem_type_index=:{glob_module,glob_object} dem_args type_arity common_defs cons_vars subst ls
| off_type_index==dem_type_index
| has_no_ArrowKind ls.ls_td_infos.[glob_module].[glob_object].tdi_kinds
# {ls_type_heaps,ls_td_infos} = ls
({tsp_sign},th_vars,ls_td_infos) = typeProperties glob_object glob_module [] [] common_defs ls_type_heaps.th_vars ls_td_infos
ls & ls_type_heaps = {ls_type_heaps & th_vars=th_vars}, ls_td_infos=ls_td_infos
| is_positive_sign tsp_sign type_arity
= lift_offered_substitutions_args off_args dem_args common_defs cons_vars subst ls
= (subst,ls)
= (subst,ls)
= (subst,ls)
where
lift_offered_substitutions_args [off_arg:off_args] [dem_arg:dem_args] common_defs cons_vars subst ls
# (subst,ls) = lift_offered_substitutions_args off_args dem_args common_defs cons_vars subst ls
= lift_offered_substitutions off_arg dem_arg common_defs cons_vars subst ls
lift_offered_substitutions_args [] [] common_defs cons_vars subst ls
= (subst,ls)
is_positive_sign {sc_pos_vect,sc_neg_vect} arity
| arity==0
= True
| arity<32
# m = (1<<arity)-1
= (sc_pos_vect bitand m) == m && (sc_neg_vect bitand m) == 0
= sc_pos_vect == -1 && sc_neg_vect == 0
lift_pos_atype_with_offered_type :: !{#CommonDefs} !{#BOOLVECT} !AType !AType !*{!Type} !*LiftState -> (!Bool,!AType,!*{!Type},!*LiftState)
lift_pos_atype_with_offered_type modules cons_vars {at_attribute=TA_Multi,at_type=off_type} attr_type=:{at_attribute=TA_Multi,at_type} subst ls
// no new type attribute
# (changed, at_type, subst, ls) = lift_pos_type_with_offered_type modules cons_vars off_type at_type subst ls
| changed
= (True, {attr_type & at_type = at_type},subst, ls)
= (False, attr_type,subst, ls)
lift_pos_atype_with_offered_type modules cons_vars {at_type=off_type} attr_type=:{at_type} subst ls
# (changed, at_type, subst, ls) = lift_pos_type_with_offered_type modules cons_vars off_type at_type subst ls
| changed
| typeIsNonCoercible cons_vars at_type
= (True, {attr_type & at_type = at_type},subst, ls)
= (True, {attr_type & at_attribute = TA_TempVar ls.ls_next_attr, at_type = at_type}, subst, {ls & ls_next_attr = inc ls.ls_next_attr})
| typeIsNonCoercible cons_vars at_type
= (False, attr_type,subst, ls)
= (True, {attr_type & at_attribute = TA_TempVar ls.ls_next_attr}, subst, {ls & ls_next_attr = inc ls.ls_next_attr})
lift_pos_type_with_offered_type :: !{#CommonDefs} !{#BOOLVECT} !Type !Type !*{!Type} !*LiftState -> (!Bool,!Type,!*{!Type},!*LiftState)
lift_pos_type_with_offered_type modules cons_vars (TempV _) type subst ls
= lift modules cons_vars type subst ls
lift_pos_type_with_offered_type modules cons_vars (_ :@: _) type subst ls
= lift modules cons_vars type subst ls
lift_pos_type_with_offered_type modules cons_vars off_type type=:(TempV tv_number) subst ls
# (type, subst) = subst![tv_number]
= case type of
TE
-> (False, type, subst, ls)
TLiftedSubst type
# (_, type, subst, ls) = lift_pos_type_with_offered_type modules cons_vars off_type type subst ls
-> (True, type, subst, ls)
_
# (_, type, subst, ls) = lift_pos_type_with_offered_type modules cons_vars off_type type subst ls
-> (True, type, subst, ls)
lift_pos_type_with_offered_type modules cons_vars (_ --> off_res_type) type=:(arg_type0 --> res_type0) subst ls
# (changed, arg_type, subst, ls) = lift modules cons_vars arg_type0 subst ls
| changed
# (changed, res_type, subst, ls) = lift_pos_atype_with_offered_type modules cons_vars off_res_type res_type0 subst ls
| changed
= (True, arg_type --> res_type, subst, ls)
= (True, arg_type --> res_type0, subst, ls)
# (changed, res_type, subst, ls) = lift_pos_atype_with_offered_type modules cons_vars off_res_type res_type0 subst ls
| changed
= (True, arg_type0 --> res_type, subst, ls)
= (False, type, subst, ls)
lift_pos_type_with_offered_type modules cons_vars off_type=:(TA _ _) type=:(TA _ _) subst ls=:{ls_type_heaps}
# (_, off_type, ls_type_heaps) = tryToExpand off_type TA_Multi modules ls_type_heaps
# (_, type, ls_type_heaps) = tryToExpand type TA_Multi modules ls_type_heaps
= lift_pos_type_application_with_offered_type modules cons_vars off_type type subst {ls & ls_type_heaps = ls_type_heaps}
lift_pos_type_with_offered_type modules cons_vars off_type=:(TA _ _) type=:(TAS _ _ _) subst ls=:{ls_type_heaps}
# (_, off_type, ls_type_heaps) = tryToExpand off_type TA_Multi modules ls_type_heaps
# (_, type, ls_type_heaps) = tryToExpand type TA_Multi modules ls_type_heaps
= lift_pos_type_application_with_offered_type modules cons_vars off_type type subst {ls & ls_type_heaps = ls_type_heaps}
lift_pos_type_with_offered_type modules cons_vars off_type=:(TAS _ _ _) type=:(TA _ _) subst ls=:{ls_type_heaps}
# (_, off_type, ls_type_heaps) = tryToExpand off_type TA_Multi modules ls_type_heaps
# (_, type, ls_type_heaps) = tryToExpand type TA_Multi modules ls_type_heaps
= lift_pos_type_application_with_offered_type modules cons_vars off_type type subst {ls & ls_type_heaps = ls_type_heaps}
lift_pos_type_with_offered_type modules cons_vars off_type=:(TAS _ _ _) type=:(TAS _ _ _) subst ls=:{ls_type_heaps}
# (_, off_type, ls_type_heaps) = tryToExpand off_type TA_Multi modules ls_type_heaps
# (_, type, ls_type_heaps) = tryToExpand type TA_Multi modules ls_type_heaps
= lift_pos_type_application_with_offered_type modules cons_vars off_type type subst {ls & ls_type_heaps = ls_type_heaps}
lift_pos_type_with_offered_type modules cons_vars off_type type=:(TArrow1 arg_type) subst ls
# (changed, arg_type, subst, ls) = lift modules cons_vars arg_type subst ls
| changed
= (True, TArrow1 arg_type, subst, ls)
= (False, type, subst, ls)
lift_pos_type_with_offered_type modules cons_vars off_type type=:(TempCV temp_var :@: types) subst ls
= lift modules cons_vars type subst ls
lift_pos_type_with_offered_type modules cons_vars off_type (TFA vars type) subst ls
= abort "lift_pos_type_with_offered_type TFA"
lift_pos_type_with_offered_type modules cons_vars off_type type subst ls
= (False, type, subst, ls)
lift_pos_type_application_with_offered_type :: !{#CommonDefs} !{#Int} !Type !Type !*{!Type} !*LiftState -> *(!Bool,!Type,!*{!Type},!*LiftState)
lift_pos_type_application_with_offered_type modules cons_vars (TA _ off_type_args) type=:(TA _ _) subst ls
= lift_pos_TA_application_with_offered_type modules cons_vars off_type_args type subst ls
lift_pos_type_application_with_offered_type modules cons_vars (TAS _ off_type_args _) type=:(TA _ _) subst ls
= lift_pos_TA_application_with_offered_type modules cons_vars off_type_args type subst ls
lift_pos_type_application_with_offered_type modules cons_vars (TA _ off_type_args) type=:(TAS _ _ _) subst ls
= lift_pos_TAS_application_with_offered_type modules cons_vars off_type_args type subst ls
lift_pos_type_application_with_offered_type modules cons_vars (TAS _ off_type_args _) type=:(TAS _ _ _) subst ls
= lift_pos_TAS_application_with_offered_type modules cons_vars off_type_args type subst ls
lift_pos_type_application_with_offered_type modules cons_vars off_type type subst ls
= lift_pos_type_with_offered_type modules cons_vars off_type type subst ls
lift_pos_TA_application_with_offered_type :: !{#CommonDefs} !{#Int} ![AType] !Type !*{!Type} !*LiftState -> *(!Bool,!Type,!*{!Type},!*LiftState)
lift_pos_TA_application_with_offered_type modules cons_vars off_type_args t0=:(TA cons_id=:{type_ident,type_index={glob_object,glob_module},type_arity,type_prop=type_prop0} cons_args) subst ls=:{ls_type_heaps}
| has_no_ArrowKind ls.ls_td_infos.[glob_module].[glob_object].tdi_kinds
# (type_prop, th_vars, ls_td_infos) = typeProperties glob_object glob_module [] [] modules ls_type_heaps.th_vars ls.ls_td_infos
ls & ls_td_infos = ls_td_infos, ls_type_heaps = {ls_type_heaps & th_vars = th_vars}
# (changed,cons_args, subst, ls=:{ls_type_heaps}) = lift_pos_list_with_offered_type modules cons_vars off_type_args cons_args type_prop.tsp_sign subst ls
| changed
| equal_type_prop type_prop type_prop0
= (True, TA cons_id cons_args, subst, ls)
= (True, TA {cons_id & type_prop = type_prop} cons_args, subst, ls)
| equal_type_prop type_prop type_prop0
= (False, t0, subst, ls)
= (True, TA {cons_id & type_prop = type_prop} cons_args, subst, ls)
= liftTypeApplication modules cons_vars t0 subst ls
lift_pos_TAS_application_with_offered_type :: !{#CommonDefs} !{#Int} ![AType] !Type !*{!Type} !*LiftState -> *(!Bool,!Type,!*{!Type},!*LiftState)
lift_pos_TAS_application_with_offered_type modules cons_vars off_type t0=:(TAS cons_id=:{type_ident,type_index={glob_object,glob_module},type_arity,type_prop=type_prop0} cons_args strictness) subst ls=:{ls_type_heaps}
| has_no_ArrowKind ls.ls_td_infos.[glob_module].[glob_object].tdi_kinds
# (type_prop, th_vars, ls_td_infos) = typeProperties glob_object glob_module [] [] modules ls_type_heaps.th_vars ls.ls_td_infos
ls & ls_td_infos = ls_td_infos, ls_type_heaps = {ls_type_heaps & th_vars = th_vars}
# (changed,cons_args, subst, ls) = lift_pos_list_with_offered_type modules cons_vars off_type cons_args type_prop.tsp_sign subst ls
| changed
| equal_type_prop type_prop type_prop0
= (True, TAS cons_id cons_args strictness, subst, ls)
= (True, TAS {cons_id & type_prop = type_prop} cons_args strictness, subst, ls)
| equal_type_prop type_prop type_prop0
= (False, t0, subst, ls)
= (True, TAS {cons_id & type_prop = type_prop} cons_args strictness, subst, ls)
= liftTypeApplication modules cons_vars t0 subst ls
lift_pos_list_with_offered_type :: !{#CommonDefs} !{#BOOLVECT} ![AType] ![AType] !SignClassification !*{!Type} !*LiftState -> (!Bool,![AType], !*{!Type}, !*LiftState)
lift_pos_list_with_offered_type modules cons_vars [off_type:off_types] ts0=:[t0:ts] {sc_pos_vect,sc_neg_vect} subst ls
# next_sc = {sc_pos_vect=sc_pos_vect>>1,sc_neg_vect=sc_neg_vect>>1}
| sc_pos_vect bitand 1 > sc_neg_vect bitand 1
# (changed, t, subst, ls) = lift_pos_atype_with_offered_type modules cons_vars off_type t0 subst ls
| changed
# (_, ts, subst, ls) = lift_pos_list_with_offered_type modules cons_vars off_types ts next_sc subst ls
= (True,[t:ts],subst,ls)
# (changed, ts, subst, ls) = lift_pos_list_with_offered_type modules cons_vars off_types ts next_sc subst ls
| changed
= (True, [t:ts], subst, ls)
= (False, ts0, subst, ls)
# (changed, t, subst, ls) = lift modules cons_vars t0 subst ls
| changed
# (_, ts, subst, ls) = lift_pos_list_with_offered_type modules cons_vars ts off_types next_sc subst ls
= (True,[t:ts],subst,ls)
# (changed, ts, subst, ls) = lift_pos_list_with_offered_type modules cons_vars ts off_types next_sc subst ls
| changed
= (True, [t:ts], subst, ls)
= (False, ts0, subst, ls)
lift_pos_list_with_offered_type modules cons_vars [] [] sign_class subst ls
= (False, [], subst, ls)
liftRemainingSubstitutions :: !*{!Type} !{#CommonDefs} !{#BOOLVECT} !Int !*TypeHeaps !*TypeDefInfos -> (*{! Type}, !Int, !*TypeHeaps, !*TypeDefInfos)
liftRemainingSubstitutions subst modules cons_vars attr_store type_heaps td_infos
# ls = {ls_next_attr = attr_store, ls_td_infos = td_infos, ls_type_heaps = type_heaps}
= lift_substitution 0 modules cons_vars subst ls
where
lift_substitution var_index modules cons_vars subst ls
| var_index < size subst
# (type, subst) = subst![var_index]
= case type of
TLiftedSubst type
-> lift_substitution (inc var_index) modules cons_vars {subst & [var_index] = type} ls
_
# (_, type, subst, ls) = lift modules cons_vars type subst ls
-> lift_substitution (inc var_index) modules cons_vars {subst & [var_index] = type} ls
= (subst, ls.ls_next_attr, ls.ls_type_heaps, ls.ls_td_infos)
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment