Skip to content
GitLab
Commit 91f39a06 authored by Diederik van Arkel's avatar Diederik van Arkel
Browse files

add strictness annotations

parent b214320a
Hide whitespace changes
Inline Side-by-side
frontend/classify.icl
View file @ 91f39a06
...@@ -437,6 +437,7 @@ instance consumerRequirements Case where ...@@ -437,6 +437,7 @@ instance consumerRequirements Case where
_ -> False _ -> False
// use_context_default = not (case_explicit || has_default) // use_context_default = not (case_explicit || has_default)
combine_counts :: !Int !*{#Int} !{#Int} -> *{#Int}
combine_counts 0 accu env combine_counts 0 accu env
= accu = accu
combine_counts i accu env combine_counts i accu env
...@@ -446,10 +447,12 @@ instance consumerRequirements Case where ...@@ -446,10 +447,12 @@ instance consumerRequirements Case where
accu = { accu & [i1] = unify_counts rca rce } accu = { accu & [i1] = unify_counts rca rce }
= combine_counts i1 accu env = combine_counts i1 accu env
where where
unify_counts :: !Int !Int -> Int
unify_counts 0 x = x unify_counts 0 x = x
unify_counts 1 x = if (x==2) 2 (inc x) unify_counts 1 x = if (x==2) 2 (inc x)
unify_counts 2 x = 2 unify_counts 2 x = 2
inspect_patterns :: !{#.CommonDefs} !.Bool !.CasePatterns ![.Bool] -> (!.Bool,!Bool)
inspect_patterns common_defs has_default (AlgebraicPatterns {glob_object, glob_module} algebraic_patterns) unsafe_bits inspect_patterns common_defs has_default (AlgebraicPatterns {glob_object, glob_module} algebraic_patterns) unsafe_bits
# type_def = common_defs.[glob_module].com_type_defs.[glob_object] # type_def = common_defs.[glob_module].com_type_defs.[glob_object]
defined_symbols = case type_def.td_rhs of defined_symbols = case type_def.td_rhs of
...@@ -535,6 +538,7 @@ instance consumerRequirements Case where ...@@ -535,6 +538,7 @@ instance consumerRequirements Case where
= True = True
= multimatch_loop has_default (dropWhile (\(ds_index,_,_)->ds_index==cip) constructors_in_pattern) = multimatch_loop has_default (dropWhile (\(ds_index,_,_)->ds_index==cip) constructors_in_pattern)
combine_pattern_counts :: !.Bool !.CasePatterns ![.Bool] ![{#.Int}] !{#Int} -> *{#Int}
combine_pattern_counts has_default patterns unsafe_bits guard_counts default_counts combine_pattern_counts has_default patterns unsafe_bits guard_counts default_counts
| not ok_pattern_type | not ok_pattern_type
= createArray (size default_counts) 2 = createArray (size default_counts) 2
...@@ -575,6 +579,7 @@ where ...@@ -575,6 +579,7 @@ where
count_size = size default_counts count_size = size default_counts
zero_array = createArray count_size 0 zero_array = createArray count_size 0
sort3 :: !.[Int] !.[a] !.[b] -> .[(!Int,!Int,!a,!b)]
sort3 constr_indices unsafe_bits counts sort3 constr_indices unsafe_bits counts
= sortBy smaller (zip4 constr_indices [0..] unsafe_bits counts) = sortBy smaller (zip4 constr_indices [0..] unsafe_bits counts)
where where
...@@ -587,7 +592,7 @@ where ...@@ -587,7 +592,7 @@ where
zip4 _ _ _ _ zip4 _ _ _ _
= [] = []
count_loop :: RefCounts RefCounts [(Int,Int,Bool,RefCounts)] -> *RefCounts count_loop :: !RefCounts !RefCounts ![(!Int,!Int,!Bool,!RefCounts)] -> *RefCounts
count_loop default_counts unified_counts [] count_loop default_counts unified_counts []
= {e \\ e <-: unified_counts} = {e \\ e <-: unified_counts}
count_loop default_counts unified_counts [(c_index,p_index,unsafe,counts):patterns] count_loop default_counts unified_counts [(c_index,p_index,unsafe,counts):patterns]
...@@ -597,7 +602,7 @@ where ...@@ -597,7 +602,7 @@ where
_ -> counts _ -> counts
= count_loop default_counts (unify_counts ccount unified_counts) next = count_loop default_counts (unify_counts ccount unified_counts) next
where where
splitWhile :: (a -> .Bool) !u:[a] -> (.[a],v:[a]), [u <= v]; splitWhile :: !(a -> .Bool) !u:[a] -> (!.[a],!v:[a]), [u <= v];
splitWhile f [] splitWhile f []
= ([],[]) = ([],[])
splitWhile f cons=:[a:x] splitWhile f cons=:[a:x]
...@@ -606,7 +611,7 @@ where ...@@ -606,7 +611,7 @@ where
= ([a:t],d) = ([a:t],d)
= ([],cons) = ([],cons)
count_constructor :: RefCounts RefCounts [(Int,Int,Bool,RefCounts)] -> RefCounts count_constructor :: !RefCounts !RefCounts ![(!Int,!Int,!Bool,!RefCounts)] -> RefCounts
count_constructor default_counts combined_counts [] count_constructor default_counts combined_counts []
= combine_counts combined_counts default_counts = combine_counts combined_counts default_counts
count_constructor default_counts combined_counts [(_,_,unsafe,counts):patterns] count_constructor default_counts combined_counts [(_,_,unsafe,counts):patterns]
...@@ -614,7 +619,7 @@ where ...@@ -614,7 +619,7 @@ where
= count_constructor default_counts (combine_counts combined_counts counts) patterns = count_constructor default_counts (combine_counts combined_counts counts) patterns
= combine_counts combined_counts counts = combine_counts combined_counts counts
combine_counts :: RefCounts RefCounts -> RefCounts combine_counts :: !RefCounts !RefCounts -> RefCounts
combine_counts c1 c2 combine_counts c1 c2
= {unify_counts e1 e2 \\ e1 <-: c1 & e2 <-: c2} = {unify_counts e1 e2 \\ e1 <-: c1 & e2 <-: c2}
where where
...@@ -627,10 +632,12 @@ where ...@@ -627,10 +632,12 @@ where
accu = { accu & [i1] = unify_counts rca rce } accu = { accu & [i1] = unify_counts rca rce }
= combine i1 accu env = combine i1 accu env
unify_counts :: !Int !Int -> Int
unify_counts 0 x = x unify_counts 0 x = x
unify_counts 1 x = if (x==2) 2 (inc x) unify_counts 1 x = if (x==2) 2 (inc x)
unify_counts 2 x = 2 unify_counts 2 x = 2
unify_counts :: !RefCounts !RefCounts -> *RefCounts
unify_counts c1 c2 unify_counts c1 c2
= {unify_counts e1 e2 \\ e1 <-: c1 & e2 <-: c2} = {unify_counts e1 e2 \\ e1 <-: c1 & e2 <-: c2}
where where
...@@ -644,11 +651,13 @@ where ...@@ -644,11 +651,13 @@ where
accu = { accu & [i1] = unify_counts rce rca } accu = { accu & [i1] = unify_counts rce rca }
= unify i1 accu env = unify i1 accu env
unify_counts :: !Int !Int -> Int
unify_counts 0 x = x unify_counts 0 x = x
unify_counts 1 x = if (x==0) 1 x unify_counts 1 x = if (x==0) 1 x
unify_counts 2 x = 2 unify_counts 2 x = 2
//consumer_requirements_of_guards :: !CasePatterns ConsumerAnalysisRO !*AnalyseInfo -> (!Int,.[Bool],!*AnalyseInfo) //consumer_requirements_of_guards :: !CasePatterns ConsumerAnalysisRO !*AnalyseInfo -> (!Int,.[Bool],!*AnalyseInfo)
consumer_requirements_of_guards :: !.CasePatterns !.ConsumerAnalysisRO !*AnalyseInfo -> *(!Int,!.[Bool],![{#Int}],!*AnalyseInfo)
consumer_requirements_of_guards (AlgebraicPatterns type patterns) common_defs ai consumer_requirements_of_guards (AlgebraicPatterns type patterns) common_defs ai
# pattern_exprs # pattern_exprs
= [ ap_expr \\ {ap_expr}<-patterns] = [ ap_expr \\ {ap_expr}<-patterns]
...@@ -686,7 +695,7 @@ bindPatternVars [fv=:{fv_info_ptr,fv_count} : vars] next_var next_var_of_fun var ...@@ -686,7 +695,7 @@ bindPatternVars [fv=:{fv_info_ptr,fv_count} : vars] next_var next_var_of_fun var
bindPatternVars [] next_var next_var_of_fun var_heap bindPatternVars [] next_var next_var_of_fun var_heap
= (next_var, next_var_of_fun, var_heap) = (next_var, next_var_of_fun, var_heap)
independentConsumerRequirements :: !.[Expression] ConsumerAnalysisRO !*AnalyseInfo -> (!ConsClass,.[Bool],[RefCounts],!*AnalyseInfo) independentConsumerRequirements :: !.[Expression] !ConsumerAnalysisRO !*AnalyseInfo -> (!ConsClass,!.[Bool],![RefCounts],!*AnalyseInfo)
independentConsumerRequirements exprs info ai independentConsumerRequirements exprs info ai
# ref_counts = ai.ai_cur_ref_counts # ref_counts = ai.ai_cur_ref_counts
# (count_size,ref_counts) = usize ref_counts # (count_size,ref_counts) = usize ref_counts
...@@ -695,6 +704,7 @@ independentConsumerRequirements exprs info ai ...@@ -695,6 +704,7 @@ independentConsumerRequirements exprs info ai
# (counts,unsafe) = unzip counts_unsafe # (counts,unsafe) = unzip counts_unsafe
= (cc,unsafe,counts,{ ai & ai_cur_ref_counts = ref_counts}) = (cc,unsafe,counts,{ ai & ai_cur_ref_counts = ref_counts})
where where
cons_reqs :: !Expression !*(!.Int,!*AnalyseInfo) -> *(!.(!{#Int},!Bool),!*(!Int,!*AnalyseInfo))
cons_reqs expr (cc,ai) cons_reqs expr (cc,ai)
# (cce, unsafe, ai) = consumerRequirements expr info ai # (cce, unsafe, ai) = consumerRequirements expr info ai
# cc = combineClasses cce cc # cc = combineClasses cce cc
...@@ -1214,17 +1224,19 @@ reanalyseFunction fun fun_info_ptr common_defs imported_funs main_dcl_module_n s ...@@ -1214,17 +1224,19 @@ reanalyseFunction fun fun_info_ptr common_defs imported_funs main_dcl_module_n s
= (fun_cons_class,fun_defs,ai.ai_var_heap,ai.ai_fun_heap,ai_cons_class) = (fun_cons_class,fun_defs,ai.ai_var_heap,ai.ai_fun_heap,ai_cons_class)
fresh_variables :: ![.FreeVar] !Int !Int !*(Heap VarInfo) -> *(!.[Int],!Int,!*(Heap VarInfo))
fresh_variables [{fv_info_ptr} : vars] arg_position next_var_number var_heap fresh_variables [{fv_info_ptr} : vars] arg_position next_var_number var_heap
# var_heap
= writePtr fv_info_ptr (VI_AccVar next_var_number arg_position) var_heap
# (fresh_vars, last_var_number, var_heap) # (fresh_vars, last_var_number, var_heap)
= fresh_variables vars (inc arg_position) (inc next_var_number) var_heap = fresh_variables vars (inc arg_position) (inc next_var_number) var_heap
var_heap
= writePtr fv_info_ptr (VI_AccVar next_var_number arg_position) var_heap
= ([next_var_number : fresh_vars], last_var_number, var_heap) = ([next_var_number : fresh_vars], last_var_number, var_heap)
fresh_variables [] _ next_var_number var_heap fresh_variables [] _ next_var_number var_heap
= ([], next_var_number, var_heap) = ([], next_var_number, var_heap)
// count_locals determines number of local variables... // count_locals determines number of local variables...
count_locals :: !Expression !Int -> Int
count_locals (Var _) n count_locals (Var _) n
= n = n
count_locals (App {app_args}) n count_locals (App {app_args}) n
......
frontend/trans.icl
View file @ 91f39a06
...@@ -1489,16 +1489,19 @@ where ...@@ -1489,16 +1489,19 @@ where
# strict1=Strict 1 # strict1=Strict 1
= { {ats_types=[el],ats_strictness=if (arg_is_strict i args_strictness) strict1 NotStrict} \\ i<-[0..] & el <- st_args } = { {ats_types=[el],ats_strictness=if (arg_is_strict i args_strictness) strict1 NotStrict} \\ i<-[0..] & el <- st_args }
is_dictionary :: !.AType !{#{#.TypeDefInfo}} -> Bool
is_dictionary {at_type=TA {type_index} _} es_td_infos is_dictionary {at_type=TA {type_index} _} es_td_infos
#! td_infos_of_module=es_td_infos.[type_index.glob_module] #! td_infos_of_module=es_td_infos.[type_index.glob_module]
= type_index.glob_object>=size td_infos_of_module || td_infos_of_module.[type_index.glob_object].tdi_group_nr==(-1) = type_index.glob_object>=size td_infos_of_module || td_infos_of_module.[type_index.glob_object].tdi_group_nr==(-1)
is_dictionary _ es_td_infos is_dictionary _ es_td_infos
= False = False
set_cons_var_bit :: !.TypeVar !*(!*{#.Int},!u:(Heap TypeVarInfo)) -> (!.{#Int},!v:(Heap TypeVarInfo)), [u <= v]
set_cons_var_bit {tv_info_ptr} (cons_vars, th_vars) set_cons_var_bit {tv_info_ptr} (cons_vars, th_vars)
# (TVI_Type (TempV i), th_vars) = readPtr tv_info_ptr th_vars # (TVI_Type (TempV i), th_vars) = readPtr tv_info_ptr th_vars
= (set_bit i cons_vars, th_vars) = (set_bit i cons_vars, th_vars)
copy_opt_symbol_type :: !(Optional .SymbolType) !*TypeHeaps -> (!(Optional .SymbolType),!.TypeHeaps)
copy_opt_symbol_type No ti_type_heaps copy_opt_symbol_type No ti_type_heaps
= (No, ti_type_heaps) = (No, ti_type_heaps)
copy_opt_symbol_type (Yes symbol_type=:{st_vars, st_attr_vars, st_args, st_result, st_attr_env}) copy_opt_symbol_type (Yes symbol_type=:{st_vars, st_attr_vars, st_args, st_result, st_attr_env})
...@@ -1514,12 +1517,14 @@ where ...@@ -1514,12 +1517,14 @@ where
= (Yes { symbol_type & st_vars = fresh_st_vars, st_attr_vars = fresh_st_attr_vars, st_args = fresh_st_args, = (Yes { symbol_type & st_vars = fresh_st_vars, st_attr_vars = fresh_st_attr_vars, st_args = fresh_st_args,
st_result = fresh_st_result, st_attr_env = fresh_st_attr_env}, ti_type_heaps) st_result = fresh_st_result, st_attr_env = fresh_st_attr_env}, ti_type_heaps)
add_propagation_attributes :: !{#.CommonDefs} !(Optional .SymbolType) !*(!*TypeHeaps,!*{#*{#.TypeDefInfo}}) -> (!(Optional .SymbolType),!(!.TypeHeaps,!{#.{#TypeDefInfo}}))
add_propagation_attributes common_defs No state add_propagation_attributes common_defs No state
= (No, state) = (No, state)
add_propagation_attributes common_defs (Yes st) state add_propagation_attributes common_defs (Yes st) state
# (st, state) = add_propagation_attributes` common_defs st state # (st, state) = add_propagation_attributes` common_defs st state
= (Yes st, state) = (Yes st, state)
add_propagation_attributes` :: !{#.CommonDefs} !.SymbolType !*(!*TypeHeaps,!*{#*{#.TypeDefInfo}}) -> (!.SymbolType,!(!.TypeHeaps,!{#.{#TypeDefInfo}}))
add_propagation_attributes` common_defs st=:{st_args, st_result, st_attr_env, st_attr_vars} add_propagation_attributes` common_defs st=:{st_args, st_result, st_attr_env, st_attr_vars}
(type_heaps, type_def_infos) (type_heaps, type_def_infos)
# ps = # ps =
...@@ -1541,6 +1546,7 @@ where ...@@ -1541,6 +1546,7 @@ where
state = (ps.prop_type_heaps, ps.prop_td_infos) state = (ps.prop_type_heaps, ps.prop_td_infos)
= (sound_symbol_type, state) = (sound_symbol_type, state)
add_propagation_attributes_to_atype :: !{#.CommonDefs} !.AType !*PropState -> (!AType,!.PropState)
add_propagation_attributes_to_atype modules type ps add_propagation_attributes_to_atype modules type ps
| is_dictionary type ps.prop_td_infos | is_dictionary type ps.prop_td_infos
= (type, ps) = (type, ps)
...@@ -1551,6 +1557,7 @@ where ...@@ -1551,6 +1557,7 @@ where
// add_propagation_attributes_to_atypes modules types ps // add_propagation_attributes_to_atypes modules types ps
// = mapSt (add_propagation_attributes_to_atype modules) types ps // = mapSt (add_propagation_attributes_to_atype modules) types ps
accum_class_type :: !{!.Producer} !.ReadOnlyTI !.Int !(!u:[v:AType],!.b,!.c) -> (!w:[x:AType],!.b,!.c), [u <= w,v <= x]
accum_class_type prods ro i (type_accu, ti_fun_defs, ti_fun_heap) accum_class_type prods ro i (type_accu, ti_fun_defs, ti_fun_heap)
= case prods.[i] of = case prods.[i] of
PR_Class _ _ class_type PR_Class _ _ class_type
...@@ -1558,6 +1565,7 @@ where ...@@ -1558,6 +1565,7 @@ where
_ _
-> (type_accu, ti_fun_defs, ti_fun_heap) -> (type_accu, ti_fun_defs, ti_fun_heap)
accum_function_producer_type :: !{!.Producer} !.ReadOnlyTI !.Int !*(!u:[v:(Optional .SymbolType)],!*{#.FunDef},!*(Heap FunctionInfo)) -> (!w:[x:(Optional SymbolType)],!.{#FunDef},!.(Heap FunctionInfo)), [u <= w,v <= x]
accum_function_producer_type prods ro i (type_accu, ti_fun_defs, ti_fun_heap) accum_function_producer_type prods ro i (type_accu, ti_fun_defs, ti_fun_heap)
= case prods.[size prods-i-1] of = case prods.[size prods-i-1] of
PR_Empty PR_Empty
...@@ -1572,11 +1580,13 @@ where ...@@ -1572,11 +1580,13 @@ where
= get_producer_type symbol ro ti_fun_defs ti_fun_heap = get_producer_type symbol ro ti_fun_defs ti_fun_heap
-> ([Yes symbol_type:type_accu], ti_fun_defs, ti_fun_heap) -> ([Yes symbol_type:type_accu], ti_fun_defs, ti_fun_heap)
collectPropagatingConsVars :: ![AType] !*(Heap TypeVarInfo) -> (!.[TypeVar],!.(Heap TypeVarInfo))
collectPropagatingConsVars type th_vars collectPropagatingConsVars type th_vars
# th_vars # th_vars
= performOnTypeVars initializeToTVI_Empty type th_vars = performOnTypeVars initializeToTVI_Empty type th_vars
= performOnTypeVars collect_unencountered_cons_var type ([], th_vars) = performOnTypeVars collect_unencountered_cons_var type ([], th_vars)
where where
collect_unencountered_cons_var :: !.TypeAttribute !u:TypeVar !*(!v:[w:TypeVar],!*(Heap TypeVarInfo)) -> (!x:[y:TypeVar],!.(Heap TypeVarInfo)), [v <= x,w u <= y]
collect_unencountered_cons_var TA_MultiOfPropagatingConsVar tv=:{tv_info_ptr} (cons_var_accu, th_vars) collect_unencountered_cons_var TA_MultiOfPropagatingConsVar tv=:{tv_info_ptr} (cons_var_accu, th_vars)
# (tvi, th_vars) = readPtr tv_info_ptr th_vars # (tvi, th_vars) = readPtr tv_info_ptr th_vars
= case tvi of = case tvi of
...@@ -1587,6 +1597,7 @@ where ...@@ -1587,6 +1597,7 @@ where
collect_unencountered_cons_var _ _ state collect_unencountered_cons_var _ _ state
= state = state
replace_integers_in_substitution :: (!{!.TypeVar},!{!.TypeAttribute},!{#.Int}) !.Int !*(!*{!Type},!*{#.Bool}) -> (!.{!Type},!.{#Bool})
replace_integers_in_substitution replace_input i (subst, used) replace_integers_in_substitution replace_input i (subst, used)
# (subst_i, subst) # (subst_i, subst)
= subst![i] = subst![i]
...@@ -1604,6 +1615,7 @@ where ...@@ -1604,6 +1615,7 @@ where
No No
-> (subst, coercions, ti_type_def_infos, ti_type_heaps) -> (subst, coercions, ti_type_def_infos, ti_type_heaps)
expand_type :: !{#.CommonDefs} !{#.Int} !.AType !*(!*Coercions,!u:{!.Type},!*TypeHeaps,!*{#*{#.TypeDefInfo}}) -> (!AType,!(!.Coercions,!v:{!Type},!.TypeHeaps,!{#.{#TypeDefInfo}})), [u <= v]
expand_type ro_common_defs cons_vars atype (coercions, subst, ti_type_heaps, ti_type_def_infos) expand_type ro_common_defs cons_vars atype (coercions, subst, ti_type_heaps, ti_type_def_infos)
| is_dictionary atype ti_type_def_infos | is_dictionary atype ti_type_def_infos
# (_, atype, subst) = arraySubst atype subst # (_, atype, subst) = arraySubst atype subst
...@@ -2188,7 +2200,7 @@ bind_to_temp_type_var {tv_info_ptr} (next_type_var_nr, th_vars) ...@@ -2188,7 +2200,7 @@ 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) 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) = (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 :: !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 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 # (app_args, extra_args) = complete_application fun_def.fun_arity app_args extra_args
// | False -!-> ("transformFunctionApplication",app_symb,app_args,extra_args,fun_def.fun_arity,cc_size) = undef // | False -!-> ("transformFunctionApplication",app_symb,app_args,extra_args,fun_def.fun_arity,cc_size) = undef
...@@ -2214,9 +2226,9 @@ transformFunctionApplication fun_def instances cc=:{cc_size, cc_args, cc_linear_ ...@@ -2214,9 +2226,9 @@ transformFunctionApplication fun_def instances cc=:{cc_size, cc_args, cc_linear_
non_var (Var _) = False non_var (Var _) = False
non_var _ = True non_var _ = True
# ok_non_rec_consumer = non_rec_consumer && safe_args # ok_non_rec_consumer = non_rec_consumer && safe_args
# (producers, new_args, ti) #! (producers, new_args, ti)
= determineProducers is_applied_to_macro_fun consumer_is_curried ok_non_rec_consumer fun_def.fun_type cc_linear_bits cc_args app_args 0 (createArray cc_size PR_Empty) ro ti = determineProducers is_applied_to_macro_fun consumer_is_curried ok_non_rec_consumer fun_def.fun_type cc_linear_bits cc_args app_args 0 (createArray cc_size PR_Empty) ro ti
# (arity_changed,new_args,extra_args,producers,cc_args,cc_linear_bits,fun_def,ti) #! (arity_changed,new_args,extra_args,producers,cc_args,cc_linear_bits,fun_def,ti)
= determineCurriedProducersInExtraArgs new_args extra_args is_applied_to_macro_fun producers cc_args cc_linear_bits fun_def ro ti = determineCurriedProducersInExtraArgs new_args extra_args is_applied_to_macro_fun producers cc_args cc_linear_bits fun_def ro ti
| containsProducer cc_size producers || arity_changed | containsProducer cc_size producers || arity_changed
# (is_new, fun_def_ptr, instances, ti_fun_heap) = tryToFindInstance producers instances ti.ti_fun_heap # (is_new, fun_def_ptr, instances, ti_fun_heap) = tryToFindInstance producers instances ti.ti_fun_heap
...@@ -2247,6 +2259,7 @@ where ...@@ -2247,6 +2259,7 @@ where
is_not_caf FK_Caf = False is_not_caf FK_Caf = False
is_not_caf _ = True is_not_caf _ = True
transform_trivial_function :: !.App ![.Expression] ![.Expression] !.ReadOnlyTI !*TransformInfo -> *(!Expression,!*TransformInfo)
transform_trivial_function app=:{app_symb} app_args extra_args ro ti 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_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 # {fun_body=fun_body=:TransformedBody {tb_args,tb_rhs},fun_type} = fun_def
...@@ -2261,6 +2274,7 @@ where ...@@ -2261,6 +2274,7 @@ where
-> (tb_rhs, ti) -> (tb_rhs, ti)
-> (tb_rhs @ extra_args, ti) -> (tb_rhs @ extra_args, ti)
update_instance_info :: !.SymbKind !.InstanceInfo !*TransformInfo -> *TransformInfo
update_instance_info (SK_Function {glob_object}) instances ti=:{ti_instances} update_instance_info (SK_Function {glob_object}) instances ti=:{ti_instances}
= { ti & ti_instances = { ti_instances & [glob_object] = instances } } = { ti & ti_instances = { ti_instances & [glob_object] = instances } }
update_instance_info (SK_LocalMacroFunction glob_object) instances ti=:{ti_instances} update_instance_info (SK_LocalMacroFunction glob_object) instances ti=:{ti_instances}
...@@ -2271,11 +2285,13 @@ where ...@@ -2271,11 +2285,13 @@ where
# (FI_Function fun_info, ti_fun_heap) = readPtr fun_def_ptr ti_fun_heap # (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 })} = { ti & ti_fun_heap = ti_fun_heap <:= (fun_def_ptr, FI_Function { fun_info & gf_instance_info = instances })}
complete_application :: !.Int !.[Expression] !.[Expression] -> (!.[Expression],![Expression])
complete_application form_arity args extra_args complete_application form_arity args extra_args
= (take form_arity all_args,drop form_arity all_args) = (take form_arity all_args,drop form_arity all_args)
where where
all_args = args ++ extra_args all_args = args ++ extra_args
build_application :: !.App ![.Expression] -> Expression
build_application app [] build_application app []
= App app = App app
build_application app extra_args build_application app extra_args
...@@ -2285,6 +2301,7 @@ is_cons_or_decons_of_UList_or_UTSList glob_object glob_module imported_funs ...@@ -2285,6 +2301,7 @@ is_cons_or_decons_of_UList_or_UTSList glob_object glob_module imported_funs
:== let type = imported_funs.[glob_module].[glob_object].ft_type; :== let type = imported_funs.[glob_module].[glob_object].ft_type;
in type.st_arity>0 && not (isEmpty type.st_context); in type.st_arity>0 && not (isEmpty type.st_context);
determineCurriedProducersInExtraArgs :: ![Expression] ![Expression] !Bool !{!.Producer} ![Int] ![Bool] !FunDef !ReadOnlyTI !*TransformInfo -> *(!Bool,![Expression],![Expression],!{!Producer},![Int],![Bool],!FunDef,!*TransformInfo)
determineCurriedProducersInExtraArgs new_args [] is_applied_to_macro_fun producers cc_args cc_linear_bits fun_def ro ti determineCurriedProducersInExtraArgs new_args [] is_applied_to_macro_fun producers cc_args cc_linear_bits fun_def ro ti
= (False,new_args,[],producers,cc_args,cc_linear_bits,fun_def,ti) = (False,new_args,[],producers,cc_args,cc_linear_bits,fun_def,ti)
determineCurriedProducersInExtraArgs new_args extra_args is_applied_to_macro_fun producers cc_args cc_linear_bits fun_def ro ti determineCurriedProducersInExtraArgs new_args extra_args is_applied_to_macro_fun producers cc_args cc_linear_bits fun_def ro ti
...@@ -2620,6 +2637,7 @@ transformApplication app=:{app_symb=symb=:{symb_kind}, app_args} extra_args ...@@ -2620,6 +2637,7 @@ transformApplication app=:{app_symb=symb=:{symb_kind}, app_args} extra_args
| not (isEmpty specials) | not (isEmpty specials)
# (ei,ti_symbol_heap) = mapSt readAppInfo app_args ti.ti_symbol_heap # (ei,ti_symbol_heap) = mapSt readAppInfo app_args ti.ti_symbol_heap
with with
readAppInfo :: !Expression !*ExpressionHeap -> (!ExprInfo,!*ExpressionHeap)
readAppInfo (App {app_info_ptr}) heap readAppInfo (App {app_info_ptr}) heap
| isNilPtr app_info_ptr | isNilPtr app_info_ptr
= (EI_Empty,heap) = (EI_Empty,heap)
...@@ -2635,6 +2653,7 @@ transformApplication app=:{app_symb=symb=:{symb_kind}, app_args} extra_args ...@@ -2635,6 +2653,7 @@ transformApplication app=:{app_symb=symb=:{symb_kind}, app_args} extra_args
= 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 = build_application app app_args extra_args gi ti
where where
build_application :: !.App ![.Expression] ![.Expression] !(Global .Int) !*TransformInfo -> (!Expression,!*TransformInfo)
build_application app app_args extra_args {glob_module,glob_object} ti build_application app app_args extra_args {glob_module,glob_object} ti
| isEmpty extra_args | isEmpty extra_args
= (App {app & app_args = app_args}, ti) = (App {app & app_args = app_args}, ti)
...@@ -2645,7 +2664,7 @@ transformApplication app=:{app_symb=symb=:{symb_kind}, app_args} extra_args ...@@ -2645,7 +2664,7 @@ transformApplication app=:{app_symb=symb=:{symb_kind}, app_args} extra_args
| nr_of_extra_args <= ar_diff | nr_of_extra_args <= ar_diff
= (App {app & app_args = app_args ++ extra_args }, ti) = (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) = (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 build_special_application app app_args extra_args {glob_module,glob_object} ro ti
| isEmpty extra_args | isEmpty extra_args
= (App {app & app_args = app_args}, ti) = (App {app & app_args = app_args}, ti)
...@@ -2656,13 +2675,15 @@ transformApplication app=:{app_symb=symb=:{symb_kind}, app_args} extra_args ...@@ -2656,13 +2675,15 @@ transformApplication app=:{app_symb=symb=:{symb_kind}, app_args} extra_args
| nr_of_extra_args <= ar_diff | nr_of_extra_args <= ar_diff
= (App {app & app_args = app_args ++ extra_args }, ti) = (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) = (App {app & app_args = app_args ++ take ar_diff extra_args } @ drop ar_diff extra_args, ti)
*/
find_member_n :: !Int !String !{#.DefinedSymbol} -> Int
find_member_n i member_string a find_member_n i member_string a
| i<size a | i<size a
| a.[i].ds_ident.id_name % (0,size member_string-1)==member_string | a.[i].ds_ident.id_name % (0,size member_string-1)==member_string
= i = i
= find_member_n (i+1) member_string a = find_member_n (i+1) member_string a
select_member :: !.Expression !(Global .DefinedSymbol) !.Int !*TransformInfo -> *(!Expression,!*TransformInfo)
select_member exp=:(App {app_symb={symb_kind=SK_Constructor _},app_args,app_info_ptr}) select_symb me_offset ti=:{ti_symbol_heap} select_member exp=:(App {app_symb={symb_kind=SK_Constructor _},app_args,app_info_ptr}) select_symb me_offset ti=:{ti_symbol_heap}
| not (isNilPtr app_info_ptr) | not (isNilPtr app_info_ptr)
# (ei,ti_symbol_heap) = readPtr app_info_ptr ti_symbol_heap # (ei,ti_symbol_heap) = readPtr app_info_ptr ti_symbol_heap
...@@ -2693,12 +2714,14 @@ transformApplication app=:{app_symb={symb_name,symb_kind = SK_Constructor cons_i ...@@ -2693,12 +2714,14 @@ transformApplication app=:{app_symb={symb_name,symb_kind = SK_Constructor cons_i
# (app_args,extra_args) = complete_application cons_type.st_arity app_args extra_args # (app_args,extra_args) = complete_application cons_type.st_arity app_args extra_args
= (build_application { app & app_args = app_args } extra_args, ti) = (build_application { app & app_args = app_args } extra_args, ti)
where where
complete_application :: !.Int ![Expression] ![Expression] -> (![Expression],![Expression])
complete_application form_arity args [] complete_application form_arity args []
= (args, []) = (args, [])
complete_application form_arity args extra_args complete_application form_arity args extra_args
# arity_diff = min (form_arity - length args) (length extra_args) # arity_diff = min (form_arity - length args) (length extra_args)
= (args ++ take arity_diff extra_args, drop arity_diff extra_args) = (args ++ take arity_diff extra_args, drop arity_diff extra_args)
build_application :: !.App ![.Expression] -> Expression
build_application app [] build_application app []
= App app = App app
build_application app extra_args build_application app extra_args
...@@ -2771,7 +2794,7 @@ transformSelection selector_kind selectors expr ro ti ...@@ -2771,7 +2794,7 @@ transformSelection selector_kind selectors expr ro ti
// XXX store linear_bits and cc_args together ? // XXX store linear_bits and cc_args together ?
determineProducers :: Bool Bool Bool (Optional SymbolType) [Bool] [Int] [Expression] Int *{!Producer} ReadOnlyTI *TransformInfo -> *(!*{!Producer},![Expression],!*TransformInfo); determineProducers :: !Bool !Bool !Bool !(Optional SymbolType) ![Bool] ![Int] ![Expression] !Int *{!Producer} !ReadOnlyTI !*TransformInfo -> *(!*{!Producer},![Expression],!*TransformInfo);
determineProducers _ _ _ _ _ _ [] _ producers _ ti determineProducers _ _ _ _ _ _ [] _ producers _ ti
= (producers, [], ti) = (producers, [], ti)
determineProducers is_applied_to_macro_fun consumer_is_curried ok_non_rec_consumer fun_type [linear_bit : linear_bits] [ cons_arg : cons_args ] [ arg : args ] prod_index producers ro ti determineProducers is_applied_to_macro_fun consumer_is_curried ok_non_rec_consumer fun_type [linear_bit : linear_bits] [ cons_arg : cons_args ] [ arg : args ] prod_index producers ro ti
...@@ -2779,12 +2802,12 @@ determineProducers is_applied_to_macro_fun consumer_is_curried ok_non_rec_consum ...@@ -2779,12 +2802,12 @@ determineProducers is_applied_to_macro_fun consumer_is_curried ok_non_rec_consum
# (producers, new_arg, ti) = determine_producer is_applied_to_macro_fun consumer_is_curried ok_non_rec_consumer linear_bit arg [] prod_index producers ro ti # (producers, new_arg, ti) = determine_producer is_applied_to_macro_fun consumer_is_curried ok_non_rec_consumer linear_bit arg [] prod_index producers ro ti
| isProducer producers.[prod_index] | isProducer producers.[prod_index]
= (producers, new_arg++args, ti) = (producers, new_arg++args, ti)