move producerRequirements from module trans to module classify

git-svn-id: https://svn.cs.ru.nl/repos/clean-compiler/trunk@1765 1f8540f1-abd5-4d5b-9d24-4c5ce8603e2d

3 files changed, 254 insertions, 233 deletions

diff --git a/frontend/classify.dcl b/frontend/classify.dcl
index c448395..c8fa829 100644
--- a/frontend/classify.dcl
+++ b/frontend/classify.dcl
@@ -16,3 +16,16 @@ analyseGroups	:: !{# CommonDefs} !{#{#FunType}} !IndexRange !Int !Int !*{! Group
 
 reanalyseGroups	:: !{# CommonDefs} !{#{#FunType}} !Int !Int ![FunctionInfoPtr]  ![Group] !*{#FunDef} !*VarHeap !*ExpressionHeap !*FunctionHeap !*{!ConsClasses}
 				-> (!CleanupInfo, !*{#FunDef}, !*VarHeap, !*ExpressionHeap, !*FunctionHeap, !*{!ConsClasses}, !Bool)
+
+:: *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 Expression
\ No newline at end of file
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)
diff --git a/frontend/trans.icl b/frontend/trans.icl
index f1837b5..3985063 100644
--- a/frontend/trans.icl
+++ b/frontend/trans.icl
@@ -4244,214 +4244,6 @@ where
 			_
 				-> ([ v : global_vars ], var_heap)
 
-/*
-isYes (Yes _) = True
-isYes _ = False
-*/
-
-//@ 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)
-		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)
-
 //@ fun_def & cons_arg getters...
 
 get_fun_def :: !SymbKind !Int !u:{#FunDef} !*FunctionHeap -> (!FunDef, !u:{#FunDef}, !*FunctionHeap)
@@ -4490,31 +4282,6 @@ get_fun_def_and_cons_args (SK_GeneratedFunction fun_info_ptr fun_index) cons_arg
 	# (FI_Function {gf_fun_def, gf_cons_args}, fun_heap) = readPtr fun_info_ptr fun_heap
 	= (gf_fun_def, gf_cons_args, cons_args, fun_defs, fun_heap)
 
-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) -!-> ("r_c_a",si)
-		SK_LocalMacroFunction glob_object
-			| glob_object < prs_size
-				# (cons_args,prs) = prs!prs_cons_args.[glob_object]
-				-> (Yes cons_args,prs)
-			-> (No,prs) -!-> ("r_c_a",si)
-		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 -!-> ("Unexpected symbol kind: ", si, sk),prs)
-
 //@ <<<
 
 instance <<< Group where