added fusion of unboxed lists of records, moved

FI_IsNonRecursive from partition.icl and trans.icl
to syntax.dcl, added FI_IsUnboxedListOfRecordsConsOrNil
to mark instances of unboxed lists of records generated
in type.icl


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

4 files changed, 102 insertions, 94 deletions

diff --git a/frontend/partition.icl b/frontend/partition.icl
index c8ffcad..46a0288 100644
--- a/frontend/partition.icl
+++ b/frontend/partition.icl
@@ -609,10 +609,6 @@ dummy_predef_symbols =
 	, predef_or				= dummy_predef_symbol
 	}
 
-///// FI_IsNonRecursive
-
-FI_IsNonRecursive	:== 4
-
 set_rec_prop non_recursive fi_properties
 	= case non_recursive of
 		True	-> fi_properties bitor FI_IsNonRecursive
diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl
index 3ab1a5a..62923d4 100644
--- a/frontend/syntax.dcl
+++ b/frontend/syntax.dcl
@@ -500,10 +500,10 @@ NoGlobalIndex :== {gi_module=NoIndex,gi_index=NoIndex}
 
 ::	FunCall = FunCall !Index !Level | MacroCall !ModuleIndex !Index Level | DclFunCall !ModuleIndex !DclFunctionIndex;
 
-/* Sjaak 19-3-2001 ... */
-
 FI_IsMacroFun	:== 1			// whether the function is a local function of a macro
 FI_HasTypeSpec	:== 2			// whether the function has u user defined type
+FI_IsNonRecursive :== 4			// used in trans.icl and partition.icl
+FI_IsUnboxedListOfRecordsConsOrNil :== 8
 
 ::	FunInfo =
 	{	fi_calls			:: ![FunCall]
@@ -514,7 +514,6 @@ FI_HasTypeSpec	:== 2			// whether the function has u user defined type
 	,	fi_dynamics			:: ![ExprInfoPtr]
 	,	fi_properties		:: !BITVECT
 	}
-/* ... Sjaak 19-3-2001 */
 
 ::	ParsedBody =
 	{	pb_args		:: ![ParsedExpr]
diff --git a/frontend/trans.icl b/frontend/trans.icl
index 6f3b23b..b7d6e76 100644
--- a/frontend/trans.icl
+++ b/frontend/trans.icl
@@ -377,7 +377,7 @@ where
 		= (No, ti)
 
 	possiblyFoldOuterCase final guard_expr outer_case ro ti
-		| SwitchAutoFoldCaseInCase (isFoldExpression guard_expr) False // otherwise GOTO next alternative
+		| SwitchAutoFoldCaseInCase (isFoldExpression guard_expr ti.ti_fun_defs ti.ti_cons_args) False // otherwise GOTO next alternative
 			| False -!-> ("possiblyFoldOuterCase","Case",bef < 0 || act < 0,ro.ro_fun_args,aci.aci_params) = undef
 			| bef < 0 || act < 0
 				= possiblyFoldOuterCase` final guard_expr outer_case ro ti	//abort "possiblyFoldOuterCase: unexpected!\n"
@@ -393,21 +393,26 @@ where
 
 //			= transformApplication { app_symb = folder, app_args = folder_args, app_info_ptr = nilPtr } [] ro ti
 //	where
-		isFoldExpression (App app)	= isFoldSymbol app.app_symb.symb_kind
+		isFoldExpression (App app)	ti_fun_defs ti_cons_args = isFoldSymbol app.app_symb.symb_kind
 			where
 				isFoldSymbol (SK_Function {glob_module,glob_object})
 					| glob_module==ro.ro_stdStrictLists_module_n
 						# type_arity = ro.ro_imported_funs.[glob_module].[glob_object].ft_type.st_arity
 						| type_arity==0 || (type_arity==2 && case app.app_args of [_:_] -> True; _ -> False)
 							= False
-							= True						
+							= True
+					| glob_module==ro.ro_main_dcl_module_n && glob_object>=size ti_cons_args &&
+						(ti_fun_defs.[glob_object].fun_info.fi_properties bitand FI_IsUnboxedListOfRecordsConsOrNil<>0) &&
+							(case ti_fun_defs.[glob_object].fun_type of
+								Yes type ->(type.st_arity==0 || (type.st_arity==2 && case app.app_args of [_:_] -> True; _ -> False)))
+							= False						
 						= True
 				isFoldSymbol (SK_LocalMacroFunction _)	= True
 				isFoldSymbol (SK_GeneratedFunction _ _)	= True
 				isFoldSymbol _							= False
-		isFoldExpression (Var _)	= True
-//		isFoldExpression (Case _)	= True
-		isFoldExpression _			= False
+		isFoldExpression (Var _)	ti_fun_defs ti_cons_args = True
+//		isFoldExpression (Case _)	ti_fun_defs ti_cons_args = True
+		isFoldExpression _			ti_fun_defs ti_cons_args = False
 		
 		folder		= ro.ro_fun_orig
 		folder_args = f_a_before` ++ [guard_expr:f_a_after`]
@@ -453,14 +458,13 @@ transCase is_active opt_aci this_case=:{case_expr = case_expr=:(App app=:{app_sy
 				(let type = ro.ro_imported_funs.[glob_module].[glob_object].ft_type
 				 in (type.st_arity==0 || (type.st_arity==2 && case app_args of [_:_] -> True; _ -> False)))
 				# type = ro.ro_imported_funs.[glob_module].[glob_object].ft_type
-				| type.st_arity==0
-					# (may_be_match_expr, ti) = match_and_instantiate_overloaded_nil case_guards case_default ro ti
-					-> expr_or_never_matching_case may_be_match_expr case_ident ti
-					# aci_linearity_of_patterns = case opt_aci of
-					  			Yes aci -> aci.aci_linearity_of_patterns
-					  (may_be_match_expr, ti) = match_and_instantiate_overloaded_cons type aci_linearity_of_patterns app_args case_guards case_default ro ti
-					-> expr_or_never_matching_case may_be_match_expr case_ident ti
-
+				-> trans_case_of_overloaded_nil_or_cons type ti
+			| glob_module==ro.ro_main_dcl_module_n && glob_object>=size ti.ti_cons_args &&
+				(ti.ti_fun_defs.[glob_object].fun_info.fi_properties bitand FI_IsUnboxedListOfRecordsConsOrNil)<>0 && is_active &&
+				(case ti.ti_fun_defs.[glob_object].fun_type of
+					Yes type ->(type.st_arity==0 || (type.st_arity==2 && case app_args of [_:_] -> True; _ -> False)))
+				# (Yes type,ti) = ti!ti_fun_defs.[glob_object].fun_type
+				-> trans_case_of_overloaded_nil_or_cons type ti
 		// otherwise it's a function application
 		_	-> case opt_aci of
 				Yes aci=:{ aci_params, aci_opt_unfolder }
@@ -578,75 +582,84 @@ where
 			match_and_instantiate_overloaded_list _ cons_index app_args [] case_default ro ti
 				= transform case_default { ro & ro_root_case_mode = NotRootCase } ti
 
-	match_and_instantiate_overloaded_nil (OverloadedListPatterns _ _ algebraicPatterns) case_default ro ti
-		= match_and_instantiate_nil algebraicPatterns case_default ro ti
-	match_and_instantiate_overloaded_nil (AlgebraicPatterns _ algebraicPatterns) case_default ro ti
-		= match_and_instantiate_nil algebraicPatterns case_default ro ti
-
-	match_and_instantiate_nil [{ap_symbol={glob_module,glob_object={ds_index}},ap_expr} : guards] case_default ro ti
-		| glob_module==cPredefinedModuleIndex
-			# index=ds_index+FirstConstructorPredefinedSymbolIndex
-			| index==PD_NilSymbol || index==PD_StrictNilSymbol || index==PD_TailStrictNilSymbol || index==PD_StrictTailStrictNilSymbol ||
-			  index==PD_OverloadedNilSymbol || index==PD_UnboxedNilSymbol || index==PD_UnboxedTailStrictNilSymbol
-				= instantiate [] [] [] ap_expr NotStrict [] ti
-				= match_and_instantiate_nil guards case_default ro ti
-	match_and_instantiate_nil [] case_default ro ti
-		= transform case_default { ro & ro_root_case_mode = NotRootCase } ti
-
-	match_and_instantiate_overloaded_cons cons_function_type linearities app_args (AlgebraicPatterns _ algebraicPatterns) case_default ro ti
-		= match_and_instantiate_overloaded_cons_boxed_match linearities app_args algebraicPatterns case_default ro ti
-		where
-			match_and_instantiate_overloaded_cons_boxed_match [linearity:linearities] app_args 
-									[{ap_symbol={glob_module,glob_object={ds_index}}, ap_vars, ap_expr} : guards] 
-									case_default ro ti
-				| glob_module==cPredefinedModuleIndex
-					# index=ds_index+FirstConstructorPredefinedSymbolIndex
-					| index==PD_ConsSymbol || index==PD_StrictConsSymbol || index==PD_TailStrictConsSymbol || index==PD_StrictTailStrictConsSymbol
-						# {cons_type} = ro.ro_common_defs.[glob_module].com_cons_defs.[ds_index]
-						= instantiate linearity app_args ap_vars ap_expr cons_type.st_args_strictness cons_type.st_args ti
-	//				| index==PD_NilSymbol || index==PD_StrictNilSymbol || index==PD_TailStrictNilSymbol || index==PD_StrictTailStrictNilSymbol
-						= match_and_instantiate_overloaded_cons_boxed_match linearities app_args guards case_default ro ti
-	//					= abort "match_and_instantiate_overloaded_cons_boxed_match"
-			match_and_instantiate_overloaded_cons_boxed_match _ app_args [] case_default ro ti
-				= transform case_default { ro & ro_root_case_mode = NotRootCase } ti
-	match_and_instantiate_overloaded_cons cons_function_type linearities app_args (OverloadedListPatterns _ _ algebraicPatterns) case_default ro ti
-		= match_and_instantiate_overloaded_cons_overloaded_match linearities app_args algebraicPatterns case_default ro ti
-		where
-			match_and_instantiate_overloaded_cons_overloaded_match [linearity:linearities] app_args 
-									[{ap_symbol={glob_module,glob_object={ds_index}}, ap_vars, ap_expr} : guards] 
-									case_default ro ti
-				| glob_module==cPredefinedModuleIndex
-					# index=ds_index+FirstConstructorPredefinedSymbolIndex
-					| index==PD_UnboxedConsSymbol || index==PD_UnboxedTailStrictConsSymbol || index==PD_OverloadedConsSymbol
-						= instantiate linearity app_args ap_vars ap_expr cons_function_type.st_args_strictness cons_function_type.st_args ti
-	//				| index==PD_UnboxedNilSymbol || index==PD_UnboxedTailStrictNilSymbol || index==PD_OverloadedNilSymbol
-						= match_and_instantiate_overloaded_cons_overloaded_match linearities app_args guards case_default ro ti
-	//					= abort "match_and_instantiate_overloaded_cons_overloaded_match"
-			match_and_instantiate_overloaded_cons_overloaded_match _ app_args [] case_default ro ti
-				= transform case_default { ro & ro_root_case_mode = NotRootCase } ti
-
-	/*
-	match_and_instantiate_overloaded_cons linearities app_args (OverloadedListPatterns _ (App {app_args=[],app_symb={symb_kind=SK_Function {glob_module=decons_module,glob_object=deconsindex}}}) algebraicPatterns) case_default ro ti
-		= match_and_instantiate_overloaded_cons_overloaded_match linearities app_args algebraicPatterns case_default ro ti
-		where
-			match_and_instantiate_overloaded_cons_overloaded_match [linearity:linearities] app_args 
-									[{ap_symbol={glob_module,glob_object={ds_index}}, ap_vars, ap_expr} : guards] 
-									case_default ro ti
-				| glob_module==cPredefinedModuleIndex
-					# index=ds_index+FirstConstructorPredefinedSymbolIndex
-					| index==PD_UnboxedConsSymbol || index==PD_UnboxedTailStrictConsSymbol || index==PD_OverloadedConsSymbol
-						# (argument_types,strictness) = case ro.ro_imported_funs.[decons_module].[deconsindex].ft_type.st_result.at_type of
-												TA _ args=:[arg1,arg2] -> (args,NotStrict)
-												TAS _ args=:[arg1,arg2] strictness -> (args,strictness)
-						= instantiate linearity app_args ap_vars ap_expr strictness argument_types ti
-					| index==PD_UnboxedNilSymbol || index==PD_UnboxedTailStrictNilSymbol || index==PD_OverloadedNilSymbol
-						= match_and_instantiate_overloaded_cons_overloaded_match linearities app_args guards case_default ro ti
-						= abort "match_and_instantiate_overloaded_cons_overloaded_match"
-			match_and_instantiate_overloaded_cons_overloaded_match [linearity:linearities] app_args [guard : guards] case_default ro ti
-				= match_and_instantiate_overloaded_cons_overloaded_match linearities app_args guards case_default ro ti
-			match_and_instantiate_overloaded_cons_overloaded_match _ app_args [] case_default ro ti
-				= transform case_default { ro & ro_root_case_mode = NotRootCase } ti
-	*/
+	trans_case_of_overloaded_nil_or_cons type ti
+		| type.st_arity==0
+			# (may_be_match_expr, ti) = match_and_instantiate_overloaded_nil case_guards case_default ro ti
+			= expr_or_never_matching_case may_be_match_expr case_ident ti
+			# aci_linearity_of_patterns = case opt_aci of
+			  			Yes aci -> aci.aci_linearity_of_patterns
+			  (may_be_match_expr, ti) = match_and_instantiate_overloaded_cons type aci_linearity_of_patterns app_args case_guards case_default ro ti
+			= expr_or_never_matching_case may_be_match_expr case_ident ti
+	where
+		match_and_instantiate_overloaded_nil (OverloadedListPatterns _ _ algebraicPatterns) case_default ro ti
+			= match_and_instantiate_nil algebraicPatterns case_default ro ti
+		match_and_instantiate_overloaded_nil (AlgebraicPatterns _ algebraicPatterns) case_default ro ti
+			= match_and_instantiate_nil algebraicPatterns case_default ro ti
+	
+		match_and_instantiate_nil [{ap_symbol={glob_module,glob_object={ds_index}},ap_expr} : guards] case_default ro ti
+			| glob_module==cPredefinedModuleIndex
+				# index=ds_index+FirstConstructorPredefinedSymbolIndex
+				| index==PD_NilSymbol || index==PD_StrictNilSymbol || index==PD_TailStrictNilSymbol || index==PD_StrictTailStrictNilSymbol ||
+				  index==PD_OverloadedNilSymbol || index==PD_UnboxedNilSymbol || index==PD_UnboxedTailStrictNilSymbol
+					= instantiate [] [] [] ap_expr NotStrict [] ti
+					= match_and_instantiate_nil guards case_default ro ti
+		match_and_instantiate_nil [] case_default ro ti
+			= transform case_default { ro & ro_root_case_mode = NotRootCase } ti
+	
+		match_and_instantiate_overloaded_cons cons_function_type linearities app_args (AlgebraicPatterns _ algebraicPatterns) case_default ro ti
+			= match_and_instantiate_overloaded_cons_boxed_match linearities app_args algebraicPatterns case_default ro ti
+			where
+				match_and_instantiate_overloaded_cons_boxed_match [linearity:linearities] app_args 
+										[{ap_symbol={glob_module,glob_object={ds_index}}, ap_vars, ap_expr} : guards] 
+										case_default ro ti
+					| glob_module==cPredefinedModuleIndex
+						# index=ds_index+FirstConstructorPredefinedSymbolIndex
+						| index==PD_ConsSymbol || index==PD_StrictConsSymbol || index==PD_TailStrictConsSymbol || index==PD_StrictTailStrictConsSymbol
+							# {cons_type} = ro.ro_common_defs.[glob_module].com_cons_defs.[ds_index]
+							= instantiate linearity app_args ap_vars ap_expr cons_type.st_args_strictness cons_type.st_args ti
+		//				| index==PD_NilSymbol || index==PD_StrictNilSymbol || index==PD_TailStrictNilSymbol || index==PD_StrictTailStrictNilSymbol
+							= match_and_instantiate_overloaded_cons_boxed_match linearities app_args guards case_default ro ti
+		//					= abort "match_and_instantiate_overloaded_cons_boxed_match"
+				match_and_instantiate_overloaded_cons_boxed_match _ app_args [] case_default ro ti
+					= transform case_default { ro & ro_root_case_mode = NotRootCase } ti
+		match_and_instantiate_overloaded_cons cons_function_type linearities app_args (OverloadedListPatterns _ _ algebraicPatterns) case_default ro ti
+			= match_and_instantiate_overloaded_cons_overloaded_match linearities app_args algebraicPatterns case_default ro ti
+			where
+				match_and_instantiate_overloaded_cons_overloaded_match [linearity:linearities] app_args 
+										[{ap_symbol={glob_module,glob_object={ds_index}}, ap_vars, ap_expr} : guards] 
+										case_default ro ti
+					| glob_module==cPredefinedModuleIndex
+						# index=ds_index+FirstConstructorPredefinedSymbolIndex
+						| index==PD_UnboxedConsSymbol || index==PD_UnboxedTailStrictConsSymbol || index==PD_OverloadedConsSymbol
+							= instantiate linearity app_args ap_vars ap_expr cons_function_type.st_args_strictness cons_function_type.st_args ti
+		//				| index==PD_UnboxedNilSymbol || index==PD_UnboxedTailStrictNilSymbol || index==PD_OverloadedNilSymbol
+							= match_and_instantiate_overloaded_cons_overloaded_match linearities app_args guards case_default ro ti
+		//					= abort "match_and_instantiate_overloaded_cons_overloaded_match"
+				match_and_instantiate_overloaded_cons_overloaded_match _ app_args [] case_default ro ti
+					= transform case_default { ro & ro_root_case_mode = NotRootCase } ti
+	
+		/*
+		match_and_instantiate_overloaded_cons linearities app_args (OverloadedListPatterns _ (App {app_args=[],app_symb={symb_kind=SK_Function {glob_module=decons_module,glob_object=deconsindex}}}) algebraicPatterns) case_default ro ti
+			= match_and_instantiate_overloaded_cons_overloaded_match linearities app_args algebraicPatterns case_default ro ti
+			where
+				match_and_instantiate_overloaded_cons_overloaded_match [linearity:linearities] app_args 
+										[{ap_symbol={glob_module,glob_object={ds_index}}, ap_vars, ap_expr} : guards] 
+										case_default ro ti
+					| glob_module==cPredefinedModuleIndex
+						# index=ds_index+FirstConstructorPredefinedSymbolIndex
+						| index==PD_UnboxedConsSymbol || index==PD_UnboxedTailStrictConsSymbol || index==PD_OverloadedConsSymbol
+							# (argument_types,strictness) = case ro.ro_imported_funs.[decons_module].[deconsindex].ft_type.st_result.at_type of
+													TA _ args=:[arg1,arg2] -> (args,NotStrict)
+													TAS _ args=:[arg1,arg2] strictness -> (args,strictness)
+							= instantiate linearity app_args ap_vars ap_expr strictness argument_types ti
+						| index==PD_UnboxedNilSymbol || index==PD_UnboxedTailStrictNilSymbol || index==PD_OverloadedNilSymbol
+							= match_and_instantiate_overloaded_cons_overloaded_match linearities app_args guards case_default ro ti
+							= abort "match_and_instantiate_overloaded_cons_overloaded_match"
+				match_and_instantiate_overloaded_cons_overloaded_match [linearity:linearities] app_args [guard : guards] case_default ro ti
+					= match_and_instantiate_overloaded_cons_overloaded_match linearities app_args guards case_default ro ti
+				match_and_instantiate_overloaded_cons_overloaded_match _ app_args [] case_default ro ti
+					= transform case_default { ro & ro_root_case_mode = NotRootCase } ti
+		*/
 
 	instantiate linearity app_args ap_vars ap_expr cons_type_args_strictness cons_type_args ti
 		# zipped = zip2 ap_vars app_args
@@ -2327,7 +2340,7 @@ transformFunctionApplication fun_def instances cc=:{cc_size, cc_args, cc_linear_
 		# is_applied_to_macro_fun = fun_def.fun_info.fi_properties bitand FI_IsMacroFun <> 0
 	  	# consumer_is_curried = cc_size <> length app_args
 		# non_rec_consumer
-			= (fun_def.fun_info.fi_properties bitand FI_IsNonRecursive) <> 0 with FI_IsNonRecursive = 4
+			= (fun_def.fun_info.fi_properties bitand FI_IsNonRecursive) <> 0
 		# safe_args
 			= isEmpty [arg \\ arg <- app_args & cc_arg <- cc_args | unsafe cc_arg && non_var arg]
 						with
@@ -3024,7 +3037,7 @@ determineProducer is_applied_to_macro_fun consumer_is_curried ok_non_rec_consume
 				-!-> ("Produce1cc_hnr",symb.symb_name)
 // NON-REC...
 	# non_rec_producer
-		= (fun_info.fi_properties bitand FI_IsNonRecursive) <> 0 with FI_IsNonRecursive = 4
+		= (fun_info.fi_properties bitand FI_IsNonRecursive) <> 0
 	# ok_non_rec
 		= case fun_body of
 			Expanding _
@@ -3078,7 +3091,7 @@ determineProducer is_applied_to_macro_fun consumer_is_curried ok_non_rec_consume
 					-!-> ("Produce2cc_ho",symb.symb_name)
 // NON-REC...
 		# non_rec_producer
-			= (fun_info.fi_properties bitand FI_IsNonRecursive) <> 0 with FI_IsNonRecursive = 4
+			= (fun_info.fi_properties bitand FI_IsNonRecursive) <> 0
 		# ok_non_rec
 			= case fun_body of
 				Expanding _
diff --git a/frontend/type.icl b/frontend/type.icl
index 4262256..20e5e07 100644
--- a/frontend/type.icl
+++ b/frontend/type.icl
@@ -2768,7 +2768,7 @@ where
 						,	fun_pos			= me_pos
 						,	fun_kind		= FK_Unknown
 						,	fun_lifted		= 0
-						,	fun_info		= EmptyFunInfo
+						,	fun_info		= {EmptyFunInfo & fi_properties=FI_IsUnboxedListOfRecordsConsOrNil}
 						}
 					= ({fun_defs & [fun_index]=fun}, type_heaps, error)