Newer
Older
import syntax, transform, checksupport, StdCompare, check, utilities, unitype, typesupport, type,
compilerSwitches
:: PartitioningInfo =
{ pi_marks :: !.{# Int}
, pi_next_num :: !Int
, pi_next_group :: !Int
, pi_groups :: ![[Int]]
, pi_deps :: ![Int]
}
NotChecked :== -1
implies a b :== not a || b
partitionateFunctions :: !*{# FunDef} ![IndexRange] -> (!*{! Group}, !*{# FunDef})
partitionateFunctions fun_defs ranges
#! max_fun_nr = size fun_defs
# partitioning_info = { pi_marks = createArray max_fun_nr NotChecked, pi_deps = [], pi_next_num = 0, pi_next_group = 0, pi_groups = [] }
(fun_defs, {pi_groups,pi_next_group}) =
foldSt (partitionate_functions max_fun_nr) ranges (fun_defs, partitioning_info)
groups = { {group_members = group} \\ group <- reverse pi_groups }
= (groups, fun_defs)
where
partitionate_functions :: !Index !IndexRange !(!*{# FunDef}, !*PartitioningInfo) -> (!*{# FunDef}, !*PartitioningInfo)
partitionate_functions max_fun_nr ir=:{ir_from,ir_to} (fun_defs, pi=:{pi_marks})
| ir_from == ir_to
= (fun_defs, pi)
| pi_marks.[ir_from] == NotChecked
# (_, fun_defs, pi) = partitionate_function ir_from max_fun_nr fun_defs pi
= partitionate_functions max_fun_nr { ir & ir_from = inc ir_from } (fun_defs, pi)
= partitionate_functions max_fun_nr { ir & ir_from = inc ir_from } (fun_defs, pi)
partitionate_function :: !Int !Int !*{# FunDef} !*PartitioningInfo -> *(!Int, !*{# FunDef}, !*PartitioningInfo)
partitionate_function fun_index max_fun_nr fun_defs pi=:{pi_next_num}
# (fd, fun_defs) = fun_defs![fun_index]
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
# {fi_calls} = fd.fun_info
(min_dep, fun_defs, pi) = visit_functions fi_calls max_fun_nr max_fun_nr fun_defs (push_on_dep_stack fun_index pi)
= try_to_close_group fun_index pi_next_num min_dep max_fun_nr fun_defs pi
/*
partitionate_function :: !Int !Int !*{# FunDef} !*PartitioningInfo -> *(!Int, !*{# FunDef}, !*PartitioningInfo)
partitionate_function fun_index max_fun_nr fun_defs pi=:{pi_next_num}
#! fd = fun_defs.[fun_index]
| fd.fun_kind
# {fi_calls} = fd.fun_info
(min_dep, fun_defs, pi) = visit_functions fi_calls max_fun_nr max_fun_nr fun_defs (push_on_dep_stack fun_index pi)
= try_to_close_group fun_index pi_next_num min_dep max_fun_nr fun_defs pi
= (max_fun_nr, fun_defs, pi)
*/
push_on_dep_stack :: !Int !*PartitioningInfo -> *PartitioningInfo;
push_on_dep_stack fun_index pi=:{pi_deps,pi_marks,pi_next_num}
= { pi & pi_deps = [fun_index : pi_deps], pi_marks = { pi_marks & [fun_index] = pi_next_num}, pi_next_num = inc pi_next_num}
visit_functions :: ![FunCall] !Int !Int !*{# FunDef} !*PartitioningInfo -> *(!Int, !*{# FunDef}, !*PartitioningInfo)
visit_functions [{fc_index}:funs] min_dep max_fun_nr fun_defs pi=:{pi_marks}
#! mark = pi_marks.[fc_index]
| mark == NotChecked
# (mark, fun_defs, pi) = partitionate_function fc_index max_fun_nr fun_defs pi
= visit_functions funs (min min_dep mark) max_fun_nr fun_defs pi
= visit_functions funs (min min_dep mark) max_fun_nr fun_defs pi
visit_functions [] min_dep max_fun_nr fun_defs pi
= (min_dep, fun_defs, pi)
try_to_close_group :: !Int !Int !Int !Int !*{# FunDef} !*PartitioningInfo -> *(!Int, !*{# FunDef}, !*PartitioningInfo)
try_to_close_group fun_index fun_nr min_dep max_fun_nr fun_defs pi=:{pi_marks, pi_deps, pi_groups, pi_next_group}
| fun_nr <= min_dep
# (pi_deps, pi_marks, group, fun_defs)
= close_group fun_index pi_deps pi_marks [] max_fun_nr pi_next_group fun_defs
pi = { pi & pi_deps = pi_deps, pi_marks = pi_marks, pi_next_group = inc pi_next_group, pi_groups = [group : pi_groups] }
= (max_fun_nr, fun_defs, pi)
= (min_dep, fun_defs, pi)
where
close_group :: !Int ![Int] !*{# Int} ![Int] !Int !Int !*{# FunDef} -> (![Int], !*{# Int}, ![Int], !*{# FunDef})
close_group fun_index [d:ds] marks group max_fun_nr group_number fun_defs
# marks = { marks & [d] = max_fun_nr }
#! fd = fun_defs.[d]
# fun_defs = { fun_defs & [d] = { fd & fun_info.fi_group_index = group_number }}
| d == fun_index
= (ds, marks, [d : group], fun_defs)
= close_group fun_index ds marks [d : group] max_fun_nr group_number fun_defs
:: BitVector :== Int
:: *AnalyseInfo =
{ ai_var_heap :: !*VarHeap
, ai_cons_class :: !*{! ConsClasses}
, ai_cur_ref_counts :: !*{#Int} // for each variable 0,1 or 2
, ai_class_subst :: !* ConsClassSubst
, ai_next_var :: !Int
, ai_next_var_of_fun :: !Int
, ai_cases_of_vars_for_function :: ![Case]
// , ai_main_dcl_module_n :: !Int
}
:: SharedAI =
{ sai_common_defs :: !{# CommonDefs }
, sai_imported_funs :: !{# {# FunType} }
:: CleanupInfo :== [ExprInfoPtr]
cNoFunArg :== -1
cNope :== -1
/*
The argument classification (i.e. 'accumulating', 'active' or 'passive') of consumers
is represented by a negative integer value.
Positive classifications are used to identify variables.
Unification of classifications is done on-the-fly
*/
cPassive :== -1
cActive :== -2
cAccumulating :== -3
cVarOfMultimatchCase :== -4
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
IsAVariable cons_class :== cons_class >= 0
combineClasses cc1 cc2
| IsAVariable cc1
= cAccumulating
| IsAVariable cc2
= cAccumulating
= min cc1 cc2
unifyClassifications :: !ConsClass !ConsClass !*ConsClassSubst -> *ConsClassSubst
unifyClassifications cc1 cc2 subst
# (cc1,subst) = skip_indirections_of_variables cc1 subst
(cc2,subst) = skip_indirections_of_variables cc2 subst
= combine_cons_classes cc1 cc2 subst
where
skip_indirections_of_variables :: Int !*ConsClassSubst -> (!Int,!*ConsClassSubst)
skip_indirections_of_variables cc subst
| IsAVariable cc
#! cc = skip_indirections cc subst
= (cc, subst)
= (cc, subst)
where
skip_indirections cons_var subst
#! redir = subst.[cons_var]
| IsAVariable redir
= skip_indirections redir subst
= cons_var
combine_cons_classes :: !Int !Int !*ConsClassSubst -> *ConsClassSubst
combine_cons_classes cc1 cc2 subst
| cc1 == cc2
= subst
| IsAVariable cc1
#! cc_val1 = subst.[cc1]
| IsAVariable cc2
#! cc_val2 = subst.[cc2]
= { subst & [cc2] = cc1, [cc1] = combine_cons_constants cc_val1 cc_val2 }
= { subst & [cc1] = combine_cons_constants cc_val1 cc2 }
| IsAVariable cc2
#! cc_val2 = subst.[cc2]
= { subst & [cc2] = combine_cons_constants cc1 cc_val2 }
= subst
combine_cons_constants cc1 cc2
= min cc1 cc2
write_ptr ptr val heap mess
| isNilPtr ptr
= abort mess
= heap <:= (ptr,val)
readVarInfo :: VarInfoPtr *VarHeap -> (VarInfo, !*VarHeap)
readVarInfo var_info_ptr var_heap
# (var_info, var_heap) = readPtr var_info_ptr var_heap
= case var_info of
VI_Extended _ original_var_info -> (original_var_info, var_heap)
_ -> (var_info, var_heap)
writeVarInfo :: VarInfoPtr VarInfo *VarHeap -> *VarHeap
writeVarInfo var_info_ptr new_var_info var_heap
# (old_var_info, var_heap) = readPtr var_info_ptr var_heap
= case old_var_info of
VI_Extended extensions _ -> writePtr var_info_ptr (VI_Extended extensions new_var_info) var_heap
_ -> writePtr var_info_ptr new_var_info var_heap
:: ConsumerAnalysisRO = ConsumerAnalysisRO !ConsumerAnalysisRORecord;
:: ConsumerAnalysisRORecord = {common_defs::!{# CommonDefs},imported_funs::!{#{#FunType}},main_dcl_module_n::!Int,stdStrictLists_module_n::!Int}
class consumerRequirements a :: !a !ConsumerAnalysisRO !AnalyseInfo -> (!ConsClass, !UnsafePatternBool, !AnalyseInfo)
:: UnsafePatternBool :== Bool
not_an_unsafe_pattern (cc, _, ai) = (cc, False, ai)
instance consumerRequirements BoundVar
where
consumerRequirements {var_name,var_info_ptr} _ ai=:{ai_var_heap}
# (var_info, ai_var_heap) = readPtr var_info_ptr ai_var_heap
= continuation var_info { ai & ai_var_heap=ai_var_heap }
where
continuation (VI_AccVar temp_var arg_position) ai=:{ai_cur_ref_counts}
// | arg_position<0
// = (temp_var, ai)
#! ref_count = ai_cur_ref_counts.[arg_position]
ai_cur_ref_counts = { ai_cur_ref_counts & [arg_position]=min (ref_count+1) 2 }
= (temp_var, False, { ai & ai_cur_ref_counts=ai_cur_ref_counts })
= abort ("consumerRequirements" ---> (var_name))// <<- var_info))
// continuation vi ai
// = (cPassive, ai)
instance consumerRequirements Expression where
consumerRequirements (Var var) common_defs ai
= consumerRequirements var common_defs ai
consumerRequirements (App app) common_defs ai
= consumerRequirements app common_defs ai
consumerRequirements (fun_expr @ exprs) common_defs ai
# (cc_fun, _, ai) = consumerRequirements fun_expr common_defs ai
ai_class_subst = unifyClassifications cActive cc_fun ai.ai_class_subst
= consumerRequirements exprs common_defs { ai & ai_class_subst = ai_class_subst }
consumerRequirements (Let {let_strict_binds, let_lazy_binds,let_expr}) common_defs ai=:{ai_next_var,ai_next_var_of_fun,ai_var_heap}
# let_binds = let_strict_binds ++ let_lazy_binds
# (new_next_var, new_ai_next_var_of_fun, ai_var_heap) = init_variables let_binds ai_next_var ai_next_var_of_fun ai_var_heap
# ai = acc_requirements_of_let_binds let_binds ai_next_var common_defs
{ ai & ai_next_var = new_next_var, ai_next_var_of_fun = new_ai_next_var_of_fun, ai_var_heap = ai_var_heap }
= consumerRequirements let_expr common_defs ai // XXX why not not_an_unsafe_pattern
init_variables [{lb_dst={fv_name, fv_count, fv_info_ptr}} : binds] ai_next_var ai_next_var_of_fun ai_var_heap
| fv_count > 0
= init_variables binds (inc ai_next_var) (inc ai_next_var_of_fun)
(writePtr fv_info_ptr (VI_AccVar ai_next_var ai_next_var_of_fun) ai_var_heap)
= init_variables binds ai_next_var ai_next_var_of_fun ai_var_heap
init_variables [] ai_next_var ai_next_var_of_fun ai_var_heap
= (ai_next_var, ai_next_var_of_fun, ai_var_heap)
acc_requirements_of_let_binds [ {lb_src, lb_dst} : binds ] ai_next_var common_defs ai
| lb_dst.fv_count > 0
# (bind_var, _, ai) = consumerRequirements lb_src common_defs ai
ai_class_subst = unifyClassifications ai_next_var bind_var ai.ai_class_subst
= acc_requirements_of_let_binds binds (inc ai_next_var) common_defs { ai & ai_class_subst = ai_class_subst }
= acc_requirements_of_let_binds binds ai_next_var common_defs ai
acc_requirements_of_let_binds [] ai_next_var _ ai
consumerRequirements (Case case_expr) common_defs ai
= consumerRequirements case_expr common_defs ai
consumerRequirements (BasicExpr _ _) _ ai
= (cPassive, False, ai)
consumerRequirements (MatchExpr _ _ expr) common_defs ai
= consumerRequirements expr common_defs ai
consumerRequirements (Selection _ expr selectors) common_defs ai
# (cc, _, ai) = consumerRequirements expr common_defs ai
ai_class_subst = unifyClassifications cActive cc ai.ai_class_subst
ai = requirementsOfSelectors selectors common_defs { ai & ai_class_subst = ai_class_subst }
= (cPassive, False, ai)
consumerRequirements (Update expr1 selectors expr2) common_defs ai
# (cc, _, ai) = consumerRequirements expr1 common_defs ai
ai = requirementsOfSelectors selectors common_defs ai
(cc, _, ai) = consumerRequirements expr2 common_defs ai
= (cPassive, False, ai)
consumerRequirements (RecordUpdate cons_symbol expression expressions) common_defs ai
# (cc, _, ai) = consumerRequirements expression common_defs ai
(cc, _, ai) = consumerRequirements expressions common_defs ai
= (cPassive, False, ai)
consumerRequirements (TupleSelect tuple_symbol arg_nr expr) common_defs ai
= consumerRequirements expr common_defs ai
consumerRequirements (AnyCodeExpr _ _ _) _ ai
= (cPassive, False, ai)
consumerRequirements (ABCCodeExpr _ _) _ ai
= (cPassive, False, ai)
consumerRequirements (DynamicExpr dynamic_expr) common_defs ai
= consumerRequirements dynamic_expr common_defs ai
consumerRequirements (TypeCodeExpression _) _ ai
= (cPassive, False, ai)
consumerRequirements EE _ ai
= (cPassive, False, ai)
consumerRequirements (NoBind _) _ ai
= (cPassive, False, ai)
consumerRequirements expr _ ai
requirementsOfSelectors selectors common_defs ai
= foldSt (reqs_of_selector common_defs) selectors ai
reqs_of_selector common_defs (ArraySelection _ _ index_expr) ai
# (_, _, ai) = consumerRequirements index_expr common_defs ai
reqs_of_selector common_defs (DictionarySelection dict_var _ _ index_expr) ai
# (_, _, ai) = consumerRequirements index_expr common_defs ai
(cc_var, _, ai) = consumerRequirements dict_var common_defs ai
= { ai & ai_class_subst = unifyClassifications cActive cc_var ai.ai_class_subst }
reqs_of_selector _ _ ai
= ai
instance consumerRequirements App where
consumerRequirements {app_symb={symb_kind = SK_Function {glob_module,glob_object}, symb_arity, symb_name}, app_args} common_defs=:(ConsumerAnalysisRO {main_dcl_module_n,stdStrictLists_module_n,imported_funs}) ai=:{ai_cons_class/*,ai_main_dcl_module_n*/}
| glob_module == main_dcl_module_n//ai_main_dcl_module_n
| glob_object < size ai_cons_class
#! fun_class = ai_cons_class.[glob_object]
= reqs_of_args fun_class.cc_args app_args cPassive common_defs ai
= consumerRequirements app_args common_defs ai
| glob_module==stdStrictLists_module_n && symb_arity>0
# name=symb_name.id_name
| is_nil_cons_or_decons_of_UList_or_UTSList glob_object glob_module imported_funs
// && trace_tn ("consumerRequirements "+++name+++" "+++toString imported_funs.[glob_module].[glob_object].ft_type.st_arity)
# [app_arg:app_args]=app_args;
# (cc, _, ai) = consumerRequirements app_arg common_defs ai
# ai_class_subst = unifyClassifications cActive cc ai.ai_class_subst
# ai={ ai & ai_class_subst = ai_class_subst }
= consumerRequirements app_args common_defs ai
= consumerRequirements app_args common_defs ai
= consumerRequirements app_args common_defs ai
consumerRequirements {app_symb={symb_kind = SK_LocalMacroFunction glob_object, symb_arity, symb_name}, app_args} common_defs=:(ConsumerAnalysisRO {main_dcl_module_n}) ai=:{ai_cons_class/*,ai_main_dcl_module_n*/}
| glob_object < size ai_cons_class
#! fun_class = ai_cons_class.[glob_object]
= reqs_of_args fun_class.cc_args app_args cPassive common_defs ai
= consumerRequirements app_args common_defs ai
consumerRequirements {app_args} common_defs ai
= not_an_unsafe_pattern (consumerRequirements app_args common_defs ai)
reqs_of_args _ [] cumm_arg_class _ ai
= (cumm_arg_class, False, ai)
reqs_of_args [] _ cumm_arg_class _ ai
= (cumm_arg_class, False, ai)
reqs_of_args [form_cc : ccs] [arg : args] cumm_arg_class common_defs ai
# (act_cc, _, ai) = consumerRequirements arg common_defs ai
ai_class_subst = unifyClassifications form_cc act_cc ai.ai_class_subst
= reqs_of_args ccs args (combineClasses act_cc cumm_arg_class) common_defs { ai & ai_class_subst = ai_class_subst }
instance consumerRequirements Case where
consumerRequirements kees=:{case_expr,case_guards,case_default,case_info_ptr} common_defs=:(ConsumerAnalysisRO {common_defs=common_defs_parameter}) ai
# (cce, _, ai) = consumerRequirements case_expr common_defs ai
(ccgs, unsafe_bits, ai) = consumer_requirements_of_guards case_guards common_defs ai
has_default = case case_default of
Yes _ -> True
_ -> False
(ccd, default_is_unsafe, ai) = consumerRequirements case_default common_defs ai
(every_constructor_appears_in_safe_pattern, may_be_active) = inspect_patterns common_defs_parameter has_default case_guards unsafe_bits
safe = (has_default && not default_is_unsafe) || every_constructor_appears_in_safe_pattern
ai_class_subst = unifyClassifications (if may_be_active cActive cVarOfMultimatchCase) cce ai.ai_class_subst
ai = { ai & ai_class_subst = ai_class_subst }
ai = case case_expr of
Var {var_info_ptr}
| may_be_active
-> { ai & ai_cases_of_vars_for_function=[kees:ai.ai_cases_of_vars_for_function] }
-> ai
_ -> ai
# ai = case case_guards of
OverloadedListPatterns (OverloadedList _ _ _ _) decons_expr=:(App {app_symb={symb_arity=1,symb_kind=SK_Function _},app_args=[app_arg]}) patterns
// decons_expr will be optimized to a decons_u Selector in transform
# (cc, _, ai) = consumerRequirements app_arg common_defs ai
# ai_class_subst = unifyClassifications cActive cc ai.ai_class_subst
-> { ai & ai_class_subst = ai_class_subst }
OverloadedListPatterns _ decons_expr _
# (_,_,ai) = consumerRequirements decons_expr common_defs ai
-> ai
_
-> ai
= (combineClasses ccgs ccd, not safe, ai)
where
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]
defined_symbols = case type_def.td_rhs of
AlgType defined_symbols -> defined_symbols
RecordType {rt_constructor} -> [rt_constructor]
all_constructors = [ ds_index \\ {ds_index}<-defined_symbols ]
pattern_constructors = [ glob_object.ds_index \\ {ap_symbol={glob_object}}<-algebraic_patterns]
sorted_pattern_constructors = sort pattern_constructors unsafe_bits
all_sorted_constructors = if (is_sorted all_constructors) all_constructors (sortBy (<) all_constructors)
= (appearance_loop all_sorted_constructors sorted_pattern_constructors, not (multimatch_loop has_default sorted_pattern_constructors))
inspect_patterns common_defs has_default (BasicPatterns BT_Bool basic_patterns) unsafe_bits
# bools_indices = [ if bool 1 0 \\ {bp_value=BVB bool}<-basic_patterns ]
sorted_pattern_constructors = sort bools_indices unsafe_bits
= (appearance_loop [0,1] sorted_pattern_constructors,
not (multimatch_loop has_default sorted_pattern_constructors))
// inspect_patterns common_defs has_default (OverloadedListPatterns {glob_object, glob_module} algebraic_patterns) unsafe_bits
inspect_patterns common_defs has_default (OverloadedListPatterns overloaded_list _ algebraic_patterns) unsafe_bits
# type_def = case overloaded_list of
UnboxedList {glob_object, glob_module} _ _ _
-> common_defs.[glob_module].com_type_defs.[glob_object]
UnboxedTailStrictList {glob_object, glob_module} _ _ _
-> common_defs.[glob_module].com_type_defs.[glob_object]
OverloadedList {glob_object, glob_module} _ _ _
-> common_defs.[glob_module].com_type_defs.[glob_object]
defined_symbols = case type_def.td_rhs of
AlgType defined_symbols -> defined_symbols
RecordType {rt_constructor} -> [rt_constructor]
all_constructors = [ ds_index \\ {ds_index}<-defined_symbols ]
pattern_constructors = [ glob_object.ds_index \\ {ap_symbol={glob_object}}<-algebraic_patterns]
sorted_pattern_constructors = sort pattern_constructors unsafe_bits
all_sorted_constructors = if (is_sorted all_constructors) all_constructors (sortBy (<) all_constructors)
= (appearance_loop all_sorted_constructors sorted_pattern_constructors, not (multimatch_loop has_default sorted_pattern_constructors))
inspect_patterns _ _ _ _
is_sorted [x]
= True
is_sorted [h1:t=:[h2:_]]
= h1 < h2 && is_sorted t
sort constr_indices unsafe_bits
= sortBy smaller (zip3 constr_indices [0..] unsafe_bits)
where
smaller (i1,si1,_) (i2,si2,_)
| i1<i2 = True
| i1>i2 = False
= si1<si2
zip3 [h1:t1] [h2:t2] [h3:t3]
= [(h1,h2,h3):zip3 t1 t2 t3]
zip3 _ _ _
= []
appearance_loop [] _
= True
appearance_loop _ []
= False
appearance_loop l1=:[constructor_in_type:constructors_in_type] [(constructor_in_pattern,_,is_unsafe_pattern):constructors_in_pattern]
| constructor_in_type < constructor_in_pattern
= False
// constructor_in_type==constructor_in_pattern
| is_unsafe_pattern
// maybe there is another pattern that is safe for this constructor
= appearance_loop l1 constructors_in_pattern
// the constructor will match safely. Skip over patterns with the same constructor and test the following constructor
= appearance_loop constructors_in_type (dropWhile (\(ds_index,_,_)->ds_index==constructor_in_pattern) constructors_in_pattern)
= False
= a_loop has_default cip iup t
where
a_loop has_default cip iup []
= iup && has_default
a_loop has_default cip iup [(constructor_in_pattern, _, is_unsafe_pattern):constructors_in_pattern]
| cip<constructor_in_pattern
| iup && has_default
= True
= a_loop has_default constructor_in_pattern is_unsafe_pattern constructors_in_pattern
| iup
= True
= multimatch_loop has_default (dropWhile (\(ds_index,_,_)->ds_index==cip) constructors_in_pattern)
instance consumerRequirements DynamicExpr where
consumerRequirements {dyn_expr} common_defs ai
= consumerRequirements dyn_expr common_defs ai
bindPatternVars [fv=:{fv_info_ptr,fv_count} : vars] next_var next_var_of_fun var_heap
= bindPatternVars vars (inc next_var) (inc next_var_of_fun) (writePtr fv_info_ptr (VI_AccVar next_var next_var_of_fun) var_heap)
= bindPatternVars vars next_var next_var_of_fun (writePtr fv_info_ptr (VI_Count 0 False) var_heap)
bindPatternVars [] next_var next_var_of_fun var_heap
= (next_var, next_var_of_fun, var_heap)
consumer_requirements_of_guards (AlgebraicPatterns type patterns) common_defs ai
# pattern_exprs = [ ap_expr \\ {ap_expr}<-patterns]
pattern_vars = flatten [ ap_vars \\ {ap_vars}<-patterns]
(ai_next_var, ai_next_var_of_fun, ai_var_heap) = bindPatternVars pattern_vars ai.ai_next_var ai.ai_next_var_of_fun ai.ai_var_heap
ai = { ai & ai_var_heap=ai_var_heap, ai_next_var=ai_next_var, ai_next_var_of_fun = ai_next_var_of_fun }
= independentConsumerRequirements pattern_exprs common_defs ai
consumer_requirements_of_guards (BasicPatterns type patterns) common_defs ai
# pattern_exprs = [ bp_expr \\ {bp_expr}<-patterns]
= independentConsumerRequirements pattern_exprs common_defs ai
consumer_requirements_of_guards (OverloadedListPatterns type _ patterns) common_defs ai
# pattern_exprs = [ ap_expr \\ {ap_expr}<-patterns]
pattern_vars = flatten [ ap_vars \\ {ap_vars}<-patterns]
(ai_next_var, ai_next_var_of_fun, ai_var_heap) = bindPatternVars pattern_vars ai.ai_next_var ai.ai_next_var_of_fun ai.ai_var_heap
ai = { ai & ai_var_heap=ai_var_heap, ai_next_var=ai_next_var, ai_next_var_of_fun = ai_next_var_of_fun }
= independentConsumerRequirements pattern_exprs common_defs ai
instance consumerRequirements BasicPattern where
consumerRequirements {bp_expr} common_defs ai
= consumerRequirements bp_expr common_defs ai
instance consumerRequirements (Optional a) | consumerRequirements a where
consumerRequirements (Yes x) common_defs ai
= consumerRequirements x common_defs ai
consumerRequirements No _ ai
= (cPassive, False, ai)
instance consumerRequirements (!a,!b) | consumerRequirements a & consumerRequirements b where
consumerRequirements (x, y) common_defs ai
# (ccx, _, ai) = consumerRequirements x common_defs ai
(ccy, _, ai) = consumerRequirements y common_defs ai
= (combineClasses ccx ccy, False, ai)
instance consumerRequirements [a] | consumerRequirements a where
consumerRequirements [x : xs] common_defs ai
# (ccx, _, ai) = consumerRequirements x common_defs ai
(ccxs, _, ai) = consumerRequirements xs common_defs ai
= (combineClasses ccx ccxs, False, ai)
consumerRequirements [] _ ai
= (cPassive, False, ai)
instance consumerRequirements (Bind a b) | consumerRequirements a where
consumerRequirements {bind_src} common_defs ai
= consumerRequirements bind_src common_defs ai
independentConsumerRequirements exprs common_defs ai=:{ai_cur_ref_counts}
// reference counting happens independently for each pattern expression
#! s = size ai_cur_ref_counts
zero_array = createArray s 0
(_, cc, r_unsafe_bits ,ai) = foldSt (independent_consumer_requirements common_defs) exprs (zero_array, cPassive, [], ai)
= (cc, reverse r_unsafe_bits, ai)
independent_consumer_requirements common_defs expr (zero_array, cc, unsafe_bits_accu, ai=:{ai_cur_ref_counts})
#! s = size ai_cur_ref_counts
ai = { ai & ai_cur_ref_counts=zero_array }
(cce, is_unsafe_case, ai) = consumerRequirements expr common_defs ai
(unused, unified_ref_counts) = unify_ref_count_arrays s ai_cur_ref_counts ai.ai_cur_ref_counts
ai = { ai & ai_cur_ref_counts=unified_ref_counts }
= ({ unused & [i]=0 \\ i<-[0..s-1]}, combineClasses cce cc, [is_unsafe_case:unsafe_bits_accu], ai)
unify_ref_count_arrays 0 src1 src2_dest
= (src1, src2_dest)
unify_ref_count_arrays i src1 src2_dest
#! i1 = dec i
rc1 = src1.[i1]
rc2 = src2_dest.[i1]
= unify_ref_count_arrays i1 src1 { src2_dest & [i1]= unify_ref_counts rc1 rc2}
// unify_ref_counts outer_ref_count ref_count_in_pattern
unify_ref_counts 0 x = if (x==2) 2 0
unify_ref_counts 1 x = if (x==0) 1 2
unify_ref_counts 2 _ = 2
analyseGroups :: !{# CommonDefs} !{#{#FunType}} !IndexRange !Int !Int !*{! Group} !*{#FunDef} !*VarHeap !*ExpressionHeap
-> (!CleanupInfo, !*{! ConsClasses}, !*{! Group}, !*{#FunDef}, !*VarHeap, !*ExpressionHeap)
analyseGroups common_defs imported_funs {ir_from, ir_to} main_dcl_module_n stdStrictLists_module_n groups fun_defs var_heap expr_heap
#! nr_of_funs = size fun_defs + ir_from - ir_to /* Sjaak */
nr_of_groups = size groups
# consumerAnalysisRO=ConsumerAnalysisRO {common_defs=common_defs,imported_funs=imported_funs,main_dcl_module_n=main_dcl_module_n,stdStrictLists_module_n=stdStrictLists_module_n}
= iFoldSt (analyse_group consumerAnalysisRO) 0 nr_of_groups
([], createArray nr_of_funs { cc_size = 0, cc_args = [], cc_linear_bits = []}, groups, fun_defs, var_heap, expr_heap)
analyse_group common_defs group_nr (cleanup_info, class_env, groups, fun_defs, var_heap, expr_heap)
# ({group_members}, groups) = groups![group_nr]
# (nr_of_vars, nr_of_local_vars, var_heap, class_env, fun_defs) = initial_cons_class group_members 0 0 var_heap class_env fun_defs
initial_subst = createArray (nr_of_vars + nr_of_local_vars) cPassive
(ai_cases_of_vars_for_group, ai, fun_defs)
= analyse_functions common_defs group_members []
{ ai_var_heap = var_heap,
ai_cons_class = class_env,
ai_cur_ref_counts = {}, ai_class_subst = initial_subst,
ai_next_var = nr_of_vars,
ai_next_var_of_fun = 0,
ai_cases_of_vars_for_function = [] //,
// ai_main_dcl_module_n=main_dcl_module_n
} fun_defs
class_env = collect_classifications group_members ai.ai_cons_class ai.ai_class_subst
(cleanup_info, class_env, fun_defs, var_heap, expr_heap)
= foldSt set_case_expr_info (flatten ai_cases_of_vars_for_group) (cleanup_info,class_env, fun_defs, ai.ai_var_heap, expr_heap)
= (cleanup_info, class_env, groups, fun_defs, var_heap, expr_heap)
where
set_case_expr_info ({case_expr=case_expr=:(Var {var_info_ptr}), case_guards, case_info_ptr},fun_index) (cleanup_acc, class_env, fun_defs, var_heap, expr_heap)
# (VI_AccVar _ arg_position, var_heap) = readPtr var_info_ptr var_heap
({cc_size, cc_args, cc_linear_bits},class_env) = class_env![fun_index]
(aci_linearity_of_patterns, var_heap) = get_linearity_info cc_linear_bits case_guards var_heap
| arg_position<cc_size && (arg_position>=cc_size || cc_args!!arg_position==cActive) && cc_linear_bits!!arg_position
// mark non multimatch cases whose case_expr is an active linear function argument
# aci = { aci_params = [], aci_opt_unfolder = No, aci_free_vars=No, aci_linearity_of_patterns = aci_linearity_of_patterns }
= ([case_info_ptr:cleanup_acc], class_env, fun_defs, var_heap,
set_extended_expr_info case_info_ptr (EEI_ActiveCase aci) expr_heap)
= (cleanup_acc, class_env, fun_defs, var_heap, expr_heap)
get_linearity_info cc_linear_bits (AlgebraicPatterns _ algebraic_patterns) var_heap
= mapSt (get_linearity_info_of_pattern cc_linear_bits) algebraic_patterns var_heap
get_linearity_info cc_linear_bits (OverloadedListPatterns _ _ algebraic_patterns) var_heap
= mapSt (get_linearity_info_of_pattern cc_linear_bits) algebraic_patterns var_heap
get_linearity_info cc_linear_bits _ var_heap
= ([], var_heap)
get_linearity_info_of_pattern cc_linear_bits {ap_vars} var_heap
# (var_indices, var_heap) = mapSt get_var_index ap_vars var_heap
= ([if (index==cNope) True (cc_linear_bits!!index) \\ index<-var_indices], var_heap)
get_var_index {fv_info_ptr} var_heap
# (vi, var_heap) = readPtr fv_info_ptr var_heap
index = case vi of
VI_AccVar _ index -> index
VI_Count 0 False -> cNope
= (index, var_heap)
initial_cons_class [fun : funs] next_var_number nr_of_local_vars var_heap class_env fun_defs
# (fun_def, fun_defs) = fun_defs![fun]
(fresh_vars, next_var_number, var_heap) = fresh_variables tb_args 0 next_var_number var_heap
= initial_cons_class funs next_var_number (length fun_def.fun_info.fi_local_vars + nr_of_local_vars) var_heap
{ class_env & [fun] = { cc_size = 0, cc_args = fresh_vars, cc_linear_bits=[]}} fun_defs
initial_cons_class [] next_var_number nr_of_local_vars var_heap class_env fun_defs
= (next_var_number, nr_of_local_vars, var_heap, class_env, fun_defs)
fresh_variables [{fv_name,fv_info_ptr} : vars] arg_position next_var_number var_heap
# (fresh_vars, last_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)
fresh_variables [] _ next_var_number var_heap
analyse_functions common_defs [fun : funs] cfvog_accu ai fun_defs
# (fun_def, fun_defs) = fun_defs![fun]
(TransformedBody {tb_args, tb_rhs}) = fun_def.fun_body
nr_of_args = length tb_args
ai = { ai & ai_cur_ref_counts = createArray (nr_of_args + length fun_def.fun_info.fi_local_vars) 0,
ai_next_var_of_fun = nr_of_args }
(_, _, ai) = consumerRequirements tb_rhs common_defs ai
ai_cur_ref_counts = ai.ai_cur_ref_counts
ai = { ai & ai_cur_ref_counts={} }
ai_cons_class = update_array_element ai.ai_cons_class fun
(\cc->{ cc & cc_linear_bits=[ ref_count<2 \\ ref_count<-:ai_cur_ref_counts] })
cases_of_vars_for_function = [(a,fun) \\ a<-ai.ai_cases_of_vars_for_function ]
ai = { ai & ai_cons_class=ai_cons_class, ai_cases_of_vars_for_function=[] }
= analyse_functions common_defs funs [cases_of_vars_for_function:cfvog_accu] ai fun_defs
where
update_array_element array index transition
# (before, array) = array![index]
= { array & [index]=transition before }
analyse_functions common_defs [] cfvog_accu ai fun_defs
= (cfvog_accu, ai, fun_defs)
collect_classifications [] class_env class_subst
= class_env
collect_classifications [fun : funs] class_env class_subst
# (fun_class, class_env) = class_env![fun]
# fun_class = determine_classification fun_class class_subst
Martin Wierich
committed
= collect_classifications funs { class_env & [fun] = fun_class /*---> (fun, fun_class)*/} class_subst
where
determine_classification cc class_subst
# (cc_size, cc_args) = mapAndLength (skip_indirections class_subst) cc.cc_args
= { cc & cc_size = cc_size, cc_args = cc_args }
skip_indirections class_subst cc
| IsAVariable cc
= skip_indirections class_subst class_subst.[cc]
= cc
mapAndLength f [x : xs]
#! x = f x
(length, xs) = mapAndLength f xs
= (inc length, [x : xs])
mapAndLength f []
= (0, [])
:: TransformInfo =
{ ti_fun_defs :: !.{# FunDef}
, ti_instances :: !.{! InstanceInfo }
, ti_cons_args :: !{! ConsClasses}
, ti_new_functions :: ![FunctionInfoPtr]
, ti_fun_heap :: !.FunctionHeap
, ti_var_heap :: !.VarHeap
, ti_symbol_heap :: !.ExpressionHeap
, ti_type_heaps :: !.TypeHeaps
, ti_type_def_infos :: !.TypeDefInfos
, ti_next_fun_nr :: !Index
, ti_cleanup_info :: !CleanupInfo
, ti_recursion_introduced :: !Optional Index
, ti_trace :: !Bool // XXX just for tracing
:: ReadOnlyTI =
{ ro_imported_funs :: !{# {# FunType} }
, ro_common_defs :: !{# CommonDefs }
, ro_root_case_mode :: !RootCaseMode
, ro_fun :: !SymbIdent
, ro_fun_args :: ![FreeVar]
, ro_stdStrictLists_module_n :: !Int
:: RootCaseMode = NotRootCase | RootCase | RootCaseOfZombie
class transform a :: !a !ReadOnlyTI !*TransformInfo -> (!a, !*TransformInfo)
transform expr=:(App app=:{app_symb,app_args}) ro ti
# (app_args, ti) = transform app_args ro ti
= transformApplication { app & app_args = app_args } [] ro ti
transform appl_expr=:(expr @ exprs) ro ti
# (expr, ti) = transform expr ro ti
(exprs, ti) = transform exprs ro ti
-> transformApplication app exprs ro ti
transform (Let lad=:{let_strict_binds, let_lazy_binds, let_expr}) ro ti
# ti = store_type_info_of_bindings_in_heap lad ti
(let_strict_binds, ti) = transform let_strict_binds ro ti
(let_lazy_binds, ti) = transform let_lazy_binds ro ti
(let_expr, ti) = transform let_expr ro ti
= (Let { lad & let_lazy_binds = let_lazy_binds, let_strict_binds = let_strict_binds, let_expr = let_expr}, ti)
where
store_type_info_of_bindings_in_heap {let_strict_binds, let_lazy_binds,let_info_ptr} ti
# let_binds = let_strict_binds ++ let_lazy_binds
# (EI_LetType var_types, ti_symbol_heap) = readExprInfo let_info_ptr ti.ti_symbol_heap
ti_var_heap = foldSt (\(var_type, {lb_dst={fv_info_ptr}}) var_heap
->setExtendedVarInfo fv_info_ptr (EVI_VarType var_type) var_heap)
(zip2 var_types let_binds) ti.ti_var_heap
= { ti & ti_symbol_heap = ti_symbol_heap, ti_var_heap = ti_var_heap }
transform (Case kees) ro ti
# ti = store_type_info_of_patterns_in_heap kees ti
= transformCase kees ro ti
where
store_type_info_of_patterns_in_heap {case_guards,case_info_ptr} ti
= case case_guards of
AlgebraicPatterns _ patterns
# (EI_CaseType {ct_cons_types},ti_symbol_heap) = readExprInfo case_info_ptr ti.ti_symbol_heap
ti_var_heap = foldSt store_type_info_of_alg_pattern (zip2 ct_cons_types patterns) ti.ti_var_heap
-> { ti & ti_symbol_heap = ti_symbol_heap, ti_var_heap = ti_var_heap }
BasicPatterns _ _
-> ti // no variables occur
OverloadedListPatterns _ _ patterns
# (EI_CaseType {ct_cons_types},ti_symbol_heap) = readExprInfo case_info_ptr ti.ti_symbol_heap
ti_var_heap = foldSt store_type_info_of_alg_pattern (zip2 ct_cons_types patterns) ti.ti_var_heap
-> { ti & ti_symbol_heap = ti_symbol_heap, ti_var_heap = ti_var_heap }
NoPattern
-> ti
store_type_info_of_alg_pattern (var_types,{ap_vars}) var_heap
= foldSt (\(var_type, {fv_info_ptr}) var_heap
->setExtendedVarInfo fv_info_ptr (EVI_VarType var_type) var_heap) (zip2 var_types ap_vars) var_heap
transform (Selection opt_type expr selectors) ro ti
# (expr, ti) = transform expr ro ti
= transformSelection opt_type selectors expr ti
John van Groningen
committed
transform (Update expr1 selectors expr2) ro ti
# (expr1,ti) = transform expr1 ro ti
John van Groningen
committed
# (selectors,ti) = transform_expressions_in_selectors selectors ti
with
transform_expressions_in_selectors [selection=:RecordSelection _ _ : selections] ti
# (selections,ti) = transform_expressions_in_selectors selections ti
= ([selection:selections],ti)
transform_expressions_in_selectors [ArraySelection ds ep expr : selections] ti
# (expr,ti) = transform expr ro ti
# (selections,ti) = transform_expressions_in_selectors selections ti
= ([ArraySelection ds ep expr:selections],ti)
transform_expressions_in_selectors [DictionarySelection bv dictionary_selections ep expr : selections] ti
# (expr,ti) = transform expr ro ti
# (dictionary_selections,ti) = transform_expressions_in_selectors dictionary_selections ti
# (selections,ti) = transform_expressions_in_selectors selections ti
= ([DictionarySelection bv dictionary_selections ep expr:selections],ti)
transform_expressions_in_selectors [] ti
= ([],ti)
John van Groningen
committed
# (expr2,ti) = transform expr2 ro ti
= (Update expr1 selectors expr2,ti)
transform (RecordUpdate cons_symbol expr exprs) ro ti
# (expr,ti) = transform expr ro ti
# (exprs,ti) = transform_fields exprs ro ti
=(RecordUpdate cons_symbol expr exprs,ti)
where
transform_fields [] ro ti
= ([],ti)
transform_fields [bind=:{bind_src} : fields] ro ti
# (bind_src,ti) = transform bind_src ro ti
# (fields,ti) = transform_fields fields ro ti
= ([{bind & bind_src=bind_src} : fields],ti)
transform (TupleSelect a1 arg_nr expr) ro ti
# (expr,ti) = transform expr ro ti
= (TupleSelect a1 arg_nr expr,ti)
transform (MatchExpr a1 a2 expr) ro ti
# (expr,ti) = transform expr ro ti
= (MatchExpr a1 a2 expr,ti)
transform (DynamicExpr dynamic_expr) ro ti
# (dynamic_expr, ti) = transform dynamic_expr ro ti
= (DynamicExpr dynamic_expr, ti)
transform expr ro ti
setExtendedVarInfo var_info_ptr extension var_heap
# (old_var_info, var_heap) = readPtr var_info_ptr var_heap
= case old_var_info of
VI_Extended _ original_var_info -> writePtr var_info_ptr (VI_Extended extension original_var_info) var_heap
_ -> writePtr var_info_ptr (VI_Extended extension old_var_info) var_heap
neverMatchingCase = { case_expr = EE, case_guards = NoPattern, case_default = No, case_ident = No, case_info_ptr = nilPtr,
Ronny Wichers Schreur
committed
// RWS ...
case_explicit = False,
// ... RWS
case_default_pos = NoPos }
transform dyn=:{dyn_expr} ro ti
# (dyn_expr, ti) = transform dyn_expr ro ti
unfold_state_to_ti us ti
:== { ti & ti_var_heap = us.us_var_heap, ti_symbol_heap = us.us_symbol_heap,ti_cleanup_info=us.us_cleanup_info }
transformCase this_case=:{case_expr,case_guards,case_default,case_ident,case_info_ptr} ro ti
| SwitchFusion False True
= skip_over this_case ro ti
# (case_info, ti_symbol_heap) = readPtr case_info_ptr ti.ti_symbol_heap
ti = { ti & ti_symbol_heap=ti_symbol_heap }
(result_expr, ti) = case case_info of
EI_Extended (EEI_ActiveCase aci) _
| is_variable case_expr
-> skip_over this_case ro ti
-> case ro.ro_root_case_mode of
NotRootCase -> possibly_generate_case_function this_case aci ro ti
_ -> transCase True (Yes aci) this_case ro ti
_ -> transCase False No this_case ro ti
ti = { ti & ti_symbol_heap = remove_aci_free_vars_info case_info_ptr ti.ti_symbol_heap }
= (removeNeverMatchingSubcases result_expr, ti)
where
skip_over this_case=:{case_expr,case_guards,case_default} ro ti
# ro_lost_root = { ro & ro_root_case_mode = NotRootCase }
(new_case_expr, ti) = transform case_expr ro_lost_root ti
(new_case_guards, ti) = transform case_guards ro_lost_root ti
(new_case_default, ti) = transform case_default ro_lost_root ti
= (Case { this_case & case_expr=new_case_expr, case_guards=new_case_guards, case_default=new_case_default }, ti)
is_variable (Var _) = True
is_variable _ = False
remove_aci_free_vars_info case_info_ptr ti_symbol_heap
= app_EEI_ActiveCase (\aci->{aci & aci_free_vars = No }) case_info_ptr ti_symbol_heap
transCase is_active opt_aci this_case=:{case_expr,case_guards,case_default,case_ident,case_info_ptr} ro ti
| ti.ti_trace && (False--->("transCase",Case this_case))
= undef
= case case_expr of
Case case_in_case
| is_active
-> lift_case case_in_case this_case ro ti
-> skip_over this_case ro ti
App app=:{app_symb,app_args}
-> case app_symb.symb_kind of
SK_Constructor cons_index
| not is_active
-> skip_over this_case ro ti // XXX currently only active cases are matched at runtime (multimatch problem)
# algebraicPatterns = getAlgebraicPatterns case_guards
aci = case opt_aci of
Yes aci -> aci
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
(may_be_match_expr, ti) = match_and_instantiate aci.aci_linearity_of_patterns cons_index app_args algebraicPatterns case_default ro ti
-> case may_be_match_expr of
Yes match_expr
-> (match_expr, ti)
No
-> (Case neverMatchingCase, ti)
// otherwise it's a function application
_ -> case opt_aci of
Yes aci=:{ aci_params, aci_opt_unfolder }
-> case aci_opt_unfolder of
No -> skip_over this_case ro ti
Yes unfolder
| not (equal app_symb.symb_kind unfolder.symb_kind)
// in this case a third function could be fused in
-> skip_over this_case ro ti
# variables = [ Var {var_name=fv_name, var_info_ptr=fv_info_ptr, var_expr_ptr=nilPtr}
\\ {fv_name, fv_info_ptr} <- ro.ro_fun_args ]
(ti_next_fun_nr, ti) = ti!ti_next_fun_nr
(new_next_fun_nr, app_symb)
= case ro.ro_root_case_mode of
RootCaseOfZombie
# (ro_fun=:{symb_kind=SK_GeneratedFunction fun_info_ptr _}) = ro.ro_fun
-> (inc ti_next_fun_nr,
{ ro_fun & symb_kind=SK_GeneratedFunction fun_info_ptr ti_next_fun_nr })
RootCase
-> (ti_next_fun_nr, ro.ro_fun)
ti = { ti & ti_next_fun_nr = new_next_fun_nr, ti_recursion_introduced = Yes ti_next_fun_nr }
app_args1 = replace_arg [ fv_info_ptr \\ {fv_info_ptr}<-aci_params ] app_args variables
(app_args2, ti) = transform app_args1 { ro & ro_root_case_mode = NotRootCase } ti
-> (App {app_symb=app_symb, app_args=app_args2, app_info_ptr=nilPtr}, ti)
No -> skip_over this_case ro ti
BasicExpr basic_value _
| not is_active
-> skip_over this_case ro ti // XXX currently only active cases are matched at runtime (multimatch problem)
# basicPatterns = getBasicPatterns case_guards
may_be_match_pattern = dropWhile (\{bp_value} -> bp_value<>basic_value) basicPatterns
| isEmpty may_be_match_pattern
-> case case_default of
Yes default_expr-> transform default_expr { ro & ro_root_case_mode = NotRootCase } ti
No -> (Case neverMatchingCase, ti)
-> transform (hd may_be_match_pattern).bp_expr { ro & ro_root_case_mode = NotRootCase } ti
Martin Wierich
committed
Let lad
| not is_active
-> skip_over this_case ro ti
# ro_not_root = { ro & ro_root_case_mode = NotRootCase }
(new_let_strict_binds, ti) = transform lad.let_strict_binds ro_not_root ti
(new_let_lazy_binds, ti) = transform lad.let_lazy_binds ro_not_root ti
Martin Wierich
committed
(new_let_expr, ti) = transform (Case { this_case & case_expr = lad.let_expr }) ro ti
-> (Let { lad & let_expr = new_let_expr, let_strict_binds = new_let_strict_binds, let_lazy_binds = new_let_lazy_binds }, ti)
_ -> skip_over this_case ro ti
where
equal (SK_Function glob_index1) (SK_Function glob_index2)
= glob_index1==glob_index2
equal (SK_LocalMacroFunction glob_index1) (SK_LocalMacroFunction glob_index2)
= glob_index1==glob_index2
equal (SK_GeneratedFunction _ index1) (SK_GeneratedFunction _ index2)
= index1==index2
equal _ _
= False
replace_arg producer_vars=:[fv_info_ptr:_] act_pars form_pars=:[h_form_pars=:(Var {var_info_ptr}):t_form_pars]
| fv_info_ptr<>var_info_ptr
= [h_form_pars:replace_arg producer_vars act_pars t_form_pars]
= replacement producer_vars act_pars form_pars
where
replacement producer_vars [] form_pars
= form_pars
replacement producer_vars _ []
= []
replacement producer_vars [h_act_pars:t_act_pars] [form_par=:(Var {var_info_ptr}):form_pars]
| isMember var_info_ptr producer_vars
= [h_act_pars:replacement producer_vars t_act_pars form_pars]
= replacement producer_vars t_act_pars form_pars
getAlgebraicPatterns (AlgebraicPatterns _ algebraicPatterns)
= algebraicPatterns
getAlgebraicPatterns (OverloadedListPatterns _ _ algebraicPatterns)
= algebraicPatterns
getBasicPatterns (BasicPatterns _ basicPatterns)
= basicPatterns
lift_case nested_case=:{case_guards,case_default} outer_case ro ti
# default_exists = case case_default of
Yes _ -> True
No -> False
(case_guards, ti) = lift_patterns default_exists case_guards outer_case ro ti
(case_default, ti) = lift_default case_default outer_case ro ti
(EI_CaseType outer_case_type, ti_symbol_heap) = readExprInfo outer_case.case_info_ptr ti.ti_symbol_heap
// the result type of the nested case becomes the result type of the outer case
ti_symbol_heap = overwrite_result_type nested_case.case_info_ptr outer_case_type.ct_result_type ti_symbol_heap
// after this transformation the aci_free_vars information doesn't hold anymore
ti_symbol_heap = remove_aci_free_vars_info nested_case.case_info_ptr ti_symbol_heap
ti = { ti & ti_symbol_heap = ti_symbol_heap }
= (Case {nested_case & case_guards = case_guards, case_default = case_default}, ti)
where
overwrite_result_type case_info_ptr new_result_type ti_symbol_heap
#! (EI_CaseType case_type, ti_symbol_heap) = readExprInfo case_info_ptr ti_symbol_heap
= writeExprInfo case_info_ptr (EI_CaseType { case_type & ct_result_type = new_result_type}) ti_symbol_heap
lift_patterns default_exists (AlgebraicPatterns type case_guards) outer_case ro ti
# guard_exprs = [ ap_expr \\ {ap_expr} <- case_guards ]
# (guard_exprs_with_case, ti) = lift_patterns_2 default_exists guard_exprs outer_case ro ti
= (AlgebraicPatterns type [ { case_guard & ap_expr=guard_expr } \\ case_guard<-case_guards & guard_expr<-guard_exprs_with_case], ti)
lift_patterns default_exists (BasicPatterns basic_type case_guards) outer_case ro ti
# guard_exprs = [ bp_expr \\ {bp_expr} <- case_guards ]
# (guard_exprs_with_case, ti) = lift_patterns_2 default_exists guard_exprs outer_case ro ti
= (BasicPatterns basic_type [ { case_guard & bp_expr=guard_expr } \\ case_guard<-case_guards & guard_expr<-guard_exprs_with_case], ti)
lift_patterns default_exists (OverloadedListPatterns type decons_expr case_guards) outer_case ro ti
# guard_exprs = [ ap_expr \\ {ap_expr} <- case_guards ]
# (guard_exprs_with_case, ti) = lift_patterns_2 default_exists guard_exprs outer_case ro ti
= (OverloadedListPatterns type decons_expr [ { case_guard & ap_expr=guard_expr } \\ case_guard<-case_guards & guard_expr<-guard_exprs_with_case], ti)
lift_patterns_2 False [guard_expr] outer_case ro ti
// if no default pattern exists, then the outer case expression does not have to be copied for the last pattern
# (guard_expr, ti) = transformCase {outer_case & case_expr = guard_expr} ro ti
= ([guard_expr], ti)
lift_patterns_2 default_exists [guard_expr : guard_exprs] outer_case ro ti
# us = { us_var_heap = ti.ti_var_heap, us_symbol_heap = ti.ti_symbol_heap, us_opt_type_heaps = No,us_cleanup_info=ti.ti_cleanup_info,
us_local_macro_functions = No }
ui = {ui_handle_aci_free_vars = LeaveThem, ui_convert_module_n= -1,ui_conversion_table=No }
(outer_guards, us=:{us_cleanup_info}) = unfold outer_case.case_guards ui us
(expr_info, ti_symbol_heap) = readPtr outer_case.case_info_ptr us.us_symbol_heap
(new_info_ptr, ti_symbol_heap) = newPtr expr_info ti_symbol_heap
new_cleanup_info = case expr_info of
EI_Extended _ _
-> [new_info_ptr:us_cleanup_info]
_ -> us_cleanup_info
ti = { ti & ti_var_heap = us.us_var_heap, ti_symbol_heap = ti_symbol_heap, ti_cleanup_info=new_cleanup_info }
new_case = { outer_case & case_expr = guard_expr, case_guards=outer_guards, case_info_ptr=new_info_ptr }
(guard_expr, ti) = transformCase new_case ro ti
(guard_exprs, ti) = lift_patterns_2 default_exists guard_exprs outer_case ro ti
= ([guard_expr : guard_exprs], ti)
lift_patterns_2 _ [] _ _ ti
= ([], ti)
lift_default (Yes default_expr) outer_case ro ti
# (default_expr, ti) = transformCase { outer_case & case_expr = default_expr } ro ti
= (Yes default_expr, ti)
lift_default No _ _ ti
= (No, ti)
match_and_instantiate [linearity:linearities] cons_index app_args
[{ap_symbol={glob_module,glob_object={ds_index}}, ap_vars, ap_expr} : guards] case_default ro ti
| cons_index.glob_module == glob_module && cons_index.glob_object == ds_index
# zipped = zip2 ap_vars app_args
unfoldables = [ linear || in_normal_form app_arg \\ linear <- linearity & app_arg <- app_args ]
unfoldable_args = filterWith unfoldables zipped
not_unfoldable = map not unfoldables
non_unfoldable_args = filterWith not_unfoldable zipped
ti_var_heap = foldSt (\({fv_info_ptr}, arg) -> writeVarInfo fv_info_ptr (VI_Expression arg)) unfoldable_args ti.ti_var_heap
(new_expr, ti_symbol_heap) = possibly_add_let non_unfoldable_args ap_expr not_unfoldable glob_module ds_index ro ti.ti_symbol_heap
unfold_state = { us_var_heap = ti_var_heap, us_symbol_heap = ti_symbol_heap, us_opt_type_heaps = No,us_cleanup_info=ti.ti_cleanup_info,
us_local_macro_functions = No }
ui= {ui_handle_aci_free_vars = LeaveThem, ui_convert_module_n= -1,ui_conversion_table=No }
(unfolded_expr, unfold_state) = unfold new_expr ui unfold_state
(final_expr, ti) = transform unfolded_expr { ro & ro_root_case_mode = NotRootCase } (unfold_state_to_ti unfold_state ti)
= (Yes final_expr, ti)
= match_and_instantiate linearities cons_index app_args guards case_default ro ti