aboutsummaryrefslogtreecommitdiff
path: root/frontend/classify.icl
diff options
context:
space:
mode:
Diffstat (limited to 'frontend/classify.icl')
-rw-r--r--frontend/classify.icl241
1 files changed, 241 insertions, 0 deletions
diff --git a/frontend/classify.icl b/frontend/classify.icl
index f14072f..92c14f1 100644
--- a/frontend/classify.icl
+++ b/frontend/classify.icl
@@ -1498,3 +1498,244 @@ is_non_zero rc = score rc > 0
is_non_zero` :: !RefCount -> Bool
is_non_zero` rc = score` rc > 0
+
+//@ producerRequirements
+
+:: *PRState =
+ { prs_group :: ![Int]
+ , prs_cons_args :: !*{!ConsClasses}
+ , prs_main_dcl_module_n :: !Int
+ , prs_fun_heap :: !*FunctionHeap
+ , prs_fun_defs :: !*{#FunDef}
+ , prs_group_index :: !Int
+ }
+
+class producerRequirements a
+ :: !a !*PRState -> *(!Bool,!*PRState)
+
+instance producerRequirements [a] | producerRequirements a where
+ producerRequirements [] prs
+ = (True,prs)
+ producerRequirements [x:xs] prs
+ # (safe,prs) = producerRequirements x prs
+ | safe = producerRequirements xs prs
+ = (safe,prs)
+
+instance producerRequirements Expression where
+ producerRequirements (Var var) prs
+ = (True,prs)
+ producerRequirements (App {app_symb={symb_kind=(SK_Constructor _)},app_args}) prs
+ = producerRequirements app_args prs
+ producerRequirements app=:(App {app_symb,app_args}) prs
+/*
+ # (rec,prs) = is_recursive_app app prs
+ | not rec
+ = producerRequirements app_args prs
+*/
+ // look up consumer class for app_symb args
+ #! (maybe_ca,prs) = retrieve_consumer_args app_symb prs
+ // need to check for recursive call in safe arg...
+ = case maybe_ca of
+ No // assuming that for functions that have no consumer info no unfolding will occur
+ // note that this means that generated functions must be visible this way...
+// # prs = prs ---> ("No cons info for",app_symb)
+ -> (True,prs)
+ Yes ca // for each arg:
+ // if safe && top of arg is App of group member...
+ // else recurse into arg
+// # prs = prs ---> ("Yes cons info for",app_symb,ca.cc_args,ca.cc_linear_bits)
+ -> check_app_arguments ca.cc_args ca.cc_linear_bits app_args prs
+ where
+ check_app_arguments [cc_arg:cc_args] [cc_linear_bit:cc_bits] [app_arg:app_args] prs
+ | cc_arg == CActive && cc_linear_bit
+ # (rec,prs) = is_recursive_app app_arg prs
+ | rec = (False,prs)
+ # (safe,prs)= producerRequirements app_arg prs
+ | safe = check_app_arguments cc_args cc_bits app_args prs
+ = (safe,prs)
+ # (safe,prs) = producerRequirements app_arg prs
+ | safe = check_app_arguments cc_args cc_bits app_args prs
+ = (safe,prs)
+ check_app_arguments _ _ _ prs
+ = (True,prs)
+
+ is_recursive_app (App {app_symb}) prs
+ // check if app_symb member of prs_group
+ # {symb_kind} = app_symb
+ #! main_dcl_module_n = prs.prs_main_dcl_module_n
+ # { glob_module, glob_object }
+ = case symb_kind of
+ SK_Function global_index -> global_index
+ SK_LocalMacroFunction index -> { glob_module = main_dcl_module_n, glob_object = index }
+ SK_GeneratedFunction info_ptr index -> { glob_module = main_dcl_module_n, glob_object = index }
+ _ -> {glob_module = -1, glob_object = -1}
+ | glob_module <> main_dcl_module_n
+ = (False,prs)
+ #! (fun_def,fun_defs,fun_heap) = get_fun_def symb_kind prs.prs_main_dcl_module_n prs.prs_fun_defs prs.prs_fun_heap
+ prs = {prs & prs_fun_defs = fun_defs, prs_fun_heap = fun_heap}
+ rec = fun_def.fun_info.fi_group_index == prs.prs_group_index
+ = (rec,prs)
+ where
+ get_fun_def :: !SymbKind !Int !u:{#FunDef} !*FunctionHeap -> (!FunDef, !u:{#FunDef}, !*FunctionHeap)
+ get_fun_def (SK_Function {glob_module, glob_object}) main_dcl_module_n fun_defs fun_heap
+ | glob_module<>main_dcl_module_n
+ = abort "sanity check 2 failed in module trans"
+ # (fun_def, fun_defs) = fun_defs![glob_object]
+ = (fun_def, fun_defs, fun_heap)
+ get_fun_def (SK_LocalMacroFunction glob_object) main_dcl_module_n fun_defs fun_heap
+ # (fun_def, fun_defs) = fun_defs![glob_object]
+ = (fun_def, fun_defs, fun_heap)
+ get_fun_def (SK_GeneratedFunction fun_ptr _) main_dcl_module_n fun_defs fun_heap
+ # (FI_Function {gf_fun_def}, fun_heap) = readPtr fun_ptr fun_heap
+ = (gf_fun_def, fun_defs, fun_heap)
+ is_recursive_app _ prs
+ = (False,prs)
+
+ producerRequirements (fun_expr @ exprs) prs
+ // recurse
+ # (safe,prs) = producerRequirements fun_expr prs
+ | safe = producerRequirements exprs prs
+ = (safe,prs)
+ producerRequirements (Let {let_strict_binds,let_lazy_binds,let_expr}) prs
+ // watch out for function shadowing by 'let' binds
+ // recurse into binding exprs
+ // continue with 'in' body
+ # (safe,prs) = producerRequirements let_lazy_binds prs
+ | not safe = (safe,prs)
+ # (safe,prs) = producerRequirements let_strict_binds prs
+ | not safe = (safe,prs)
+ # (safe,prs) = producerRequirements let_expr prs
+ | not safe = (safe,prs)
+ = (safe,prs)
+ producerRequirements (Case {case_expr,case_guards,case_default,case_ident}) prs
+ // watch out for function shadowing by guards or case ident
+ // check case_expr
+ # (safe,prs) = producerRequirements case_expr prs
+ | not safe = (safe,prs)
+ // check case_guards
+ # (safe,prs) = producerRequirements case_guards prs
+ | not safe = (safe,prs)
+ // check case_default
+ # (safe,prs) = producerRequirements case_default prs
+ | not safe = (safe,prs)
+ = (True,prs)
+ producerRequirements (Selection _ expr sels) prs
+ # (safe,prs) = producerRequirements expr prs
+ | safe = producerRequirements sels prs
+ = (safe,prs)
+ producerRequirements (Update expr1 sels expr2) prs
+ # (safe,prs) = producerRequirements expr1 prs
+ | not safe = (safe,prs)
+ # (safe,prs) = producerRequirements expr2 prs
+ | not safe = (safe,prs)
+ # (safe,prs) = producerRequirements sels prs
+ | not safe = (safe,prs)
+ = (True,prs)
+ producerRequirements (RecordUpdate _ expr exprs) prs
+ // ...
+ # (safe,prs) = producerRequirements expr prs
+ | safe = producerFieldRequirements exprs prs
+ = (safe,prs)
+ where
+ producerFieldRequirements [] prs
+ = (True,prs)
+ producerFieldRequirements [{bind_src}:fields] prs
+ # (safe,prs) = producerRequirements bind_src prs
+ | safe = producerFieldRequirements fields prs
+ = (safe,prs)
+ producerRequirements (TupleSelect _ _ expr) prs
+ = producerRequirements expr prs
+ producerRequirements (BasicExpr _) prs
+ = (True,prs)
+ producerRequirements (AnyCodeExpr _ _ _) prs
+ = (False,prs)
+ producerRequirements (ABCCodeExpr _ _) prs
+ = (False,prs)
+ producerRequirements (MatchExpr _ expr) prs
+ = producerRequirements expr prs
+ producerRequirements (DynamicExpr _) prs
+ = (False,prs)
+ producerRequirements (TypeCodeExpression _) prs
+ = (False,prs)
+ producerRequirements (EE) prs
+ = (False,prs)
+ producerRequirements (NoBind var) prs
+ = (True,prs)
+ producerRequirements (FailExpr _) prs
+ = (True,prs)
+ producerRequirements expr prs
+ = abort ("producerRequirements " ---> expr)
+
+instance producerRequirements (Optional a) | producerRequirements a where
+ producerRequirements (Yes x) prs
+ = producerRequirements x prs
+ producerRequirements No prs
+ = (True,prs)
+
+instance producerRequirements CasePatterns where
+ producerRequirements (AlgebraicPatterns index patterns) prs
+ // name shadowing...
+ # (safe,prs) = producerRequirements patterns prs
+ = (safe,prs)
+ producerRequirements (BasicPatterns type patterns) prs
+ // name shadowing...
+ # (safe,prs) = producerRequirements patterns prs
+ = (safe,prs)
+ producerRequirements (OverloadedListPatterns _ _ patterns) prs
+ // name shadowing...
+ # (safe,prs) = producerRequirements patterns prs
+ = (safe,prs)
+ producerRequirements (DynamicPatterns patterns) prs
+ //...disallow for now...
+ = (False,prs)
+ producerRequirements NoPattern prs
+ = (True,prs)
+
+instance producerRequirements AlgebraicPattern where
+ producerRequirements {ap_expr} prs
+ // name shadowing...
+ = producerRequirements ap_expr prs
+
+instance producerRequirements BasicPattern where
+ producerRequirements {bp_expr} prs
+ // name shadowing...
+ = producerRequirements bp_expr prs
+
+instance producerRequirements LetBind where
+ producerRequirements {lb_src} prs
+ = producerRequirements lb_src prs
+
+instance producerRequirements Selection where
+ producerRequirements (RecordSelection _ _) prs
+ = (True,prs)
+ producerRequirements (ArraySelection _ _ expr) prs
+ = producerRequirements expr prs
+ producerRequirements (DictionarySelection _ sels _ expr) prs
+ # (safe,prs) = producerRequirements expr prs
+ | safe = producerRequirements sels prs
+ = (safe,prs)
+
+retrieve_consumer_args :: !SymbIdent !*PRState -> (!Optional ConsClasses, !*PRState)
+retrieve_consumer_args si=:{symb_kind} prs=:{prs_cons_args, prs_main_dcl_module_n}
+ # (prs_size, prs_cons_args) = usize prs_cons_args
+ prs = {prs & prs_cons_args = prs_cons_args}
+ = case symb_kind of
+ SK_Function {glob_module, glob_object}
+ | glob_module == prs_main_dcl_module_n && glob_object < prs_size
+ # (cons_args,prs) = prs!prs_cons_args.[glob_object]
+ -> (Yes cons_args,prs)
+ -> (No,prs)
+ SK_LocalMacroFunction glob_object
+ | glob_object < prs_size
+ # (cons_args,prs) = prs!prs_cons_args.[glob_object]
+ -> (Yes cons_args,prs)
+ -> (No,prs)
+ SK_GeneratedFunction fun_ptr fun_index
+ | fun_index < prs_size
+ # (cons_args,prs) = prs!prs_cons_args.[fun_index]
+ -> (Yes cons_args,prs)
+ # (FI_Function {gf_cons_args}, fun_heap) = readPtr fun_ptr prs.prs_fun_heap
+ # prs = {prs & prs_fun_heap = fun_heap}
+ -> (Yes gf_cons_args,prs)
+// SK_Constructor cons_index
+ sk -> (No,prs)
generated by cgit v1.2.3 (git 2.39.1) at 2025-03-15 04:23:30 +0000