aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authordiederik2002-07-24 09:37:16 +0000
committerdiederik2002-07-24 09:37:16 +0000
commita1e9ec87652d019205ddf15fa0486bc7ee8dd13e (patch)
tree0667809a97b022404c9fe3a98663d5e4854aa2ac
parentrepair a bug introduced in revision 1.57: add the list of (diff)
move consumer classification to separate module
git-svn-id: https://svn.cs.ru.nl/repos/clean-compiler/trunk@1166 1f8540f1-abd5-4d5b-9d24-4c5ce8603e2d
-rw-r--r--frontend/classify.dcl14
-rw-r--r--frontend/classify.icl594
-rw-r--r--frontend/trans.dcl11
-rw-r--r--frontend/trans.icl579
4 files changed, 613 insertions, 585 deletions
diff --git a/frontend/classify.dcl b/frontend/classify.dcl
new file mode 100644
index 0000000..e72fcf6
--- /dev/null
+++ b/frontend/classify.dcl
@@ -0,0 +1,14 @@
+definition module classify
+
+import syntax, checksupport, transform
+
+cPassive :== -1
+cActive :== -2
+cAccumulating :== -3
+cVarOfMultimatchCase :== -4
+
+:: CleanupInfo :== [ExprInfoPtr]
+
+analyseGroups :: !{# CommonDefs} !{#{#FunType}} !IndexRange !Int !Int !*{! Group} !*{#FunDef} !*VarHeap !*ExpressionHeap
+ -> (!CleanupInfo, !*{! ConsClasses}, !*{! Group}, !*{#FunDef}, !*VarHeap, !*ExpressionHeap)
+
diff --git a/frontend/classify.icl b/frontend/classify.icl
new file mode 100644
index 0000000..fa1abbf
--- /dev/null
+++ b/frontend/classify.icl
@@ -0,0 +1,594 @@
+/*
+ module owner: Diederik van Arkel
+*/
+implementation module classify
+
+SwitchMultimatchClassification multi no_multi :== multi
+
+import syntax, checksupport, transform
+
+:: CleanupInfo :== [ExprInfoPtr]
+
+setExtendedExprInfo :: !ExprInfoPtr !ExtendedExprInfo !*ExpressionHeap -> *ExpressionHeap
+setExtendedExprInfo expr_info_ptr extension expr_info_heap
+ # (expr_info, expr_info_heap) = readPtr expr_info_ptr expr_info_heap
+ = case expr_info of
+ EI_Extended _ ei
+ -> expr_info_heap <:= (expr_info_ptr, EI_Extended extension ei)
+ ei -> expr_info_heap <:= (expr_info_ptr, EI_Extended extension ei)
+
+is_nil_cons_or_decons_of_UList_or_UTSList glob_object glob_module imported_funs
+ :== not (isEmpty imported_funs.[glob_module].[glob_object].ft_type.st_context);
+
+/*
+ * ANALYSIS: only determines consumerClass; producerClasses are determined after each group is transformed.
+ */
+
+IsAVariable cons_class :== cons_class >= 0
+
+combineClasses :: !ConsClass !ConsClass -> ConsClass
+combineClasses cc1 cc2
+ | IsAVariable cc1
+ = cAccumulating
+ | IsAVariable cc2
+ = cAccumulating
+ = min cc1 cc2
+
+aiUnifyClassifications cc1 cc2 ai
+ :== {ai & ai_class_subst = unifyClassifications cc1 cc2 ai.ai_class_subst}
+
+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 :: !ConsClass !*ConsClassSubst -> (!ConsClass,!*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 :: !ConsClass !ConsClass !*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 :: !ConsClass !ConsClass -> ConsClass
+ combine_cons_constants cc1 cc2
+ = min cc1 cc2
+
+determine_classification :: !ConsClasses !.ConsClassSubst -> ConsClasses
+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 }
+where
+ mapAndLength f [x : xs]
+ #! x = f x
+ (length, xs) = mapAndLength f xs
+ = (inc length, [x : xs])
+ mapAndLength f []
+ = (0, [])
+
+ skip_indirections subst cc
+ | IsAVariable cc
+ = skip_indirections subst subst.[cc]
+ = cc
+
+//@ Consumer Analysis datatypes...
+
+:: RefCounts :== {#Int}
+
+:: *AnalyseInfo =
+ { ai_var_heap :: !*VarHeap
+ , ai_cons_class :: !*{! ConsClasses}
+ , ai_cur_ref_counts :: !*RefCounts // 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]
+ }
+
+/* defined in syntax.dcl:
+
+:: ConsClasses =
+ { cc_size ::!Int
+ , cc_args ::![ConsClass]
+ , cc_linear_bits ::![Bool]
+ , cc_producer ::!ProdClass
+ }
+:: ConsClass :== Int
+*/
+
+cPassive :== -1
+cActive :== -2
+cAccumulating :== -3
+cVarOfMultimatchCase :== -4
+
+/*
+ NOTE: ordering of above values is relevant since unification
+ is defined later as:
+
+ combine_cons_constants :: !ConsClass !ConsClass -> ConsClass
+ combine_cons_constants cc1 cc2
+ = min cc1 cc2
+*/
+
+:: ConsClassSubst :== {# ConsClass}
+
+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
+*/
+
+:: ConsumerAnalysisRO = ConsumerAnalysisRO !ConsumerAnalysisRORecord;
+
+:: ConsumerAnalysisRORecord =
+ { common_defs :: !{# CommonDefs}
+ , imported_funs :: !{#{#FunType}}
+ , main_dcl_module_n :: !Int
+ , stdStrictLists_module_n :: !Int
+ }
+
+:: UnsafePatternBool :== Bool
+
+not_an_unsafe_pattern (cc, _, ai) = (cc, False, ai)
+
+//@ consumerRequirements
+
+class consumerRequirements a :: !a !ConsumerAnalysisRO !AnalyseInfo -> (!ConsClass, !UnsafePatternBool, !AnalyseInfo)
+
+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
+ ai = { ai & ai_var_heap=ai_var_heap }
+ = case var_info of
+ VI_AccVar temp_var arg_position
+ #! (ref_count,ai) = ai!ai_cur_ref_counts.[arg_position]
+ ai = { ai & ai_cur_ref_counts.[arg_position] = min (ref_count+1) 2 }
+ -> (temp_var, False, ai)
+ _
+ -> abort ("consumerRequirements" ---> (var_name))
+
+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 = aiUnifyClassifications cActive cc_fun ai
+ = consumerRequirements exprs common_defs ai
+ 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 = { ai & ai_next_var = new_next_var, ai_next_var_of_fun = new_ai_next_var_of_fun, ai_var_heap = ai_var_heap }
+ # ai = acc_requirements_of_let_binds let_binds ai_next_var common_defs ai
+ = consumerRequirements let_expr common_defs ai // XXX why not not_an_unsafe_pattern
+ where
+ init_variables [{lb_dst={fv_count, fv_info_ptr}} : binds] ai_next_var ai_next_var_of_fun ai_var_heap
+ | fv_count > 0
+ # ai_var_heap = writePtr fv_info_ptr (VI_AccVar ai_next_var ai_next_var_of_fun) ai_var_heap
+ = init_variables binds (inc ai_next_var) (inc 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 = aiUnifyClassifications ai_next_var bind_var ai
+ = acc_requirements_of_let_binds binds (inc ai_next_var) common_defs ai
+ = acc_requirements_of_let_binds binds ai_next_var common_defs ai
+ acc_requirements_of_let_binds [] ai_next_var _ ai
+ = 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 = aiUnifyClassifications cActive cc ai
+ ai = requirementsOfSelectors selectors common_defs ai
+ = (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
+ = abort ("consumerRequirements ") // <<- expr)
+
+requirementsOfSelectors selectors common_defs ai
+ = foldSt (reqs_of_selector common_defs) selectors ai
+where
+ reqs_of_selector common_defs (ArraySelection _ _ index_expr) ai
+ # (_, _, ai) = consumerRequirements index_expr common_defs ai
+ = 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
+ = aiUnifyClassifications cActive cc_var ai
+ reqs_of_selector _ _ ai
+ = ai
+
+instance consumerRequirements App where
+ consumerRequirements {app_symb={symb_kind = SK_Function {glob_module,glob_object}, 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 && (not (isEmpty app_args)) && is_nil_cons_or_decons_of_UList_or_UTSList glob_object glob_module imported_funs
+// && trace_tn ("consumerRequirements "+++symb_name.id_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 = aiUnifyClassifications cActive cc ai
+ = consumerRequirements app_args common_defs ai
+
+ = consumerRequirements app_args common_defs ai
+ consumerRequirements {app_symb={symb_kind = SK_LocalMacroFunction glob_object, 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 :: [.Int] !.[Expression] Int ConsumerAnalysisRO !*AnalyseInfo -> *(!Int,!.Bool,!*AnalyseInfo)
+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 = aiUnifyClassifications form_cc act_cc ai
+ = reqs_of_args ccs args (combineClasses act_cc cumm_arg_class) common_defs ai
+
+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 = aiUnifyClassifications (if may_be_active cActive cVarOfMultimatchCase) cce ai
+ 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_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 = aiUnifyClassifications cActive cc ai
+ -> ai
+ 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 _ _ _ _
+ = (False, False)
+
+ 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)
+
+ multimatch_loop has_default []
+ = False
+ multimatch_loop has_default [(cip, _, iup):t]
+ = 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)
+
+consumer_requirements_of_guards :: !CasePatterns ConsumerAnalysisRO !*AnalyseInfo -> (!Int,.[Bool],!*AnalyseInfo)
+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
+
+bindPatternVars :: !.[FreeVar] !Int !Int !*VarHeap -> (!Int,!Int,!*VarHeap)
+bindPatternVars [fv=:{fv_info_ptr,fv_count} : vars] next_var next_var_of_fun var_heap
+ | fv_count > 0
+ = 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)
+
+independentConsumerRequirements :: !.[Expression] ConsumerAnalysisRO !*AnalyseInfo -> (!Int,.[Bool],!*AnalyseInfo)
+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)
+ where
+ 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
+
+instance consumerRequirements DynamicExpr where
+ consumerRequirements {dyn_expr} common_defs ai
+ = consumerRequirements dyn_expr 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
+
+//@ Analysis
+
+// determine consumerRequirements for functions
+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 = [], cc_producer=False}, groups, fun_defs, var_heap, expr_heap)
+where
+ 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
+//initial classification...
+ 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]
+ # (TransformedBody {tb_args}) = fun_def.fun_body
+ (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=[], cc_producer=False}} 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)
+//determine classification...
+ 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)
+//final classification...
+ 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
+ = collect_classifications funs { class_env & [fun] = fun_class /*---> (fun, fun_class)*/} class_subst
+
+ 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,
+ setExtendedExprInfo 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)
+
+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
+ = ([], next_var_number, var_heap)
diff --git a/frontend/trans.dcl b/frontend/trans.dcl
index dcd33a8..3108536 100644
--- a/frontend/trans.dcl
+++ b/frontend/trans.dcl
@@ -3,16 +3,7 @@ definition module trans
import StdEnv
import syntax, transform
-
-cPassive :== -1
-cActive :== -2
-cAccumulating :== -3
-cVarOfMultimatchCase :== -4
-
-:: CleanupInfo
-
-analyseGroups :: !{# CommonDefs} !{#{#FunType}} !IndexRange !Int !Int !*{! Group} !*{#FunDef} !*VarHeap !*ExpressionHeap
- -> (!CleanupInfo, !*{! ConsClasses}, !*{! Group}, !*{#FunDef}, !*VarHeap, !*ExpressionHeap)
+import classify
transformGroups :: !CleanupInfo !Int !Int !*{! Group} !*{#FunDef} !*{!.ConsClasses} !{# CommonDefs} !{# {# FunType} }
!*ImportedTypes !ImportedConstructors !*TypeDefInfos !*VarHeap !*TypeHeaps !*ExpressionHeap !Bool
diff --git a/frontend/trans.icl b/frontend/trans.icl
index 55e810f..70509b3 100644
--- a/frontend/trans.icl
+++ b/frontend/trans.icl
@@ -1,8 +1,12 @@
+/*
+ module owner: Diederik van Arkel
+*/
implementation module trans
import StdEnv
import syntax, transform, checksupport, StdCompare, check, utilities, unitype, typesupport, type
+import classify
SwitchCaseFusion fuse dont_fuse :== dont_fuse // fuse
SwitchGeneratedFusion fuse dont_fuse :== fuse
@@ -13,8 +17,6 @@ SwitchCurriedFusion fuse dont_fuse :== fuse
(-!->) infix
(-!->) a b :== a // ---> b
-:: CleanupInfo :== [ExprInfoPtr]
-
fromYes (Yes x) = x
is_SK_Function_or_SK_LocalMacroFunction (SK_Function _) = True
@@ -123,106 +125,6 @@ where
:: BitVector :== Int
*/
-/*
- * ANALYSIS: only determines consumerClass; producerClasses are determined after each group is transformed.
- */
-
-:: *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]
- }
-
-/* defined in syntax.dcl:
-
-:: ConsClasses =
- { cc_size ::!Int
- , cc_args ::![ConsClass]
- , cc_linear_bits ::![Bool]
- , cc_producer ::!ProdClass
- }
-:: ConsClass :== Int
-*/
-
-:: ConsClassSubst :== {# ConsClass}
-
-//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
-
-IsAVariable cons_class :== cons_class >= 0
-
-combineClasses :: !ConsClass !ConsClass -> ConsClass
-combineClasses cc1 cc2
- | IsAVariable cc1
- = cAccumulating
- | IsAVariable cc2
- = cAccumulating
- = min cc1 cc2
-
-aiUnifyClassifications cc1 cc2 ai
- :== {ai & ai_class_subst = unifyClassifications cc1 cc2 ai.ai_class_subst}
-
-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 :: !ConsClass !*ConsClassSubst -> (!ConsClass,!*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 :: !ConsClass !ConsClass !*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 :: !ConsClass !ConsClass -> ConsClass
- combine_cons_constants cc1 cc2
- = min cc1 cc2
-/*
-write_ptr ptr val heap mess
- | isNilPtr ptr
- = abort mess
- = heap <:= (ptr,val)
-*/
-
// Extended variable info accessors...
readVarInfo :: VarInfoPtr *VarHeap -> (VarInfo, !*VarHeap)
@@ -268,14 +170,6 @@ writeExprInfo expr_info_ptr new_expr_info symbol_heap
EI_Extended extensions _ -> writePtr expr_info_ptr (EI_Extended extensions new_expr_info) symbol_heap
_ -> writePtr expr_info_ptr new_expr_info symbol_heap
-setExtendedExprInfo :: !ExprInfoPtr !ExtendedExprInfo !*ExpressionHeap -> *ExpressionHeap
-setExtendedExprInfo expr_info_ptr extension expr_info_heap
- # (expr_info, expr_info_heap) = readPtr expr_info_ptr expr_info_heap
- = case expr_info of
- EI_Extended _ ei
- -> expr_info_heap <:= (expr_info_ptr, EI_Extended extension ei)
- ei -> expr_info_heap <:= (expr_info_ptr, EI_Extended extension ei)
-
app_EEI_ActiveCase transformer expr_info_ptr expr_heap
# (expr_info, expr_heap) = readPtr expr_info_ptr expr_heap
= case expr_info of
@@ -295,468 +189,6 @@ cleanup_attributes expr_info_ptr symbol_heap
EI_Extended _ expr_info -> writePtr expr_info_ptr expr_info symbol_heap
_ -> symbol_heap
-//@ Consumer Analysis datatypes...
-
-:: ConsumerAnalysisRO = ConsumerAnalysisRO !ConsumerAnalysisRORecord;
-
-:: ConsumerAnalysisRORecord = {common_defs::!{# CommonDefs},imported_funs::!{#{#FunType}},main_dcl_module_n::!Int,stdStrictLists_module_n::!Int}
-
-:: UnsafePatternBool :== Bool
-
-not_an_unsafe_pattern (cc, _, ai) = (cc, False, ai)
-
-//@ consumerRequirements
-
-class consumerRequirements a :: !a !ConsumerAnalysisRO !AnalyseInfo -> (!ConsClass, !UnsafePatternBool, !AnalyseInfo)
-
-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
- ai = { ai & ai_var_heap=ai_var_heap }
- = case var_info of
- VI_AccVar temp_var arg_position
- #! (ref_count,ai) = ai!ai_cur_ref_counts.[arg_position]
- ai = { ai & ai_cur_ref_counts.[arg_position] = min (ref_count+1) 2 }
- -> (temp_var, False, ai)
- _
- -> abort ("consumerRequirements" ---> (var_name))
-
-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 = aiUnifyClassifications cActive cc_fun ai
- = consumerRequirements exprs common_defs ai
- 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 = { ai & ai_next_var = new_next_var, ai_next_var_of_fun = new_ai_next_var_of_fun, ai_var_heap = ai_var_heap }
- # ai = acc_requirements_of_let_binds let_binds ai_next_var common_defs ai
- = consumerRequirements let_expr common_defs ai // XXX why not not_an_unsafe_pattern
- where
- init_variables [{lb_dst={fv_count, fv_info_ptr}} : binds] ai_next_var ai_next_var_of_fun ai_var_heap
- | fv_count > 0
- # ai_var_heap = writePtr fv_info_ptr (VI_AccVar ai_next_var ai_next_var_of_fun) ai_var_heap
- = init_variables binds (inc ai_next_var) (inc 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 = aiUnifyClassifications ai_next_var bind_var ai
- = acc_requirements_of_let_binds binds (inc ai_next_var) common_defs ai
- = acc_requirements_of_let_binds binds ai_next_var common_defs ai
- acc_requirements_of_let_binds [] ai_next_var _ ai
- = 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 = aiUnifyClassifications cActive cc ai
- ai = requirementsOfSelectors selectors common_defs ai
- = (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
- = abort ("consumerRequirements ") // <<- expr)
-
-requirementsOfSelectors selectors common_defs ai
- = foldSt (reqs_of_selector common_defs) selectors ai
-where
- reqs_of_selector common_defs (ArraySelection _ _ index_expr) ai
- # (_, _, ai) = consumerRequirements index_expr common_defs ai
- = 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
- = aiUnifyClassifications cActive cc_var ai
- reqs_of_selector _ _ ai
- = ai
-
-instance consumerRequirements App where
- consumerRequirements {app_symb={symb_kind = SK_Function {glob_module,glob_object}, 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 && (not (isEmpty app_args)) && is_nil_cons_or_decons_of_UList_or_UTSList glob_object glob_module imported_funs
-// && trace_tn ("consumerRequirements "+++symb_name.id_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 = aiUnifyClassifications cActive cc ai
- = consumerRequirements app_args common_defs ai
-
- = consumerRequirements app_args common_defs ai
- consumerRequirements {app_symb={symb_kind = SK_LocalMacroFunction glob_object, 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 :: [.Int] !.[Expression] Int ConsumerAnalysisRO !*AnalyseInfo -> *(!Int,!.Bool,!*AnalyseInfo)
-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 = aiUnifyClassifications form_cc act_cc ai
- = reqs_of_args ccs args (combineClasses act_cc cumm_arg_class) common_defs ai
-
-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 = aiUnifyClassifications (if may_be_active cActive cVarOfMultimatchCase) cce ai
- 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_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 = aiUnifyClassifications cActive cc ai
- -> ai
- 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 _ _ _ _
- = (False, False)
-
- 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)
-
- multimatch_loop has_default []
- = False
- multimatch_loop has_default [(cip, _, iup):t]
- = 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)
-
-consumer_requirements_of_guards :: !CasePatterns ConsumerAnalysisRO !*AnalyseInfo -> (!Int,.[Bool],!*AnalyseInfo)
-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
-
-bindPatternVars :: !.[FreeVar] !Int !Int !*VarHeap -> (!Int,!Int,!*VarHeap)
-bindPatternVars [fv=:{fv_info_ptr,fv_count} : vars] next_var next_var_of_fun var_heap
- | fv_count > 0
- = 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)
-
-independentConsumerRequirements :: !.[Expression] ConsumerAnalysisRO !*AnalyseInfo -> (!Int,.[Bool],!*AnalyseInfo)
-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)
- where
- 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
-
-instance consumerRequirements DynamicExpr where
- consumerRequirements {dyn_expr} common_defs ai
- = consumerRequirements dyn_expr 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
-
-//@ Analysis
-
-// determine consumerRequirements for functions
-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 = [], cc_producer=False}, groups, fun_defs, var_heap, expr_heap)
-where
- 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,
- setExtendedExprInfo 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]
- # (TransformedBody {tb_args}) = fun_def.fun_body
- (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=[], cc_producer=False}} 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
- = ([], 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
- = 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, [])
-
/*
* TRANSFORM
*/
@@ -2480,9 +1912,6 @@ is_cons_or_decons_of_UList_or_UTSList glob_object glob_module imported_funs
:== let type = imported_funs.[glob_module].[glob_object].ft_type;
in type.st_arity>0 && not (isEmpty type.st_context);
-is_nil_cons_or_decons_of_UList_or_UTSList glob_object glob_module imported_funs
- :== not (isEmpty imported_funs.[glob_module].[glob_object].ft_type.st_context);
-
transformApplication :: !App ![Expression] !ReadOnlyTI !*TransformInfo -> *(!Expression,!*TransformInfo)
transformApplication app=:{app_symb=symb=:{symb_kind}, app_args} extra_args
ro ti=:{ti_cons_args,ti_instances,ti_fun_defs}