path: root/frontend/trans.icl

implementation module trans

import StdEnv, StdStrictLists

import syntax, transform, checksupport, compare_types, utilities, expand_types, unitype, type
import classify, partition
from StdOverloadedList import RepeatnM,TakeM,++$,Any

SwitchCaseFusion			fuse dont_fuse :== fuse
SwitchGeneratedFusion		fuse dont_fuse :== fuse
SwitchFunctionFusion		fuse dont_fuse :== fuse
SwitchConstructorFusion		fuse fuse_generics dont_fuse :== fuse_generics
SwitchRnfConstructorFusion  rnf  linear	   :== rnf
SwitchCurriedFusion			fuse xtra dont_fuse :== fuse 
SwitchExtraCurriedFusion	fuse macro	   :== fuse//(fuse && macro)//fuse
SwitchTrivialFusion			fuse dont_fuse :== fuse
SwitchUnusedFusion			fuse dont_fuse :== fuse
SwitchTransformConstants	tran dont_tran :== tran
SwitchSpecialFusion			fuse dont_fuse :== fuse
SwitchArityChecks			check dont_check :== check
SwitchAutoFoldCaseInCase	fold dont	   :== fold
SwitchAutoFoldAppInCase		fold dont	   :== fold
SwitchAlwaysIntroduceCaseFunction yes no   :== no
SwitchNonRecFusion			fuse dont_fuse :== dont_fuse
SwitchHOFusion				fuse dont_fuse :== fuse
SwitchHOFusion`				fuse dont_fuse :== fuse
SwitchStrictPossiblyAddLet  strict lazy    :== lazy//strict

/*
(-!->) infix
(-!->) a b :== a  // ---> b
(<-!-) infix
(<-!-) a b :== a  // <--- b
*/

fromYes (Yes x) = x

is_SK_Function_or_SK_LocalMacroFunction (SK_Function _) = True
is_SK_Function_or_SK_LocalMacroFunction (SK_LocalMacroFunction _) = True
is_SK_Function_or_SK_LocalMacroFunction _ = False

undeff :== -1

empty_atype = { at_attribute = TA_Multi, at_type = TE }

get_producer_symbol (PR_Curried symbol arity)
	= (symbol,arity)
get_producer_symbol (PR_Function symbol arity _)
	= (symbol,arity)
get_producer_symbol (PR_GeneratedFunction symbol arity _)
	= (symbol,arity)
get_producer_symbol (PR_Constructor symbol arity _)
	= (symbol,arity)
get_producer_symbol (PR_CurriedFunction symbol arity _)
	= (symbol,arity)

// Extended variable info accessors...

readVarInfo :: VarInfoPtr *VarHeap -> (VarInfo, !*VarHeap)
readVarInfo var_info_ptr var_heap
	# (var_info, var_heap) = readPtr var_info_ptr var_heap
	= case var_info of
		VI_Extended _ original_var_info	-> (original_var_info, var_heap)
		_								-> (var_info, var_heap)

readExtendedVarInfo :: VarInfoPtr *VarHeap -> (ExtendedVarInfo, !*VarHeap)
readExtendedVarInfo var_info_ptr var_heap
	# (var_info, var_heap) = readPtr var_info_ptr var_heap
	= case var_info of
		VI_Extended extensions _	-> (extensions, var_heap)
		_							-> abort "Error in compiler: 'readExtendedVarInfo' failed in module trans.\n"

writeVarInfo :: VarInfoPtr VarInfo *VarHeap -> *VarHeap
writeVarInfo var_info_ptr new_var_info var_heap
	# (old_var_info, var_heap) = readPtr var_info_ptr var_heap
	= case old_var_info of
		VI_Extended extensions _	-> writePtr var_info_ptr (VI_Extended extensions new_var_info) var_heap
		_							-> writePtr var_info_ptr new_var_info var_heap

setExtendedVarInfo :: !VarInfoPtr !ExtendedVarInfo !*VarHeap -> *VarHeap
setExtendedVarInfo var_info_ptr extension var_heap
	# (old_var_info, var_heap) = readPtr var_info_ptr var_heap
	= case old_var_info of
		VI_Extended _ original_var_info	-> writePtr var_info_ptr (VI_Extended extension original_var_info) var_heap
		_								-> writePtr var_info_ptr (VI_Extended extension old_var_info) var_heap

// Extended expression info accessors...

readExprInfo :: !ExprInfoPtr !*ExpressionHeap -> (!ExprInfo,!*ExpressionHeap)
readExprInfo expr_info_ptr symbol_heap
	# (expr_info, symbol_heap) = readPtr expr_info_ptr symbol_heap
	= case expr_info of
		EI_Extended _ ei	-> (ei, symbol_heap)
		_					-> (expr_info, symbol_heap)

writeExprInfo :: !ExprInfoPtr !ExprInfo !*ExpressionHeap -> *ExpressionHeap
writeExprInfo expr_info_ptr new_expr_info symbol_heap
	# (expr_info, symbol_heap) = readPtr expr_info_ptr symbol_heap
	= case expr_info of
		EI_Extended extensions _	-> writePtr expr_info_ptr (EI_Extended extensions new_expr_info) symbol_heap
		_							-> writePtr expr_info_ptr new_expr_info symbol_heap

app_EEI_ActiveCase transformer expr_info_ptr expr_heap
	# (expr_info, expr_heap) = readPtr expr_info_ptr expr_heap
	= case expr_info of
		(EI_Extended (EEI_ActiveCase aci) original_expr_info)
			-> writePtr expr_info_ptr (EI_Extended (EEI_ActiveCase (transformer aci)) original_expr_info) expr_heap
		_	-> expr_heap

set_aci_free_vars_info_case unbound_variables case_info_ptr expr_heap
	= app_EEI_ActiveCase (\aci -> { aci & aci_free_vars=Yes unbound_variables }) case_info_ptr expr_heap

remove_aci_free_vars_info case_info_ptr expr_heap
	= app_EEI_ActiveCase (\aci->{aci & aci_free_vars = No }) case_info_ptr expr_heap

cleanup_attributes expr_info_ptr symbol_heap
	# (expr_info, symbol_heap) = readPtr expr_info_ptr symbol_heap
	= case expr_info of
		EI_Extended _ expr_info -> writePtr expr_info_ptr expr_info symbol_heap
		_ -> symbol_heap

//	TRANSFORM

::	*TransformInfo =
	{	ti_fun_defs				:: !*{# FunDef}
	,	ti_instances 			:: !*{! InstanceInfo }
	,	ti_cons_args 			:: !*{! ConsClasses}
	,	ti_new_functions 		:: ![FunctionInfoPtr]
	,	ti_fun_heap				:: !*FunctionHeap
	,	ti_var_heap				:: !*VarHeap
	,	ti_symbol_heap			:: !*ExpressionHeap
	,	ti_type_heaps			:: !*TypeHeaps
	,	ti_type_def_infos		:: !*TypeDefInfos
	,	ti_next_fun_nr			:: !Index
	,	ti_cleanup_info			:: !CleanupInfo
	,	ti_recursion_introduced	:: !Optional RI
	,	ti_error_file			:: !*File
	,	ti_predef_symbols		:: !*PredefinedSymbols
	}

:: RI = { ri_fun_index :: !Int, ri_fun_ptr :: !FunctionInfoPtr}

::	ReadOnlyTI = 
	{	ro_imported_funs	:: !{# {# FunType} }
	,	ro_common_defs		:: !{# CommonDefs }
// the following four are used when possibly generating functions for cases...
	,	ro_root_case_mode		:: !RootCaseMode
	,	ro_tfi					:: !TransformFunctionInfo
	,	ro_main_dcl_module_n 	:: !Int
	,	ro_transform_fusion		:: !Bool			// fusion switch
	,	ro_StdStrictLists_module_n :: !Int
	,	ro_StdGeneric_module_n	:: !Int
	}

::	TransformFunctionInfo =
	{	tfi_root				:: !SymbIdent		// original function
	,	tfi_case				:: !SymbIdent		// original function or possibly generated case
	,	tfi_args				:: ![FreeVar]		// args of above
	,	tfi_vars				:: ![FreeVar]		// strict variables
	,	tfi_orig				:: !SymbIdent		// original consumer
	,	tfi_n_args_before_producer :: !Int
	,	tfi_n_producer_args		:: !Int
	}

::	RootCaseMode = NotRootCase | RootCase | RootCaseOfZombie

::	CopyState = {
		cs_var_heap				:: !.VarHeap,
		cs_symbol_heap			:: !.ExpressionHeap,
		cs_opt_type_heaps		:: !.Optional .TypeHeaps,
		cs_cleanup_info			:: ![ExprInfoPtr]
	}

::	CopyInfo = { ci_handle_aci_free_vars	:: !AciFreeVarsHandleMode }

:: AciFreeVarsHandleMode = LeaveAciFreeVars | RemoveAciFreeVars | SubstituteAciFreeVars

neverMatchingCase (Yes ident)
	= FailExpr ident
neverMatchingCase _ 
	# ident = {id_name = "neverMatchingCase", id_info = nilPtr}
	= FailExpr ident

store_type_info_of_alg_pattern_in_pattern_variables ct_cons_types patterns var_heap
	= fold2St store_type_info_of_alg_pattern ct_cons_types patterns var_heap
	where
		store_type_info_of_alg_pattern var_types {ap_vars} var_heap
			= fold2St store_type_info_of_pattern_var var_types ap_vars var_heap

		store_type_info_of_pattern_var var_type {fv_info_ptr} var_heap
			= setExtendedVarInfo fv_info_ptr (EVI_VarType var_type) var_heap

class transform a :: !a !ReadOnlyTI !*TransformInfo -> (!a, !*TransformInfo)

instance transform Expression
where
	transform (App app=:{app_args}) ro ti
		# (app_args, ti) = transform app_args ro ti
		= transformApplication {app & app_args = app_args} [] ro ti
	transform appl_expr=:(expr @ exprs) ro ti
		# (expr, ti) = transform expr ro ti
		  (exprs, ti) = transform exprs ro ti
		= case expr of
			App app
				-> transformApplication app exprs ro ti
			_
				-> (expr @ exprs, ti)
	transform (Let lad=:{let_strict_binds, let_lazy_binds, let_expr}) ro ti
		# ti = store_type_info_of_bindings_in_heap lad ti
		  (let_strict_binds, ti) = transform let_strict_binds ro ti
		  (let_lazy_binds, ti) = transform let_lazy_binds ro ti
		  (let_expr, ti) = transform let_expr ro ti
		  lad = { lad & let_lazy_binds = let_lazy_binds, let_strict_binds = let_strict_binds, let_expr = let_expr}
		= (Let lad, ti)
	  where
		store_type_info_of_bindings_in_heap {let_strict_binds, let_lazy_binds,let_info_ptr} ti
			# let_binds = let_strict_binds ++ let_lazy_binds
			  (EI_LetType var_types, ti_symbol_heap) = readExprInfo let_info_ptr ti.ti_symbol_heap
			  ti_var_heap = foldSt store_type_info_let_bind (zip2 var_types let_binds) ti.ti_var_heap
			= {ti & ti_symbol_heap = ti_symbol_heap, ti_var_heap = ti_var_heap}
		store_type_info_let_bind (var_type, {lb_dst={fv_info_ptr}}) var_heap
			= setExtendedVarInfo fv_info_ptr (EVI_VarType var_type) var_heap

	transform (Case kees) ro ti
		# ti = store_type_info_of_patterns_in_heap kees ti
		= transformCase kees ro ti
	  where
		store_type_info_of_patterns_in_heap {case_guards,case_info_ptr} ti
			= case case_guards of
				AlgebraicPatterns _ patterns
					# (EI_CaseType {ct_cons_types},ti_symbol_heap) = readExprInfo case_info_ptr ti.ti_symbol_heap
					  ti_var_heap = store_type_info_of_alg_pattern_in_pattern_variables ct_cons_types patterns ti.ti_var_heap
					-> { ti & ti_symbol_heap = ti_symbol_heap, ti_var_heap = ti_var_heap }
				BasicPatterns _ _
					-> ti // no variables occur
				OverloadedListPatterns _ _ patterns
					# (EI_CaseType {ct_cons_types},ti_symbol_heap) = readExprInfo case_info_ptr ti.ti_symbol_heap
					  ti_var_heap = store_type_info_of_alg_pattern_in_pattern_variables ct_cons_types patterns ti.ti_var_heap
					-> { ti & ti_symbol_heap = ti_symbol_heap, ti_var_heap = ti_var_heap }
				NoPattern
					-> ti

	transform (Selection opt_type expr selectors) ro ti
		# (expr, ti) = transform expr ro ti
		= transformSelection opt_type selectors expr ro ti
	transform (Update expr1 selectors expr2) ro ti
		# (expr1,ti) = transform expr1 ro ti
		# (selectors,ti) = transform_expressions_in_selectors selectors ro ti
		# (expr2,ti) = transform expr2 ro ti
		= (Update expr1 selectors expr2,ti)
	transform (RecordUpdate cons_symbol expr exprs) ro ti
		# (expr,ti) = transform expr ro ti
		# (exprs,ti) = transform_fields exprs ro ti
		=(RecordUpdate cons_symbol expr exprs,ti)
	where	
		transform_fields [] ro ti
			= ([],ti)
		transform_fields [bind=:{bind_src} : fields] ro ti
			# (bind_src,ti) = transform bind_src ro ti
			# (fields,ti) = transform_fields fields ro ti
			= ([{bind & bind_src=bind_src} : fields],ti)
	transform (TupleSelect a1 arg_nr expr) ro ti
		# (expr,ti) = transform expr ro ti
		= (TupleSelect a1 arg_nr expr,ti)
	transform (MatchExpr a1 expr) ro ti
		# (expr,ti) = transform expr ro ti
		= (MatchExpr a1 expr,ti)
	transform (IsConstructor expr cons_symbol cons_arity global_type_index case_ident position) ro ti
		# (expr,ti) = transform expr ro ti
		= (IsConstructor expr cons_symbol cons_arity global_type_index case_ident position, ti)
	transform (DynamicExpr dynamic_expr) ro ti
		# (dynamic_expr, ti) = transform dynamic_expr ro ti
		= (DynamicExpr dynamic_expr, ti)
	transform (DictionariesFunction dictionaries expr expr_type) ro ti
		# (expr,ti) = transform expr ro ti
		= (DictionariesFunction dictionaries expr expr_type,ti)
	transform expr ro ti
		= (expr, ti)

transform_expressions_in_selectors [selection=:RecordSelection _ _ : selections] ro ti
	# (selections,ti) = transform_expressions_in_selectors selections ro ti
	= ([selection:selections],ti)
transform_expressions_in_selectors [ArraySelection ds ep expr : selections] ro ti
	# (expr,ti) = transform expr ro ti
	# (selections,ti) = transform_expressions_in_selectors selections ro ti
	= ([ArraySelection ds ep expr:selections],ti)
transform_expressions_in_selectors [DictionarySelection bv dictionary_selections ep expr : selections] ro ti
	# (expr,ti) = transform expr ro ti
	# (dictionary_selections,ti) = transform_expressions_in_selectors dictionary_selections ro ti
	# (selections,ti) = transform_expressions_in_selectors selections ro ti
	= ([DictionarySelection bv dictionary_selections ep expr:selections],ti)
transform_expressions_in_selectors [] ro ti
	= ([],ti)

instance transform DynamicExpr where
	transform dyn=:{dyn_expr} ro ti
		# (dyn_expr, ti) = transform dyn_expr ro ti
		= ({dyn & dyn_expr = dyn_expr}, ti)

transformCase this_case=:{case_expr,case_guards,case_default,case_ident,case_info_ptr} ro ti
	| SwitchCaseFusion (not ro.ro_transform_fusion) True
		= skip_over this_case ro ti
	| isNilPtr case_info_ptr			// encountered neverMatchingCase?!
		= skip_over this_case ro ti
	# (case_info, ti_symbol_heap) = readPtr case_info_ptr ti.ti_symbol_heap
	  ti = { ti & ti_symbol_heap=ti_symbol_heap }
	  (result_expr, ti)	= case case_info of
							EI_Extended (EEI_ActiveCase aci) _
								| is_variable case_expr
									-> skip_over this_case ro ti
								-> case ro.ro_root_case_mode of
									NotRootCase
										-> transform_active_non_root_case this_case aci ro ti
									_
										-> transform_active_root_case aci this_case ro ti
							_
								-> skip_over this_case ro ti
	  ti = { ti & ti_symbol_heap = remove_aci_free_vars_info case_info_ptr ti.ti_symbol_heap }
	# final_expr = removeNeverMatchingSubcases result_expr ro
	= (final_expr, ti) // ---> ("transformCase",result_expr,final_expr)
where
	is_variable (Var _) = True
	is_variable _ 		= False

skip_over this_case=:{case_expr=case_expr=:BasicExpr basic_value,case_guards=case_guards=:BasicPatterns basic_type basicPatterns,case_default} ro ti
	// currently only active cases are matched at runtime (multimatch problem)
	# matching_patterns = [pattern \\ pattern=:{bp_value}<-basicPatterns | bp_value==basic_value]
	= case matching_patterns of
		[]
			-> case case_default of
				Yes default_expr
					-> transform default_expr {ro & ro_root_case_mode = NotRootCase} ti
				No
					# ro_lost_root = {ro & ro_root_case_mode = NotRootCase}
					# (new_case_expr, ti) = transform case_expr ro_lost_root ti
					-> (Case {this_case & case_expr=new_case_expr, case_guards=BasicPatterns basic_type []}, ti)
/*
					// The following does not work, because a FailExpr may only occur as else of an if in the backend */
					# never_ident = case ro.ro_root_case_mode of
										NotRootCase -> this_case.case_ident
										_ -> Yes ro.ro_tfi.tfi_case.symb_ident
					-> (neverMatchingCase never_ident, ti)
*/
		[{bp_expr}]
			| case_alt_matches_always bp_expr ro
				-> transform bp_expr {ro & ro_root_case_mode = NotRootCase} ti
		_
			# ro_lost_root = {ro & ro_root_case_mode = NotRootCase}
			  (new_case_expr, ti) = transform case_expr ro_lost_root ti
			  (new_case_guards, ti) = transform case_guards ro_lost_root ti
			  (new_case_default, ti) = transform case_default ro_lost_root ti
			-> (Case {this_case & case_expr=new_case_expr, case_guards=new_case_guards, case_default=new_case_default}, ti)
skip_over this_case=:{case_expr,case_guards,case_default} ro ti
	# ro_lost_root = { ro & ro_root_case_mode = NotRootCase }
	  (new_case_expr, ti) = transform case_expr ro_lost_root ti
	  (new_case_guards, ti) = transform case_guards ro_lost_root ti
	  (new_case_default, ti) = transform case_default ro_lost_root ti
	= (Case { this_case & case_expr=new_case_expr, case_guards=new_case_guards, case_default=new_case_default }, ti)

case_alt_matches_always (Case {case_default,case_explicit,case_guards}) ro
	| case_explicit
		= True
		= case case_default of
			Yes _
				-> True
			_
				-> case case_guards of
					AlgebraicPatterns {gi_module,gi_index} algebraic_patterns
						-> case ro.ro_common_defs.[gi_module].com_type_defs.[gi_index].td_rhs of
							AlgType constructors
								| same_length constructors algebraic_patterns
									-> algebraic_patterns_match_always algebraic_patterns ro
							RecordType _
								-> algebraic_patterns_match_always algebraic_patterns ro
							_
								-> False
					_
						-> False
case_alt_matches_always (Let {let_expr}) ro
	= case_alt_matches_always let_expr ro
case_alt_matches_always _ ro
	= True

algebraic_patterns_match_always [{ap_expr}:algebraic_patterns] ro
	= case_alt_matches_always ap_expr ro && algebraic_patterns_match_always algebraic_patterns ro
algebraic_patterns_match_always [] ro
	= True

free_vars_to_bound_vars free_vars
	= [Var {var_ident = fv_ident, var_info_ptr = fv_info_ptr, var_expr_ptr = nilPtr} \\ {fv_ident,fv_info_ptr} <- free_vars]

transform_active_root_case aci this_case=:{case_expr = Case case_in_case} ro ti
	= lift_case case_in_case this_case ro ti
where
	lift_case nested_case=:{case_guards,case_default} outer_case ro ti
		| isNilPtr nested_case.case_info_ptr	// neverMatchingCase ?!
			= skip_over outer_case ro ti
		# default_exists = case case_default of
							Yes _	-> True
							No		-> False
		  (case_guards, ti) = lift_patterns default_exists case_guards nested_case.case_info_ptr outer_case ro ti
		  (case_default, ti) = lift_default case_default outer_case ro ti
		  (EI_CaseType outer_case_type, ti_symbol_heap) = readExprInfo outer_case.case_info_ptr ti.ti_symbol_heap
		// the result type of the nested case becomes the result type of the outer case
		  ti_symbol_heap = overwrite_result_type nested_case.case_info_ptr outer_case_type.ct_result_type ti_symbol_heap
		// after this transformation the aci_free_vars information doesn't hold anymore
		  ti_symbol_heap = remove_aci_free_vars_info nested_case.case_info_ptr ti_symbol_heap
		  ti = { ti & ti_symbol_heap = ti_symbol_heap }
		= (Case {nested_case & case_guards = case_guards, case_default = case_default}, ti)
	  where
		overwrite_result_type case_info_ptr new_result_type ti_symbol_heap
			#! (EI_CaseType case_type, ti_symbol_heap)	= readExprInfo case_info_ptr ti_symbol_heap
			= writeExprInfo case_info_ptr (EI_CaseType { case_type & ct_result_type = new_result_type}) ti_symbol_heap

	lift_patterns default_exists (AlgebraicPatterns type case_guards) case_info_ptr outer_case ro ti
		# guard_exprs	= [ ap_expr \\ {ap_expr} <- case_guards ]
		  (EI_CaseType {ct_cons_types},symbol_heap) = readExprInfo case_info_ptr ti.ti_symbol_heap
		  var_heap = store_type_info_of_alg_pattern_in_pattern_variables ct_cons_types case_guards ti.ti_var_heap
		  ti = {ti & ti_symbol_heap=symbol_heap,ti_var_heap=var_heap}
		  (guard_exprs_with_case, ti) = lift_patterns_2 default_exists guard_exprs outer_case ro ti
		= (AlgebraicPatterns type [ { case_guard & ap_expr=guard_expr } \\ case_guard<-case_guards & guard_expr<-guard_exprs_with_case], ti)
	lift_patterns default_exists (BasicPatterns basic_type case_guards) case_info_ptr outer_case ro ti
		# guard_exprs	= [ bp_expr \\ {bp_expr} <- case_guards ]
		  (guard_exprs_with_case, ti) = lift_patterns_2 default_exists guard_exprs outer_case ro ti
		= (BasicPatterns basic_type [ { case_guard & bp_expr=guard_expr } \\ case_guard<-case_guards & guard_expr<-guard_exprs_with_case], ti)
	lift_patterns default_exists (OverloadedListPatterns type decons_expr case_guards) case_info_ptr outer_case ro ti
		# guard_exprs	= [ ap_expr \\ {ap_expr} <- case_guards ]
		  (EI_CaseType {ct_cons_types},symbol_heap) = readExprInfo case_info_ptr ti.ti_symbol_heap
		  var_heap = store_type_info_of_alg_pattern_in_pattern_variables ct_cons_types case_guards ti.ti_var_heap
		  ti = {ti & ti_symbol_heap=symbol_heap,ti_var_heap=var_heap}
		  (guard_exprs_with_case, ti) = lift_patterns_2 default_exists guard_exprs outer_case ro ti
		= (OverloadedListPatterns type decons_expr [ { case_guard & ap_expr=guard_expr } \\ case_guard<-case_guards & guard_expr<-guard_exprs_with_case], ti)

	lift_patterns_2 False [guard_expr] outer_case ro ti
		// if no default pattern exists, then the outer case expression does not have to be copied for the last pattern
		# (guard_expr, ti)						= possiblyFoldOuterCase True guard_expr outer_case ro ti
		= ([guard_expr], ti)
	lift_patterns_2 default_exists [guard_expr : guard_exprs] outer_case ro ti
		# (guard_expr, ti)						= possiblyFoldOuterCase False guard_expr outer_case ro ti
		  (guard_exprs, ti) = lift_patterns_2 default_exists guard_exprs outer_case ro ti
		= ([guard_expr : guard_exprs], ti)
	lift_patterns_2 _ [] _ _ ti
		= ([], ti)
		
	lift_default (Yes default_expr) outer_case ro ti
		# (default_expr, ti)					= possiblyFoldOuterCase True default_expr outer_case ro ti
		= (Yes default_expr, ti)
	lift_default No _ _ ti
		= (No, ti)

	possiblyFoldOuterCase final guard_expr outer_case ro=:{ro_tfi} ti
		| SwitchAutoFoldCaseInCase (isFoldExpression guard_expr ti.ti_fun_defs ti.ti_cons_args) False // otherwise GOTO next alternative
			| ro_tfi.tfi_n_args_before_producer < 0 || ro_tfi.tfi_n_producer_args < 0
				= possiblyFoldOuterCase` final guard_expr outer_case ro ti	//abort "possiblyFoldOuterCase: unexpected!\n"
			= case aci.aci_opt_unfolder of
				No
					-> possiblyFoldOuterCase` final guard_expr outer_case ro ti
				Yes _
					-> transformApplication (make_consumer_application ro_tfi guard_expr) [] ro ti
		= possiblyFoldOuterCase` final guard_expr outer_case ro ti
	where
		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
					| 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 _)	ti_fun_defs ti_cons_args = True
//		isFoldExpression (Case _)	ti_fun_defs ti_cons_args = True
		isFoldExpression _			ti_fun_defs ti_cons_args = False

	possiblyFoldOuterCase` final guard_expr outer_case ro ti
		| final
			# new_case = {outer_case & case_expr = guard_expr}
			= transformCase new_case ro ti // ---> ("possiblyFoldOuterCase`",Case new_case)
		# cs = {cs_var_heap = ti.ti_var_heap, cs_symbol_heap = ti.ti_symbol_heap, cs_opt_type_heaps = No, cs_cleanup_info=ti.ti_cleanup_info}
		  (outer_guards, cs=:{cs_cleanup_info})	= copyCasePatterns outer_case.case_guards No {ci_handle_aci_free_vars = LeaveAciFreeVars} cs
		  (expr_info, ti_symbol_heap)			= readPtr outer_case.case_info_ptr cs.cs_symbol_heap
		  (new_info_ptr, ti_symbol_heap)		= newPtr expr_info ti_symbol_heap
		  new_cleanup_info 						= case expr_info of
		  		EI_Extended _ _
		  			-> [new_info_ptr:cs_cleanup_info]
		  		_ 	-> cs_cleanup_info
		  ti = { ti & ti_var_heap = cs.cs_var_heap, ti_symbol_heap = ti_symbol_heap, ti_cleanup_info=new_cleanup_info }
		  new_case								= { outer_case & case_expr = guard_expr, case_guards=outer_guards, case_info_ptr=new_info_ptr }
		= transformCase new_case ro ti // ---> ("possiblyFoldOuterCase`",Case new_case)

transform_active_root_case aci this_case=:{case_expr = case_expr=:(App app=:{app_symb,app_args}),case_guards,case_default,case_explicit,case_ident} ro ti
	= case app_symb.symb_kind of
		SK_Constructor cons_index
			// currently only active cases are matched at runtime (multimatch problem)
			# aci_linearity_of_patterns = aci.aci_linearity_of_patterns
			  (may_be_match_expr, ti) = match_and_instantiate aci_linearity_of_patterns cons_index app_args case_guards case_default ro ti
			-> expr_or_never_matching_case may_be_match_expr case_ident ti
		SK_Function {glob_module,glob_object}
			| glob_module==ro.ro_StdStrictLists_module_n &&
				(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
				-> 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 &&
				(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
		_
			# {aci_params,aci_opt_unfolder} = aci
			-> case aci_opt_unfolder of
				No
					-> skip_over this_case ro ti									// -!-> ("transform_active_root_case","No opt unfolder")
				Yes unfolder
					| not (equal app_symb.symb_kind unfolder.symb_kind)
						// in this case a third function could be fused in
						-> possiblyFoldOuterCase this_case ro ti					// -!-> ("transform_active_root_case","Diff opt unfolder",unfolder,app_symb)
					# variables = [ Var {var_ident=fv_ident, var_info_ptr=fv_info_ptr, var_expr_ptr=nilPtr}
									\\ {fv_ident, fv_info_ptr} <- ro.ro_tfi.tfi_args ]
					  (app_symb, ti)
						= case ro.ro_root_case_mode /* -!-> ("transform_active_root_case","Yes opt unfolder",unfolder) */ of
							RootCaseOfZombie
								# (recursion_introduced,ti) = ti!ti_recursion_introduced
								  (ro_fun=:{symb_kind=SK_GeneratedFunction fun_info_ptr _}) = ro.ro_tfi.tfi_case
								-> case recursion_introduced of
									No
										# (ti_next_fun_nr, ti) = ti!ti_next_fun_nr
										  ri = {ri_fun_index=ti_next_fun_nr, ri_fun_ptr=fun_info_ptr}
										  ti & ti_next_fun_nr = inc ti_next_fun_nr, ti_recursion_introduced = Yes ri,
										  	   ti_new_functions = [fun_info_ptr:ti.ti_new_functions]
										-> ({ro_fun & symb_kind=SK_GeneratedFunction fun_info_ptr ti_next_fun_nr}, ti)
//											-!-> ("Recursion","RootCaseOfZombie",ti_next_fun_nr,recursion_introduced)
									Yes {ri_fun_index,ri_fun_ptr}
										| ri_fun_ptr==fun_info_ptr
											-> ({ro_fun & symb_kind=SK_GeneratedFunction fun_info_ptr ri_fun_index},ti)
							RootCase
								-> (ro.ro_tfi.tfi_root,{ti & ti_recursion_introduced = No})
//									-!-> ("Recursion","RootCase",ro.ro_tfi.tfi_root)
					  app_args1 = replace_arg [ fv_info_ptr \\ {fv_info_ptr}<-aci_params ] app_args variables
					  (app_args2, ti) = transform app_args1 { ro & ro_root_case_mode = NotRootCase } ti
					-> (App {app_symb=app_symb, app_args=app_args2, app_info_ptr=nilPtr}, ti)
where
	possiblyFoldOuterCase this_case ro=:{ro_tfi} ti
		| SwitchAutoFoldAppInCase True False
			| ro_tfi.tfi_n_args_before_producer < 0 || ro_tfi.tfi_n_producer_args < 0
				= skip_over this_case ro ti	//abort "possiblyFoldOuterCase: unexpected!\n"
			= transformApplication (make_consumer_application ro_tfi case_expr) [] ro ti
		= skip_over this_case ro ti

	equal (SK_Function glob_index1) (SK_Function glob_index2)
		= glob_index1==glob_index2
	equal (SK_LocalMacroFunction glob_index1) (SK_LocalMacroFunction glob_index2)
		= glob_index1==glob_index2
	equal (SK_GeneratedFunction _ index1) (SK_GeneratedFunction _ index2)
		= index1==index2
	equal _ _
		= False

	replace_arg [] _ f
		= f
	replace_arg producer_vars=:[fv_info_ptr:_] act_pars form_pars=:[h_form_pars=:(Var {var_info_ptr}):t_form_pars]
		| fv_info_ptr<>var_info_ptr
			= [h_form_pars:replace_arg producer_vars act_pars t_form_pars]
		= replacement producer_vars act_pars form_pars
	  where
		replacement producer_vars [] form_pars
			= form_pars
		replacement producer_vars _ []
			= []
		replacement producer_vars [h_act_pars:t_act_pars] [form_par=:(Var {var_info_ptr}):form_pars]
			| isMember var_info_ptr producer_vars
				= [h_act_pars:replacement producer_vars t_act_pars form_pars]
			= replacement producer_vars t_act_pars form_pars

	match_and_instantiate linearities cons_index app_args (AlgebraicPatterns _ algebraicPatterns) case_default ro ti
		= match_and_instantiate_algebraic_type linearities cons_index app_args algebraicPatterns case_default ro ti
		where
			match_and_instantiate_algebraic_type [!linearity:linearities!] cons_index app_args
												 [{ap_symbol={glob_module,glob_object={ds_index}}, ap_vars, ap_expr} : guards] case_default ro ti
				| cons_index.glob_module == glob_module && cons_index.glob_object == ds_index
					# {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
				= match_and_instantiate_algebraic_type linearities cons_index app_args guards case_default ro ti
			match_and_instantiate_algebraic_type _ cons_index app_args [] case_default ro ti
				= transform case_default { ro & ro_root_case_mode = NotRootCase } ti
	match_and_instantiate linearities cons_index app_args (OverloadedListPatterns (OverloadedList _ _ _ _) _ algebraicPatterns) case_default ro ti
		= match_and_instantiate_overloaded_list linearities cons_index app_args algebraicPatterns case_default ro ti
		where
			match_and_instantiate_overloaded_list [!linearity:linearities!] cons_index=:{glob_module=cons_glob_module,glob_object=cons_ds_index} app_args 
									[{ap_symbol={glob_module,glob_object={ds_index}}, ap_vars, ap_expr} : guards] 
									case_default ro ti
				| equal_list_contructor glob_module ds_index cons_glob_module cons_ds_index
					# {cons_type} = ro.ro_common_defs.[cons_glob_module].com_cons_defs.[cons_ds_index]
					= instantiate linearity app_args ap_vars ap_expr cons_type.st_args_strictness cons_type.st_args ti
					= match_and_instantiate_overloaded_list linearities cons_index app_args guards case_default ro ti
					where
						equal_list_contructor glob_module ds_index cons_glob_module cons_ds_index
							| glob_module==cPredefinedModuleIndex && cons_glob_module==cPredefinedModuleIndex
								# index=ds_index+FirstConstructorPredefinedSymbolIndex
								# cons_index=cons_ds_index+FirstConstructorPredefinedSymbolIndex
								| index==PD_OverloadedConsSymbol
									= cons_index==PD_ConsSymbol || cons_index==PD_StrictConsSymbol || cons_index==PD_TailStrictConsSymbol || cons_index==PD_StrictTailStrictConsSymbol
								| index==PD_OverloadedNilSymbol
									= cons_index==PD_NilSymbol || cons_index==PD_StrictNilSymbol || cons_index==PD_TailStrictNilSymbol || cons_index==PD_StrictTailStrictNilSymbol
									= abort "equal_list_contructor"
			match_and_instantiate_overloaded_list _ cons_index 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 = 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_ap_vars_and_args = zip2 ap_vars app_args
		  (body_strictness,ti_fun_defs,ti_fun_heap) = body_strict ap_expr ap_vars ro ti.ti_fun_defs ti.ti_fun_heap
		  ti = {ti & ti_fun_defs = ti_fun_defs, ti_fun_heap = ti_fun_heap}
		  unfoldables = [ (arg_is_strict i body_strictness || ((not (arg_is_strict i cons_type_args_strictness))) && linear) || in_normal_form app_arg
		  				 \\ linear <|- linearity & app_arg <- app_args & i <- [0..]]
		  unfoldable_args = filterWith unfoldables zipped_ap_vars_and_args
		  not_unfoldable = map not unfoldables
		  ti_var_heap = foldSt (\({fv_info_ptr}, arg) -> writeVarInfo fv_info_ptr (VI_Expression arg)) unfoldable_args ti.ti_var_heap
		  (new_expr, ti_symbol_heap) = possibly_add_let zipped_ap_vars_and_args ap_expr not_unfoldable cons_type_args ro ti.ti_symbol_heap cons_type_args_strictness
		  copy_state = { cs_var_heap = ti_var_heap, cs_symbol_heap = ti_symbol_heap, cs_opt_type_heaps = No,cs_cleanup_info=ti.ti_cleanup_info }
		  (unfolded_expr, copy_state) = copy new_expr {ci_handle_aci_free_vars = LeaveAciFreeVars} copy_state
		  ti_var_heap = foldSt (\({fv_info_ptr}, arg) -> writeVarInfo fv_info_ptr VI_Empty) unfoldable_args copy_state.cs_var_heap
		  ti & ti_var_heap = ti_var_heap,ti_symbol_heap = copy_state.cs_symbol_heap,ti_cleanup_info=copy_state.cs_cleanup_info
		  (final_expr, ti) = transform unfolded_expr { ro & ro_root_case_mode = NotRootCase } ti
//		| False ---> ("instantiate",app_args,ap_vars,ap_expr,final_expr,unfoldables) = undef
		= (Yes final_expr, ti)
	where
		body_strict (Var v) ap_vars ro fun_defs fun_heap
			# lazy_args = insert_n_lazy_values_at_beginning (length app_args) NotStrict
			# is = [i \\ i <- [0..] & var <- ap_vars | v.var_info_ptr == var.fv_info_ptr]
			= case is of
				[]		-> (lazy_args,fun_defs,fun_heap)
				[i:_]	-> (add_strictness i lazy_args,fun_defs,fun_heap)
		body_strict (App app) ap_vars ro fun_defs fun_heap
			# (is,fun_defs,fun_heap) = app_indices app ro fun_defs fun_heap
			# lazy_args = insert_n_lazy_values_at_beginning (length app_args) NotStrict
			= (seq (map add_strictness is) lazy_args, fun_defs,fun_heap)
		body_strict _ _ ro fun_defs fun_heap
			# lazy_args = insert_n_lazy_values_at_beginning (length app_args) NotStrict
			= (lazy_args,fun_defs,fun_heap)
		
		app_indices {app_symb,app_args} ro fun_defs fun_heap
			# ({st_args_strictness,st_arity},fun_defs,fun_heap)	= get_producer_type app_symb ro fun_defs fun_heap
			| length app_args == st_arity
				= find_indices st_args_strictness 0 app_args ro fun_defs fun_heap
				= ([],fun_defs,fun_heap)
		where
			find_indices st_args_strictness i [] ro fun_defs fun_heap
				= ([],fun_defs,fun_heap)
			find_indices st_args_strictness i [e:es] ro fun_defs fun_heap
				# (is,fun_defs,fun_heap)	= find_index st_args_strictness i e ro fun_defs fun_heap
				# (iss,fun_defs,fun_heap)	= find_indices st_args_strictness (i+1) es ro fun_defs fun_heap
				= (is++iss,fun_defs,fun_heap)

			find_index st_args_strictness i e ro fun_defs fun_heap
				| arg_is_strict i st_args_strictness
					= case e of
						Var v	-> ([i \\ i <- [0..] & var <- ap_vars | v.var_info_ptr == var.fv_info_ptr],fun_defs,fun_heap)
						App	a	-> app_indices a ro fun_defs fun_heap
						_		-> ([],fun_defs,fun_heap)
				= ([],fun_defs,fun_heap)
		
	expr_or_never_matching_case (Yes match_expr) case_ident ti
		= (match_expr, ti)
	expr_or_never_matching_case No case_ident ti
		= (neverMatchingCase never_ident, ti) // <-!- ("transform_active_root_case:App:neverMatchingCase",never_ident)
		where
			never_ident = case ro.ro_root_case_mode of
							NotRootCase -> case_ident
							_ -> Yes ro.ro_tfi.tfi_case.symb_ident

transform_active_root_case aci this_case=:{case_expr=case_expr=:BasicExpr basic_value,case_guards=case_guards=:BasicPatterns _ basicPatterns,case_default} ro ti
	// currently only active cases are matched at runtime (multimatch problem)
	# matching_patterns = [pattern \\ pattern=:{bp_value}<-basicPatterns | bp_value==basic_value]
	= case matching_patterns of
		[]
			-> case case_default of
				Yes default_expr
					-> transform default_expr { ro & ro_root_case_mode = NotRootCase } ti
				No
					-> (neverMatchingCase never_ident, ti)
					with
						never_ident = case ro.ro_root_case_mode of
							NotRootCase -> this_case.case_ident
							_ -> Yes ro.ro_tfi.tfi_case.symb_ident
		[{bp_expr}:_]
			-> transform bp_expr {ro & ro_root_case_mode = NotRootCase} ti

transform_active_root_case aci this_case=:{case_expr = (Let lad)} ro ti
	# ro_not_root = { ro & ro_root_case_mode = NotRootCase }
	  (new_let_strict_binds, ti) = transform lad.let_strict_binds ro_not_root ti
	  (new_let_lazy_binds, ti) = transform lad.let_lazy_binds ro_not_root ti
	  (new_let_expr, ti) = transform (Case { this_case & case_expr = lad.let_expr }) ro ti
	= (Let { lad & let_expr = new_let_expr, let_strict_binds = new_let_strict_binds, let_lazy_binds = new_let_lazy_binds }, ti)

transform_active_root_case aci this_case ro ti
	= skip_over this_case ro ti

make_consumer_application {tfi_orig,tfi_args,tfi_n_args_before_producer=bef,tfi_n_producer_args=act} arg_expr
	# args = free_vars_to_bound_vars (take bef tfi_args) ++ [arg_expr : free_vars_to_bound_vars (drop (bef+act) tfi_args)]
	= {app_symb = tfi_orig, app_args = args, app_info_ptr = nilPtr}

in_normal_form (Var _)			= True
in_normal_form (BasicExpr _)	= True
in_normal_form _				= False

filterWith [True:t2] [h1:t1]
	= [h1:filterWith t2 t1]
filterWith [False:t2] [h1:t1]
	= filterWith t2 t1
filterWith _ _
	= []

possibly_add_let [] ap_expr _ _ _ ti_symbol_heap cons_type_args_strictness
	= (ap_expr, ti_symbol_heap)
possibly_add_let zipped_ap_vars_and_args ap_expr not_unfoldable cons_type_args ro ti_symbol_heap cons_type_args_strictness
	# let_type = filterWith not_unfoldable cons_type_args
	  (new_info_ptr, ti_symbol_heap) = newPtr (EI_LetType let_type) ti_symbol_heap
	= SwitchStrictPossiblyAddLet
		(let
			strict_binds	= [ {lb_src=lb_src, lb_dst=lb_dst, lb_position = NoPos}
									\\ (lb_dst,lb_src)<-zipped_ap_vars_and_args
									& n <- not_unfoldable
									& i <- [0..]
									| n && arg_is_strict i cons_type_args_strictness
									]
			lazy_binds		= [ {lb_src=lb_src, lb_dst=lb_dst, lb_position = NoPos}
									\\ (lb_dst,lb_src)<-zipped_ap_vars_and_args
									& n <- not_unfoldable
									& i <- [0..]
									| n && not (arg_is_strict i cons_type_args_strictness)
									]
		 in
		 	case (strict_binds,lazy_binds) of
		 		([],[])
		 			->	ap_expr
		 		_
		 			->	Let
						{	let_strict_binds	= strict_binds
						,	let_lazy_binds		= lazy_binds
						,	let_expr			= ap_expr
						,	let_info_ptr		= new_info_ptr
						,	let_expr_position	= NoPos
						}
	  , ti_symbol_heap
	  ) 
	  (let
			lazy_binds		= [ {lb_src=lb_src, lb_dst=lb_dst, lb_position = NoPos}
									\\ (lb_dst,lb_src)<-zipped_ap_vars_and_args
									& n <- not_unfoldable
									| n
									]
	   in
			case lazy_binds of
				[]
					-> ap_expr
				_
					-> Let
		  			 	{	let_strict_binds	= []
						,	let_lazy_binds		= lazy_binds
						,	let_expr			= ap_expr
						,	let_info_ptr		= new_info_ptr
						,	let_expr_position	= NoPos
						}
	  , ti_symbol_heap
	  )

free_variables_of_expression expr ti
	# ti_var_heap = clearVariables expr ti.ti_var_heap
	  fvi = {fvi_var_heap = ti_var_heap, fvi_expr_heap = ti.ti_symbol_heap, fvi_variables = [], fvi_expr_ptrs = ti.ti_cleanup_info}
	  {fvi_var_heap, fvi_expr_heap, fvi_variables, fvi_expr_ptrs} = freeVariables expr fvi
	  ti = {ti & ti_var_heap = fvi_var_heap, ti_symbol_heap = fvi_expr_heap, ti_cleanup_info = fvi_expr_ptrs}
	 = (fvi_variables,ti)

transform_active_non_root_case :: !Case !ActiveCaseInfo !ReadOnlyTI !*TransformInfo -> *(!Expression, !*TransformInfo)
transform_active_non_root_case kees=:{case_info_ptr,case_expr = App {app_symb}} aci=:{aci_free_vars} ro ti=:{ti_recursion_introduced=old_ti_recursion_introduced}
	| not aci.aci_safe
		= skip_over kees ro ti
	| is_safe_producer app_symb.symb_kind ro ti.ti_fun_heap ti.ti_cons_args
		// determine free variables	
		# (free_vars,ti) = free_variables_of_expression (Case {kees & case_expr=EE}) ti	
		// search function definition and consumer arguments
		  (outer_fun_def, outer_cons_args, ti_cons_args, ti_fun_defs, ti_fun_heap)
				= get_fun_def_and_cons_args ro.ro_tfi.tfi_root.symb_kind ti.ti_cons_args ti.ti_fun_defs ti.ti_fun_heap
		  outer_arguments
		  		= case outer_fun_def.fun_body of
								TransformedBody {tb_args} 	-> tb_args
								Expanding args				-> args
		  outer_info_ptrs = [ fv_info_ptr \\ {fv_info_ptr}<-outer_arguments]
		  free_var_info_ptrs = [ var_info_ptr \\ {var_info_ptr}<-free_vars ]
		  used_mask = [isMember fv_info_ptr free_var_info_ptrs \\ {fv_info_ptr}<-outer_arguments]
		  arguments_from_outer_fun = [ outer_argument \\ outer_argument<-outer_arguments & used<-used_mask | used ]
		  lifted_arguments
		  		= [ { fv_def_level = undeff, fv_ident = var_ident, fv_info_ptr = var_info_ptr, fv_count = undeff}
								\\ {var_ident, var_info_ptr} <- free_vars | not (isMember var_info_ptr outer_info_ptrs)]
		  all_args = lifted_arguments++arguments_from_outer_fun
		| SwitchArityChecks (1+length all_args > 32) False
			# ti = { ti & ti_cons_args = ti_cons_args, ti_fun_defs = ti_fun_defs, ti_fun_heap = ti_fun_heap, ti_recursion_introduced = No }
			| ro.ro_transform_fusion
				# ti = { ti & ti_error_file = ti.ti_error_file <<< "Possibly missed fusion oppurtunity: Case Arity > 32 " <<< ro.ro_tfi.tfi_root.symb_ident.id_name <<< "\n"}
				= skip_over kees ro ti
			= skip_over kees ro ti
		# (fun_info_ptr, ti_fun_heap) = newPtr FI_Empty ti_fun_heap
		  fun_ident = { id_name = ro.ro_tfi.tfi_root.symb_ident.id_name+++"_case", id_info = nilPtr }
		  fun_symb = { symb_ident = fun_ident, symb_kind=SK_GeneratedFunction fun_info_ptr undeff }
		# ti = { ti & ti_cons_args = ti_cons_args, ti_fun_defs = ti_fun_defs, ti_fun_heap = ti_fun_heap }
//				---> ("lifted arguments",[fv_ident\\{fv_ident}<-lifted_arguments],outer_arguments,
//					'\n',kees.case_expr,kees.case_guards,kees.case_default)
	  	# fun_index = ti.ti_next_fun_nr
	  	# ti = { ti & ti_next_fun_nr = fun_index + 1 }
		// JvG: why are dictionaries not the first arguments ?
		# new_ro = { ro & ro_root_case_mode = RootCaseOfZombie, ro_tfi.tfi_case = fun_symb, ro_tfi.tfi_args = all_args }
		= generate_case_function_with_pattern_argument fun_index case_info_ptr (Case kees) outer_fun_def outer_cons_args used_mask fun_symb all_args ti

transform_active_non_root_case kees=:{case_info_ptr} aci=:{aci_free_vars} ro ti=:{ti_recursion_introduced=old_ti_recursion_introduced}
	| not aci.aci_safe
		= skip_over kees ro ti
	// determine free variables
	# (free_vars,ti) = free_variables_of_expression (Case kees) ti	
	// search function definition and consumer arguments
	  (outer_fun_def, outer_cons_args, ti_cons_args, ti_fun_defs, ti_fun_heap)
			= get_fun_def_and_cons_args ro.ro_tfi.tfi_root.symb_kind ti.ti_cons_args ti.ti_fun_defs ti.ti_fun_heap
	  outer_arguments
	  		= case outer_fun_def.fun_body of
							TransformedBody {tb_args} 	-> tb_args
							Expanding args				-> args
	  outer_info_ptrs = [ fv_info_ptr \\ {fv_info_ptr}<-outer_arguments]
	  free_var_info_ptrs = [ var_info_ptr \\ {var_info_ptr}<-free_vars ]
	  used_mask = [isMember fv_info_ptr free_var_info_ptrs \\ {fv_info_ptr}<-outer_arguments]
	  arguments_from_outer_fun = [ outer_argument \\ outer_argument<-outer_arguments & used<-used_mask | used ]
	  lifted_arguments
	  		= [ { fv_def_level = undeff, fv_ident = var_ident, fv_info_ptr = var_info_ptr, fv_count = undeff}
							\\ {var_ident, var_info_ptr} <- free_vars | not (isMember var_info_ptr outer_info_ptrs)]
	  all_args = lifted_arguments++arguments_from_outer_fun
	| SwitchArityChecks (length all_args > 32) False
		# ti = { ti & ti_cons_args = ti_cons_args, ti_fun_defs = ti_fun_defs, ti_fun_heap = ti_fun_heap, ti_recursion_introduced = No }
		| ro.ro_transform_fusion
			#  ti	= { ti & ti_error_file = ti.ti_error_file <<< "Possibly missed fusion oppurtunity: Case Arity > 32 " <<< ro.ro_tfi.tfi_root.symb_ident.id_name <<< "\n"}
			= skip_over kees ro ti
		= skip_over kees ro ti
	# (fun_info_ptr, ti_fun_heap) = newPtr FI_Empty ti_fun_heap
	  fun_ident = { id_name = ro.ro_tfi.tfi_root.symb_ident.id_name+++"_case", id_info = nilPtr }
	  fun_symb = { symb_ident = fun_ident, symb_kind=SK_GeneratedFunction fun_info_ptr undeff }
//					<-!- ("<<<transformCaseFunction",fun_symb)
	| SwitchAlwaysIntroduceCaseFunction True False
	  	# fun_index = ti.ti_next_fun_nr
		# ti &	ti_cons_args = ti_cons_args, ti_fun_defs = ti_fun_defs, ti_fun_heap = ti_fun_heap,
				ti_next_fun_nr = fun_index + 1, ti_new_functions = [fun_info_ptr:ti.ti_new_functions]
		# new_ro = { ro & ro_root_case_mode = RootCaseOfZombie , ro_tfi.tfi_case = fun_symb, ro_tfi.tfi_args = all_args }
	  	= generate_case_function fun_index case_info_ptr (Case kees) outer_fun_def outer_cons_args used_mask new_ro ti
	# new_ro = { ro & ro_root_case_mode = RootCaseOfZombie,
				 ro_tfi.tfi_case = fun_symb, ro_tfi.tfi_args = all_args, ro_tfi.tfi_n_args_before_producer = -1,  ro_tfi.tfi_n_producer_args = -1 }
	  ti = { ti & ti_cons_args = ti_cons_args, ti_fun_defs = ti_fun_defs, ti_fun_heap = ti_fun_heap, ti_recursion_introduced = No }
	  (new_expr, ti)
	  		= transformCase kees new_ro ti
	  (ti_recursion_introduced, ti) = ti!ti_recursion_introduced
//	  			<-!- ("transformCaseFunction>>>",fun_symb)
	  ti = { ti & ti_recursion_introduced = old_ti_recursion_introduced }
	= case ti_recursion_introduced of
		Yes {ri_fun_index}
			-> generate_case_function ri_fun_index case_info_ptr new_expr outer_fun_def outer_cons_args used_mask new_ro ti
		No	-> (new_expr, ti)

FI_CopyMask:==63

generate_case_function :: !Int !ExprInfoPtr !Expression FunDef .ConsClasses [.Bool] !.ReadOnlyTI !*TransformInfo -> (!Expression,!*TransformInfo)
generate_case_function fun_index case_info_ptr new_expr outer_fun_def outer_cons_args used_mask
					{ro_tfi={tfi_case=tfi_fun=:{symb_kind=SK_GeneratedFunction fun_info_ptr _},tfi_args}} ti
	# fun_arity								= length tfi_args
	  ti = arity_warning "generate_case_function" tfi_fun.symb_ident fun_index fun_arity ti
	  (Yes {st_args,st_attr_env})			= outer_fun_def.fun_type
	  types_from_outer_fun					= [ st_arg \\ st_arg <- st_args & used <- used_mask | used ]
	  nr_of_lifted_vars						= fun_arity-(length types_from_outer_fun)
	  (lifted_types, ti_var_heap)			= get_types_of_local_vars (take nr_of_lifted_vars tfi_args) ti.ti_var_heap
	  (EI_CaseType {ct_result_type}, ti_symbol_heap) = readExprInfo case_info_ptr ti.ti_symbol_heap
	  (form_vars, ti_var_heap)				= mapSt bind_to_fresh_expr_var tfi_args ti_var_heap

	  arg_types								= lifted_types++types_from_outer_fun

	# ti = {ti & ti_var_heap = ti_var_heap, ti_symbol_heap = ti_symbol_heap}
	# (fun_type,type_variables,ti)			= determine_case_function_type fun_arity ct_result_type arg_types st_attr_env ti

	  // unfold...
	  cs =		{ cs_var_heap				= ti.ti_var_heap
	  			, cs_symbol_heap			= ti.ti_symbol_heap
				, cs_opt_type_heaps			= Yes ti.ti_type_heaps
	  			, cs_cleanup_info			= ti.ti_cleanup_info
	  			}
	  (copied_expr, cs)
			= copy new_expr {ci_handle_aci_free_vars = SubstituteAciFreeVars} cs
	  {cs_var_heap=ti_var_heap, cs_symbol_heap=ti_symbol_heap, cs_cleanup_info=ti_cleanup_info, cs_opt_type_heaps = Yes ti_type_heaps} = cs

	  ti_var_heap = remove_VI_Expression_values tfi_args ti_var_heap
	  ti_type_heaps & th_vars = remove_TVI_Type_values type_variables ti_type_heaps.th_vars

	  // generated function...
	  fun_def =	{ fun_ident					= tfi_fun.symb_ident
				, fun_arity					= fun_arity
				, fun_priority				= NoPrio
				, fun_body					= TransformedBody { tb_args = form_vars, tb_rhs = copied_expr}
				, fun_type					= Yes fun_type
				, fun_pos					= NoPos
				, fun_kind					= FK_Function cNameNotLocationDependent
				, fun_lifted				= undeff
				, fun_info = 	{	fi_calls		= []
								,	fi_group_index	= outer_fun_def.fun_info.fi_group_index
								,	fi_def_level	= NotALevel
								,	fi_free_vars	= []
								,	fi_local_vars	= []
								,	fi_dynamics		= []
								,	fi_properties	= outer_fun_def.fun_info.fi_properties bitand FI_CopyMask
								}
				}
	# cc_args_from_outer_fun		= [ cons_arg \\ cons_arg <- outer_cons_args.cc_args & used <- used_mask | used ]
	  cc_linear_bits_from_outer_fun	= [# cons_arg \\ cons_arg <|- outer_cons_args.cc_linear_bits & used <- used_mask | used !]
	  new_cons_args =
				{ cc_size			= fun_arity
				, cc_args			= repeatn nr_of_lifted_vars CPassive ++ cc_args_from_outer_fun
				, cc_linear_bits	= RepeatnAppendM nr_of_lifted_vars False cc_linear_bits_from_outer_fun
				, cc_producer		= False
				}
	  gf =		{ gf_fun_def		= fun_def
				, gf_instance_info	= II_Empty
				, gf_cons_args		= new_cons_args
				, gf_fun_index		= fun_index
				}
	  ti_fun_heap = writePtr fun_info_ptr (FI_Function gf) ti.ti_fun_heap
	  ti = { ti & ti_var_heap		= ti_var_heap
	  			, ti_fun_heap		= ti_fun_heap
	  			, ti_symbol_heap	= ti_symbol_heap
	  			, ti_type_heaps		= ti_type_heaps
	  			, ti_cleanup_info	= ti_cleanup_info 
	  			}
	  app_symb = {tfi_fun & symb_kind = SK_GeneratedFunction fun_info_ptr fun_index}
	  app_args = free_vars_to_bound_vars tfi_args
	= ( App {app_symb = app_symb, app_args = app_args, app_info_ptr = nilPtr}, ti)

generate_case_function_with_pattern_argument :: !Int !ExprInfoPtr !Expression FunDef .ConsClasses [.Bool] !SymbIdent ![FreeVar] !*TransformInfo
	-> (!Expression,!*TransformInfo)
generate_case_function_with_pattern_argument fun_index case_info_ptr 
					case_expr=:(Case kees=:{case_expr=old_case_expr}) outer_fun_def outer_cons_args used_mask
					ro_fun=:{symb_kind=SK_GeneratedFunction fun_info_ptr _} ro_fun_args ti
	# fun_arity								= length ro_fun_args
	  ti = arity_warning "generate_case_function" ro_fun.symb_ident fun_index fun_arity ti
	  (Yes {st_args,st_attr_env})			= outer_fun_def.fun_type
	  types_from_outer_fun					= [ st_arg \\ st_arg <- st_args & used <- used_mask | used ]
	  nr_of_lifted_vars						= fun_arity-(length types_from_outer_fun)
	  (lifted_types, ti_var_heap)			= get_types_of_local_vars (take nr_of_lifted_vars ro_fun_args) ti.ti_var_heap
	  (EI_CaseType {ct_result_type,ct_pattern_type}, ti_symbol_heap) = readExprInfo case_info_ptr ti.ti_symbol_heap
	  (form_vars, ti_var_heap)				= mapSt bind_to_fresh_expr_var ro_fun_args ti_var_heap

	  arg_types								= lifted_types++types_from_outer_fun

	  ti = {ti & ti_var_heap = ti_var_heap, ti_symbol_heap = ti_symbol_heap}
	  (fun_type,type_variables,ti)			= determine_case_function_type fun_arity ct_result_type [ct_pattern_type:arg_types] st_attr_env ti

	  cs =		{ cs_var_heap				= ti.ti_var_heap
	  			, cs_symbol_heap			= ti.ti_symbol_heap
				, cs_opt_type_heaps			= Yes ti.ti_type_heaps
	  			, cs_cleanup_info			= ti.ti_cleanup_info
	  			}
	  (Case copied_kees, cs)
			= copy (Case {kees & case_expr=EE}) {ci_handle_aci_free_vars = SubstituteAciFreeVars} cs
	  {cs_var_heap=ti_var_heap, cs_symbol_heap=ti_symbol_heap, cs_cleanup_info=ti_cleanup_info, cs_opt_type_heaps = Yes ti_type_heaps} = cs

	  ti_var_heap = remove_VI_Expression_values ro_fun_args ti_var_heap
	  ti_type_heaps & th_vars = remove_TVI_Type_values type_variables ti_type_heaps.th_vars

	  (new_info_ptr, ti_var_heap) = newPtr VI_Empty ti_var_heap
	  var_id = {id_name = "_x", id_info = nilPtr}
	  case_free_var = {fv_def_level = NotALevel, fv_ident = var_id, fv_info_ptr = new_info_ptr, fv_count = 0}
	  case_var = Var {var_ident = var_id, var_info_ptr = new_info_ptr, var_expr_ptr = nilPtr}
	  copied_expr = Case {copied_kees & case_expr=case_var}
	  form_vars = [case_free_var:form_vars]
	  fun_arity = fun_arity+1
	  // generated function...
	  fun_def =	{ fun_ident					= ro_fun.symb_ident
				, fun_arity					= fun_arity
				, fun_priority				= NoPrio
				, fun_body					= TransformedBody { tb_args = form_vars, tb_rhs = copied_expr}
				, fun_type					= Yes fun_type
				, fun_pos					= NoPos
				, fun_kind					= FK_Function cNameNotLocationDependent
				, fun_lifted				= undeff
				, fun_info = 	{	fi_calls		= []
								,	fi_group_index	= outer_fun_def.fun_info.fi_group_index
								,	fi_def_level	= NotALevel
								,	fi_free_vars	= []
								,	fi_local_vars	= []
								,	fi_dynamics		= []
								,	fi_properties	= outer_fun_def.fun_info.fi_properties bitand FI_CopyMask
								}
				}
	  cc_args_from_outer_fun		= [ cons_arg \\ cons_arg <- outer_cons_args.cc_args & used <- used_mask | used ]
	  cc_linear_bits_from_outer_fun	= [# cons_arg \\ cons_arg <|- outer_cons_args.cc_linear_bits & used <- used_mask | used !]
	  new_cons_args =
	  			{ cc_size			= fun_arity
	  			, cc_args			= [CActive : repeatn nr_of_lifted_vars CPassive ++ cc_args_from_outer_fun]
				, cc_linear_bits	= [#True : RepeatnAppendM nr_of_lifted_vars False cc_linear_bits_from_outer_fun!]
	  			, cc_producer		= False
	  			}
	  gf =		{ gf_fun_def		= fun_def
	  			, gf_instance_info	= II_Empty
	  			, gf_cons_args		= new_cons_args
	  			, gf_fun_index		= fun_index
	  			}
	  ti_fun_heap = writePtr fun_info_ptr (FI_Function gf) ti.ti_fun_heap
	  ti = { ti & ti_new_functions	= [fun_info_ptr:ti.ti_new_functions]
	  			, ti_var_heap		= ti_var_heap
	  			, ti_fun_heap		= ti_fun_heap
	  			, ti_symbol_heap	= ti_symbol_heap
	  			, ti_type_heaps		= ti_type_heaps
	  			, ti_cleanup_info	= ti_cleanup_info 
	  			}
	  app_symb = { ro_fun & symb_kind = SK_GeneratedFunction fun_info_ptr fun_index}
	  app_args = [old_case_expr : free_vars_to_bound_vars ro_fun_args]
	= (App {app_symb = app_symb, app_args = app_args, app_info_ptr = nilPtr}, ti)

get_types_of_local_vars vars var_heap
	= mapSt get_type_of_local_var vars var_heap
where
	get_type_of_local_var {fv_info_ptr} var_heap
		# (EVI_VarType a_type, var_heap)	= readExtendedVarInfo fv_info_ptr var_heap
		= (a_type, var_heap)

determine_case_function_type fun_arity ct_result_type arg_types st_attr_env ti=:{ti_type_heaps}
	# (type_variables, th_vars)				= getTypeVars [ct_result_type:arg_types] ti_type_heaps.th_vars
	  (fresh_type_vars, th_vars)			= bind_to_fresh_type_variables type_variables th_vars
	  ti_type_heaps							= { ti_type_heaps & th_vars = th_vars }
	  (_, fresh_arg_types, ti_type_heaps)	= substitute arg_types ti_type_heaps
	  (_, fresh_result_type, ti_type_heaps)	= substitute ct_result_type ti_type_heaps
	  fun_type =
	  			{ st_vars					= fresh_type_vars
	  			, st_args					= fresh_arg_types
	  			, st_arity					= fun_arity
	  			, st_args_strictness		= NotStrict
	  			, st_result					= fresh_result_type
	  			, st_context				= []
	  			, st_attr_vars				= []
	  			, st_attr_env				= []
	  			}
	  ti									= { ti & ti_type_heaps = ti_type_heaps }
	= (fun_type,type_variables,ti)

removeNeverMatchingSubcases :: Expression !.ReadOnlyTI -> Expression
removeNeverMatchingSubcases keesExpr=:(Case kees) ro
	// remove those case guards whose right hand side is a never matching case
	| is_never_matching_case keesExpr
		= keesExpr
	# {case_guards, case_default} = kees
	  filtered_default = get_filtered_default case_default
	= case case_guards of
		AlgebraicPatterns i alg_patterns
			| not (any (is_never_matching_case o get_alg_rhs) alg_patterns) && not (is_never_matching_default case_default)
				-> keesExpr // frequent case: all subexpressions can't fail
			# filtered_case_guards = filter (not o is_never_matching_case o get_alg_rhs) alg_patterns
			| has_become_never_matching filtered_default filtered_case_guards
				-> neverMatchingCase never_ident
			| is_default_only filtered_default filtered_case_guards
				-> fromYes case_default
			-> Case {kees & case_guards = AlgebraicPatterns i filtered_case_guards, case_default = filtered_default }
		BasicPatterns bt basic_patterns
			| not (any (is_never_matching_case o get_basic_rhs) basic_patterns) && not (is_never_matching_default case_default)
				-> keesExpr // frequent case: all subexpressions can't fail
			# filtered_case_guards = filter (not o is_never_matching_case o get_basic_rhs) basic_patterns
			| has_become_never_matching filtered_default filtered_case_guards
				-> neverMatchingCase never_ident
			| is_default_only filtered_default filtered_case_guards
				-> fromYes case_default
			-> Case {kees & case_guards = BasicPatterns bt filtered_case_guards, case_default = filtered_default }
		OverloadedListPatterns i decons_expr alg_patterns
			| not (any (is_never_matching_case o get_alg_rhs) alg_patterns) && not (is_never_matching_default case_default)
				-> keesExpr // frequent case: all subexpressions can't fail
			# filtered_case_guards = filter (not o is_never_matching_case o get_alg_rhs) alg_patterns
			| has_become_never_matching filtered_default filtered_case_guards
				-> neverMatchingCase never_ident
			| is_default_only filtered_default filtered_case_guards
				-> fromYes case_default
			-> Case {kees & case_guards = OverloadedListPatterns i decons_expr filtered_case_guards, case_default = filtered_default }
		_	-> abort "removeNeverMatchingSubcases does not match"
where
	get_filtered_default y=:(Yes c_default)
		| is_never_matching_case c_default
			= No
		= y
	get_filtered_default no
		= no
	has_become_never_matching No [] = True
	has_become_never_matching _ _ = False
	is_default_only (Yes _) [] = True
	is_default_only _ _ = False
	is_never_matching_case (Case {case_guards = NoPattern, case_default = No })
		= True
	is_never_matching_case _
		= False
	get_alg_rhs {ap_expr} = ap_expr
	get_basic_rhs {bp_expr} = bp_expr
	is_never_matching_default No
		= False
	is_never_matching_default (Yes expr)
		= is_never_matching_case expr
	never_ident = case ro.ro_root_case_mode of
		NotRootCase -> kees.case_ident
		_ -> Yes ro.ro_tfi.tfi_case.symb_ident
removeNeverMatchingSubcases expr ro
	= expr

instance transform LetBind
where
	transform bind=:{lb_src} ro ti
		# (lb_src, ti) = transform lb_src ro ti
		= ({ bind & lb_src = lb_src }, ti)

instance transform BasicPattern
where
	transform pattern=:{bp_expr} ro ti
		# (bp_expr, ti) = transform bp_expr ro ti
		= ({ pattern & bp_expr = bp_expr }, ti)

instance transform AlgebraicPattern
where
	transform pattern=:{ap_expr} ro ti
		# (ap_expr, ti) = transform ap_expr ro ti
		= ({ pattern & ap_expr = ap_expr }, ti)

instance transform CasePatterns
where
	transform (AlgebraicPatterns type patterns) ro ti
		# (patterns, ti) = transform patterns ro ti
		= (AlgebraicPatterns type patterns, ti)
	transform (BasicPatterns type patterns) ro ti
		# (patterns, ti) = transform patterns ro ti
		= (BasicPatterns type patterns, ti)
	transform (OverloadedListPatterns type=:(OverloadedList _ _ _ _) decons_expr patterns) ro ti
		# (patterns, ti) = transform patterns ro ti
		# (decons_expr, ti) = transform decons_expr ro ti
		= (OverloadedListPatterns type decons_expr patterns, ti)
	transform (OverloadedListPatterns type decons_expr patterns) ro ti
		# (patterns, ti) = transform patterns ro ti
		# (decons_expr, ti) = transform decons_expr ro ti
		= (OverloadedListPatterns type decons_expr patterns, ti)
	transform NoPattern ro ti
		= (NoPattern, ti)
	transform _ ro ti
		= abort "transform CasePatterns does not match"

instance transform (Optional a) | transform a
where
	transform (Yes x) ro ti
		# (x, ti) = transform x ro ti
		= (Yes x, ti)
	transform no ro ti
		= (no, ti)

instance transform [a] | transform a
where
	transform [x : xs]  ro ti
		# (x, ti) = transform x ro ti
		  (xs, ti) = transform xs ro ti
		= ([x : xs], ti)
	transform [] ro ti
		= ([], ti)

cIsANewFunction		:== True
cIsNotANewFunction	:== False

tryToFindInstance :: !{! Producer} !InstanceInfo !*FunctionHeap -> *(!Bool, !FunctionInfoPtr, !InstanceInfo, !.FunctionHeap)
tryToFindInstance new_prods II_Empty fun_heap
	# (fun_def_ptr, fun_heap) = newPtr FI_Empty fun_heap
	= (cIsANewFunction, fun_def_ptr, II_Node new_prods fun_def_ptr II_Empty II_Empty, fun_heap)
tryToFindInstance new_prods instances=:(II_Node prods fun_def_ptr left right) fun_heap
	| size new_prods > size prods
		# (is_new, new_fun_def_ptr, right, fun_heap) = tryToFindInstance new_prods right fun_heap
		= (is_new, new_fun_def_ptr, II_Node prods fun_def_ptr left right, fun_heap)
	| size new_prods < size prods
		# (is_new, new_fun_def_ptr, left, fun_heap) = tryToFindInstance new_prods left fun_heap
		= (is_new, new_fun_def_ptr, II_Node prods fun_def_ptr left right, fun_heap)
	# cmp = compareProducers new_prods prods
	| cmp == Equal
		= (cIsNotANewFunction, fun_def_ptr, instances, fun_heap)
	| cmp == Greater
		# (is_new, new_fun_def_ptr, right, fun_heap) = tryToFindInstance new_prods right fun_heap
		= (is_new, new_fun_def_ptr, II_Node prods fun_def_ptr left right, fun_heap)
		# (is_new, new_fun_def_ptr, left, fun_heap) = tryToFindInstance new_prods left fun_heap
		= (is_new, new_fun_def_ptr, II_Node prods fun_def_ptr left right, fun_heap)

compareProducers prods1 prods2
	#! nr_of_prods = size prods1
	= compare_producers 0 nr_of_prods prods1 prods2
where
	compare_producers prod_index nr_of_prods prods1 prods2
		| prod_index == nr_of_prods
			= Equal
		# cmp = prods1.[prod_index] =< prods2.[prod_index]
		| cmp == Equal
			= compare_producers (inc prod_index) nr_of_prods prods1 prods2
		= cmp

instance =< Bool
where
	(=<) True True = Equal
	(=<) True False = Smaller
	(=<) False True = Greater
	(=<) False False = Equal

instance =< Producer
where
	(=<) pr1 pr2
		| equal_constructor pr1 pr2
			= compare_constructor_arguments  pr1 pr2
		| less_constructor pr1 pr2
			= Smaller
			= Greater
	where
		compare_constructor_arguments (PR_Function _ _ index1) (PR_Function _ _ index2)
			= index1 =< index2
		compare_constructor_arguments (PR_GeneratedFunction _ _ index1) (PR_GeneratedFunction _ _ index2)
			= index1 =< index2
		compare_constructor_arguments 	(PR_Class app1 lifted_vars_with_types1 t1)
										(PR_Class app2 lifted_vars_with_types2 t2)
			# cmp = smallerOrEqual t1 t2
			| cmp<>Equal
				= cmp
			= compare_types lifted_vars_with_types1 lifted_vars_with_types2
		compare_constructor_arguments (PR_Curried symb_ident1 _) (PR_Curried symb_ident2 _)
			= symb_ident1 =< symb_ident2
		compare_constructor_arguments PR_Empty PR_Empty
			= Equal
		compare_constructor_arguments PR_Unused PR_Unused
			= Equal
		compare_constructor_arguments (PR_Constructor symb_ident1 _ _) (PR_Constructor symb_ident2 _ _)
			= symb_ident1 =< symb_ident2
		compare_constructor_arguments (PR_CurriedFunction symb_ident1 _ _) (PR_CurriedFunction symb_ident2 _ _)
			= symb_ident1 =< symb_ident2
		compare_constructor_arguments (PR_String s1) (PR_String s2)
			| s1==s2
				= Equal
			| s1<s2
				= Smaller
				= Greater
		compare_constructor_arguments (PR_Int i1) (PR_Int i2)
			| i1==i2
				= Equal
			| i1<i2
				= Smaller
				= Greater
		compare_constructor_arguments (PR_Equal i1) (PR_Equal i2)
			| i1==i2
				= Equal
			| i1<i2
				= Smaller
				= Greater
		compare_constructor_arguments (PR_EqualRemove i1) (PR_EqualRemove i2)
			| i1==i2
				= Equal
			| i1<i2
				= Smaller
				= Greater

		compare_types [(_, type1):types1] [(_, type2):types2]
			# cmp = smallerOrEqual type1 type2
			| cmp<>Equal
				= cmp
			= compare_types types1 types2
		compare_types [] [] = Equal
		compare_types [] _ = Smaller
		compare_types _ [] = Greater
		
/*
 *	UNIQUENESS STUFF...
 */

create_fresh_type_vars :: !Int !*TypeVarHeap -> (!{!TypeVar}, !*TypeVarHeap)
create_fresh_type_vars nr_of_all_type_vars th_vars
	# fresh_array = createArray  nr_of_all_type_vars {tv_ident = {id_name="",id_info=nilPtr}, tv_info_ptr=nilPtr}
	= iFoldSt allocate_fresh_type_var 0 nr_of_all_type_vars (fresh_array,th_vars)
where
	allocate_fresh_type_var i (array, th_vars)
		# (new_tv_info_ptr, th_vars) = newPtr TVI_Empty th_vars
		  tv = { tv_ident = { id_name = "a"+++toString i, id_info = nilPtr }, tv_info_ptr=new_tv_info_ptr }
		= ({array & [i] = tv}, th_vars)

create_fresh_attr_vars :: !{!CoercionTree} !Int !*AttrVarHeap -> (!{!TypeAttribute}, !.AttrVarHeap)
create_fresh_attr_vars demanded nr_of_attr_vars th_attrs
	# fresh_array = createArray nr_of_attr_vars TA_None
	= iFoldSt (allocate_fresh_attr_var demanded) 0 nr_of_attr_vars (fresh_array, th_attrs)
where
	allocate_fresh_attr_var demanded i (attr_var_array, th_attrs)
		= case demanded.[i] of
			CT_Unique
				-> ({ attr_var_array & [i] = TA_Unique}, th_attrs)
			CT_NonUnique
				-> ({ attr_var_array & [i] = TA_Multi}, th_attrs)
			_
				# (av, th_attrs) = NewAttrVar i th_attrs
				-> ({attr_var_array & [i] = TA_Var av}, th_attrs)

coercionsToAttrEnv :: !{!TypeAttribute} !Coercions -> [AttrInequality]
coercionsToAttrEnv attr_vars {coer_offered}
	= coercionsToAttrEnv 0 attr_vars coer_offered
where
	coercionsToAttrEnv :: !Int !{!TypeAttribute} !{!CoercionTree} -> [AttrInequality]
	coercionsToAttrEnv demanded_i attr_vars coer_offered
		| demanded_i<size coer_offered
			# (offered,_) = flattenCoercionTree coer_offered.[demanded_i]
			= coercionsToAttrEnvNextTree offered demanded_i attr_vars coer_offered
			= []

	coercionsToAttrEnvNextTree :: ![Int] !Int !{!TypeAttribute} !{!CoercionTree} -> [AttrInequality]
	coercionsToAttrEnvNextTree [offered_i:offered_is] demanded_i attr_vars coer_offered
		#! attr_inequalities = coercionsToAttrEnvNextTree offered_is demanded_i attr_vars coer_offered
		# (TA_Var demanded_attr_var) = attr_vars.[demanded_i]
		#! demanded_attr_var=demanded_attr_var
		# (TA_Var offered_attr_var) = attr_vars.[offered_i]
		#! offered_attr_var=offered_attr_var
		= [{ai_offered = offered_attr_var, ai_demanded = demanded_attr_var} : attr_inequalities]
	coercionsToAttrEnvNextTree [] demanded_i attr_vars coer_offered
		= coercionsToAttrEnv (demanded_i+1) attr_vars coer_offered

substitute_attr_inequality {ai_offered, ai_demanded} th_attrs
	#! ac_offered = pointer_to_int ai_offered th_attrs
	   ac_demanded = pointer_to_int ai_demanded th_attrs
	= ({ ac_offered = ac_offered, ac_demanded = ac_demanded }, th_attrs)
  where
	pointer_to_int {av_info_ptr} th_attrs
		# (AVI_Attr (TA_TempVar i)) = sreadPtr av_info_ptr th_attrs
		= i

new_inequality {ac_offered, ac_demanded} coercions
	= newInequality ac_offered ac_demanded coercions

:: UniquenessRequirement =
	{	ur_offered		:: !AType
	,	ur_demanded		:: !AType
	,	ur_attr_ineqs	:: ![AttrCoercion]
	}

:: ATypesWithStrictness = {ats_types::![AType],ats_strictness::!StrictnessList};

compute_args_strictness new_arg_types_array = compute_args_strictness 0 0 NotStrict 0 new_arg_types_array
  	where
  		compute_args_strictness strictness_index strictness strictness_list array_index new_arg_types_array
  			| array_index==size new_arg_types_array
  				| strictness==0
  					= strictness_list
  					= append_strictness strictness strictness_list
  				# {ats_types,ats_strictness} = new_arg_types_array.[array_index]
  				# (strictness_index,strictness) = add_strictness_for_arguments ats_types 0 strictness_index strictness strictness_list
  					with
  						add_strictness_for_arguments [] ats_strictness_index strictness_index strictness strictness_list
  							= (strictness_index,strictness)
  						add_strictness_for_arguments [_:ats_types] ats_strictness_index strictness_index strictness strictness_list
  							| arg_is_strict ats_strictness_index ats_strictness
  								# (strictness_index,strictness,strictness_list) = add_next_strict strictness_index strictness strictness_list
  								= add_strictness_for_arguments ats_types (ats_strictness_index+1) strictness_index strictness strictness_list
  								# (strictness_index,strictness,strictness_list) = add_next_not_strict strictness_index strictness strictness_list
  								= add_strictness_for_arguments ats_types (ats_strictness_index+1) strictness_index strictness strictness_list
  				= compute_args_strictness strictness_index strictness strictness_list (array_index+1) new_arg_types_array
	
/*
 * GENERATE FUSED FUNCTION
 */

:: OptionalProducerType = ProducerType !SymbolType ![TypeVar] | NoProducerType

:: *DetermineArgsState =
	{ das_vars						:: ![FreeVar]
	, das_arg_types					:: !*{#ATypesWithStrictness}
	, das_next_attr_nr				:: !Int
	, das_new_linear_bits			:: ![#Bool!]
	, das_new_cons_args				:: ![ConsClass]
	, das_uniqueness_requirements	:: ![UniquenessRequirement]
	, das_AVI_Attr_TA_TempVar_info_ptrs	:: ![[AttributeVar]]
	, das_subst						:: !*{!Type}
	, das_type_heaps				:: !*TypeHeaps
	, das_fun_defs					:: !*{#FunDef}
	, das_fun_heap					:: !*FunctionHeap
	, das_var_heap					:: !*VarHeap
	, das_cons_args					:: !*{!ConsClasses}
	, das_predef					:: !*PredefinedSymbols
	, das_removed_equal_info_ptr	:: !VarInfoPtr
	}

generateFunction :: !SymbIdent !FunDef ![ConsClass] ![#Bool!] !{! Producer} !FunctionInfoPtr !ReadOnlyTI !Int !*TransformInfo -> (!Index, !Int, !*TransformInfo)
generateFunction app_symb fd=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_info = {fi_group_index,fi_properties},fun_arity}
				 cc_args cc_linear_bits prods fun_def_ptr ro n_extra
				 ti=:{ti_var_heap,ti_next_fun_nr,ti_new_functions,ti_fun_heap,ti_symbol_heap,ti_fun_defs,
				 		ti_type_heaps,ti_cons_args,ti_cleanup_info, ti_type_def_infos}
//	| False--->("generating new function",fd.fun_ident.id_name,"->",ti_next_fun_nr,prods,tb_args)		= undef
/*
	| False-!->("generating new function",fd.fun_ident.id_name,"->",ti_next_fun_nr)		= undef
	| False-!->("with type",fd.fun_type)												= undef
	| False-!->("producers:",II_Node prods nilPtr II_Empty II_Empty,("cc_args",cc_args,("cc_linear_bits",cc_linear_bits)))		= undef
	| False-!->("body:",tb_args, tb_rhs)												= undef
*/
	#!(fi_group_index, ti_cons_args, ti_fun_defs, ti_fun_heap)
			= max_group_index 0 prods ro.ro_main_dcl_module_n fi_group_index ti_fun_defs ti_fun_heap ti_cons_args

	# (Yes consumer_symbol_type) = fd.fun_type
	  consumer_symbol_type		= strip_universal_quantor consumer_symbol_type
	  (sound_consumer_symbol_type, (ti_type_heaps, ti_type_def_infos))
	  		= add_propagation_attributes` ro.ro_common_defs consumer_symbol_type (ti_type_heaps, ti_type_def_infos)
	  (function_producer_types, ti_fun_defs, ti_fun_heap)
	  		= iFoldSt (accum_function_producer_type prods ro) 0 (size prods) 
	  				([], ti_fun_defs, ti_fun_heap)
	  function_producer_types	= mapOpt strip_universal_quantor function_producer_types
	  (opt_sound_function_producer_types, (ti_type_heaps, ti_type_def_infos))
	  		= mapSt (add_propagation_attributes ro.ro_common_defs) function_producer_types (ti_type_heaps, ti_type_def_infos)
	  (opt_sound_function_producer_types, ti_type_heaps)
	  		= mapSt copy_opt_symbol_type opt_sound_function_producer_types ti_type_heaps

	  sound_function_producer_types = [x \\ ProducerType x _ <- opt_sound_function_producer_types]

	# {st_attr_vars,st_args,st_args_strictness,st_result,st_attr_env} = sound_consumer_symbol_type

	  class_types = [{at_attribute = TA_Multi, at_type = class_type} \\ PR_Class _ _ class_type <-:prods]
	  (type_vars_in_class_types, th_vars) = mapSt getTypeVars class_types ti_type_heaps.th_vars

	  all_involved_types
	  		= class_types ++ (flatten (map (\{st_args, st_result}-> [st_result:st_args]) 
					  					[sound_consumer_symbol_type:sound_function_producer_types]))
//	| False ---> ("all_involved_types",app_symb,all_involved_types)	= undef
	# (propagating_cons_vars, th_vars)
	  		= collectPropagatingConsVars all_involved_types th_vars
	  all_type_vars
	  		=   flatten [st_vars \\ {st_vars} <- [sound_consumer_symbol_type:sound_function_producer_types]]
	  		  ++flatten type_vars_in_class_types
//	| False -!-> ("all_type_vars",all_type_vars)	= undef
	# (nr_of_all_type_vars, th_vars) = foldSt bind_to_temp_type_var all_type_vars (0, th_vars)
	  subst = createArray nr_of_all_type_vars TE
	  (next_attr_nr, th_attrs) = bind_to_temp_attr_vars st_attr_vars (FirstAttrVar, ti_type_heaps.th_attrs)
	  // remember the st_attr_vars, because the AVI_Attr (TA_TempVar _)'s must be removed before unfold,
	  // because types in Cases and Lets should not use TA_TempVar's
	  das_AVI_Attr_TA_TempVar_info_ptrs = [st_attr_vars]
	  ti_type_heaps = {ti_type_heaps & th_attrs = th_attrs, th_vars = th_vars}
	  (_, st_args, ti_type_heaps) = substitute st_args ti_type_heaps
	  (_, st_result, ti_type_heaps) = substitute st_result ti_type_heaps
// determine args...
	# das = { das_vars						= []
			, das_arg_types					= st_args_array st_args st_args_strictness
			, das_next_attr_nr				= next_attr_nr
			, das_new_linear_bits			= [#!]
			, das_new_cons_args				= []
			, das_uniqueness_requirements	= []
			, das_AVI_Attr_TA_TempVar_info_ptrs = das_AVI_Attr_TA_TempVar_info_ptrs
			, das_subst						= subst
			, das_type_heaps				= ti_type_heaps
			, das_fun_defs					= ti_fun_defs
			, das_fun_heap					= ti_fun_heap
			, das_var_heap					= ti_var_heap
			, das_cons_args					= ti_cons_args
			, das_predef					= ti.ti_predef_symbols
			, das_removed_equal_info_ptr = nilPtr
			}
	# das		= determine_args cc_linear_bits cc_args 0 prods opt_sound_function_producer_types tb_args ro das
	  uvar		= [arg \\ prod <-: prods & arg <- tb_args | isUnused prod]
	  				with
	  					isUnused PR_Unused = True
//	  					isUnused (PR_EqualRemove _) = True
	  					isUnused _ = False
	  
	  new_fun_args				= das.das_vars
	  new_arg_types_array		= das.das_arg_types
	  next_attr_nr				= das.das_next_attr_nr
	  new_linear_bits			= das.das_new_linear_bits
	  new_cons_args				= das.das_new_cons_args
	  uniqueness_requirements	= das.das_uniqueness_requirements
	  das_AVI_Attr_TA_TempVar_info_ptrs = das.das_AVI_Attr_TA_TempVar_info_ptrs
	  subst						= das.das_subst
	  ti_type_heaps				= das.das_type_heaps
	  ti_fun_defs				= das.das_fun_defs
	  ti_fun_heap				= das.das_fun_heap
	  ti_var_heap				= das.das_var_heap
	  ti_cons_args				= das.das_cons_args
	  ti_predef_symbols			= das.das_predef
	  das_removed_equal_info_ptr = das.das_removed_equal_info_ptr

	  new_fun_arity = length new_fun_args
	| SwitchArityChecks (new_fun_arity > 32 && new_fun_arity >= fun_arity) False
		# new_gen_fd =
			{	gf_fun_def			= fd
			,	gf_instance_info	= II_Empty
			,	gf_cons_args		= {cc_args=[], cc_size=0, cc_linear_bits=[#!], cc_producer=False}
			,	gf_fun_index		= -1
			}
		# ti_fun_heap 	= ti_fun_heap <:= (fun_def_ptr, FI_Function new_gen_fd)
		# ti = { ti & ti_type_heaps = ti_type_heaps, ti_symbol_heap = ti_symbol_heap, ti_fun_defs = ti_fun_defs
				, ti_fun_heap = ti_fun_heap, ti_var_heap = ti_var_heap, ti_cons_args = ti_cons_args, ti_type_def_infos = ti_type_def_infos
				, ti_predef_symbols = ti_predef_symbols }
		| ro.ro_transform_fusion
			#  ti = { ti & ti_error_file = ti.ti_error_file <<< "Possibly missed fusion oppurtunity: Function Arity > 32 " <<< ro.ro_tfi.tfi_root.symb_ident.id_name <<< "\n"}
			= (-1,new_fun_arity,ti)
		= (-1,new_fun_arity,ti)
	# new_arg_types = flatten [ ats_types \\ {ats_types}<-:new_arg_types_array ]
	  new_args_strictness = compute_args_strictness new_arg_types_array

	  cons_vars = createArray (inc (BITINDEX nr_of_all_type_vars)) 0
	  (cons_vars, th_vars)
			= foldSt set_cons_var_bit propagating_cons_vars (cons_vars, ti_type_heaps.th_vars)
//	| False--->("subst before", [el\\el<-:subst], "cons_vars", [el\\el<-:cons_vars])		= undef
	# ti_type_heaps = { ti_type_heaps & th_vars = th_vars }

	# (next_attr_nr, subst, ti_type_def_infos, ti_type_heaps)
		= foldSt (lift_offered_substitutions_for_unification ro.ro_common_defs cons_vars) uniqueness_requirements (next_attr_nr, subst, ti_type_def_infos, ti_type_heaps)
	# (subst, next_attr_nr, ti_type_heaps, ti_type_def_infos)
  		= liftRemainingSubstitutions subst ro.ro_common_defs cons_vars next_attr_nr ti_type_heaps ti_type_def_infos
//	| False--->("subst after lifting", [el\\el<-:subst])		= undef

	# (consumer_attr_inequalities, th_attrs)
			= mapSt substitute_attr_inequality st_attr_env ti_type_heaps.th_attrs
	  ti_type_heaps & th_attrs = th_attrs

	  coercions
	  		= { coer_offered	= {{ CT_Empty \\ i <- [0 .. next_attr_nr - 1] } & [AttrMulti] = CT_NonUnique }
	  		  , coer_demanded	= {{ CT_Empty \\ i <- [0 .. next_attr_nr - 1] } & [AttrUni] = CT_Unique } }
	  coercions
	  		= foldSt new_inequality consumer_attr_inequalities coercions
	  coercions
	  		= foldSt (\{ur_attr_ineqs} coercions -> foldSt new_inequality ur_attr_ineqs coercions) uniqueness_requirements coercions
	  (subst, coercions, ti_type_def_infos, ti_type_heaps)
	  		= foldSt (coerce_types ro.ro_common_defs cons_vars) uniqueness_requirements (subst, coercions, ti_type_def_infos, ti_type_heaps)
	# ([st_result:new_arg_types], (coercions, subst, ti_type_heaps, ti_type_def_infos))
	  		= mapSt (expand_type ro.ro_common_defs cons_vars) [st_result:new_arg_types]
	  				(coercions, subst, ti_type_heaps, ti_type_def_infos)
	# (fresh_type_vars_array,ti_type_heaps)
	  		= accTypeVarHeap (create_fresh_type_vars nr_of_all_type_vars) ti_type_heaps
	  (attr_partition, demanded) 
	  		= partitionateAttributes coercions.coer_offered coercions.coer_demanded
	  		// to eliminate circles in the attribute inequalities graph that was built during "determine_args"
	  (fresh_attr_vars, ti_type_heaps)
	  		= accAttrVarHeap (create_fresh_attr_vars demanded (size demanded)) ti_type_heaps
	  		// the attribute variables stored in the "demanded" graph are represented as integers: 
	  		// prepare to replace them by pointers
	  used_attr_vars = createArray (size demanded) False
	  replace_input = (fresh_type_vars_array, fresh_attr_vars, attr_partition)
	  (_, fresh_arg_types, used_attr_vars) = replaceIntegers new_arg_types replace_input used_attr_vars
	  (_, fresh_result_type, used_attr_vars) = replaceIntegers st_result replace_input used_attr_vars
			// replace the integer-attribute-variables with pointer-attribute-variables or TA_Unique or TA_Multi
	  final_coercions
	  		= removeUnusedAttrVars demanded [i \\ i<-[0..size used_attr_vars-1] | not used_attr_vars.[i]]
			// the attribute inequalities graph may have contained unused attribute variables.

 	  (all_attr_vars2, ti_type_heaps)
 	  		= accAttrVarHeap (getAttrVars (fresh_arg_types, fresh_result_type)) ti_type_heaps
	  all_attr_vars = get_used_attr_vars 0 used_attr_vars fresh_attr_vars
	  (all_fresh_type_vars, ti_type_heaps)
 	  		= accTypeVarHeap (getTypeVars (fresh_arg_types, fresh_result_type)) ti_type_heaps
	  new_fun_type
	  		= Yes
	  			{ st_vars		= all_fresh_type_vars
	  			, st_args		= fresh_arg_types
	  			, st_args_strictness=new_args_strictness
	  			, st_arity		= new_fun_arity
	  			, st_result		= fresh_result_type
	  			, st_context	= []
	  			, st_attr_vars	= all_attr_vars
	  			, st_attr_env	= coercionsToAttrEnv fresh_attr_vars final_coercions 
				}
/* DvA... STRICT_LET
	  // DvA: moet hier rekening houden met strictness dwz alleen safe args expanderen en rest in stricte let genereren...
	  (tb_rhs,ti_symbol_heap,strict_free_vars) = case let_bindings of
	  			([],[],_,_)
	  				-> (tb_rhs,ti_symbol_heap,[])
	  			(s,l,st,lt)
					# let_type = st++lt
					# (new_info_ptr, ti_symbol_heap) = newPtr (EI_LetType let_type) ti_symbol_heap
	  				# new_expr = Let
	  						{ let_strict_binds	= s
	  						, let_lazy_binds	= l
	  						, let_expr			= tb_rhs
	  						, let_info_ptr		= new_info_ptr
	  						, let_expr_position	= NoPos
	  						}
	  				# strict_free_vars = [lb_dst \\ {lb_dst} <- s]
	  				-> (new_expr,ti_symbol_heap,strict_free_vars)
...DvA */
	  new_fd_expanding 
	  		= { fd & fun_body = Expanding new_fun_args, fun_arity = new_fun_arity,fun_type=new_fun_type,
	  				 fun_info.fi_group_index = fi_group_index,
	  				 fun_info.fi_properties = fi_properties bitand FI_CopyMask 
/* DvA... STRICT_LET
					,fun_info.fi_free_vars = strict_free_vars++fd.fun_info.fi_free_vars
...DvA */
			  }
	  new_fd_cons_args
//	  		= {cc_args = new_cons_args, cc_size = length new_cons_args, cc_linear_bits=new_linear_bits, cc_producer = False}
	  		= {cc_args = repeatn (length new_cons_args) CPassive, cc_size = length new_cons_args, cc_linear_bits=new_linear_bits, cc_producer = False}
	  new_gen_fd
	  		= { gf_fun_def = new_fd_expanding,	gf_instance_info = II_Empty, gf_fun_index = ti_next_fun_nr,
				 gf_cons_args = new_fd_cons_args }
	  ti_fun_heap = ti_fun_heap <:= (fun_def_ptr, FI_Function new_gen_fd)
	  (subst, _)
	  		= iFoldSt (replace_integers_in_substitution (fresh_type_vars_array, fresh_attr_vars, attr_partition))
	  				0 nr_of_all_type_vars (subst, createArray (size demanded) False)
	  		// replace the integer-attribute-variables with pointer-attribute-variables or TA_Unique or TA_Multi in subst
	  (_, th_vars)
	  		= foldSt (\{tv_info_ptr} (i, th_vars) 
	  					-> case subst.[i] of
	  						TE
	  							-> (i+1, writePtr tv_info_ptr (TVI_Type (TV fresh_type_vars_array.[i])) th_vars)
	  						_
	  							-> (i+1, writePtr tv_info_ptr (TVI_Type subst.[i]) th_vars))
	  				all_type_vars (0, ti_type_heaps.th_vars)
	  // remove the AVI_Attr (TA_TempVar _)'s before unfold, because types in Cases and Lets should not use TA_TempVar's
	  th_attrs = remove_TA_TempVars_in_info_ptrs das_AVI_Attr_TA_TempVar_info_ptrs ti_type_heaps.th_attrs
	  cs 	=	{ cs_var_heap				= ti_var_heap
	  			, cs_symbol_heap			= ti_symbol_heap
				, cs_opt_type_heaps			= Yes { ti_type_heaps & th_vars=th_vars, th_attrs=th_attrs }
	  			, cs_cleanup_info			= ti_cleanup_info
	  			}
//	| False ---> ("before unfold:", tb_rhs) = undef
	# (tb_rhs, {cs_var_heap=var_heap,cs_symbol_heap,cs_opt_type_heaps=Yes ti_type_heaps, cs_cleanup_info})
			= copy tb_rhs {ci_handle_aci_free_vars = RemoveAciFreeVars} cs
//	| False ---> ("unfolded:", tb_rhs) = undef

	# th_vars = remove_TVI_Type_values all_type_vars ti_type_heaps.th_vars
	  th_attrs = foldSt remove_AVI_Attr_values das_AVI_Attr_TA_TempVar_info_ptrs ti_type_heaps.th_attrs
	  ti_type_heaps & th_vars=th_vars, th_attrs=th_attrs

	# var_heap						= fold2St store_arg_type_info new_fun_args fresh_arg_types var_heap
		with
			store_arg_type_info {fv_info_ptr} a_type ti_var_heap
				= setExtendedVarInfo fv_info_ptr (EVI_VarType a_type) ti_var_heap
	# var_heap = if (isNilPtr das_removed_equal_info_ptr)
					var_heap
					(writeVarInfo das_removed_equal_info_ptr VI_Empty var_heap)
	# ro_fun= { symb_ident = fd.fun_ident, symb_kind = SK_GeneratedFunction fun_def_ptr ti_next_fun_nr }
	# ro_root_case_mode = case tb_rhs of 
	  						Case _
	  							-> RootCase
	  						_	-> NotRootCase

	# (n_args_before_producer,n_producer_args,var_heap)
		= if (more_unused_producers prods)
			(-1,-1,var_heap)
			(n_args_before_producer_and_n_producer_args tb_args new_fun_args var_heap)

	# tfi = {	tfi_root = ro_fun,
				tfi_case = ro_fun,
				tfi_orig = app_symb,
				tfi_args = new_fun_args,
				tfi_vars = uvar ++ [arg \\ arg <- new_fun_args & i <- [0..] | arg_is_strict i new_args_strictness],
										// evt ++ verwijderde stricte arg...
				tfi_n_args_before_producer = n_args_before_producer,
				tfi_n_producer_args = n_producer_args
			 }
	# ro = { ro & ro_root_case_mode = ro_root_case_mode, ro_tfi=tfi}
				// ---> ("genfun uvars",uvar,[arg \\ arg <- new_fun_args & i <- [0..] | arg_is_strict i new_args_strictness])
//	| False ---> ("transform generated function:",ti_next_fun_nr,ro_root_case_mode)		= undef
//	| False ---> ("transforming new function:",ti_next_fun_nr,tb_rhs)		= undef
//	| False -!-> ("transforming new function:",tb_rhs)		= undef
	# ti
			= { ti & ti_var_heap = var_heap, ti_fun_heap = ti_fun_heap, ti_symbol_heap = cs_symbol_heap,
	  			ti_next_fun_nr = inc ti_next_fun_nr, ti_type_def_infos = ti_type_def_infos,
	  			ti_new_functions = [fun_def_ptr : ti_new_functions], ti_fun_defs = ti_fun_defs,
	  			ti_type_heaps = ti_type_heaps, ti_cleanup_info = cs_cleanup_info,
	  			ti_cons_args = ti_cons_args,
	  			ti_predef_symbols = ti_predef_symbols }
	# ti = arity_warning "generateFunction" fd.fun_ident.id_name ti_next_fun_nr new_fun_arity ti

	# (tb_rhs,ti)		= case n_extra of
							0	-> (tb_rhs,ti)
							_
								# act_args = map f2b (reverse (take n_extra (reverse new_fun_args)))
									with
										f2b { fv_ident, fv_info_ptr }
											= Var { var_ident = fv_ident, var_info_ptr = fv_info_ptr, var_expr_ptr = nilPtr }
								-> add_args_to_fun_body act_args fresh_result_type tb_rhs ro ti
	  (new_fun_rhs, ti)
			= transform tb_rhs ro ti
	  new_fd
	  		= { new_fd_expanding & fun_body = TransformedBody {tb_args = new_fun_args, tb_rhs = new_fun_rhs} }
//	| False ---> ("generated function", new_fd)		= undef

	# new_gen_fd = { new_gen_fd & gf_fun_def = new_fd, gf_cons_args = new_fd_cons_args}
	# ti = { ti & ti_fun_heap 	= ti.ti_fun_heap <:= (fun_def_ptr, FI_Function new_gen_fd) }
	= (ti_next_fun_nr, new_fun_arity, ti)
where
	st_args_array :: ![AType] !StrictnessList -> .{#ATypesWithStrictness}
	st_args_array st_args args_strictness
		# strict1=Strict 1
		= { {ats_types=[el],ats_strictness=if (arg_is_strict i args_strictness) strict1 NotStrict} \\ i<-[0..] & el <- st_args }

	is_dictionary :: !.AType !{#{#.TypeDefInfo}} -> Bool
	is_dictionary {at_type=TA {type_index} _} es_td_infos
		#! td_infos_of_module=es_td_infos.[type_index.glob_module]
		= type_index.glob_object>=size td_infos_of_module || td_infos_of_module.[type_index.glob_object].tdi_group_nr==(-1)
	is_dictionary _ es_td_infos
		= False

	set_cons_var_bit :: !.TypeVar !*(!*{#.Int},!u:(Heap TypeVarInfo)) -> (!.{#Int},!v:(Heap TypeVarInfo)), [u <= v]
	set_cons_var_bit {tv_info_ptr} (cons_vars, th_vars)
		# (TVI_Type (TempV i), th_vars) = readPtr tv_info_ptr th_vars 
		= (set_bit i cons_vars, th_vars)

	copy_opt_symbol_type :: !(Optional SymbolType) !*TypeHeaps -> (!OptionalProducerType,!*TypeHeaps)
	copy_opt_symbol_type No ti_type_heaps
		= (NoProducerType, ti_type_heaps)
	copy_opt_symbol_type (Yes symbol_type=:{st_vars, st_attr_vars, st_args, st_result, st_attr_env})
				ti_type_heaps=:{th_vars, th_attrs}
		# (fresh_st_vars, th_vars) = bind_to_fresh_type_variables st_vars th_vars
		  (fresh_st_attr_vars, th_attrs)
				= mapSt bind_to_fresh_attr_variable st_attr_vars th_attrs
		  ti_type_heaps & th_vars = th_vars, th_attrs = th_attrs
		  (_, [fresh_st_result:fresh_st_args], ti_type_heaps) = substitute [st_result:st_args] ti_type_heaps
		  (_, fresh_st_attr_env, ti_type_heaps) = substitute st_attr_env ti_type_heaps
		  th_vars = remove_TVI_Type_values st_vars ti_type_heaps.th_vars
		  th_attrs = remove_AVI_Attr_values st_attr_vars ti_type_heaps.th_attrs
		  ti_type_heaps & th_vars=th_vars, th_attrs=th_attrs
		  symbol_type & st_vars = fresh_st_vars, st_attr_vars = fresh_st_attr_vars, st_args = fresh_st_args,
						st_result = fresh_st_result, st_attr_env = fresh_st_attr_env
		= (ProducerType symbol_type st_vars, ti_type_heaps)

	add_propagation_attributes :: !{#.CommonDefs} !(Optional .SymbolType) !*(!*TypeHeaps,!*{#*{#.TypeDefInfo}})
											  -> (!(Optional .SymbolType),! (!.TypeHeaps,! {#.{# TypeDefInfo}}))
	add_propagation_attributes common_defs No state
		= (No, state)
	add_propagation_attributes common_defs (Yes st) state
		# (st, state)	= add_propagation_attributes` common_defs st state
		= (Yes st, state)

	add_propagation_attributes` :: !{#.CommonDefs} !.SymbolType !*(!*TypeHeaps,!*{#*{#.TypeDefInfo}})
											   -> (!.SymbolType,! (!.TypeHeaps,! {#.{# TypeDefInfo}}))
	add_propagation_attributes` common_defs st=:{st_args, st_result, st_attr_env, st_attr_vars}
				(type_heaps, type_def_infos)
		# ps	=	{ prop_type_heaps	= type_heaps
					, prop_td_infos		= type_def_infos
					, prop_attr_vars	= st_attr_vars
					, prop_attr_env		= st_attr_env
					, prop_error		= No 
					}
		# ([sound_st_result:sound_st_args], ps)
			  	= mapSt (add_propagation_attributes_to_atype common_defs) [st_result:st_args] ps
		  sound_symbol_type = {st & st_args	= sound_st_args
								  , st_result = sound_st_result
								  , st_attr_env = ps.prop_attr_env
								  , st_attr_vars = ps.prop_attr_vars
								}
		  state = (ps.prop_type_heaps, ps.prop_td_infos)
		= (sound_symbol_type, state)

	add_propagation_attributes_to_atype :: !{#.CommonDefs} !.AType !*PropState -> (!AType,!.PropState)
	add_propagation_attributes_to_atype modules type ps
		| is_dictionary type ps.prop_td_infos
			= (type, ps)
			= addPropagationAttributesToAType modules type ps

	accum_function_producer_type :: !{!.Producer} !.ReadOnlyTI !.Int !*(!u:[v:(Optional .SymbolType)],!*{#.FunDef},!*(Heap FunctionInfo))
																	 -> (!w:[x:(Optional SymbolType)],!.{# FunDef},!.(Heap FunctionInfo)), [u <= w,v <= x]
	accum_function_producer_type prods ro i (type_accu, ti_fun_defs, ti_fun_heap)
		= case prods.[size prods-i-1] of
			PR_Empty
				-> ([No:type_accu], ti_fun_defs, ti_fun_heap)
			PR_Class _ _ class_type
				-> ([No:type_accu], ti_fun_defs, ti_fun_heap)
			PR_Unused
				-> ([No:type_accu], ti_fun_defs, ti_fun_heap)
			PR_String _
				# string_type = TA (MakeTypeSymbIdent {glob_object = PD_StringTypeIndex, glob_module = cPredefinedModuleIndex} predefined_idents.[PD_StringType] 0) []
				  string_atype = {at_attribute=TA_Multi,at_type=string_type}
				  symbol_type = {st_vars=[],st_args=[],st_args_strictness=NotStrict,st_arity=0,st_result=string_atype,st_context=[],st_attr_vars=[],st_attr_env=[]}
				-> ([Yes symbol_type:type_accu], ti_fun_defs, ti_fun_heap)
			PR_Int _
				# int_atype = {at_attribute=TA_Multi,at_type=TB BT_Int}
				  symbol_type = {st_vars=[],st_args=[],st_args_strictness=NotStrict,st_arity=0,st_result=int_atype,st_context=[],st_attr_vars=[],st_attr_env=[]}
				-> ([Yes symbol_type:type_accu], ti_fun_defs, ti_fun_heap)
			PR_Equal _
				-> ([No:type_accu], ti_fun_defs, ti_fun_heap)
			PR_EqualRemove _
				-> ([No:type_accu], ti_fun_defs, ti_fun_heap)
			producer
				# (symbol,_) = get_producer_symbol producer
				  (symbol_type, ti_fun_defs, ti_fun_heap)
						= get_producer_type symbol ro ti_fun_defs ti_fun_heap
				-> ([Yes symbol_type:type_accu], ti_fun_defs, ti_fun_heap)

	collectPropagatingConsVars :: ![AType] !*(Heap TypeVarInfo) -> (!.[TypeVar],!.(Heap TypeVarInfo))
	collectPropagatingConsVars type th_vars
		# th_vars = performOnTypeVars initializeToTVI_Empty type th_vars
		= performOnTypeVars collect_unencountered_cons_var type ([], th_vars)
	  where
		collect_unencountered_cons_var :: !.TypeAttribute !u:TypeVar !*(!v:[w:TypeVar],!*(Heap TypeVarInfo)) -> (!x:[y:TypeVar],!.(Heap TypeVarInfo)), [v <= x,w u <= y]
		collect_unencountered_cons_var TA_MultiOfPropagatingConsVar tv=:{tv_info_ptr} (cons_var_accu, th_vars)
			# (tvi, th_vars) = readPtr tv_info_ptr th_vars
			= case tvi of
				TVI_Empty
					-> ([tv:cons_var_accu], writePtr tv_info_ptr TVI_Used th_vars)
				TVI_Used
					-> (cons_var_accu, th_vars)
		collect_unencountered_cons_var _ _ state
			= state

	replace_integers_in_substitution :: (!{!.TypeVar},!{!.TypeAttribute},!{#.Int}) !.Int !*(!*{!Type},!*{#.Bool}) -> (!.{!Type},!.{#Bool})
	replace_integers_in_substitution replace_input i (subst, used)
		# (subst_i, subst) = subst![i]
		  (_, subst_i, used) = replaceIntegers subst_i replace_input used
		= ({ subst & [i] = subst_i }, used)

	coerce_types common_defs cons_vars {ur_offered, ur_demanded} (subst, coercions, ti_type_def_infos, ti_type_heaps)
		# (opt_error_info, subst, coercions, ti_type_def_infos, ti_type_heaps)
				= determineAttributeCoercions ur_offered ur_demanded True subst coercions common_defs cons_vars ti_type_def_infos ti_type_heaps
		= case opt_error_info of
			Yes _
				-> abort "Error in compiler: determineAttributeCoercions failed in module trans"
			No
				-> (subst, coercions, ti_type_def_infos, ti_type_heaps)

	lift_offered_substitutions_for_unification common_defs cons_vars {ur_offered, ur_demanded} (next_attr_nr,subst,ti_type_def_infos,ti_type_heaps)
		= liftOfferedSubstitutions ur_offered ur_demanded common_defs cons_vars next_attr_nr subst ti_type_def_infos ti_type_heaps

	expand_type :: !{#.CommonDefs} !{#.Int} !.AType !*(!*Coercions,!u:{!.Type},!*TypeHeaps,!*{#*{#.TypeDefInfo}}) -> (!AType,!(!.Coercions,!v:{!Type},!.TypeHeaps,!{#.{#TypeDefInfo}})), [u <= v]
	expand_type ro_common_defs cons_vars atype (coercions, subst, ti_type_heaps, ti_type_def_infos)
		| is_dictionary atype ti_type_def_infos
			# (_, atype, subst) = arraySubst atype subst
			= (atype, (coercions, subst, ti_type_heaps, ti_type_def_infos))
		# es = {es_type_heaps = ti_type_heaps, es_td_infos = ti_type_def_infos}
		  (_, btype, (subst, es))
		  		= expandType ro_common_defs cons_vars atype (subst, es)
 		  {es_type_heaps = ti_type_heaps, es_td_infos = ti_type_def_infos}
				= es
		# cs = {crc_type_heaps = ti_type_heaps, crc_coercions = coercions, crc_td_infos = ti_type_def_infos}
		  (_, cs)
		  		= coerce PositiveSign ro_common_defs cons_vars [] btype btype cs
		  { crc_type_heaps = ti_type_heaps, crc_coercions = coercions, crc_td_infos = ti_type_def_infos }
		  		= cs
		= (btype, (coercions, subst, ti_type_heaps, ti_type_def_infos))

	n_args_before_producer_and_n_producer_args :: [FreeVar] [FreeVar] *VarHeap -> (!Int,!Int,!*VarHeap)
	n_args_before_producer_and_n_producer_args tb_args new_fun_args var_heap
		# (n_args1,resto,restn,var_heap) = take1 tb_args new_fun_args var_heap
			with
				take1 [o:os] [n:ns] var_heap
					# (vi,var_heap) = readVarInfo o.fv_info_ptr var_heap
					= case vi of
						VI_Variable _ fip
							| fip == n.fv_info_ptr
								# (n_args1,os,ns,var_heap) = take1 os ns var_heap
								-> (n_args1+1,os,ns,var_heap)
						_
							-> (0,[o:os],[n:ns],var_heap)
				take1 os ns var_heap
					= (0,os,ns,var_heap)
		# (n_args2n,resto,restn,var_heap) = take2 resto restn var_heap
			with
				take2 [] [] var_heap
					= (0,[],[],var_heap)
				take2 os ns var_heap
					# (os`,var_heap) = extend os var_heap 
					# os`` = map fst os`
					# ns`` = map (\{fv_info_ptr}->fv_info_ptr) ns
					# condO = \(o,_) -> not (isMember o ns``)
					# condN = \{fv_info_ptr} -> not (isMember fv_info_ptr os``)
					# ro` = dropWhile condO os`
					# an = takeWhile condN ns
					# rn = dropWhile condN ns
					# ro = shrink ro`
					= (length an,ro,rn,var_heap)
				where
					extend os uvh = mapSt ext os uvh
					where
						ext o uvh
							# (vi,uvh) = readVarInfo o.fv_info_ptr uvh
							= case vi of
								VI_Variable _ fip	-> ((fip,o),uvh)
								_					-> ((nilPtr,o),uvh)

					shrink as = map snd as

					isMember x [hd:tl]
						| isNilPtr x	= False
						| isNilPtr hd	= isMember x tl
						= hd==x || isMember x tl
					isMember x []	= False
		# var_heap = take3 resto restn var_heap
			with
				take3 [o:os] [n:ns] var_heap
					# (vi,var_heap) = readVarInfo o.fv_info_ptr var_heap
					= case vi of
						VI_Variable _ fip
							| fip == n.fv_info_ptr
								= take3 os ns var_heap
				take3 [] [] var_heap
					= var_heap
		= (n_args1,n_args2n,var_heap)

	get_used_attr_vars :: !Int !{#Bool} !{!TypeAttribute} -> [AttributeVar]
	get_used_attr_vars attr_var_n used_attr_vars fresh_attr_vars
		| attr_var_n<size used_attr_vars
			| used_attr_vars.[attr_var_n]
				# (TA_Var used_attr_var) = fresh_attr_vars.[attr_var_n]
				#! used_attr_var = used_attr_var
				#! used_attr_vars = get_used_attr_vars (attr_var_n+1) used_attr_vars fresh_attr_vars
				= [used_attr_var : used_attr_vars]
				= get_used_attr_vars (attr_var_n+1) used_attr_vars fresh_attr_vars
			= []

more_unused_producers producers
	= more_unused_producers 0 producers
where
	more_unused_producers i producers
		| i<size producers
			= case producers.[i] of
				PR_Empty
					-> more_unused_producers (i+1) producers
				PR_Unused
					-> more_unused_producers2 (i+1) producers
				_
					-> False
			= False

	more_unused_producers2 i producers
		| i<size producers
			= case producers.[i] of
				PR_Empty
					-> more_unused_producers2 (i+1) producers
				PR_Unused
					-> True
			= False

// get_producer_type retrieves the type of symbol
get_producer_type :: !SymbIdent !.ReadOnlyTI !*{#FunDef} !*FunctionHeap -> (!SymbolType,!*{#FunDef},!*FunctionHeap)
get_producer_type {symb_kind=SK_Function {glob_module, glob_object}} ro fun_defs fun_heap
	| glob_module == ro.ro_main_dcl_module_n
		# ({fun_type=Yes symbol_type, fun_info={fi_properties}}, fun_defs) = fun_defs![glob_object]
		|  fi_properties bitand FI_HasTypeSpec <> 0
			# (_, symbol_type) = removeAnnotations symbol_type
			= (symbol_type, fun_defs, fun_heap)
			= (symbol_type, fun_defs, fun_heap)
		# {ft_type} = ro.ro_imported_funs.[glob_module].[glob_object]
		  (_, ft_type=:{st_args,st_args_strictness}) = removeAnnotations ft_type
		  new_st_args = addTypesOfDictionaries ro.ro_common_defs ft_type.st_context st_args
		  new_st_arity = length new_st_args
		  new_st_args_strictness = insert_n_strictness_values_at_beginning (new_st_arity-length st_args) st_args_strictness
		= ({ft_type & st_args = new_st_args, st_args_strictness = new_st_args_strictness, st_arity = new_st_arity, st_context = [] }, fun_defs, fun_heap)
get_producer_type {symb_kind=SK_LocalMacroFunction glob_object} ro fun_defs fun_heap
	# ({fun_type=Yes symbol_type}, fun_defs) = fun_defs![glob_object]
	= (symbol_type, fun_defs, fun_heap)
get_producer_type {symb_kind=SK_GeneratedFunction fun_ptr _} ro fun_defs fun_heap
	# (FI_Function {gf_fun_def={fun_type=Yes symbol_type}}, fun_heap) = readPtr fun_ptr fun_heap
	= (symbol_type, fun_defs, fun_heap)
get_producer_type {symb_kind=SK_Constructor {glob_module, glob_object}} ro fun_defs fun_heap
	# cons_defs = ro.ro_common_defs.[glob_module].com_cons_defs
	# {cons_type} = cons_defs.[glob_object]
	# (_,cons_type) = removeAnnotations cons_type	// necessary???
	= (cons_type, fun_defs, fun_heap)

determine_args
	:: ![#Bool!] ![ConsClass] !Index !{!Producer} ![OptionalProducerType] ![FreeVar] !ReadOnlyTI !*DetermineArgsState
	-> *DetermineArgsState
determine_args _ [] prod_index producers prod_atypes forms _ das=:{das_var_heap}
	# (vars, das_var_heap)	= new_variables forms das_var_heap
	= {das & das_vars = vars, das_var_heap = das_var_heap}
where
	new_variables [] var_heap
		= ([], var_heap)
	new_variables [form=:{fv_ident,fv_info_ptr}:forms] var_heap
		# (vars, var_heap) = new_variables forms var_heap
		  (new_info_ptr, var_heap) = newPtr VI_Empty var_heap
		= ([{ form & fv_info_ptr = new_info_ptr } : vars], writeVarInfo fv_info_ptr (VI_Variable fv_ident new_info_ptr) var_heap)
determine_args [#linear_bit : linear_bits!] [cons_arg : cons_args] prod_index producers [prod_atype:prod_atypes] [form : forms] input das
	# das = determine_args linear_bits cons_args (inc prod_index) producers prod_atypes forms input das
	# producer = producers.[prod_index]
	# producer
		= if (cons_arg==CActive || cons_arg==CUnusedStrict || cons_arg==CUnusedLazy)
			producer
			(case producer of
				PR_String _			-> producer
				PR_Int _			-> producer
				PR_Curried _ 0		-> producer
				PR_Equal arg_index	-> producer
				PR_EqualRemove _	-> producer
				_					-> PR_Empty)
	= determine_arg producer prod_atype form prod_index ((linear_bit,cons_arg), input) das

determine_arg
	:: !Producer OptionalProducerType !FreeVar .Int !(!(!Bool,!ConsClass),!ReadOnlyTI) !*DetermineArgsState
	-> *DetermineArgsState

determine_arg PR_Empty _ form=:{fv_ident,fv_info_ptr} _ ((linear_bit,cons_arg), _) das=:{das_var_heap}
	# (new_info_ptr, das_var_heap) = newPtr VI_Empty das_var_heap
	# das_var_heap = writeVarInfo fv_info_ptr (VI_Variable fv_ident new_info_ptr) das_var_heap
	= { das & das_vars				= [{form & fv_info_ptr = new_info_ptr} : das.das_vars]
			, das_new_linear_bits	= [#linear_bit : das.das_new_linear_bits!]
			, das_new_cons_args		= [cons_arg : das.das_new_cons_args]
			, das_var_heap			= das_var_heap }

determine_arg PR_Unused _ form prod_index (_,ro) das
	# no_arg_type = {ats_types = [], ats_strictness = NotStrict}
	= {das & das_arg_types.[prod_index] = no_arg_type}

determine_arg (PR_Class class_app free_vars_and_types class_type) _ {fv_info_ptr} prod_index (_,ro)
			  das=:{das_arg_types, das_subst, das_type_heaps, das_predef}
	# (ws_arg_type, das_arg_types) = das_arg_types![prod_index]
	# {ats_types=[arg_type:_]} = ws_arg_type
	  (_, int_class_type, das_type_heaps) = substitute class_type das_type_heaps
	  class_atype = { empty_atype & at_type = int_class_type }
	  type_input
	  		= { ti_common_defs = ro.ro_common_defs
	  		  , ti_functions = ro.ro_imported_funs
			  ,	ti_main_dcl_module_n = ro.ro_main_dcl_module_n
			  , ti_expand_newtypes = True
			  }
	// AA: Dummy generic dictionary does not unify with corresponding class dictionary.
	// Make it unify
	# ({pds_module,pds_def},das_predef) = das_predef![PD_TypeGenericDict]
	# genericGlobalIndex	= {glob_module = pds_module, glob_object = pds_def}
	# (succ, das_subst, das_type_heaps)
		//AA: = unify class_atype arg_type type_input das_subst das_type_heaps
		= unify_dict class_atype arg_type type_input das_subst das_type_heaps
		with
			unify_dict class_atype=:{at_type=TA type_symb1 args1} arg_type=:{at_type=TA type_symb2 args2} 
				| type_symb1 == type_symb2 
					= unify class_atype arg_type
				// FIXME: check indexes, not names. Need predefs for that. 	
//				| type_symb1.type_ident.id_name == "GenericDict"
				| type_symb1.type_index == genericGlobalIndex
					= unify {class_atype & at_type = TA type_symb2 args1} arg_type	
//				| type_symb2.type_ident.id_name == "GenericDict"
				| type_symb2.type_index == genericGlobalIndex
					= unify class_atype {arg_type & at_type = TA type_symb1 args2} 	  				
			unify_dict class_atype arg_type 
				= unify class_atype arg_type
	| not succ
		= abort ("sanity check nr 93 in module trans failed\n"--->(class_atype,"\n", arg_type))
	# (free_vars_and_types,das_type_heaps) = mapSt subFVT free_vars_and_types das_type_heaps
		with
			subFVT (fv,ty) type_heaps
				# (_, ty`,type_heaps) = substitute ty type_heaps
				= ((fv,ty`),type_heaps)

	# ws_ats_types = [ { empty_atype & at_type = at_type } \\ (_, at_type) <- free_vars_and_types]
	# ws_arg_type` = {ats_types= ws_ats_types, ats_strictness = first_n_strict (length free_vars_and_types) }

	= {das
		& das_vars = mapAppend (\({var_info_ptr,var_ident}, _)
						-> { fv_ident = var_ident, fv_info_ptr = var_info_ptr, fv_def_level = NotALevel, fv_count = 0 })
				  			  free_vars_and_types das.das_vars
		, das_arg_types			= {das_arg_types & [prod_index] = ws_arg_type` }
		, das_new_linear_bits	= MapAppend (\_ -> True) free_vars_and_types das.das_new_linear_bits
		, das_new_cons_args		= mapAppend (\_ -> CActive) free_vars_and_types das.das_new_cons_args
		, das_subst				= das_subst
		, das_type_heaps		= das_type_heaps
		, das_var_heap			= writeVarInfo fv_info_ptr (VI_Dictionary class_app.app_symb class_app.app_args class_type) das.das_var_heap
		, das_predef			= das_predef
		}

determine_arg (PR_String s) _ {fv_info_ptr} prod_index (_,ro) das=:{das_var_heap,das_arg_types}
	# no_arg_type = {ats_types = [], ats_strictness = NotStrict}
	  das_arg_types & [prod_index] = no_arg_type
	  das_var_heap = writeVarInfo fv_info_ptr (VI_Expression (BasicExpr (BVS s))) das_var_heap
	= {das & das_arg_types=das_arg_types, das_var_heap=das_var_heap}

determine_arg (PR_Int i) _ {fv_info_ptr} prod_index (_,ro) das=:{das_var_heap,das_arg_types}
	# no_arg_type = {ats_types = [], ats_strictness = NotStrict}
	  das_arg_types & [prod_index] = no_arg_type
	  das_var_heap = writeVarInfo fv_info_ptr (VI_Expression (BasicExpr (BVInt i))) das_var_heap
	= {das & das_arg_types=das_arg_types, das_var_heap=das_var_heap}

determine_arg (PR_Equal arg_index) _ form=:{fv_ident,fv_info_ptr} prod_index ((linear_bit,cons_arg), ro) das=:{das_var_heap,das_removed_equal_info_ptr}
	# (new_info_ptr, das_var_heap) = newPtr VI_Empty das_var_heap
	# var_info = VI_Variable fv_ident new_info_ptr
	# das_var_heap = writeVarInfo fv_info_ptr var_info das_var_heap
	# das_var_heap = writeVarInfo das_removed_equal_info_ptr var_info das_var_heap
	= {das & das_vars				= [{form & fv_info_ptr = new_info_ptr} : das.das_vars]
		   , das_new_linear_bits	= [#False/*linear_bit*//*?*/ : das.das_new_linear_bits!]
		   , das_new_cons_args		= [CPassive/*cons_arg*//*?*/ : das.das_new_cons_args]
		   , das_var_heap = das_var_heap}

determine_arg (PR_EqualRemove arg_index) _ form=:{fv_info_ptr} prod_index (_,ro) das=:{das_subst,das_arg_types,das_type_heaps}
	# ([prod_type:_], das_arg_types) = das_arg_types![prod_index].ats_types
	# ([arg_type:_], das_arg_types) = das_arg_types![arg_index].ats_types
	# type_input = {ti_common_defs = ro.ro_common_defs, ti_functions = ro.ro_imported_funs, ti_main_dcl_module_n = ro.ro_main_dcl_module_n, ti_expand_newtypes = True}
	# (succ, das_subst, das_type_heaps)
	  	= unify prod_type arg_type type_input das_subst das_type_heaps
	| not succ
		| False ---> ("prod_type",prod_type,"\narg_type",arg_type) = undef
		= abort "Error in compiler: unification in module trans failed\n"
	# no_arg_type = {ats_types = [], ats_strictness = NotStrict}
	  das_arg_types & [prod_index] = no_arg_type
	= {das & das_arg_types = das_arg_types, das_subst = das_subst, das_type_heaps = das_type_heaps, das_removed_equal_info_ptr = fv_info_ptr}

determine_arg producer (ProducerType {st_args, st_args_strictness, st_result, st_attr_vars, st_context, st_attr_env, st_arity, st_vars} original_type_vars)
				{fv_info_ptr,fv_ident} prod_index ((linear_bit, _),ro)
				das=:{das_subst,das_type_heaps,das_fun_defs,das_fun_heap,das_var_heap,das_cons_args,das_arg_types,das_next_attr_nr,das_AVI_Attr_TA_TempVar_info_ptrs}

	# {th_vars, th_attrs}		= das_type_heaps
	# (symbol,symbol_arity)		= get_producer_symbol producer
	  curried					= case producer of
	  									PR_Curried _ _ -> True
	  									PR_CurriedFunction _ _ _  -> True
	  									_ -> False;
	#! size_fun_defs			= size das_fun_defs

	# ({cc_args, cc_linear_bits}, das_fun_heap, das_cons_args)
			= calc_cons_args curried symbol.symb_kind symbol_arity das_cons_args linear_bit size_fun_defs das_fun_heap
	  ({ats_types=[arg_type:_],ats_strictness}, das_arg_types) = das_arg_types![prod_index]

	  (das_next_attr_nr, th_attrs)
	  		= bind_to_temp_attr_vars st_attr_vars (das_next_attr_nr, th_attrs)
	  // remember the st_attr_vars, because the AVI_Attr (TA_TempVar _)'s must be removed before unfold,
	  // because types in Cases and Lets should not use TA_TempVar's
	  das_AVI_Attr_TA_TempVar_info_ptrs = [st_attr_vars:das_AVI_Attr_TA_TempVar_info_ptrs]
	  		// prepare for substitute calls
	  (_, st_args, das_type_heaps) = substitute st_args {das_type_heaps & th_vars = th_vars, th_attrs = th_attrs}
	  (_, st_result, das_type_heaps) = substitute st_result das_type_heaps
	  nr_of_applied_args = symbol_arity
	  (application_type, attr_env, das_next_attr_nr)
	  		= build_application_type st_arity (length st_context) st_result st_args nr_of_applied_args [] das_next_attr_nr
	  type_input
	  		= { ti_common_defs			= ro.ro_common_defs
	  		  , ti_functions			= ro.ro_imported_funs
			  ,	ti_main_dcl_module_n	= ro.ro_main_dcl_module_n
			  , ti_expand_newtypes = True }
	# (succ, das_subst, das_type_heaps)
	  		= unify application_type arg_type type_input das_subst das_type_heaps
	| not succ
		= abort "Error in compiler: unification in module trans failed\n"
	# (attr_inequalities, das_type_heaps)
			= accAttrVarHeap (mapSt substitute_attr_inequality st_attr_env) das_type_heaps
	  new_uniqueness_requirement
			= { ur_offered		= application_type
			  , ur_demanded		= arg_type
			  , ur_attr_ineqs	= attr_inequalities ++ attr_env
			  }
	  (expr_to_unfold,form_vars,das_fun_defs,das_fun_heap,das_var_heap)
		= make_producer_expression_and_args producer original_type_vars st_vars das.das_vars das_fun_defs das_fun_heap das_var_heap
/* DvA... STRICT_LET
	  (expr_to_unfold, das_var_heap, let_bindings)
			= case arg_type.at_annotation of
				AN_Strict
					# (new_info_ptr_l, das_var_heap) = newPtr VI_Empty das_var_heap
	  				# free_var_l = { fv_ident = { id_name = "free_l", id_info = nilPtr }, fv_info_ptr = new_info_ptr_l, fv_count = 0, fv_def_level = NotALevel }
			  		# act_var_l = Var { var_ident = { id_name = "act_l", id_info = nilPtr }, var_info_ptr = new_info_ptr_l, var_expr_ptr = nilPtr }

					# bind = {lb_dst = fv, lb_src = act_var_l, lb_position = NoPos}

					# das_var_heap = writeVarInfo new_info_ptr_l expr_to_unfold das_var_heap

					# let_bindings = case let_bindings of
									(s,l,st,lt) -> ([bind:s],l,[arg_type:st],lt)
					-> (VI_Empty, das_var_heap, let_bindings)
				_	-> (expr_to_unfold,das_var_heap,let_bindings)
...DvA */
	# das_arg_types = { das_arg_types & [prod_index] = {ats_types=take nr_of_applied_args st_args,ats_strictness=st_args_strictness} }
	=	{ das 
		& das_vars						= form_vars
		, das_arg_types					= das_arg_types 
		, das_next_attr_nr				= das_next_attr_nr
		, das_new_linear_bits			= cc_linear_bits ++$ das.das_new_linear_bits
		, das_new_cons_args				= cc_args ++ das.das_new_cons_args
		, das_uniqueness_requirements	= [new_uniqueness_requirement:das.das_uniqueness_requirements]
		, das_AVI_Attr_TA_TempVar_info_ptrs = das_AVI_Attr_TA_TempVar_info_ptrs
		, das_subst						= das_subst
		, das_type_heaps				= das_type_heaps
		, das_fun_defs					= das_fun_defs
		, das_fun_heap					= das_fun_heap
		, das_var_heap					= writeVarInfo fv_info_ptr expr_to_unfold das_var_heap
		, das_cons_args					= das_cons_args
		}
where
	make_producer_expression_and_args (PR_Constructor symbol=:{symb_kind=SK_Constructor {glob_module}} arity _) _ _ das_vars das_fun_defs das_fun_heap das_var_heap
		# (form_vars, act_vars, das_var_heap) = build_n_anonymous_var_args arity das_vars das_var_heap
		= (VI_Expression (App {app_symb = symbol, app_args = act_vars, app_info_ptr = nilPtr}),form_vars,das_fun_defs,das_fun_heap,das_var_heap)
	make_producer_expression_and_args (PR_Curried symbol=:{symb_kind=SK_Function {glob_module}} arity) _ _ das_vars das_fun_defs das_fun_heap das_var_heap
		| glob_module <> ro.ro_main_dcl_module_n
			# (form_vars, act_vars, das_var_heap) = build_n_anonymous_var_args arity das_vars das_var_heap
			= (VI_Expression (App {app_symb = symbol, app_args = act_vars, app_info_ptr = nilPtr}),form_vars,das_fun_defs,das_fun_heap,das_var_heap)
	make_producer_expression_and_args (PR_Curried symbol=:{symb_kind} arity) _ _ das_vars das_fun_defs das_fun_heap das_var_heap
		# ({fun_body}, das_fun_defs, das_fun_heap)
			= get_fun_def symb_kind ro.ro_main_dcl_module_n das_fun_defs das_fun_heap
		= case fun_body of
			TransformedBody tb=:{tb_args}
				# (form_vars, act_vars, das_var_heap)
					= build_n_named_var_args arity tb_args das_vars das_var_heap
				-> (VI_Expression (App {app_symb = symbol, app_args = act_vars, app_info_ptr = nilPtr}),form_vars,das_fun_defs,das_fun_heap,das_var_heap)
			_
				# (form_vars, act_vars, das_var_heap) = build_n_anonymous_var_args arity das_vars das_var_heap
				-> (VI_Expression (App {app_symb = symbol, app_args = act_vars, app_info_ptr = nilPtr}),form_vars,das_fun_defs,das_fun_heap,das_var_heap)
	make_producer_expression_and_args (PR_Function symbol=:{symb_kind} arity _) original_type_vars new_type_vars das_vars das_fun_defs das_fun_heap das_var_heap
		# ({fun_body}, das_fun_defs, das_fun_heap)
			= get_fun_def symb_kind ro.ro_main_dcl_module_n das_fun_defs das_fun_heap
		= case fun_body of
			TransformedBody tb=:{tb_args}
				# (form_vars, act_vars, das_var_heap)
					= build_n_named_var_args arity tb_args das_vars das_var_heap
				-> (VI_Body symbol tb (take arity form_vars) original_type_vars new_type_vars, form_vars, das_fun_defs,das_fun_heap,das_var_heap)
	make_producer_expression_and_args (PR_GeneratedFunction symbol=:{symb_kind} arity _) original_type_vars new_type_vars das_vars das_fun_defs das_fun_heap das_var_heap
		# ({fun_body}, das_fun_defs, das_fun_heap)
			= get_fun_def symb_kind ro.ro_main_dcl_module_n das_fun_defs das_fun_heap
		= case fun_body of
			TransformedBody tb=:{tb_args}
				# (form_vars, act_vars, das_var_heap)
					= build_n_named_var_args arity tb_args das_vars das_var_heap
				-> (VI_Body symbol tb (take arity form_vars) original_type_vars new_type_vars, form_vars, das_fun_defs,das_fun_heap,das_var_heap)
	make_producer_expression_and_args (PR_CurriedFunction symbol=:{symb_kind} arity _) original_type_vars new_type_vars das_vars das_fun_defs das_fun_heap das_var_heap
		# ({fun_body}, das_fun_defs, das_fun_heap)
			= get_fun_def symb_kind ro.ro_main_dcl_module_n das_fun_defs das_fun_heap
		= case fun_body of
			TransformedBody tb=:{tb_args}
				# (form_vars, act_vars, das_var_heap)
					= build_n_named_var_args arity tb_args das_vars das_var_heap
				  expr = App {app_symb = symbol, app_args = act_vars, app_info_ptr = nilPtr}
				-> (VI_ExpressionOrBody expr symbol tb (take arity form_vars) original_type_vars new_type_vars, form_vars, das_fun_defs,das_fun_heap,das_var_heap)

	build_n_anonymous_var_args arity das_vars das_var_heap
 		# var_names = repeatn arity {id_name = "_x", id_info = nilPtr}
		= build_var_args (/*reverse*/ var_names) das_vars [] das_var_heap

	build_n_named_var_args arity tb_args das_vars das_var_heap
		# var_names = take arity [fv_ident \\ {fv_ident}<-tb_args]
		= build_var_args (reverse var_names) das_vars [] das_var_heap

	build_var_args [] form_vars act_vars var_heap
		= (form_vars, act_vars, var_heap)
	build_var_args [new_name:new_names] form_vars act_vars var_heap
		# (info_ptr, var_heap) = newPtr VI_Empty var_heap
		  form_var = { fv_ident = new_name, fv_info_ptr = info_ptr, fv_count = 0, fv_def_level = NotALevel }
		  act_var = { var_ident = new_name, var_info_ptr = info_ptr, var_expr_ptr = nilPtr }
		= build_var_args new_names [form_var : form_vars] [Var act_var : act_vars] var_heap

	calc_cons_args curried symb_kind symbol_arity ti_cons_args linear_bit size_fun_defs fun_heap
		# (cons_size, ti_cons_args) = usize ti_cons_args
		# (opt_cons_classes, fun_heap, ti_cons_args)
				= case symb_kind of
					SK_Function {glob_module, glob_object}
						| glob_module == ro.ro_main_dcl_module_n && glob_object < cons_size
							# (cons_args, ti_cons_args) = ti_cons_args![glob_object]
							-> (Yes cons_args, fun_heap, ti_cons_args)
						-> (No, fun_heap, ti_cons_args)
					SK_LocalMacroFunction glob_object
						| glob_object < cons_size
							# (cons_args, ti_cons_args) = ti_cons_args![glob_object]
							-> (Yes cons_args, fun_heap, ti_cons_args)
						-> (No, fun_heap, ti_cons_args)
					SK_GeneratedFunction fun_ptr fun_index
						| fun_index < cons_size
							# (cons_args, ti_cons_args) = ti_cons_args![fun_index]
							-> (Yes cons_args, fun_heap, ti_cons_args)
						| fun_index < size_fun_defs
							-> abort "sanity check failed in module trans"
						# (FI_Function {gf_cons_args}, fun_heap) = readPtr fun_ptr fun_heap
						-> (Yes gf_cons_args, fun_heap, ti_cons_args)
					SK_Constructor _
						-> (No, fun_heap, ti_cons_args)
		= case opt_cons_classes of
			Yes cons_classes
				# cc_args = copy_classes symbol_arity cons_classes.cc_args
				-> ({ cc_size			= symbol_arity
					, cc_args			= cc_args
					, cc_linear_bits	= if curried
											(RepeatnM symbol_arity linear_bit)
											(TakeM symbol_arity cons_classes.cc_linear_bits)
					, cc_producer		= False
					}
		  			, fun_heap, ti_cons_args)
			No
				-> ({ cc_size			= symbol_arity
					, cc_args			= repeatn symbol_arity CPassive
					, cc_linear_bits	= RepeatnM symbol_arity linear_bit
					, cc_producer		= False
					}
					, fun_heap, ti_cons_args)

	copy_classes 0 _ = []
	copy_classes n [cc:ccs]
		= case cc of
			CUnusedStrict	-> [CActive:copy_classes (dec n) ccs]
			CUnusedLazy		-> [CActive:copy_classes (dec n) ccs]
			cc				-> [cc:copy_classes (dec n) ccs]

/*
	build_application_type st_arity nr_context_args st_result st_args nr_of_applied_args
		| st_arity+nr_context_args==nr_of_applied_args
			= st_result
		| nr_of_applied_args<nr_context_args
			= abort "sanity check nr 234 failed in module trans"
		# (applied_args, unapplied_args) = splitAt (nr_of_applied_args-nr_context_args) st_args
		  attr_approx = if (any has_unique_attribute applied_args) TA_Unique TA_Multi
		= foldr (\atype1 atype2->{at_attribute=attr_approx, at_type=atype1-->atype2})
				st_result unapplied_args
	  where
		has_unique_attribute {at_attribute=TA_Unique} = True
		has_unique_attribute _ = False
*/
	build_application_type st_arity nr_context_args st_result st_args nr_of_applied_args attr_env attr_store
		| st_arity+nr_context_args==nr_of_applied_args
			= (st_result, attr_env, attr_store)
		| nr_of_applied_args<nr_context_args
			= abort "sanity check nr 234 failed in module trans"
		# req_arity	= nr_of_applied_args - nr_context_args

		= currySymbolType st_args st_arity st_result attr_env req_arity attr_store
/*
		# (type`,attr_env`,attr_store`)
			= currySymbolType st_args st_arity st_result attr_env req_arity attr_store
		# (applied_args, unapplied_args) = splitAt req_arity st_args
		  attr_approx = if (any has_unique_attribute applied_args) TA_Unique TA_Multi			// DvA: should be var instead of multi...
		# type = foldr (\atype1 atype2->{at_attribute=attr_approx, at_type=atype1-->atype2})
				st_result unapplied_args
		| False ---> ("build",type,type`) = undef
//		= (type, attr_env, attr_store)
		= (type`, attr_env`, attr_store`)
	  where
		has_unique_attribute {at_attribute=TA_Unique} = True
		has_unique_attribute _ = False
*/

// DvA: from type.icl...
currySymbolType tst_args tst_arity tst_result tst_attr_env req_arity ts_attr_store
	| tst_arity == req_arity
		= (tst_result, tst_attr_env, ts_attr_store)
	# (tst_args, rest_args, is_unique)			= split_args req_arity tst_args 
	| is_unique
		# (type, _, _)							= buildCurriedType rest_args tst_result TA_Unique [] 0
		= (type, tst_attr_env, ts_attr_store)
		# tst_attr_env							= build_attr_env ts_attr_store tst_args tst_attr_env
		# (type, tst_attr_env, ts_attr_store)	= buildCurriedType rest_args tst_result (TA_TempVar ts_attr_store)
		  												tst_attr_env (inc ts_attr_store)
		= (type, tst_attr_env, ts_attr_store)
where
	split_args 0 args = ([], args, False)
	split_args n [atype=:{at_attribute} : args]
		# (left, right, is_unique) = split_args (dec n) args
		= ([ atype : left ], right, is_unique || attr_is_unique at_attribute)
	
	attr_is_unique TA_Unique = True
	attr_is_unique _ = False
	
	build_attr_env cum_attr_var [] attr_env
		= attr_env
	build_attr_env cum_attr_var [{at_attribute=(TA_TempVar attr_var)} : args] attr_env
		# attr_env = [{ ac_demanded = attr_var, ac_offered = cum_attr_var } : attr_env]
		= build_attr_env cum_attr_var args attr_env
	build_attr_env cum_attr_var [_ : args] attr_env
		= build_attr_env cum_attr_var args attr_env

buildCurriedType [] type cum_attr attr_env attr_store
	= (type, attr_env, attr_store)
buildCurriedType [at=:{at_attribute}:ats] type cum_attr attr_env attr_store
	# (next_cum_attr, attr_env, attr_store) = combine_attributes at_attribute cum_attr attr_env attr_store
	  (res_type, attr_env, attr_store) = buildCurriedType ats type next_cum_attr attr_env attr_store
	= ({at_attribute = cum_attr , at_type = at --> res_type }, attr_env, attr_store)
where
	combine_attributes TA_Unique cum_attr attr_env attr_store
		= (TA_Unique, attr_env, attr_store)
	combine_attributes (TA_TempVar attr_var) (TA_TempVar cum_attr_var) attr_env attr_store
		# attr_env =
			[{ ac_demanded = cum_attr_var,ac_offered = attr_store }
			,{ ac_demanded = attr_var,ac_offered = attr_store }
			:attr_env]
		= (TA_TempVar attr_store, attr_env, inc attr_store)
	combine_attributes (TA_TempVar _) cum_attr attr_env attr_store
		= (cum_attr, attr_env, attr_store)
	combine_attributes _ (TA_TempVar cum_attr_var) attr_env attr_store
		# attr_env = [{ ac_demanded = cum_attr_var,ac_offered = attr_store }:attr_env]
		= (TA_TempVar attr_store, attr_env, inc attr_store)
	combine_attributes _ cum_attr attr_env attr_store
		= (cum_attr, attr_env, attr_store)

freshAttrVar attr_var th_attrs
	:== NewAttrVar attr_var th_attrs

RepeatnAppendM n a l :== repeatn_append_ n a l
	where
		repeatn_append_ 0 _ l = l
		repeatn_append_ n a l = [|a:repeatn_append_ (dec n) a l]

MapAppend f [|x : xs] tail
	#  x = f x
	   xs = MapAppend f xs tail
	= [|x : xs]
MapAppend f [|] tail
	= tail

//@ max_group_index

max_group_index
	:: !Int !{!Producer} Index Index *{#FunDef} *FunctionHeap *{!ConsClasses}
	-> (Index,*{!ConsClasses},*{#FunDef},*FunctionHeap)
max_group_index prod_index producers ro_main_dcl_module_n current_max fun_defs fun_heap cons_args
	| prod_index == size producers
		= (current_max, cons_args, fun_defs, fun_heap)
		# (current_max, cons_args, fun_defs, fun_heap)
			= max_group_index_of_producer producers.[prod_index] current_max fun_defs fun_heap cons_args
		= max_group_index (inc prod_index) producers ro_main_dcl_module_n current_max fun_defs fun_heap cons_args
where
	max_group_index_of_producer PR_Empty current_max fun_defs fun_heap cons_args
		= (current_max, cons_args, fun_defs, fun_heap)
	max_group_index_of_producer PR_Unused current_max fun_defs fun_heap cons_args
		= (current_max, cons_args, fun_defs, fun_heap)
	max_group_index_of_producer (PR_Class {app_args} _ _) current_max fun_defs fun_heap cons_args
		= foldSt (foldrExprSt max_group_index_of_member) app_args (current_max, cons_args, fun_defs, fun_heap)
	max_group_index_of_producer (PR_Curried {symb_kind=SK_Function {glob_object=fun_index, glob_module}} _) current_max fun_defs fun_heap cons_args
		| glob_module<>ro_main_dcl_module_n
			= (current_max, cons_args, fun_defs, fun_heap)
		# (current_max, fun_defs) = max_group_index_of_fun_with_fun_index fun_index current_max fun_defs
		= (current_max, cons_args, fun_defs, fun_heap)
	max_group_index_of_producer (PR_Curried {symb_kind=SK_LocalMacroFunction fun_index} _) current_max fun_defs fun_heap cons_args
		# (current_max, fun_defs) = max_group_index_of_fun_with_fun_index fun_index current_max fun_defs
		= (current_max, cons_args, fun_defs, fun_heap)
	max_group_index_of_producer (PR_Curried { symb_kind = SK_GeneratedFunction fun_ptr fun_index} _) current_max fun_defs fun_heap cons_args
		# (current_max, fun_defs, fun_heap) = max_group_index_of_fun_with_fun_index_and_ptr fun_ptr fun_index current_max fun_defs fun_heap
		= (current_max, cons_args, fun_defs, fun_heap)
	max_group_index_of_producer (PR_Function _ _ fun_index) current_max fun_defs fun_heap cons_args
		# (current_max, fun_defs) = max_group_index_of_fun_with_fun_index fun_index current_max fun_defs
		= (current_max, cons_args, fun_defs, fun_heap)
	max_group_index_of_producer (PR_GeneratedFunction { symb_kind = SK_GeneratedFunction fun_ptr fun_index} _ _)
								current_max fun_defs fun_heap cons_args
		# (current_max, fun_defs, fun_heap) = max_group_index_of_fun_with_fun_index_and_ptr fun_ptr fun_index current_max fun_defs fun_heap
		= (current_max, cons_args, fun_defs, fun_heap)
	max_group_index_of_producer (PR_Constructor symb _ args) current_max fun_defs fun_heap cons_args
		= (current_max, cons_args, fun_defs, fun_heap)
	max_group_index_of_producer (PR_CurriedFunction {symb_kind = SK_GeneratedFunction fun_ptr fun_index} _ _)
								current_max fun_defs fun_heap cons_args
		# (current_max, fun_defs, fun_heap) = max_group_index_of_fun_with_fun_index_and_ptr fun_ptr fun_index current_max fun_defs fun_heap
		= (current_max, cons_args, fun_defs, fun_heap)
	max_group_index_of_producer (PR_CurriedFunction _ _ fun_index)
								current_max fun_defs fun_heap cons_args
		# (current_max, fun_defs) = max_group_index_of_fun_with_fun_index fun_index current_max fun_defs
		= (current_max, cons_args, fun_defs, fun_heap)
	max_group_index_of_producer (PR_String _) current_max fun_defs fun_heap cons_args
		= (current_max, cons_args, fun_defs, fun_heap)
	max_group_index_of_producer (PR_Int _) current_max fun_defs fun_heap cons_args
		= (current_max, cons_args, fun_defs, fun_heap)
	max_group_index_of_producer (PR_Equal _) current_max fun_defs fun_heap cons_args
		= (current_max, cons_args, fun_defs, fun_heap)
	max_group_index_of_producer (PR_EqualRemove _) current_max fun_defs fun_heap cons_args
		= (current_max, cons_args, fun_defs, fun_heap)

	max_group_index_of_member
				(App {app_symb = {symb_ident, symb_kind = SK_Function { glob_object = fun_index, glob_module = mod_index}}}) 
				(current_max, cons_args, fun_defs, fun_heap)
		| mod_index == ro_main_dcl_module_n
			# (size_args, cons_args) = usize cons_args
			| fun_index < size_args
				# ({fun_info = {fi_group_index}},fun_defs) = fun_defs![fun_index]
				= (max fi_group_index current_max, cons_args, fun_defs, fun_heap)
			= (current_max, cons_args, fun_defs, fun_heap)
		= (current_max, cons_args, fun_defs, fun_heap)
	max_group_index_of_member
				(App {app_symb = {symb_ident, symb_kind = SK_LocalMacroFunction fun_index}})
				(current_max, cons_args, fun_defs, fun_heap)
		# (size_args, cons_args) = usize cons_args
		| fun_index < size_args
			# ({fun_info = {fi_group_index}}, fun_defs) = fun_defs![fun_index]
			= (max fi_group_index current_max, cons_args, fun_defs, fun_heap)
		= (current_max, cons_args, fun_defs, fun_heap)
	max_group_index_of_member
				(App {app_symb = {symb_kind = SK_GeneratedFunction fun_ptr _}})
				(current_max, cons_args, fun_defs, fun_heap)
		# (FI_Function {gf_fun_def={fun_info = {fi_group_index}}}, fun_heap) = readPtr fun_ptr fun_heap
		= (max fi_group_index current_max, cons_args, fun_defs, fun_heap)
	max_group_index_of_member _ (current_max, cons_args, fun_defs, fun_heap)
		= (current_max, cons_args, fun_defs, fun_heap)

	max_group_index_of_fun_with_fun_index fun_index current_max fun_defs
		# (fun_def,fun_defs) = fun_defs![fun_index]
		= (max fun_def.fun_info.fi_group_index current_max, fun_defs)

	max_group_index_of_fun_with_fun_index_and_ptr fun_ptr fun_index current_max fun_defs fun_heap
		# (fun_size, fun_defs)	= usize fun_defs
		| fun_index < fun_size
			# ({fun_info},fun_defs) = fun_defs![fun_index] 
			= (max fun_info.fi_group_index current_max, fun_defs, fun_heap)
			# (FI_Function generated_function, fun_heap) = readPtr fun_ptr fun_heap
			= (max generated_function.gf_fun_def.fun_info.fi_group_index current_max, fun_defs, fun_heap)

class replaceIntegers a :: !a !({!TypeVar}, !{!TypeAttribute}, !AttributePartition) !*{#Bool} -> (!Bool, !a, !*{#Bool})
	// get rid of all those TempV and TA_Var things

instance replaceIntegers [a] | replaceIntegers a where
	replaceIntegers l=:[h:t] input used
		# (h_m, h_r, used) = replaceIntegers h input used
		  (t_m, t_r, used) = replaceIntegers t input used
		| h_m
			| t_m
				= (True, [h_r:t_r], used)
				= (True, [h_r:t], used)
			| t_m
				= (True, [h:t_r], used)
				= (False, l, used)
	replaceIntegers [] input used
		= (False, [], used)

instance replaceIntegers TypeAttribute where
	replaceIntegers (TA_TempVar i) (_, attributes, attr_partition) used
		# index = attr_partition.[i]
		  attribute = attributes.[index]
		= case attribute of
			TA_Var _
				-> (True, attribute, {used & [index] = True})
			_
				-> (True, attribute, used)
	replaceIntegers ta _ used
		= (False, ta, used)

instance replaceIntegers Type where
	replaceIntegers type=:(TA type_symb_ident args) input used
		# (args_m, args_r, used) = replaceIntegers args input used
		| args_m
			= (True, TA type_symb_ident args_r, used)
			= (False, type, used)
	replaceIntegers type=:(TAS type_symb_ident args strictness) input used
		# (args_m, args_r, used) = replaceIntegers args input used
		| args_m
			= (True, TAS type_symb_ident args_r strictness, used)
			= (False, type, used)
	replaceIntegers type=:(a --> b) input used
		# (a_m, a_r, used) = replaceIntegers a input used
		  (b_m, b_r, used) = replaceIntegers b input used
		| a_m
			| b_m
				= (True, a_r --> b_r, used)
				= (True, a_r --> b, used)
			| b_m
				= (True, a --> b_r, used)
				= (False, type, used)
	replaceIntegers (consvar :@: args) input=:(fresh_type_vars, _, _) used
		# (TempCV i) = consvar
		  (_, args, used) = replaceIntegers args input used
		= (True, CV fresh_type_vars.[i] :@: args, used)
	replaceIntegers (TempV i) (fresh_type_vars, _, _) used
		= (True, TV fresh_type_vars.[i], used)
	replaceIntegers type input used
		= (False, type, used)

instance replaceIntegers AType where
	replaceIntegers atype=:{at_attribute, at_type} input used
		# (at_attribute_m, at_attribute_r, used) = replaceIntegers at_attribute input used
		  (at_type_m, at_type_r, used) = replaceIntegers at_type input used
		| at_attribute_m
			| at_type_m
				= (True, {atype & at_attribute = at_attribute_r, at_type = at_type_r}, used)
				= (True, {atype & at_attribute = at_attribute_r}, used)
			| at_type_m
				= (True, {atype & at_type = at_type_r}, used)
				= (False, atype, used)

// Variable binding...

bind_to_fresh_expr_var {fv_ident, fv_info_ptr} var_heap
	# (new_info_ptr, var_heap) = newPtr VI_Empty var_heap
	  form_var = { fv_ident = fv_ident, fv_info_ptr = new_info_ptr, fv_count = undeff, fv_def_level = NotALevel }
	  act_var = { var_ident = fv_ident, var_info_ptr = new_info_ptr, var_expr_ptr = nilPtr }
	= (form_var, writeVarInfo fv_info_ptr (VI_Expression (Var act_var)) var_heap)

remove_VI_Expression_values [{fv_info_ptr}:args] var_heap
	= remove_VI_Expression_values args (writeVarInfo fv_info_ptr VI_Empty var_heap)
remove_VI_Expression_values [] var_heap
	= var_heap 

bind_to_fresh_type_variables type_variables th_vars
	= mapSt bind_to_fresh_type_variable type_variables th_vars
where
	bind_to_fresh_type_variable {tv_ident, tv_info_ptr} th_vars
		# (new_tv_info_ptr, th_vars) = newPtr TVI_Empty th_vars
		  tv = {tv_ident=tv_ident, tv_info_ptr=new_tv_info_ptr}
		= (tv, writePtr tv_info_ptr (TVI_Type (TV tv)) th_vars)

remove_TVI_Type_values [{tv_info_ptr}:type_vars] type_var_heap
	= remove_TVI_Type_values type_vars (writePtr tv_info_ptr TVI_Empty type_var_heap)
remove_TVI_Type_values [] type_var_heap
	= type_var_heap

bind_to_fresh_attr_variable {av_ident, av_info_ptr} th_attrs
	# (new_av_info_ptr, th_attrs) = newPtr AVI_Empty th_attrs
	  av = { av_ident=av_ident, av_info_ptr=new_av_info_ptr }
	= (av, writePtr av_info_ptr (AVI_Attr (TA_Var av)) th_attrs)

remove_AVI_Attr_values [{av_info_ptr}:st_attr_vars] th_attrs
	# th_attrs = writePtr av_info_ptr AVI_Empty th_attrs
	= remove_AVI_Attr_values st_attr_vars th_attrs
remove_AVI_Attr_values [] th_attrs
	= th_attrs

bind_to_temp_type_var {tv_info_ptr} (next_type_var_nr, th_vars)
	= (next_type_var_nr+1, writePtr tv_info_ptr (TVI_Type (TempV next_type_var_nr)) th_vars)

bind_to_temp_attr_vars :: [AttributeVar] *(Int,*AttrVarHeap) -> (!Int,!*AttrVarHeap)
bind_to_temp_attr_vars attr_vars next_attr_var_n_and_attrs
	= foldSt bind_to_temp_attr_var attr_vars next_attr_var_n_and_attrs
where
	bind_to_temp_attr_var {av_info_ptr} (next_attr_var_nr, th_attrs)
		= (next_attr_var_nr+1, writePtr av_info_ptr (AVI_Attr (TA_TempVar next_attr_var_nr)) th_attrs)

remove_TA_TempVars_in_info_ptrs [hAVI_Attr_TA_TempVar_info_ptrs:tAVI_Attr_TA_TempVar_info_ptrs] attrs
	# attrs = remove_TA_TempVars_in_info_ptr_list hAVI_Attr_TA_TempVar_info_ptrs attrs
	= remove_TA_TempVars_in_info_ptrs tAVI_Attr_TA_TempVar_info_ptrs attrs
where
	remove_TA_TempVars_in_info_ptr_list [{av_info_ptr}:tAVI_Attr_TA_TempVar_info_ptrs] attrs
		= case readPtr av_info_ptr attrs of
			(AVI_Attr (TA_TempVar _),attrs)
				// use TA_Multi as in cleanUpTypeAttribute
				# attrs = writePtr av_info_ptr (AVI_Attr TA_Multi) attrs
				-> remove_TA_TempVars_in_info_ptr_list tAVI_Attr_TA_TempVar_info_ptrs attrs
			(_,attrs)
				-> remove_TA_TempVars_in_info_ptr_list tAVI_Attr_TA_TempVar_info_ptrs attrs
	remove_TA_TempVars_in_info_ptr_list [] attrs
		= attrs
remove_TA_TempVars_in_info_ptrs [] attrs
	= attrs

transformFunctionApplication :: !FunDef !InstanceInfo !ConsClasses !App ![Expression] !ReadOnlyTI !*TransformInfo -> *(!Expression,!*TransformInfo)
transformFunctionApplication fun_def instances cc=:{cc_size, cc_args, cc_linear_bits} app=:{app_symb,app_args} extra_args ro ti
	# (app_args, extra_args) = complete_application fun_def.fun_arity app_args extra_args
//	| False ---> ("transformFunctionApplication",app_symb,app_args,extra_args,fun_def.fun_arity,cc_size) = undef
	| expanding_consumer
	 	= (build_application { app & app_args = app_args } extra_args, ti)
	# {fun_body=TransformedBody {tb_rhs}, fun_kind} = fun_def
	| cc_size == 0
		| SwitchTransformConstants (ro.ro_transform_fusion && is_not_caf fun_kind && is_sexy_body tb_rhs) False
			= transform_trivial_function app app_args extra_args ro ti
		= (build_application { app & app_args = app_args } extra_args, ti)
	# (opt_expr,ti) = is_trivial_function app_symb app_args fun_kind tb_rhs ro ti
	| case opt_expr of No -> False; Yes _ -> True
		= case opt_expr of
			Yes (App app)
				-> transformApplication app extra_args ro ti
			Yes rhs
				| isEmpty extra_args
					-> (rhs, ti)
					-> (rhs @ extra_args, ti)
	| cc_size >= 0
		# consumer_properties = fun_def.fun_info.fi_properties
	  	# consumer_is_curried = cc_size <> length app_args
		# non_rec_consumer = consumer_properties bitand FI_IsNonRecursive <> 0
		# safe_args
			= isEmpty [arg \\ arg <- app_args & cc_arg <- cc_args | unsafe cc_arg && non_var arg]
						with
							unsafe CAccumulating			= True
							unsafe CVarOfMultimatchCase		= True
							unsafe _						= False
							
							non_var (Var _)					= False
							non_var _						= True
	  	# ok_non_rec_consumer	= non_rec_consumer && safe_args
	  	#! (producers, new_args, strict_let_binds, ti)
			= determineProducers consumer_properties consumer_is_curried ok_non_rec_consumer fun_def.fun_type cc_linear_bits cc_args app_args 0 (createArray cc_size PR_Empty) ro ti
		#! (arity_changed,new_args,extra_args,producers,cc_args,cc_linear_bits,fun_def,n_extra,ti)
			= determineCurriedProducersInExtraArgs new_args extra_args consumer_properties producers cc_args cc_linear_bits fun_def ro ti
		| containsProducer cc_size producers || arity_changed
	  		# (is_new, fun_def_ptr, instances, ti_fun_heap) = tryToFindInstance producers instances ti.ti_fun_heap
	  		| is_new
				# ti							= update_instance_info app_symb.symb_kind instances { ti & ti_fun_heap = ti_fun_heap }
	  			# (fun_index, fun_arity, ti)	= generateFunction app_symb fun_def cc_args cc_linear_bits producers fun_def_ptr ro n_extra ti
				| fun_index == (-1)
					= (build_application { app & app_args = app_args } extra_args, ti) // ---> ("failed instance")
	  			# app_symb = { app_symb & symb_kind = SK_GeneratedFunction fun_def_ptr fun_index }
				# (app_args, extra_args) = complete_application fun_arity new_args extra_args
	  			
//	  			# (FI_Function {gf_fun_def},ti_fun_heap) = readPtr fun_def_ptr ti.ti_fun_heap
//	  			# ti = {ti & ti_fun_heap = ti_fun_heap} ---> ("generated",fun_def_ptr,gf_fun_def)
	  			
	  			# (expr,ti) = transformApplication { app & app_symb = app_symb, app_args = app_args } extra_args ro ti
	  			= possiblyAddStrictLetBinds expr strict_let_binds ti
			# (FI_Function gf=:{gf_fun_index, gf_fun_def}, ti_fun_heap) = readPtr fun_def_ptr ti_fun_heap
			# ti = {ti & ti_fun_heap = ti_fun_heap}
			| gf_fun_index == (-1)
				= (build_application { app & app_args = app_args } extra_args, ti) // ---> ("known failed instance")
			# app_symb` = { app_symb & symb_kind = SK_GeneratedFunction fun_def_ptr gf_fun_index }
			  (app_args, extra_args) = complete_application gf_fun_def.fun_arity new_args extra_args
			| gf_fun_def.fun_info.fi_properties bitand FI_Unused<>0
				# {fi_properties,fi_calls} = gf_fun_def.fun_info
				  gf & gf_fun_def.fun_info.fi_properties = (fi_properties bitxor FI_Unused) bitor FI_UnusedUsed
				  ti & ti_fun_heap = writePtr fun_def_ptr (FI_Function gf) ti.ti_fun_heap,
					   ti_new_functions = [fun_def_ptr : ti.ti_new_functions]
				  ti = add_unused_calls fi_calls ti
				  (expr,ti) = transformApplication {app & app_symb = app_symb`, app_args = app_args} extra_args ro ti
				= possiblyAddStrictLetBinds expr strict_let_binds ti
				# (expr,ti) = transformApplication {app & app_symb = app_symb`, app_args = app_args} extra_args ro ti
				= possiblyAddStrictLetBinds expr strict_let_binds ti
		| SwitchTrivialFusion ro.ro_transform_fusion False
			= transform_trivial_function app app_args extra_args ro ti
		= (build_application { app & app_args = app_args } extra_args, ti)
	= (build_application { app & app_args = app_args } extra_args, ti)
where
	expanding_consumer = case fun_def.fun_body of
								Expanding _	-> True
								_			-> False

	is_not_caf FK_Caf	= False
	is_not_caf _		= True

	possiblyAddStrictLetBinds expr strict_lets ti
		# (strict_let_binds,let_type) = unzip strict_lets
		= case strict_let_binds of
			[]	-> (expr,ti)
			_
				# (new_info_ptr, ti_symbol_heap) = newPtr (EI_LetType let_type) ti.ti_symbol_heap
				  ti = {ti & ti_symbol_heap = ti_symbol_heap}
				-> (Let 	{	let_strict_binds	= strict_let_binds
							,	let_lazy_binds		= []
							,	let_expr			= expr
							,	let_info_ptr		= new_info_ptr
							,	let_expr_position	= NoPos
							},ti) // ---> "added strict_let_binds"

	transform_trivial_function :: !.App ![.Expression] ![.Expression] !.ReadOnlyTI !*TransformInfo -> *(!Expression,!*TransformInfo)
	transform_trivial_function app=:{app_symb} app_args extra_args ro ti
		# (opt_expr,ti) = is_trivial_function_call app_symb.symb_kind app_args ro ti
		= case opt_expr of
			No
				-> (build_application {app & app_symb = app_symb, app_args = app_args} extra_args, ti)
			Yes tb_rhs=:(App app)
				# (is_cycle,ti) = is_cycle_of_trivial_function_calls app.app_symb.symb_kind app_args [app_symb.symb_kind] ro ti
				| not is_cycle
					-> transformApplication app extra_args ro ti
					| isEmpty extra_args
						-> (tb_rhs, ti)
						-> (tb_rhs @ extra_args, ti)
			Yes tb_rhs
				| isEmpty extra_args
					-> (tb_rhs, ti)
					-> (tb_rhs @ extra_args, ti)

	is_cycle_of_trivial_function_calls :: !SymbKind ![Expression] ![SymbKind] !ReadOnlyTI !*TransformInfo -> *(!Bool,!*TransformInfo)
	is_cycle_of_trivial_function_calls symb_kind app_args previous_function_symb_kinds ro ti
		| not (is_main_module_function_symbol symb_kind ro.ro_main_dcl_module_n)
			= (False,ti)
		| Any (equal_function symb_kind) previous_function_symb_kinds
			= (True,ti)
		# (opt_expr,ti) = is_trivial_function_call symb_kind app_args ro ti
		= case opt_expr of
			Yes (App {app_symb,app_args})
				-> is_cycle_of_trivial_function_calls app_symb.symb_kind app_args [symb_kind:previous_function_symb_kinds] ro ti
			_
				-> (False,ti)
	where
		is_main_module_function_symbol (SK_Function {glob_module})	main_dcl_module_n = glob_module == main_dcl_module_n
		is_main_module_function_symbol (SK_LocalMacroFunction _)	main_dcl_module_n = True
		is_main_module_function_symbol (SK_GeneratedFunction _ _)	main_dcl_module_n = True
		is_main_module_function_symbol _							main_dcl_module_n = False

		equal_function (SK_Function i1) (SK_Function i2) = i1==i2
		equal_function (SK_LocalMacroFunction i1) (SK_LocalMacroFunction i2) = i1==i2
		equal_function (SK_GeneratedFunction _ i1) (SK_GeneratedFunction _ i2) = i1==i2
		equal_function _ _ = False

	is_trivial_function :: !SymbIdent ![Expression] !FunKind !Expression !ReadOnlyTI !*TransformInfo -> *(!Optional Expression,!*TransformInfo)
	is_trivial_function app_symb app_args fun_kind rhs ro ti
		| SwitchTransformConstants (ro.ro_transform_fusion && is_not_caf fun_kind && is_sexy_body rhs) False
			= is_trivial_function_call app_symb.symb_kind app_args ro ti
			= (No, ti)

	is_trivial_function_call :: !SymbKind ![Expression] !ReadOnlyTI !*TransformInfo -> *(!Optional Expression,!*TransformInfo)
	is_trivial_function_call symb_kind app_args ro ti
		# (fun_def,ti_fun_defs,ti_fun_heap) = get_fun_def symb_kind ro.ro_main_dcl_module_n ti.ti_fun_defs ti.ti_fun_heap
		# {fun_body=fun_body=:TransformedBody {tb_args,tb_rhs},fun_type} = fun_def
		# (opt_expr, ti_fun_defs, ti_fun_heap, ti_type_heaps, ti_cons_args)
			= is_trivial_body tb_args tb_rhs app_args fun_type ro ti_fun_defs ti_fun_heap ti.ti_type_heaps ti.ti_cons_args
		# ti & ti_fun_defs = ti_fun_defs, ti_fun_heap = ti_fun_heap, ti_type_heaps = ti_type_heaps, ti_cons_args = ti_cons_args
		= (opt_expr, ti)

	update_instance_info :: !.SymbKind !.InstanceInfo !*TransformInfo -> *TransformInfo
	update_instance_info (SK_Function {glob_object}) instances ti=:{ti_instances}
		 = { ti & ti_instances = { ti_instances & [glob_object] = instances } }
	update_instance_info (SK_LocalMacroFunction glob_object) instances ti=:{ti_instances}
		 = { ti & ti_instances = { ti_instances & [glob_object] = instances } }
	update_instance_info (SK_GeneratedFunction fun_def_ptr fun_index) instances ti=:{ti_fun_heap, ti_instances}
		| fun_index < size ti_instances
			= { ti & ti_instances = { ti_instances & [fun_index] = instances } }
		# (FI_Function fun_info, ti_fun_heap) = readPtr fun_def_ptr ti_fun_heap
		= { ti & ti_fun_heap = ti_fun_heap <:= (fun_def_ptr, FI_Function { fun_info & gf_instance_info = instances })}

	complete_application :: !.Int !.[Expression] !.[Expression] -> (!.[Expression],![Expression])
	complete_application form_arity args extra_args
		= (take form_arity all_args,drop form_arity all_args)
	where
		all_args = args ++ extra_args

	build_application :: !.App ![.Expression] -> Expression
	build_application app []
		= App app
	build_application app extra_args
		= App app @ extra_args

	add_unused_calls [GeneratedFunCall _ fun_def_ptr:calls] ti=:{ti_fun_heap}
		# (FI_Function gf, ti_fun_heap) = readPtr fun_def_ptr ti_fun_heap
		  ti & ti_fun_heap=ti_fun_heap
		  {fi_properties,fi_calls} = gf.gf_fun_def.fun_info
		| fi_properties bitand FI_Unused<>0
			# gf & gf_fun_def.fun_info.fi_properties = (fi_properties bitxor FI_Unused) bitor FI_UnusedUsed
			  ti & ti_fun_heap = writePtr fun_def_ptr (FI_Function gf) ti.ti_fun_heap,
				   ti_new_functions = [fun_def_ptr : ti.ti_new_functions]
			  ti = add_unused_calls fi_calls ti
			= add_unused_calls calls ti
			= add_unused_calls calls ti
	add_unused_calls [_:calls] ti
		= add_unused_calls calls ti
	add_unused_calls [] ti
		= ti

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);

determineCurriedProducersInExtraArgs :: ![Expression] ![Expression] !BITVECT !{!.Producer} ![Int] ![#Bool!] !FunDef !ReadOnlyTI !*TransformInfo
	-> *(!Bool,![Expression],![Expression],!{!Producer},![Int],![#Bool!],!FunDef,!Int,!*TransformInfo)
determineCurriedProducersInExtraArgs new_args [] consumer_properties producers cc_args cc_linear_bits fun_def ro ti
	= (False,new_args,[],producers,cc_args,cc_linear_bits,fun_def,0,ti)
determineCurriedProducersInExtraArgs new_args extra_args consumer_properties producers cc_args cc_linear_bits fun_def ro ti
	| not (SwitchExtraCurriedFusion ro.ro_transform_fusion consumer_properties)
		= (False,new_args,extra_args,producers,cc_args,cc_linear_bits,fun_def,0,ti)
	# n_extra_args													= length extra_args
	# {fun_type = Yes symbol_type=:{st_args,st_result,st_arity}}	= fun_def
	# (ok,new_args_types,new_result_type)							= get_new_args_types_from_result_type st_result n_extra_args
	| not ok
		= (False,new_args,extra_args,producers,cc_args,cc_linear_bits,fun_def,0,ti)
	# symbol_type	= {symbol_type & st_result=new_result_type,st_args=st_args++new_args_types,st_arity=st_arity+n_extra_args}
	# fun_def							= {fun_def & fun_type=Yes symbol_type}
	# (form_args,var_heap)				= create_new_args n_extra_args ti.ti_var_heap
	# ti								= {ti & ti_var_heap=var_heap}
	# fun_def							= case fun_def.fun_body of
											TransformedBody tb
												-> {fun_def & fun_body=TransformedBody 
													{tb & tb_args = add_args_to_fun_args form_args tb.tb_args
													}}
	# new_producers						= arrayPlusList producers [PR_Empty \\ i<-[0..n_extra_args-1]]
	# new_cc_args						= cc_args ++ [CPassive \\ i<-[0..n_extra_args-1]]
	# new_cc_linear_bits				= cc_linear_bits ++$ [#True \\ i<-[0..n_extra_args-1]!]
	= (True,new_args++extra_args,[],new_producers,new_cc_args,new_cc_linear_bits,fun_def,n_extra_args,ti)
where
	get_new_args_types_from_result_type type 0
		= (True,[],type)
	get_new_args_types_from_result_type {at_type=a-->b} n
		# (ok,args_types,result_type) = get_new_args_types_from_result_type b (n-1)
		= (ok,[a:args_types],result_type)
	get_new_args_types_from_result_type type _
		= (False,[],type)

	create_new_args n_new_args var_heap
		| n_new_args==0
			= ([], var_heap)            
		# new_name				= { id_name = "_a", id_info = nilPtr }
		  (info_ptr, var_heap)	= newPtr VI_Empty var_heap
		  form_var				= { fv_ident = new_name, fv_info_ptr = info_ptr, fv_count = 0, fv_def_level = NotALevel }
		  (form_vars,var_heap)	= create_new_args (n_new_args-1) var_heap
		= ([form_var : form_vars],var_heap)

add_args_to_fun_args form_args tb_args
	= tb_args ++ form_args

add_args_to_fun_body act_args new_result_type tb_rhs ro ti
		= add_arguments tb_rhs act_args new_result_type ro ti
where
	add_arguments (App app=:{app_symb,app_args}) extra_args new_result_type ro ti
		# (form_arity,fun_defs,fun_heap) = get_arity app_symb ro ti.ti_fun_defs ti.ti_fun_heap
		# ti = {ti & ti_fun_defs=fun_defs,ti_fun_heap=fun_heap}
		# ar_diff = form_arity - length app_args
		| length extra_args <= ar_diff
			= (App {app & app_args = app_args ++ extra_args }, ti)
			= (App {app & app_args = app_args ++ take ar_diff extra_args } @ drop ar_diff extra_args, ti)
	add_arguments (Case kees=:{case_guards,case_default,case_info_ptr}) extra_args new_result_type ro ti
		# (case_default, ti)	= add_arguments_opt case_default extra_args new_result_type ro ti
		# (case_guards, ti)		= add_arguments_guards case_guards extra_args new_result_type ro ti
		# ti_symbol_heap		= overwrite_result_type case_info_ptr new_result_type ti.ti_symbol_heap
		# ti					= {ti & ti_symbol_heap = ti_symbol_heap}
		= (Case {kees & case_guards = case_guards, case_default = case_default}, ti)
	where
		overwrite_result_type case_info_ptr new_result_type ti_symbol_heap
			#! (EI_CaseType case_type, ti_symbol_heap)	= readExprInfo case_info_ptr ti_symbol_heap
			= writeExprInfo case_info_ptr (EI_CaseType { case_type & ct_result_type = new_result_type}) ti_symbol_heap
	add_arguments (Let lad=:{let_expr}) extra_args new_result_type ro ti
		# (let_expr, ti)		= add_arguments let_expr extra_args new_result_type ro ti
		= (Let {lad & let_expr = let_expr}, ti)
	add_arguments (expr1 @ expr2) extra_args _ ro ti
		= (expr1 @ (expr2++extra_args),ti)
	add_arguments expr extra_args _ ro ti
		= (expr @ extra_args,ti) // ---> ("????",expr)
	
	add_arguments_opt No _ _ ro ti = (No,ti)
	add_arguments_opt (Yes expr) extra_args new_result_type ro ti
		# (expr, ti)	= add_arguments expr extra_args new_result_type ro ti
		= (Yes expr,ti)
	
	add_arguments_guards (AlgebraicPatterns gindex apats) extra_args new_result_type ro ti
		# (apats, ti)	= add_arguments_apats apats extra_args new_result_type ro ti
		= (AlgebraicPatterns gindex apats, ti)
	add_arguments_guards (BasicPatterns btype bpats) extra_args new_result_type ro ti
		# (bpats, ti)	= add_arguments_bpats bpats extra_args new_result_type ro ti
		= (BasicPatterns btype bpats, ti)
	add_arguments_guards (DynamicPatterns dpats) extra_args new_result_type ro ti
		# (dpats, ti)	= add_arguments_dpats dpats extra_args new_result_type ro ti
		= (DynamicPatterns dpats, ti)
	add_arguments_guards (OverloadedListPatterns type decons_expr apats) extra_args new_result_type ro ti
		# (apats, ti)	= add_arguments_apats apats extra_args new_result_type ro ti
		= (OverloadedListPatterns type decons_expr apats, ti)
	add_arguments_guards NoPattern extra_args _ ro ti
		= (NoPattern, ti)
	
	add_arguments_apats [] extra_args _ ro ti = ([],ti)
	add_arguments_apats [ap=:{ap_expr}:aps] extra_args new_result_type ro ti
		# (ap_expr, ti)	= add_arguments ap_expr extra_args new_result_type ro ti
		# (aps, ti)		= add_arguments_apats aps extra_args new_result_type ro ti
		= ([{ap & ap_expr = ap_expr}:aps],ti)

	add_arguments_bpats [] extra_args _ ro ti = ([],ti)
	add_arguments_bpats [bp=:{bp_expr}:bps] extra_args new_result_type ro ti
		# (bp_expr, ti)	= add_arguments bp_expr extra_args new_result_type ro ti
		# (bps, ti)		= add_arguments_bpats bps extra_args new_result_type ro ti
		= ([{bp & bp_expr = bp_expr}:bps],ti)

	add_arguments_dpats [] extra_args _ ro ti = ([],ti)
	add_arguments_dpats [dp=:{dp_rhs}:dps] extra_args new_result_type ro ti
		# (dp_rhs, ti)	= add_arguments dp_rhs extra_args new_result_type ro ti
		# (dps, ti)	= add_arguments_dpats dps extra_args new_result_type ro ti
		= ([{dp & dp_rhs = dp_rhs}:dps],ti)

	get_arity {symb_kind=SK_Function {glob_module, glob_object}} ro fun_defs fun_heap
		| glob_module == ro.ro_main_dcl_module_n
			# (fun_arity, fun_defs) = fun_defs![glob_object].fun_arity
			= (fun_arity, fun_defs, fun_heap)
		# {ft_arity,ft_type} = ro.ro_imported_funs.[glob_module].[glob_object]
		= (ft_arity + length ft_type.st_context, fun_defs, fun_heap)
	get_arity {symb_kind=SK_LocalMacroFunction glob_object} ro fun_defs fun_heap
		# (fun_arity, fun_defs) = fun_defs![glob_object].fun_arity
		= (fun_arity, fun_defs, fun_heap)
	get_arity {symb_kind=SK_GeneratedFunction fun_ptr _} ro fun_defs fun_heap
		# (FI_Function {gf_fun_def={fun_arity}}, fun_heap) = readPtr fun_ptr fun_heap
		= (fun_arity, fun_defs, fun_heap)
	get_arity {symb_kind=SK_Constructor {glob_module, glob_object}} ro fun_defs fun_heap
		# arity = ro.ro_common_defs.[glob_module].com_cons_defs.[glob_object].cons_type.st_arity
		= (arity, fun_defs, fun_heap)

is_trivial_body :: ![FreeVar] !Expression ![Expression] !(Optional SymbolType) !.ReadOnlyTI
							 !*{#FunDef} !*FunctionHeap !*TypeHeaps !*{!ConsClasses}
	-> (!Optional Expression,!*{#FunDef},!*FunctionHeap,!*TypeHeaps,!*{!ConsClasses})
is_trivial_body [fv] (Var bv) [arg] type ro fun_defs fun_heap type_heaps cons_args
	| fv.fv_info_ptr == bv.var_info_ptr
		= (Yes arg, fun_defs, fun_heap, type_heaps, cons_args)
		= (No, fun_defs, fun_heap, type_heaps, cons_args)
is_trivial_body lhs_args (App app) f_args type ro fun_defs fun_heap type_heaps cons_args
	| not (is_safe_producer app.app_symb.symb_kind ro fun_heap cons_args)
		= (No,fun_defs,fun_heap,type_heaps,cons_args)
	# (type`,fun_defs,fun_heap)	= get_producer_type app.app_symb ro fun_defs fun_heap
	  lhs_args_var_ptrs = {!fv_info_ptr \\ {fv_info_ptr} <- lhs_args}
	  n_f_args = length f_args
	  optional_perm = match_args lhs_args app.app_args 0 n_f_args lhs_args_var_ptrs []
	= case optional_perm of
		Yes perm
			# (match, type_heaps) = match_types type type` perm ro.ro_common_defs type_heaps
			| match
				# f_args = permute_args f_args perm n_f_args
				-> (Yes (App {app & app_args = f_args}),fun_defs,fun_heap,type_heaps,cons_args)
				-> (No,fun_defs,fun_heap,type_heaps,cons_args)
		_
			-> (No,fun_defs,fun_heap,type_heaps,cons_args)
where
	match_args :: ![FreeVar] ![Expression] !Int !Int !*{!VarInfoPtr} ![Int] -> Optional [Int]
	match_args [fv:fvs] [Var bv:bvs] arg_n n_f_args lhs_args_var_ptrs reversed_perm
		| arg_n<n_f_args
			# (index,lhs_args_var_ptrs) = lookup_lhs_arg_n 0 bv.var_info_ptr lhs_args_var_ptrs
			| index<n_f_args
				= match_args fvs bvs (arg_n+1) n_f_args lhs_args_var_ptrs [index:reversed_perm]
				= No
		| fv.fv_info_ptr==bv.var_info_ptr 
			= match_args fvs bvs (arg_n+1) n_f_args lhs_args_var_ptrs [arg_n:reversed_perm]
			= No
	match_args [] [] arg_n n_f_args _ reversed_perm
		| arg_n==n_f_args
			= Yes (reverse reversed_perm)
	match_args _ _ _ _ _ _
		= No

	lookup_lhs_arg_n :: !Int !VarInfoPtr !*{!VarInfoPtr} -> (!Int,!*{!VarInfoPtr})
	lookup_lhs_arg_n i x a
		| i<size a
			# ai=a.[i]
			| isNilPtr ai || x<>ai
				= lookup_lhs_arg_n (i+1) x a
				# a & [i] = nilPtr
				= (i,a)
			= (i,a)

	// check if strict values in type are also strict in type`
	match_types :: !(Optional SymbolType) SymbolType ![Int] !{#CommonDefs} !*TypeHeaps -> (!Bool,!*TypeHeaps)
	match_types No type` perm common_defs type_heaps
		= (True,type_heaps)
	match_types (Yes type) type` perm common_defs type_heaps
		| is_not_strict type.st_args_strictness 
			= match_tuple_strictness type.st_result type`.st_result common_defs type_heaps
		| type.st_arity<>type`.st_arity
			= (False,type_heaps)
		# (args_strictness_ok,type_heaps)
			= match_args_strictness 0 type.st_arity type.st_args_strictness type`.st_args_strictness perm type.st_args type`.st_args common_defs type_heaps
		| not args_strictness_ok
			= (False,type_heaps)
			= match_tuple_strictness type.st_result type`.st_result common_defs type_heaps
	where
		match_args_strictness :: !Int !Int !StrictnessList !StrictnessList ![Int] ![AType] ![AType] !{#CommonDefs} !*TypeHeaps -> (!Bool,!*TypeHeaps)
		match_args_strictness arg_n arity s1 s2 perm arg_types1 arg_types2 common_defs type_heaps
			| arg_n<arity
				# lhs_arg_n = perm!!arg_n
				| not (arg_is_strict lhs_arg_n s1)
					= match_args_strictness (arg_n+1) arity s1 s2 perm arg_types1 arg_types2 common_defs type_heaps
				| not (arg_is_strict arg_n s2)
					= (False,type_heaps)
				# (tuple_strictness_ok,type_heaps) = match_tuple_strictness (arg_types1!!lhs_arg_n) (arg_types2!!arg_n) common_defs type_heaps
				| not tuple_strictness_ok
					= (False,type_heaps)
					= match_args_strictness (arg_n+1) arity s1 s2 perm arg_types1 arg_types2 common_defs type_heaps
				= (True,type_heaps)

		match_tuple_strictness :: !AType AType !{#CommonDefs} !*TypeHeaps -> (!Bool,!*TypeHeaps)
		match_tuple_strictness {at_type=TAS _ args1 strictness1} {at_type=TAS _ args2 strictness2} common_defs type_heaps
			| not (more_or_equal_strictness_lists strictness2 strictness1)
				= (False,type_heaps)
				= match_tuple_args_strictness 0 args1 args2 strictness1 strictness2 common_defs type_heaps
		match_tuple_strictness atype1=:{at_type=TAS _ args1 strictness1} {at_attribute,at_type=type2=:TA _ _} common_defs type_heaps
			| is_not_strict strictness1
				= (True,type_heaps)
			# (ok,type2,type_heaps)	= tryToExpand type2 at_attribute common_defs type_heaps
			|  ok
				= match_tuple_strictness atype1 {at_attribute=at_attribute,at_type=type2} common_defs type_heaps
				= (False,type_heaps)
		match_tuple_strictness {at_attribute,at_type=type1=:TA _ _} atype2=:{at_type=TAS _ _ _} common_defs type_heaps
			# (ok,type1,type_heaps)	= tryToExpand type1 at_attribute common_defs type_heaps
			| ok
				= match_tuple_strictness {at_attribute=at_attribute,at_type=type1} atype2 common_defs type_heaps
				= (True,type_heaps)
		match_tuple_strictness {at_attribute,at_type=type1=:TA _ _} atype2=:{at_type=TA _ _} common_defs type_heaps
			# (ok,type1,type_heaps)	= tryToExpand type1 at_attribute common_defs type_heaps
			| ok
				= match_tuple_strictness {at_attribute=at_attribute,at_type=type1} atype2 common_defs type_heaps
				= (True,type_heaps)
		match_tuple_strictness arg_type1 arg_type2 common_defs type_heaps
			= (True,type_heaps)

		match_tuple_args_strictness :: !Int ![AType] ![AType] !StrictnessList !StrictnessList !{#CommonDefs} !*TypeHeaps -> (!Bool,!*TypeHeaps)
		match_tuple_args_strictness arg_n [arg1:args1] [arg2:args2] strictness1 strictness2 common_defs type_heaps
			| not (arg_is_strict arg_n strictness1)
				= match_tuple_args_strictness (arg_n+1) args1 args2 strictness1 strictness2 common_defs type_heaps
			| not (arg_is_strict arg_n strictness2)
				= (False,type_heaps)
			# (tuple_strictness_ok,type_heaps) = match_tuple_strictness arg1 arg2 common_defs type_heaps
			| not tuple_strictness_ok
				= (False,type_heaps)
				= match_tuple_args_strictness (arg_n+1) args1 args2 strictness1 strictness2 common_defs type_heaps
		match_tuple_args_strictness arg_n [] [] strictness1 strictness2 common_defs type_heaps
			= (True,type_heaps)

	permute_args args perm n_f_args
		= [args!!p \\ p <- perm & arg_n<-[0..n_f_args-1]]
is_trivial_body args rhs_expr=:(BasicExpr (BVB _)) f_args type ro fun_defs fun_heap type_heaps cons_args
	| both_nil args f_args || (same_length args f_args && no_strict_args type)
		= (Yes rhs_expr,fun_defs,fun_heap,type_heaps,cons_args)
where
	no_strict_args (Yes type)
		= is_not_strict type.st_args_strictness 
	no_strict_args No
		= True
is_trivial_body args rhs f_args type ro fun_defs fun_heap type_heaps cons_args
	= (No,fun_defs,fun_heap,type_heaps,cons_args)
	
same_length [_:l1] [_:l2] = same_length l1 l2
same_length l1 l2 = both_nil l1 l2

both_nil [] [] = True
both_nil _ _ = False

is_safe_producer (SK_GeneratedFunction fun_ptr _) ro fun_heap cons_args
	# (FI_Function {gf_cons_args={cc_producer}}) = sreadPtr fun_ptr fun_heap
	= cc_producer
is_safe_producer (SK_LocalMacroFunction glob_object) ro fun_heap cons_args
	= cons_args.[glob_object].cc_producer
is_safe_producer (SK_Function {glob_module, glob_object}) ro fun_heap cons_args
	# max_index = size cons_args
	| glob_module <> ro.ro_main_dcl_module_n || glob_object >= max_index
		= False
		= cons_args.[glob_object].cc_producer
is_safe_producer (SK_Constructor {glob_module}) ro fun_heap cons_args
	= SwitchConstructorFusion True True/*(glob_module==ro.ro_StdGeneric_module_n)*/ False

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}
	| is_SK_Function_or_SK_LocalMacroFunction symb_kind // otherwise GOTO next alternative	
		# gi
			= case symb_kind of
				SK_Function global_index -> global_index
				SK_LocalMacroFunction index -> { glob_module = ro.ro_main_dcl_module_n, glob_object = index }
		# { glob_module, glob_object } = gi
		| glob_module == ro.ro_main_dcl_module_n
			| glob_object < size ti_cons_args
				#  (cons_class,ti_cons_args) = ti_cons_args![glob_object]
				   (instances, ti_instances) = ti_instances![glob_object]
				   (fun_def, ti_fun_defs) = ti_fun_defs![glob_object]
				   ti = { ti & ti_instances = ti_instances, ti_fun_defs = ti_fun_defs, ti_cons_args = ti_cons_args }
				= transformFunctionApplication fun_def instances cons_class app extra_args ro ti
			// It seems as if we have an array function 
				| isEmpty extra_args
					= (App app, ti)
					= (App { app & app_args = app_args ++ extra_args}, ti)

		| glob_module==ro.ro_StdStrictLists_module_n && is_cons_or_decons_of_UList_or_UTSList glob_object glob_module ro.ro_imported_funs && (not (isEmpty app_args))
//			&& True ---> ("transformApplication "+++toString symb.symb_ident)
			# {ft_type} = ro.ro_imported_funs.[glob_module].[glob_object] // type of cons instance of instance List [#] a | U(TS)List a
			# [{tc_class=TCClass {glob_module,glob_object={ds_index}}}:_] = ft_type.st_context			
			# member_n=find_member_n 0 symb.symb_ident.id_name ro.ro_common_defs.[glob_module].com_class_defs.[ds_index].class_members
			# cons_u_member_index=ro.ro_common_defs.[glob_module].com_class_defs.[ds_index].class_members.[member_n].ds_index
			# {me_ident,me_offset}=ro.ro_common_defs.[glob_module].com_member_defs.[cons_u_member_index]
			# select_symb= {glob_module=glob_module,glob_object={ds_ident=me_ident,ds_index=cons_u_member_index,ds_arity=1}}
			# [first_arg:other_app_args] = app_args;
			# args=other_app_args++extra_args
			| isEmpty args
				= select_member first_arg select_symb me_offset ti
				# (expr,ti) = select_member first_arg select_symb me_offset ti
				= case expr of
					App app
						-> transformApplication app args ro ti
					_
						-> (expr @ args,ti)
		// This function is imported
		| SwitchSpecialFusion
				(not (isEmpty app_args) )
				False
			// Check imported overloaded function application for specials...
			# {ft_specials}						= ro.ro_imported_funs.[glob_module].[glob_object]
			# specials							= case ft_specials of
													FSP_ContextTypes s	-> s
													_ -> []
			| not (isEmpty specials)
				# (ei,ti_symbol_heap)			= mapSt readAppInfo app_args ti.ti_symbol_heap
					with
						readAppInfo :: !Expression !*ExpressionHeap -> (!ExprInfo,!*ExpressionHeap)
						readAppInfo (App {app_info_ptr}) heap
							| isNilPtr app_info_ptr
								= (EI_Empty,heap)
							= readPtr app_info_ptr heap
						readAppInfo _ heap = (EI_Empty,heap)
				# ti							= {ti & ti_symbol_heap = ti_symbol_heap}
				# context						= ro.ro_imported_funs.[glob_module].[glob_object].ft_type.st_context
				# insts							= resolveContext context ei
				# (num_special_args,special_gi)	= findInstInSpecials insts specials
				| foundSpecial special_gi
					= build_application {app & app_symb.symb_kind = SK_Function special_gi} (drop num_special_args app_args) extra_args special_gi ti
				= build_application app app_args extra_args gi ti
			= build_application app app_args extra_args gi ti
		= build_application app app_args extra_args gi ti
	where
		build_application :: !.App ![.Expression] ![.Expression] !(Global .Int) !*TransformInfo -> (!Expression,!*TransformInfo)
		build_application app app_args extra_args {glob_module,glob_object} ti
			| isEmpty extra_args
				= (App {app & app_args = app_args}, ti)
			# {ft_arity,ft_type}	= ro.ro_imported_funs.[glob_module].[glob_object]
			  form_arity			= ft_arity + length ft_type.st_context
			  ar_diff				= form_arity - length app_args
			  nr_of_extra_args		= length extra_args
			| nr_of_extra_args <= ar_diff
				= (App {app  &  app_args = app_args ++ extra_args }, ti)
				= (App {app  &  app_args = app_args ++ take ar_diff extra_args } @ drop ar_diff extra_args, ti)
/*		
		build_special_application app app_args extra_args {glob_module,glob_object} ro ti
			| isEmpty extra_args
				= (App {app & app_args = app_args}, ti)
			# {ft_arity,ft_type} = ro.ro_imported_funs.[glob_module].[glob_object]
			  form_arity = ft_arity + length ft_type.st_context
			  ar_diff = form_arity - length app_args
			  nr_of_extra_args = length extra_args
			| nr_of_extra_args <= ar_diff
				= (App {app  &  app_args = app_args ++ extra_args }, ti)
				= (App {app  &  app_args = app_args ++ take ar_diff extra_args } @ drop ar_diff extra_args, ti)
*/
		find_member_n :: !Int !String !{#.DefinedSymbol} -> Int
		find_member_n i member_string a
			| i<size a
				| a.[i].ds_ident.id_name % (0,size member_string-1)==member_string
					= i
					= find_member_n (i+1) member_string a

		select_member :: !.Expression !(Global .DefinedSymbol) !.Int !*TransformInfo -> *(!Expression,!*TransformInfo)
		select_member exp=:(App {app_symb={symb_kind=SK_Constructor _},app_args,app_info_ptr}) select_symb me_offset ti=:{ti_symbol_heap}
			| not (isNilPtr app_info_ptr)
				# (ei,ti_symbol_heap)	= readPtr app_info_ptr ti_symbol_heap
				# ti = {ti & ti_symbol_heap = ti_symbol_heap}
				= case ei of
					(EI_DictionaryType _)	-> (app_args !! me_offset,ti)
					_						-> (Selection NormalSelector exp [RecordSelection select_symb me_offset],ti)
		select_member exp select_symb me_offset ti
			= (Selection NormalSelector exp [RecordSelection select_symb me_offset],ti)

// XXX linear_bits field has to be added for generated functions
transformApplication app=:{app_symb={symb_ident,symb_kind = SK_GeneratedFunction fun_def_ptr fun_index}} extra_args
			ro ti=:{ti_cons_args,ti_instances,ti_fun_defs,ti_fun_heap}
	| fun_index < size ti_cons_args
		#  (cons_class, ti_cons_args) = ti_cons_args![fun_index]
		   (instances, ti_instances) = ti_instances![fun_index]
		   (fun_def, ti_fun_defs) = ti_fun_defs![fun_index]
		   ti = { ti & ti_instances = ti_instances, ti_fun_defs = ti_fun_defs, ti_cons_args = ti_cons_args }
		= transformFunctionApplication fun_def instances cons_class app extra_args ro ti
	# (FI_Function {gf_fun_def,gf_instance_info,gf_cons_args}, ti_fun_heap) = readPtr fun_def_ptr ti_fun_heap
	  ti = { ti & ti_fun_heap = ti_fun_heap }
	= transformFunctionApplication gf_fun_def gf_instance_info gf_cons_args app extra_args ro ti
transformApplication app [] ro ti
	= (App app, ti)
transformApplication app=:{app_symb={symb_ident,symb_kind = SK_Constructor cons_index},app_args} extra_args
			ro ti=:{ti_cons_args,ti_instances,ti_fun_defs,ti_fun_heap}
	# {cons_type}			= ro.ro_common_defs.[cons_index.glob_module].com_cons_defs.[cons_index.glob_object]
	# (app_args,extra_args)	= complete_application cons_type.st_arity app_args extra_args
	= (build_application { app & app_args = app_args } extra_args, ti)
where
	complete_application :: !.Int ![Expression] ![Expression] -> (![Expression],![Expression])
	complete_application form_arity args []
		= (args, [])
	complete_application form_arity args extra_args
		# arity_diff = min (form_arity - length args) (length extra_args)
		= (args ++ take arity_diff extra_args, drop arity_diff extra_args)

	build_application :: !.App ![.Expression] -> Expression
	build_application app []
		= App app
	build_application app extra_args
		= App app @ extra_args
transformApplication app extra_args ro ti
	= (App app @ extra_args, ti)

transformSelection :: SelectorKind [Selection] Expression ReadOnlyTI *TransformInfo -> (!Expression,!*TransformInfo)
transformSelection NormalSelector s=:[RecordSelection _ field_index : selectors] 
					app=:(App appi=:{app_symb={symb_kind= SK_Constructor _ }, app_args, app_info_ptr})
					ro ti=:{ti_symbol_heap}
	| isNilPtr app_info_ptr
		// urgh: now reevaluates cnf for each nested strict selector :-(
		| cnf_app_args appi ro
			= transformSelection NormalSelector selectors (app_args !! field_index) ro ti
			= transform_remaining_selectors_of_normal_record_selector s app ro ti
	# (app_info, ti_symbol_heap) = readPtr app_info_ptr ti_symbol_heap
	  ti = { ti & ti_symbol_heap = ti_symbol_heap }
	= case app_info of
		EI_DictionaryType _
			-> transformSelection NormalSelector selectors (app_args !! field_index) ro ti
		_
			// urgh: now reevaluates cnf for each nested strict selector :-(
			| cnf_app_args appi ro
				-> transformSelection NormalSelector selectors (app_args !! field_index) ro ti
			-> transform_remaining_selectors_of_normal_record_selector s app ro ti
where
	cnf_args [] index strictness ro = True
	cnf_args [arg:args] index strictness ro
		| arg_is_strict index strictness
			= case arg of
				BasicExpr _	-> cnf_args args (inc index) strictness ro
				App app		-> cnf_app_args app ro
				_			-> False
		= cnf_args args (inc index) strictness ro
	
	cnf_app_args {app_symb=symb=:{symb_kind = SK_Constructor cons_index, symb_ident}, app_args} ro
		# {cons_type}		= ro.ro_common_defs.[cons_index.glob_module].com_cons_defs.[cons_index.glob_object]
		= cnf_args app_args 0 cons_type.st_args_strictness ro
	cnf_app_args {app_symb=symb=:{symb_kind}, app_args} ro
		= False
transformSelection NormalSelector s=:[RecordSelection _ field_index : selectors] 
					app=:(App appi=:{app_symb=app_symb=:{symb_kind}, app_args, app_info_ptr})
					ro ti
	| isOKSymbol symb_kind && isEmpty app_args
		# (fun_def,ti_fun_defs,ti_fun_heap)		= get_fun_def symb_kind ro.ro_main_dcl_module_n ti.ti_fun_defs ti.ti_fun_heap
		# ti = {ti & ti_fun_defs = ti_fun_defs, ti_fun_heap = ti_fun_heap}
		# {fun_body,fun_type,fun_kind}			= fun_def
		| is_not_caf fun_kind
			= case fun_body of
				TransformedBody {tb_rhs}	-> case tb_rhs of
					App app						-> transformSelection NormalSelector s tb_rhs ro ti
					_							-> transform_remaining_selectors_of_normal_record_selector s app ro ti
			= transform_remaining_selectors_of_normal_record_selector s app ro ti
where
	isOKSymbol (SK_Function {glob_module})	= glob_module == ro.ro_main_dcl_module_n
	isOKSymbol (SK_LocalMacroFunction _)	= True
	isOKSymbol (SK_GeneratedFunction _ _)	= True
	isOKSymbol _							= False
	
	is_not_caf FK_Caf	= False
	is_not_caf _		= True
transformSelection NormalSelector [] expr ro ti
	= (expr, ti)
transformSelection selector_kind selectors expr ro ti
	# (selectors,ti) = transform_expressions_in_selectors selectors ro ti
	= (Selection selector_kind expr selectors, ti)

transform_remaining_selectors_of_normal_record_selector :: ![Selection] !Expression ReadOnlyTI *TransformInfo -> (!Expression,!*TransformInfo)
transform_remaining_selectors_of_normal_record_selector selectors=:[record_selector] app ro ti
	= (Selection NormalSelector app selectors, ti)
transform_remaining_selectors_of_normal_record_selector [record_selector:remaining_selectors] app ro ti
	# (remaining_selectors,ti) = transform_expressions_in_selectors remaining_selectors ro ti
	= (Selection NormalSelector app [record_selector:remaining_selectors], ti)

//@	determineProducers: finds all legal producers in the argument list.
// This version finds FIRST legal producer in argument list...

// XXX store linear_bits and cc_args together ?

determineProducers :: !BITVECT !Bool !Bool !(Optional SymbolType) ![#Bool!] ![Int] ![Expression] !Int *{!Producer} !ReadOnlyTI !*TransformInfo
	-> *(!*{!Producer},![Expression],![(LetBind,AType)],!*TransformInfo)
determineProducers _ _ _ _ _ _ [] _ producers _ ti
	= (producers, [], [], ti)
determineProducers consumer_properties consumer_is_curried ok_non_rec_consumer consumer_type [#linear_bit : linear_bits!] [cons_arg : cons_args] [arg : args] prod_index producers ro ti
 	| cons_arg == CActive
		# (producers, new_arg, ti) = determine_producer consumer_properties consumer_is_curried ok_non_rec_consumer linear_bit arg [] prod_index producers ro ti
		| isProducer producers.[prod_index]
			= (producers, new_arg++args, [], ti)
		| not ro.ro_transform_fusion || consumer_properties bitand FI_GenericFun==0
			#! (producers, new_args, lb, ti)
				= determineProducers consumer_properties consumer_is_curried ok_non_rec_consumer consumer_type linear_bits cons_args args (inc prod_index) producers ro ti
			= (producers, new_arg++new_args, lb, ti)
			= case arg of
				BasicExpr (BVS s)
					# producers & [prod_index] = PR_String s
					-> (producers, args, [], ti)
				BasicExpr (BVInt i)
					# producers & [prod_index] = PR_Int i
					-> (producers, args, [], ti)
				_
					#! (producers, new_args, lb, ti) = determineProducers consumer_properties consumer_is_curried ok_non_rec_consumer consumer_type linear_bits cons_args args (inc prod_index) producers ro ti
					-> (producers, new_arg++new_args, lb, ti)
	| not ro.ro_transform_fusion
		#! (producers, new_args, lb, ti)
			= determineProducers consumer_properties consumer_is_curried ok_non_rec_consumer consumer_type linear_bits cons_args args (inc prod_index) producers ro ti
		= (producers, [arg : new_args], lb, ti)
	| SwitchUnusedFusion (cons_arg == CUnusedStrict && isStrictArg consumer_type prod_index) False
		# producers = { producers & [prod_index] = PR_Unused }
		# (lb,ti) = case isStrictVarOrSimpleExpression arg of
						True	-> ([],ti)
						_		# (info_ptr, ti_var_heap)	= newPtr VI_Empty ti.ti_var_heap
								  ti						= {ti & ti_var_heap = ti_var_heap}
								  lb =	{lb_dst=
								  			{ fv_ident = { id_name = "dummy_for_strict_unused", id_info = nilPtr }
								  			, fv_info_ptr = info_ptr
								  			, fv_count = 0
								  			, fv_def_level = NotALevel 
								  			}
								  		,lb_src=arg
								  		,lb_position=NoPos
								  		}
								-> ([(lb,getArgType consumer_type prod_index)],ti)
		  
		= (producers, args, lb, ti)	 // ---> ("UnusedStrict",lb,arg,fun_type)
	| SwitchUnusedFusion (cons_arg == CUnusedStrict && not (isStrictArg consumer_type prod_index) && isStrictVar arg) False
		# producers = { producers & [prod_index] = PR_Unused }
		= determineUnusedProducersInNextArgs cons_args args (prod_index+1) producers ro ti
	| SwitchUnusedFusion (cons_arg == CUnusedLazy) False
		# producers = { producers & [prod_index] = PR_Unused }
		= determineUnusedProducersInNextArgs cons_args args (prod_index+1) producers ro ti
		= case arg of
			App {app_symb=symb=:{symb_kind=SK_Function {glob_module,glob_object}},app_args=[]}
				| glob_module==ro.ro_main_dcl_module_n
					# ({fun_arity,fun_info,fun_type},ti) = ti!ti_fun_defs.[glob_object]
					| fun_arity>0
						| fun_info.fi_properties bitand FI_IsNonRecursive<>0 && consumer_properties bitand FI_GenericFun<>0
							# producers & [prod_index] = PR_Curried symb 0
							-> (producers, args, [], ti)
						# arg_n = find_same_SK_Function_arg args glob_module glob_object (prod_index+1)
						| arg_n>=0 && is_monomorphic_symbol_type fun_type
							# producers & [prod_index] = PR_Equal arg_n, [arg_n] = PR_EqualRemove prod_index
							-> (producers, [arg:remove_arg_n (arg_n-prod_index-1) args], [], ti)
							-> determineProducersInNextArgs consumer_properties consumer_is_curried ok_non_rec_consumer consumer_type linear_bits cons_args arg args prod_index producers ro ti
						-> determineProducersInNextArgs consumer_properties consumer_is_curried ok_non_rec_consumer consumer_type linear_bits cons_args arg args prod_index producers ro ti
				# {st_arity,st_context} = ro.ro_imported_funs.[glob_module].[glob_object].ft_type
				| (st_arity>0 || not (isEmpty st_context)) && consumer_properties bitand FI_GenericFun<>0
					# producers & [prod_index] = PR_Curried symb 0
					-> (producers, args, [], ti)
					-> determineProducersInNextArgs consumer_properties consumer_is_curried ok_non_rec_consumer consumer_type linear_bits cons_args arg args prod_index producers ro ti
			App {app_symb=symb=:{symb_kind=SK_LocalMacroFunction fun_index},app_args=[]}
				# ({fun_arity,fun_info,fun_type},ti) = ti!ti_fun_defs.[fun_index]
				| fun_arity>0
					| fun_info.fi_properties bitand FI_IsNonRecursive<>0 && consumer_properties bitand FI_GenericFun<>0
						# producers & [prod_index] = PR_Curried symb 0
						-> (producers, args, [], ti)
					# arg_n = find_same_SK_LocalMacroFunction_arg args fun_index (prod_index+1)
					| arg_n>=0 && is_monomorphic_symbol_type fun_type
						# producers & [prod_index] = PR_Equal arg_n, [arg_n] = PR_EqualRemove prod_index
						-> (producers, [arg:remove_arg_n (arg_n-prod_index-1) args], [], ti)
						-> determineProducersInNextArgs consumer_properties consumer_is_curried ok_non_rec_consumer consumer_type linear_bits cons_args arg args prod_index producers ro ti
					-> determineProducersInNextArgs consumer_properties consumer_is_curried ok_non_rec_consumer consumer_type linear_bits cons_args arg args prod_index producers ro ti
			App {app_symb=symb=:{symb_kind=SK_GeneratedFunction fun_ptr fun_index},app_args=[]}
				# (FI_Function {gf_fun_def={fun_arity,fun_info,fun_type}},fun_heap) = readPtr fun_ptr ti.ti_fun_heap
				  ti & ti_fun_heap = fun_heap
				| fun_arity>0
					| fun_info.fi_properties bitand FI_IsNonRecursive<>0 && consumer_properties bitand FI_GenericFun<>0
						# producers & [prod_index] = PR_Curried symb 0
						-> (producers, args, [], ti)
					# arg_n = find_same_SK_GeneratedFunction_arg args fun_index (prod_index+1)
					| arg_n>=0 && is_monomorphic_symbol_type fun_type
						# producers & [prod_index] = PR_Equal arg_n, [arg_n] = PR_EqualRemove prod_index
						-> (producers, [arg:remove_arg_n (arg_n-prod_index-1) args], [], ti)
						-> determineProducersInNextArgs consumer_properties consumer_is_curried ok_non_rec_consumer consumer_type linear_bits cons_args arg args prod_index producers ro ti
					-> determineProducersInNextArgs consumer_properties consumer_is_curried ok_non_rec_consumer consumer_type linear_bits cons_args arg args prod_index producers ro ti
			Var {var_info_ptr}
				| not (cons_arg==CUnusedStrict || cons_arg==CUnusedLazy)
					# arg_n = find_same_Var args var_info_ptr (prod_index+1)
					| arg_n>=0
						# (arg_type1,arg_type2) = get2ArgTypes consumer_type prod_index arg_n
						| equal_non_unique_atype arg_type1 arg_type2
							# producers & [prod_index] = PR_Equal arg_n, [arg_n] = PR_EqualRemove prod_index
							-> (producers, [arg:remove_arg_n (arg_n-prod_index-1) args], [], ti)
							-> determineProducersInNextArgs consumer_properties consumer_is_curried ok_non_rec_consumer consumer_type linear_bits cons_args arg args prod_index producers ro ti
						-> determineProducersInNextArgs consumer_properties consumer_is_curried ok_non_rec_consumer consumer_type linear_bits cons_args arg args prod_index producers ro ti
			BasicExpr (BVS s)
				| consumer_properties bitand FI_GenericFun<>0
					# producers & [prod_index] = PR_String s
					-> (producers, args, [], ti)
			BasicExpr (BVInt i)
				| consumer_properties bitand FI_GenericFun<>0
					# producers & [prod_index] = PR_Int i
					-> (producers, args, [], ti)
			_
				-> determineProducersInNextArgs consumer_properties consumer_is_curried ok_non_rec_consumer consumer_type linear_bits cons_args arg args prod_index producers ro ti
where
	determineProducersInNextArgs consumer_properties consumer_is_curried ok_non_rec_consumer consumer_type linear_bits cons_args arg args prod_index producers ro ti
		#! (producers, new_args, lb, ti)
			= determineProducers consumer_properties consumer_is_curried ok_non_rec_consumer consumer_type linear_bits cons_args args (inc prod_index) producers ro ti
		= (producers, [arg : new_args], lb, ti)

	determineUnusedProducersInNextArgs [cons_arg : cons_args] arg_and_args=:[arg : args] prod_index producers ro ti
		| SwitchUnusedFusion (cons_arg == CUnusedStrict && isStrictArg consumer_type prod_index) False
			# producers & [prod_index] = PR_Unused
			# (lb,ti) = case isStrictVarOrSimpleExpression arg of
							True	-> ([],ti)
							_		# (info_ptr, ti_var_heap) = newPtr VI_Empty ti.ti_var_heap
									  ti & ti_var_heap = ti_var_heap
									  lb =	{lb_dst=
									  			{ fv_ident = { id_name = "dummy_for_strict_unused", id_info = nilPtr }
									  			, fv_info_ptr = info_ptr, fv_count = 0, fv_def_level = NotALevel }
									  		,lb_src=arg, lb_position=NoPos }
									-> ([(lb,getArgType consumer_type prod_index)],ti)
			= (producers, args, lb, ti)	 // ---> ("UnusedStrict",lb,arg,fun_type)
		| SwitchUnusedFusion (cons_arg == CUnusedStrict && not (isStrictArg consumer_type prod_index) && isStrictVar arg) False
			# producers & [prod_index] = PR_Unused
			= determineUnusedProducersInNextArgs cons_args args (prod_index+1) producers ro ti
		| SwitchUnusedFusion (cons_arg == CUnusedLazy) False
			# producers & [prod_index] = PR_Unused
			= determineUnusedProducersInNextArgs cons_args args (prod_index+1) producers ro ti
			= (producers, arg_and_args, [], ti)
	determineUnusedProducersInNextArgs _ [] prod_index producers ro ti
		= (producers, [], [], ti)

	isProducer PR_Empty	= False
	isProducer _		= True
	
	isStrictArg No _ = False
	isStrictArg (Yes {st_args_strictness}) index = arg_is_strict index st_args_strictness

	getArgType (Yes {st_args}) index = st_args!!index

	isStrictVar (Var bv) = not (isEmpty [fv \\ fv <- ro.ro_tfi.tfi_vars | fv.fv_info_ptr == bv.var_info_ptr])
	isStrictVar _ = False

	isStrictVarOrSimpleExpression (Var bv)
		= not (isEmpty [fv \\ fv <- ro.ro_tfi.tfi_vars | fv.fv_info_ptr == bv.var_info_ptr])
	isStrictVarOrSimpleExpression (App {app_symb={symb_kind=SK_Constructor _},app_args=[]})
		= True
	isStrictVarOrSimpleExpression (BasicExpr _)
		= True
	isStrictVarOrSimpleExpression _
		= False

	determine_producer consumer_properties consumer_is_curried ok_non_rec_consumer linear_bit arg=:(App app=:{app_info_ptr}) new_args prod_index producers ro ti
		| isNilPtr app_info_ptr
			= determineProducer app EI_Empty consumer_properties consumer_is_curried ok_non_rec_consumer linear_bit new_args prod_index producers ro ti
		# (app_info, ti_symbol_heap) = readPtr app_info_ptr ti.ti_symbol_heap
		# ti = { ti & ti_symbol_heap = ti_symbol_heap }
		= determineProducer app app_info consumer_properties consumer_is_curried ok_non_rec_consumer linear_bit new_args prod_index producers ro ti
	determine_producer _ _ _ _ arg new_args _ producers _ ti
		= (producers, [arg : new_args], ti)

	find_same_SK_Function_arg :: ![Expression] !Int !Int !Int -> Int
	find_same_SK_Function_arg [App {app_symb={symb_kind=SK_Function {glob_module,glob_object}},app_args=[]}:args] fun_module fun_index arg_n
		| glob_module==fun_module && glob_object==fun_index
			= arg_n
			= find_same_SK_Function_arg args fun_module fun_index (arg_n+1)
	find_same_SK_Function_arg [arg:args] fun_module fun_index arg_n
		= find_same_SK_Function_arg args fun_module fun_index (arg_n+1)
	find_same_SK_Function_arg [] fun_module fun_index arg_n
		= -1

	find_same_SK_LocalMacroFunction_arg :: ![Expression] !Int !Int -> Int
	find_same_SK_LocalMacroFunction_arg [App {app_symb={symb_kind=SK_LocalMacroFunction arg_fun_index},app_args=[]}:args] fun_index arg_n
		| arg_fun_index==fun_index
			= arg_n
			= find_same_SK_LocalMacroFunction_arg args fun_index (arg_n+1)
	find_same_SK_LocalMacroFunction_arg [arg:args] fun_index arg_n
		= find_same_SK_LocalMacroFunction_arg args fun_index (arg_n+1)
	find_same_SK_LocalMacroFunction_arg [] fun_index arg_n
		= -1

	find_same_SK_GeneratedFunction_arg :: ![Expression] !Int !Int -> Int
	find_same_SK_GeneratedFunction_arg [App {app_symb={symb_kind=SK_GeneratedFunction fun_ptr arg_fun_index},app_args=[]}:args] fun_index arg_n
		| arg_fun_index==fun_index
			= arg_n
			= find_same_SK_GeneratedFunction_arg args fun_index (arg_n+1)
	find_same_SK_GeneratedFunction_arg [arg:args] fun_index arg_n
		= find_same_SK_GeneratedFunction_arg args fun_index (arg_n+1)
	find_same_SK_GeneratedFunction_arg [] fun_index arg_n
		= -1

	remove_arg_n 0 [_:args] = args
	remove_arg_n n [arg:args] = [arg : remove_arg_n (n-1) args]

	is_monomorphic_symbol_type (Yes {st_vars=[],st_attr_vars=[]})
		= True
	is_monomorphic_symbol_type No
		= False

	find_same_Var :: ![Expression] !VarInfoPtr !Int -> Int	
	find_same_Var [Var var:args] var_info_ptr arg_n
		| var.var_info_ptr==var_info_ptr
			= arg_n
			= find_same_Var args var_info_ptr (arg_n+1)
	find_same_Var [arg:args] var_info_ptr arg_n
		= find_same_Var args var_info_ptr (arg_n+1)
	find_same_Var [] var_info_ptr arg_n
		= -1

	get2ArgTypes :: !(Optional SymbolType) !Int !Int -> (!AType,!AType)
	get2ArgTypes (Yes {st_args}) arg_n1 arg_n2
		# (arg1_type,arg_types) = get_arg_type 0 arg_n1 st_args
		# (arg2_type,_ ) = get_arg_type (arg_n1+1) arg_n2 arg_types
		= (arg1_type,arg2_type)
	where
		get_arg_type arg_i arg_n [arg_type:arg_types]
			| arg_i<arg_n
				= get_arg_type (arg_i+1) arg_n arg_types
				= (arg_type,arg_types)

	equal_non_unique_atype :: !AType !AType -> Bool 
	equal_non_unique_atype {at_attribute=TA_Multi,at_type=type1} {at_attribute=TA_Multi,at_type=type2}
		= equal_non_unique_type type1 type2
	equal_non_unique_atype {at_attribute=TA_None,at_type=type1} {at_attribute=TA_None,at_type=type2}
		= equal_non_unique_type type1 type2
	equal_non_unique_atype {at_attribute=TA_Var {av_info_ptr=av_info_ptr1},at_type=type1} {at_attribute=TA_Var {av_info_ptr=av_info_ptr2},at_type=type2}
		= av_info_ptr1==av_info_ptr2 && equal_non_unique_type type1 type2
	equal_non_unique_atype type1 type2
		= False

	equal_non_unique_type :: !Type !Type -> Bool 
	equal_non_unique_type (TA {type_index=type_index1} atypes1) (TA {type_index=type_index2} atypes2)
		= type_index1==type_index2 && equal_non_unique_atypes atypes1 atypes2
	equal_non_unique_type (TAS {type_index=type_index1} atypes1 strictness1) (TAS {type_index=type_index2} atypes2 strictness2)
		= type_index1==type_index2 && equal_strictness_lists strictness1 strictness2 && equal_non_unique_atypes atypes1 atypes2
	equal_non_unique_type (a_atype1-->r_atype1) (a_atype2-->r_atype2)
		= equal_non_unique_atype a_atype1 a_atype2 && equal_non_unique_atype r_atype1 r_atype2
	equal_non_unique_type (TB BT_Int) (TB BT_Int)
		= True
	equal_non_unique_type (TB BT_Char) (TB BT_Char)
		= True
	equal_non_unique_type (TB BT_Bool) (TB BT_Bool)
		= True
	equal_non_unique_type (TB BT_Real) (TB BT_Real)
		= True
	equal_non_unique_type (TV {tv_info_ptr=tv_info_ptr1}) (TV {tv_info_ptr=tv_info_ptr2})
		= tv_info_ptr1==tv_info_ptr2
	equal_non_unique_type _ _
		= False

	equal_non_unique_atypes [atype1:atypes1] [atype2:atypes2] = equal_non_unique_atype atype1 atype2 && equal_non_unique_atypes atypes1 atypes2
	equal_non_unique_atypes [] [] = True
	equal_non_unique_atypes _ _ = False

determineProducer :: App ExprInfo BITVECT Bool Bool Bool [Expression] Int *{!Producer} ReadOnlyTI *TransformInfo
	-> *(!*{!Producer},![Expression],!*TransformInfo)
determineProducer app=:{app_symb = symb=:{symb_kind = SK_Constructor _}, app_args} (EI_DictionaryType type) _ _ _ _
				  new_args prod_index producers _ ti=:{ti_var_heap,ti_predef_symbols}
	# (normalise_symbol,ti_predef_symbols) = ti_predef_symbols![PD_Dyn_normalise]
	# (app_args, (new_vars_and_types, free_vars, ti_var_heap))
			= renewVariables app_args normalise_symbol ti_var_heap
	# prod	= PR_Class { app & app_args = app_args } new_vars_and_types type
	= ( {producers & [prod_index] = prod}
	  , free_vars++new_args
	  , {ti & ti_var_heap=ti_var_heap, ti_predef_symbols=ti_predef_symbols}
	  )
determineProducer app=:{app_symb = symb=:{symb_kind = SK_Constructor cons_index, symb_ident}, app_args} _ consumer_properties _ _ linear_bit
				  new_args prod_index producers ro ti
	# {cons_type}								= ro.ro_common_defs.[cons_index.glob_module].com_cons_defs.[cons_index.glob_object]
	  rnf										= rnf_args app_args 0 cons_type.st_args_strictness ro
	| SwitchConstructorFusion
		(ro.ro_transform_fusion && SwitchRnfConstructorFusion (linear_bit || rnf) linear_bit)
		(ro.ro_transform_fusion && (cons_index.glob_module==ro.ro_StdGeneric_module_n || consumer_properties bitand FI_GenericFun<>0)
								&& (linear_bit || rnf))
		False
		# producers = {producers & [prod_index] = PR_Constructor symb (length app_args) app_args }
		= (producers, app_args ++ new_args, ti)
	= ( producers, [App app : new_args ], ti)
where
	rnf_args [] index strictness ro
		= True
	rnf_args [arg:args] index strictness ro
		| arg_is_strict index strictness
			= case arg of
				BasicExpr _	-> rnf_args args (inc index) strictness ro
				App app		-> rnf_app_args app args index strictness ro
				_			-> False
			= rnf_args args (inc index) strictness ro

	rnf_app_args {app_symb=symb=:{symb_kind = SK_Constructor cons_index, symb_ident}, app_args} args index strictness ro
		# {cons_type}		= ro.ro_common_defs.[cons_index.glob_module].com_cons_defs.[cons_index.glob_object]
		| rnf_args app_args 0 cons_type.st_args_strictness ro
			= rnf_args args (inc index) strictness ro
			= False
	// what else is rnf => curried apps
	rnf_app_args {app_symb=symb=:{symb_kind}, app_args} args index strictness ro
		= False
determineProducer app=:{app_symb = symb=:{ symb_kind = SK_GeneratedFunction fun_ptr fun_index}, app_args} _ consumer_properties consumer_is_curried ok_non_rec_consumer linear_bit
				  new_args prod_index producers ro ti
	# (FI_Function {gf_cons_args={cc_producer},gf_fun_def={fun_body, fun_arity, fun_type, fun_info}}, ti_fun_heap) = readPtr fun_ptr ti.ti_fun_heap
	  ti & ti_fun_heap=ti_fun_heap
	  n_app_args = length app_args
	| SwitchArityChecks (n_app_args>1 && size producers + n_app_args - 1 > 32) False
		# ti & ti_error_file = ti.ti_error_file <<< "Possibly missed fusion oppurtunity: Function Arity > 32\n"
		= (producers, [App app : new_args], ti)
	| n_app_args<>fun_arity
		| SwitchCurriedFusion ro.ro_transform_fusion cc_producer False
			# (is_good_producer,ti)
				= SwitchGeneratedFusion
					(function_is_good_producer fun_body fun_type linear_bit ro ti)
					(False,ti)
			| cc_producer && is_good_producer
				= ({producers & [prod_index] = PR_CurriedFunction symb n_app_args fun_index}, app_args ++ new_args, ti)
			= ({producers & [prod_index] = PR_Curried symb n_app_args}, app_args ++ new_args, ti)
		| consumer_properties bitand FI_IsMacroFun <> 0
			= ({producers & [prod_index] = PR_Curried symb n_app_args}, app_args ++ new_args, ti)
		= (producers, [App app : new_args], ti)
	# (is_good_producer,ti)
		= SwitchGeneratedFusion
			(function_is_good_producer fun_body fun_type linear_bit ro ti)
			(False,ti)
	| cc_producer && is_good_producer
		= ({producers & [prod_index] = PR_GeneratedFunction symb n_app_args fun_index}, app_args ++ new_args, ti)
	# not_expanding_producer
		= case fun_body of
			Expanding _
				-> False
			_
				-> True //cc_producer
	| SwitchHOFusion
    	((not consumer_is_curried && not_expanding_producer) && consumer_properties bitand FI_IsMacroFun <> 0 && linear_bit && is_higher_order_function fun_type)
    	False
		= ({ producers & [prod_index] = PR_Curried symb n_app_args}, app_args ++ new_args, ti)
    | SwitchHOFusion`
    	((not consumer_is_curried && not_expanding_producer) && ok_non_rec_consumer && linear_bit && is_higher_order_function fun_type)
    	False
		= ({ producers & [prod_index] = PR_Curried symb n_app_args}, app_args ++ new_args, ti)
	# non_rec_producer = (fun_info.fi_properties bitand FI_IsNonRecursive) <> 0
	# ok_non_rec
		= case fun_body of
			Expanding _
				-> False
			(TransformedBody {tb_rhs})
				-> ro.ro_transform_fusion && not_expanding_producer && is_sexy_body tb_rhs && ok_non_rec_consumer && non_rec_producer//is_good_producer
	| SwitchNonRecFusion ok_non_rec False
		= ({producers & [prod_index] = PR_GeneratedFunction symb n_app_args fun_index}, app_args ++ new_args, ti)
	= (producers, [App app : new_args ], ti)
determineProducer app=:{app_symb = symb=:{symb_kind}, app_args} _ consumer_properties consumer_is_curried ok_non_rec_consumer linear_bit
				  new_args prod_index producers ro ti
	| is_SK_Function_or_SK_LocalMacroFunction symb_kind
		# { glob_module, glob_object }
			= case symb_kind of
				SK_Function global_index -> global_index
				SK_LocalMacroFunction index -> { glob_module = ro.ro_main_dcl_module_n, glob_object = index }
		# (fun_arity, ti) = get_fun_arity glob_module glob_object ro ti
		  n_app_args = length app_args
		| n_app_args<>fun_arity
			| consumer_properties bitand FI_IsMacroFun <> 0
				= ({ producers & [prod_index] = PR_Curried symb n_app_args}, app_args ++ new_args, ti)
			# ({cc_producer},ti) = ti!ti_cons_args.[glob_object]
			| SwitchCurriedFusion ro.ro_transform_fusion cc_producer False
				# ({fun_body,fun_type,fun_info}, ti) = ti!ti_fun_defs.[glob_object]
				# (is_good_producer,ti)
					= SwitchFunctionFusion
						(function_is_good_producer fun_body fun_type linear_bit ro ti)
						(False,ti)
				#! max_index = size ti.ti_cons_args
				| glob_module==ro.ro_main_dcl_module_n && glob_object < max_index &&
				  is_good_producer && cc_producer && not consumer_is_curried
					= ({producers & [prod_index] = PR_CurriedFunction symb n_app_args glob_object}, app_args ++ new_args, ti)
				= ({ producers & [prod_index] = PR_Curried symb n_app_args}, app_args ++ new_args, ti)
			= (producers, [App app : new_args], ti)
		#! max_index = size ti.ti_cons_args
		| glob_module <> ro.ro_main_dcl_module_n || glob_object >= max_index /* Sjaak, to skip array functions */
			= (producers, [App app : new_args ], ti)
//					-!-> ("Produce2cc_array",symb.symb_ident,if (glob_module <> ro.ro_main_dcl_module_n) "foreign" "array")
		# ({fun_body,fun_type,fun_info}, ti) = ti!ti_fun_defs.[glob_object]
		# (is_good_producer,ti)
			= SwitchFunctionFusion
				(function_is_good_producer fun_body fun_type linear_bit ro ti)
				(False,ti)
		  {cc_producer} = ti.ti_cons_args.[glob_object]
		| is_good_producer && cc_producer && not consumer_is_curried
			= ({ producers & [prod_index] = PR_Function symb n_app_args glob_object}, app_args ++ new_args, ti)
	    # not_expanding_producer
			= case fun_body of
				Expanding _
					-> False
				_
					-> True // cc_producer
		| (not consumer_is_curried && not_expanding_producer) && consumer_properties bitand FI_IsMacroFun <> 0 && linear_bit && is_higher_order_function fun_type
			= ({ producers & [prod_index] = PR_Curried symb n_app_args}, app_args ++ new_args, ti)
		# non_rec_producer = (fun_info.fi_properties bitand FI_IsNonRecursive) <> 0
		# ok_non_rec
			= case fun_body of
				Expanding _
					-> False
				(TransformedBody {tb_rhs})
					-> ro.ro_transform_fusion && not_expanding_producer && is_sexy_body tb_rhs && ok_non_rec_consumer && non_rec_producer//&& is_good_producer
		| SwitchNonRecFusion ok_non_rec False
			= ({producers & [prod_index] = PR_Function symb n_app_args glob_object}, app_args ++ new_args, ti)
		= (producers, [App app : new_args], ti)
	= (producers, [App app : new_args], ti)
where
	get_max_index ti=:{ti_cons_args}
		#! (max_index, ti_cons_args)	= usize ti_cons_args
		= (max_index, {ti & ti_cons_args = ti_cons_args})

	get_fun_arity glob_module glob_object ro ti
		| glob_module <> ro.ro_main_dcl_module_n
			# {st_arity, st_context} = ro.ro_imported_funs.[glob_module].[glob_object].ft_type
			= (st_arity+length st_context, ti)
		// for imported functions you have to add ft_arity and length st_context, but for unimported
		// functions fun_arity alone is sufficient
		= ti!ti_fun_defs.[glob_object].fun_arity

function_is_good_producer (Expanding _) fun_type linear_bit ro ti
	= (False,ti)
function_is_good_producer (TransformedBody {tb_rhs}) fun_type linear_bit ro ti
	| ro.ro_transform_fusion
		| linear_bit && is_sexy_body tb_rhs
			= (True,ti)
			= function_may_be_copied fun_type tb_rhs ro ti
		= (False,ti)
where
	function_may_be_copied (Yes {st_args_strictness}) rhs ro ti
		| is_not_strict st_args_strictness
			= expression_may_be_copied rhs ro ti
			= (False,ti)
	function_may_be_copied No rhs ro ti
		= expression_may_be_copied rhs ro ti

	// to optimize bimap
	expression_may_be_copied (Var _) ro ti
		= (True,ti)
	expression_may_be_copied (App {app_symb={symb_kind = SK_Constructor cons_index}, app_args}) ro ti
		# cons_type = ro.ro_common_defs.[cons_index.glob_module].com_cons_defs.[cons_index.glob_object].cons_type
		| cons_index.glob_module==ro.ro_StdGeneric_module_n && is_not_strict cons_type.st_args_strictness
			= expressions_may_be_copied app_args ro ti
			= (False,ti)
	expression_may_be_copied (App {app_symb={symb_kind = SK_Function {glob_object,glob_module}}, app_args}) ro ti
		| glob_module <> ro.ro_main_dcl_module_n
			# fun_type = ro.ro_imported_funs.[glob_module].[glob_object].ft_type
			| length app_args < fun_type.st_arity+length fun_type.st_context
				= expressions_may_be_copied app_args ro ti
				= (False,ti)
			# (fun_arity,ti) = ti!ti_fun_defs.[glob_object].fun_arity
			| length app_args < fun_arity
				= expressions_may_be_copied app_args ro ti
				= (False,ti)
	expression_may_be_copied (App {app_symb={symb_kind = SK_LocalMacroFunction glob_object}, app_args}) ro ti
		# (fun_arity,ti) = ti!ti_fun_defs.[glob_object].fun_arity
		| length app_args < fun_arity
			= expressions_may_be_copied app_args ro ti
			= (False,ti)
	expression_may_be_copied (App {app_symb={symb_kind = SK_GeneratedFunction fun_ptr _}, app_args}) ro ti
		# (FI_Function {gf_fun_def={fun_arity}}) = sreadPtr fun_ptr ti.ti_fun_heap
		| length app_args < fun_arity
			= expressions_may_be_copied app_args ro ti
			= (False,ti)
	expression_may_be_copied (Selection NormalSelector (Var _) [RecordSelection {glob_module,glob_object={ds_index}} _]) ro ti
		# selector_type = ro.ro_common_defs.[glob_module].com_selector_defs.[ds_index].sd_type
		| glob_module==ro.ro_StdGeneric_module_n && is_not_strict selector_type.st_args_strictness
			= (True,ti)
			= (False,ti)
	expression_may_be_copied _ ro ti
		= (False,ti)
	
	expressions_may_be_copied [expr:exprs] ro ti
		# (ok,ti) = expression_may_be_copied expr ro ti
		| ok
			= expressions_may_be_copied exprs ro ti
			= (False,ti)
	expressions_may_be_copied [] ro ti
		= (True,ti)

// when two function bodies have fusion with each other this only leads into satisfaction if one body
// fulfills the following sexyness property
// DvA: now that we have producer requirements we can integrate this condition there...
is_sexy_body (AnyCodeExpr _ _ _) = False	
is_sexy_body (ABCCodeExpr _ _) = False	
is_sexy_body (Let {let_strict_binds}) = isEmpty let_strict_binds	
	// currently a producer's body must not be a let with strict bindings. The code sharing elimination algorithm assumes that
	// all strict let bindings are on the top level expression (see "convertCasesOfFunctionsIntoPatterns"). This assumption
	// could otherwise be violated during fusion.
	// -> Here is place for optimisation: Either the fusion algorithm or the code sharing elimination algorithm could be
	// extended to generate new functions when a strict let ends up during fusion in a non top level position (MW)
is_sexy_body _ = True	

is_higher_order_function (Yes {st_result={at_type=_ --> _}})
        = True
is_higher_order_function _
        = False

containsProducer prod_index producers
	| prod_index == 0
		= False
		#! prod_index = dec prod_index
		= is_a_producer producers.[prod_index] || containsProducer prod_index producers
where
	is_a_producer PR_Empty	= False
	is_a_producer _ 		= True

:: *RenewState :== (![(BoundVar, Type)], ![Expression], !*VarHeap)

renewVariables :: ![Expression] !PredefinedSymbol !*VarHeap -> (![Expression], !RenewState)
renewVariables exprs normalise_symbol var_heap
	# (exprs, (new_vars, free_vars, var_heap))
			= mapSt map_expr_st exprs ([], [], var_heap)
	  var_heap = foldSt (\ expr var_heap
	  						-> case expr of
	  							Var {var_info_ptr}	-> writeVarInfo var_info_ptr VI_Empty var_heap
	  							_					-> var_heap
	  					) free_vars var_heap
	= (exprs, (new_vars, free_vars, var_heap))
  where
	map_expr_st (Var var=:{var_info_ptr, var_ident}) (new_vars_accu, free_vars_accu, var_heap)
		# (var_info, var_heap) = readPtr var_info_ptr var_heap
		= case var_info of
			VI_Extended _ (VI_Forward new_var)
				-> (Var new_var, (new_vars_accu, free_vars_accu, var_heap))
			VI_Extended evi=:(EVI_VarType var_type) _
				# (new_var, var_heap)
					= allocate_and_bind_new_var var_ident var_info_ptr evi var_heap
				-> (Var new_var, ([(new_var, var_type.at_type) : new_vars_accu], [Var var:free_vars_accu], var_heap))
	map_expr_st expr=:(App app=:{app_symb={symb_kind=SK_Function {glob_object,glob_module},symb_ident},app_args}) (new_vars_accu, free_vars_accu, var_heap)
		| glob_module==normalise_symbol.pds_module && glob_object==normalise_symbol.pds_def
			# (new_info_ptr, var_heap) = newPtr VI_Empty var_heap
			  new_var = { var_ident = symb_ident, var_info_ptr = new_info_ptr, var_expr_ptr = nilPtr }
			= (Var new_var, ([(new_var, TE) : new_vars_accu], [expr:free_vars_accu], var_heap))
	map_expr_st expr=:(App app=:{app_args}) st
		# (app_args, st) = mapSt map_expr_st app_args st
		= (App { app & app_args = app_args }, st)
	map_expr_st (Let lad=:{let_lazy_binds, let_strict_binds, let_expr}) st
		# (lazy_free_vars, st)
				= mapSt (\{lb_dst} st -> preprocess_local_var lb_dst st) let_lazy_binds st
		  (strict_free_vars, st)
				= mapSt (\{lb_dst} st -> preprocess_local_var lb_dst st) let_strict_binds st
		  (lazy_rhss, st)
		  		= mapSt (\{lb_src} st -> map_expr_st lb_src st) let_lazy_binds st
		  (strict_rhss, st)
		  		= mapSt (\{lb_src} st -> map_expr_st lb_src st) let_strict_binds st
		  (let_expr, st)
		  		= map_expr_st let_expr st
		  st	= foldSt (\{lb_dst} st -> postprocess_local_var lb_dst st) let_lazy_binds st
		  st	= foldSt (\{lb_dst} st -> postprocess_local_var lb_dst st) let_strict_binds st
		  expr	= Let { lad
		  			& let_lazy_binds	= add_let_binds lazy_free_vars lazy_rhss let_lazy_binds
		  			, let_strict_binds	= add_let_binds strict_free_vars strict_rhss let_strict_binds
		  			, let_expr			= let_expr
					}
		= (expr, st)
	map_expr_st (Selection a expr b) st
		# (expr, st) = map_expr_st expr st
		= (Selection a expr b, st)
	map_expr_st expr=:(BasicExpr _) st 
		= (expr, st)

	preprocess_local_var :: !FreeVar !RenewState -> (!FreeVar, !RenewState)
	preprocess_local_var fv=:{fv_ident, fv_info_ptr} (new_vars_accu, free_vars_accu, var_heap)
		# (evi, var_heap) = readExtendedVarInfo fv_info_ptr var_heap
		  (new_var, var_heap) = allocate_and_bind_new_var fv_ident fv_info_ptr evi var_heap
		= ( { fv & fv_info_ptr = new_var.var_info_ptr }
		  , (new_vars_accu, free_vars_accu, var_heap))

	allocate_and_bind_new_var var_ident var_info_ptr evi var_heap
		# (new_info_ptr, var_heap) = newPtr (VI_Extended evi VI_Empty) var_heap
		  new_var = { var_ident = var_ident, var_info_ptr = new_info_ptr, var_expr_ptr = nilPtr }
		  var_heap = writeVarInfo var_info_ptr (VI_Forward new_var) var_heap
		= (new_var, var_heap)

	postprocess_local_var :: !FreeVar !RenewState -> RenewState
	postprocess_local_var {fv_info_ptr} (a, b, var_heap)
		= (a, b, writeVarInfo fv_info_ptr VI_Empty var_heap)

foldrExprSt f expr st :== foldr_expr_st expr st
  where
	foldr_expr_st expr=:(Var _) st
		= f expr st
	foldr_expr_st app=:(App {app_args}) st
		= f app (foldSt foldr_expr_st app_args st)
	foldr_expr_st lad=:(Let {let_lazy_binds, let_strict_binds, let_expr}) st
		# st
		  		= foldSt (\{lb_src} st -> foldr_expr_st lb_src st) let_lazy_binds st
		  st
		  		= foldSt (\{lb_src} st -> foldr_expr_st lb_src st) let_strict_binds st
		  st
		  		= f let_expr st
		= f lad st
	foldr_expr_st sel=:(Selection a expr b) st
		= f sel (foldr_expr_st expr st)
	foldr_expr_st expr=:(BasicExpr _) st 
		= f expr st

add_let_binds :: [FreeVar] [Expression] [LetBind] -> [LetBind]
add_let_binds free_vars rhss original_binds
	= [{ original_bind & lb_dst = lb_dst, lb_src = lb_src}
		\\ lb_dst <- free_vars & lb_src <- rhss & original_bind <- original_binds]

remove_groups_not_used_by_original_component_members :: ComponentMembers [Component] [Component] -> (![Component],![Component])
remove_groups_not_used_by_original_component_members original_component_members new_groups removed_groups
	# last_component = last new_groups
	| contains_function_in_component last_component.component_members original_component_members
		= (new_groups,removed_groups)
		= remove_groups_not_used_by_original_component_members original_component_members (init new_groups) [last_component:removed_groups]
where
	contains_function_in_component (GeneratedComponentMember function_n _ component_members) original_component_members
		| component_contains_generated_function_n original_component_members function_n
			= True
			= contains_function_in_component component_members original_component_members
	contains_function_in_component (ComponentMember function_n component_members) original_component_members
		| component_contains_function_n original_component_members function_n
			= True
			= contains_function_in_component component_members original_component_members
	contains_function_in_component NoComponentMembers original_component_members
		= False
	
	component_contains_function_n (ComponentMember function_n2 component_members) function_n
		= function_n==function_n2 || component_contains_function_n component_members function_n
	component_contains_function_n (GeneratedComponentMember _ _ component_members) function_n
		= component_contains_function_n component_members function_n
	component_contains_function_n NoComponentMembers function_n
		= False

	component_contains_generated_function_n (GeneratedComponentMember function_n2 _ component_members) function_n
		= function_n==function_n2 || component_contains_generated_function_n component_members function_n
	component_contains_generated_function_n (ComponentMember _ component_members) function_n
		= component_contains_generated_function_n component_members function_n
	component_contains_generated_function_n NoComponentMembers function_n
		= False

remove_unused_used_functions :: ![FunctionInfoPtr] !*FunctionHeap -> (![FunctionInfoPtr],!*FunctionHeap)
remove_unused_used_functions [fun_ptr:fun_ptrs] fun_heap
	# (FI_Function gf, fun_heap) = readPtr fun_ptr fun_heap
	| gf.gf_fun_def.fun_info.fi_properties bitand FI_UnusedUsed<>0
		= remove_unused_used_functions fun_ptrs fun_heap
		# (fun_ptrs, fun_heap) = remove_unused_used_functions fun_ptrs fun_heap
		= ([fun_ptr:fun_ptrs], fun_heap)
remove_unused_used_functions [] fun_heap
	= ([],fun_heap)

mark_unused_functions_in_components :: [Component] *TransformInfo -> *TransformInfo
mark_unused_functions_in_components [removed_group:removed_groups] ti
	# ti = mark_unused_functions removed_group.component_members ti
	= mark_unused_functions_in_components removed_groups ti
where
	mark_unused_functions (ComponentMember member members) ti
		# (fun_info,ti) = ti!ti_fun_defs.[member].fun_info
		  fun_info & fi_properties = fun_info.fi_properties bitor FI_Unused
		  ti & ti_fun_defs.[member].fun_info = fun_info
		= mark_unused_functions members ti
	mark_unused_functions (GeneratedComponentMember member fun_ptr members) ti=:{ti_fun_heap}	
		# (FI_Function gf=:{gf_fun_def=fd=:{fun_info},gf_fun_index}, ti_fun_heap) = readPtr fun_ptr ti_fun_heap
		  fun_info & fi_properties = fun_info.fi_properties bitor FI_Unused
		  fd & fun_info=fun_info
		  ti & ti_fun_heap = writePtr fun_ptr (FI_Function {gf & gf_fun_def=fd}) ti_fun_heap
		= mark_unused_functions members ti
	mark_unused_functions NoComponentMembers ti
		= ti
mark_unused_functions_in_components [] ti
	= ti

transformGroups :: !CleanupInfo !Int !Int !Int !Int !*{!Component} !*{#FunDef} !*{!.ConsClasses} !{# CommonDefs}  !{# {# FunType} }
		!*ImportedTypes !*TypeDefInfos !*VarHeap !*TypeHeaps !*ExpressionHeap !Bool !*File !*PredefinedSymbols
			-> (!*{!Component}, !*{#FunDef}, !*ImportedTypes, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap, !*File, !*PredefinedSymbols)
transformGroups cleanup_info main_dcl_module_n ro_StdStrictLists_module_n def_min def_max groups fun_defs cons_args common_defs imported_funs
		imported_types type_def_infos var_heap type_heaps symbol_heap compile_with_fusion error predef_symbols
	#! nr_of_funs = size fun_defs
	# initial_ti =	{ ti_fun_defs		= fun_defs
					, ti_instances		= createArray nr_of_funs II_Empty
					, ti_cons_args		= cons_args
					, ti_new_functions	= []
					, ti_fun_heap		= newHeap
					, ti_var_heap		= var_heap
					, ti_symbol_heap	= symbol_heap
					, ti_type_heaps		= type_heaps
					, ti_type_def_infos	= type_def_infos
					, ti_next_fun_nr	= nr_of_funs
					, ti_cleanup_info	= cleanup_info
					, ti_recursion_introduced	= No
					, ti_error_file		= error
					, ti_predef_symbols	= predef_symbols }

	# groups = [group \\ group <-: groups]
	# (groups, imported_types, collected_imports, fun_indices_with_abs_syn_types, ti)
		= transform_groups 0 groups [] common_defs imported_funs imported_types [] [] initial_ti
	# groups = {group \\ group <- reverse groups}

	  {ti_fun_defs,ti_new_functions,ti_var_heap,ti_symbol_heap,ti_fun_heap,ti_next_fun_nr,ti_type_heaps,ti_cleanup_info} = ti
	# (fun_defs, imported_types, collected_imports, type_heaps, var_heap) 
			= foldSt (expand_abstract_syn_types_in_function_type common_defs) (reverse fun_indices_with_abs_syn_types)
					(ti_fun_defs, imported_types, collected_imports, ti_type_heaps, ti_var_heap)

	  (groups, new_fun_defs, imported_types, collected_imports, type_heaps, var_heap) 
	  		= foldSt (add_new_function_to_group common_defs ti_fun_heap) ti_new_functions
	  				(groups, [], imported_types, collected_imports, type_heaps, var_heap)
	  symbol_heap = foldSt cleanup_attributes ti.ti_cleanup_info ti.ti_symbol_heap
	  fun_defs = { fundef \\ fundef <- [ fundef \\ fundef <-: fun_defs ] ++ new_fun_defs }
	= (groups, fun_defs, imported_types, collected_imports,	var_heap, type_heaps, symbol_heap, ti.ti_error_file, ti.ti_predef_symbols)
where
	transform_groups :: !Int ![Component] !u:[Component] !{#CommonDefs} !{#{#FunType}} !*{#{#CheckedTypeDef}} ![(Global Int)] !v:[Int] !*TransformInfo
		-> *(!w:[Component],!.{#{#CheckedTypeDef}},![(Global Int)],!x:[Int],!*TransformInfo), [u <= w,v <= x]
	transform_groups group_nr [group:groups] acc_groups common_defs imported_funs imported_types collected_imports fun_indices_with_abs_syn_types ti
		# {component_members} = group
		# (ti_fun_defs, imported_types, collected_imports, fun_indices_with_abs_syn_types, ti_type_heaps, ti_var_heap) 
				= convert_function_types component_members common_defs
						(ti.ti_fun_defs, imported_types, collected_imports, fun_indices_with_abs_syn_types, ti.ti_type_heaps, ti.ti_var_heap)
		# ti = { ti & ti_fun_defs = ti_fun_defs, ti_type_heaps = ti_type_heaps, ti_var_heap = ti_var_heap }
		# (group_nr,acc_groups,ti) = transform_group common_defs imported_funs group_nr component_members acc_groups ti
		= transform_groups group_nr groups acc_groups common_defs imported_funs imported_types collected_imports fun_indices_with_abs_syn_types ti
	transform_groups group_nr [] acc_groups common_defs imported_funs imported_types collected_imports fun_indices_with_abs_syn_types ti
		= (acc_groups, imported_types, collected_imports, fun_indices_with_abs_syn_types, ti)

	convert_function_types (ComponentMember member members) common_defs s
		# s = convert_function_type common_defs member s
		= convert_function_types members common_defs s
	convert_function_types NoComponentMembers common_defs s
		= s
/*
	transform_groups_again :: !Int ![Component] ![Component] !{#CommonDefs} !{#{#FunType}} !*TransformInfo -> *(![Component],!*TransformInfo)
	transform_groups_again group_nr [group:groups] acc_groups common_defs imported_funs ti
		# {component_members} = group
		# (group_nr,acc_groups,ti) = transform_group common_defs imported_funs group_nr component_members acc_groups ti
		= transform_groups_again group_nr groups acc_groups common_defs imported_funs ti
	transform_groups_again group_nr [] acc_groups common_defs imported_funs ti
		= (acc_groups, ti)
*/
	transform_group :: !{#CommonDefs} !{#{#FunType}} !Int !ComponentMembers !u:[Component] !*TransformInfo -> *(!Int,!u:[Component],!*TransformInfo)
	transform_group common_defs imported_funs group_nr component_members acc_groups ti
		// assign group_nr to component_members
		# ti = assign_groups component_members group_nr ti

		# (previous_new_functions,ti) = ti!ti_new_functions
		# ti & ti_new_functions=[]
		// transform component_members
		# ti = transform_functions component_members common_defs imported_funs ti
		// partitionate group: need to know added functions for this...
		# (new_functions,ti) = ti!ti_new_functions

		# (new_generated_functions,ti_fun_heap) = remove_unused_used_functions new_functions ti.ti_fun_heap
		# ti & ti_fun_heap = ti_fun_heap,
			   ti_new_functions = new_generated_functions ++ previous_new_functions

		| not (compile_with_fusion || not (isEmpty new_functions))
			= (inc group_nr,[{component_members=component_members}:acc_groups],ti)

		# (new_functions_in_component,ti_fun_heap)
			= determine_new_functions_in_component new_functions ti.ti_fun_heap
		# ti = {ti & ti_fun_heap=ti_fun_heap}
		# (new_groups,ti) = partition_group group_nr (append_ComponentMembers component_members new_functions_in_component) ti
		// reanalyse consumers
		# (cleanup,ti_fun_defs,ti_var_heap,ti_symbol_heap,ti_fun_heap,ti_cons_args,same)
				= reanalyseGroups common_defs imported_funs main_dcl_module_n ro_StdStrictLists_module_n
					new_groups
					ti.ti_fun_defs ti.ti_var_heap ti.ti_symbol_heap ti.ti_fun_heap ti.ti_cons_args
		# ti = {ti 
				& ti_cleanup_info = cleanup ++ ti.ti_cleanup_info
				, ti_fun_defs = ti_fun_defs
				, ti_var_heap = ti_var_heap
				, ti_symbol_heap = ti_symbol_heap
				, ti_fun_heap = ti_fun_heap
				, ti_cons_args = ti_cons_args
				}
		// if wanted reapply transform_group to all found groups
		| not (isEmpty new_functions) || length new_groups > 1 || not same
			# (new_groups,removed_groups) = remove_groups_not_used_by_original_component_members component_members new_groups []
			  ti = mark_unused_functions_in_components removed_groups ti
			= transform_groups` common_defs imported_funs group_nr new_groups acc_groups ti
		// producer annotation for finished components!
		# ti = reannotate_producers group_nr component_members ti
		= (inc group_nr,(reverse new_groups)++acc_groups,ti)
	where
		transform_groups` :: !{#CommonDefs} !{#{#FunType}} !Int ![Component] !u:[Component] !*TransformInfo -> *(!Int,!u:[Component],!*TransformInfo)
		transform_groups` common_defs imported_funs group_nr [] acc_groups ti
			= (group_nr, acc_groups, ti)
		transform_groups` common_defs imported_funs group_nr [{component_members}:groups] acc_groups ti
			# (group_nr,acc_groups,ti) = transform_group common_defs imported_funs group_nr component_members acc_groups ti
			= transform_groups` common_defs imported_funs group_nr groups acc_groups ti

		assign_groups :: !ComponentMembers !Int !*TransformInfo -> *TransformInfo
		assign_groups (ComponentMember member members) group_nr ti
			# ti = {ti & ti_fun_defs.[member].fun_info.fi_group_index = group_nr}
			= assign_groups members group_nr ti
		assign_groups (GeneratedComponentMember member fun_ptr members) group_nr ti=:{ti_fun_heap}
			# (FI_Function gf=:{gf_fun_def=fd}, ti_fun_heap) = readPtr fun_ptr ti_fun_heap
			# fd = {fd & fun_info.fi_group_index = group_nr}
			# ti_fun_heap = writePtr fun_ptr (FI_Function {gf & gf_fun_def=fd}) ti_fun_heap
			# ti = {ti & ti_fun_heap=ti_fun_heap}
			= assign_groups members group_nr ti
		assign_groups NoComponentMembers group_nr ti
			= ti
		
		partition_group :: !.Int !ComponentMembers !*TransformInfo -> *(![Component],!*TransformInfo)
		partition_group group_nr component_members ti
			# {ti_fun_defs=fun_defs, ti_fun_heap=fun_heap, ti_next_fun_nr=max_fun_nr,
			   ti_predef_symbols=predef_symbols, ti_var_heap=var_heap, ti_symbol_heap=expression_heap, ti_error_file} = ti
			# next_group = group_nr
			# error_admin = {ea_file = ti_error_file, ea_loc = [], ea_ok = True }
			# (_,groups,fun_defs,fun_heap,predef_symbols,var_heap,expression_heap,error_admin)
				= partitionateFunctions`` max_fun_nr next_group fun_defs component_members main_dcl_module_n def_min def_max fun_heap predef_symbols var_heap expression_heap error_admin
			# ti = { ti	& ti_fun_defs		= fun_defs
						, ti_fun_heap		= fun_heap
						, ti_predef_symbols	= predef_symbols
						, ti_var_heap		= var_heap
						, ti_symbol_heap	= expression_heap
						, ti_error_file		= error_admin.ea_file }
			= (groups,ti)

		transform_functions :: !ComponentMembers !{#CommonDefs} !{#{#FunType}} !*TransformInfo -> *TransformInfo
		transform_functions (ComponentMember member members) common_defs imported_funs ti
			# (fun_def, ti) = ti!ti_fun_defs.[member]
			  fun_symb = {symb_ident=fun_def.fun_ident, symb_kind=SK_Function {glob_object=member, glob_module=main_dcl_module_n}}
			  (fun_body,ti)
				= transform_function fun_def.fun_type fun_def.fun_body fun_symb common_defs imported_funs ti
			  fun_def = {fun_def & fun_body=fun_body}
			  ti = {ti & ti_fun_defs.[member] = fun_def}
			= transform_functions members common_defs imported_funs ti
		transform_functions (GeneratedComponentMember member fun_ptr members) common_defs imported_funs ti
			# (FI_Function gf=:{gf_fun_def},ti_fun_heap) = readPtr fun_ptr ti.ti_fun_heap
			  fun_symb = {symb_ident=gf_fun_def.fun_ident, symb_kind=SK_GeneratedFunction fun_ptr member }
			  ti = {ti & ti_fun_heap = ti_fun_heap}
			  (fun_body,ti)
				= transform_function gf_fun_def.fun_type gf_fun_def.fun_body fun_symb common_defs imported_funs ti
			  gf_fun_def = {gf_fun_def & fun_body=fun_body}
			  ti_fun_heap = writePtr fun_ptr (FI_Function {gf & gf_fun_def=gf_fun_def}) ti.ti_fun_heap
			  ti = {ti & ti_fun_heap = ti_fun_heap}
			= transform_functions members common_defs imported_funs ti
		transform_functions NoComponentMembers common_defs imported_funs ti
			= ti

		transform_function :: !(Optional SymbolType) !FunctionBody !SymbIdent !{#CommonDefs} !{#{#FunType}} !*TransformInfo -> (!FunctionBody,!*TransformInfo)
		transform_function (Yes {st_args,st_args_strictness}) (TransformedBody tb) fun_symb common_defs imported_funs ti
			# (ro_StdGeneric_module_n,ti) = ti!ti_predef_symbols.[PD_StdGeneric].pds_def
			  ti_var_heap					= fold2St store_arg_type_info tb.tb_args st_args ti.ti_var_heap
			  tfi =	{ tfi_root				= fun_symb
					, tfi_case				= fun_symb
					, tfi_orig				= fun_symb
					, tfi_args				= tb.tb_args
					, tfi_vars				= [arg \\ arg <- tb.tb_args & i <- [0..] | arg_is_strict i st_args_strictness]
					, tfi_n_args_before_producer = -1
					, tfi_n_producer_args	= -1
					}
			  ro =	{ ro_imported_funs				= imported_funs
					, ro_common_defs 				= common_defs
					, ro_root_case_mode				= get_root_case_mode tb
					, ro_tfi						= tfi
					, ro_main_dcl_module_n			= main_dcl_module_n
					, ro_transform_fusion			= compile_with_fusion
					, ro_StdStrictLists_module_n	= ro_StdStrictLists_module_n
					, ro_StdGeneric_module_n		= ro_StdGeneric_module_n
					}
			  ti = {ti & ti_var_heap = ti_var_heap}
		  
			  (fun_rhs, ti)						= transform tb.tb_rhs ro ti
			= (TransformedBody {tb & tb_rhs = fun_rhs},ti)
		  where
			store_arg_type_info {fv_info_ptr} a_type ti_var_heap
				= setExtendedVarInfo fv_info_ptr (EVI_VarType a_type) ti_var_heap
			
			fun_def_to_symb_ident fun_index fsize {fun_ident}
				| fun_index < fsize
				= { symb_ident=fun_ident, symb_kind=SK_Function {glob_object=fun_index, glob_module=main_dcl_module_n } }

			get_root_case_mode {tb_rhs=Case _}	= RootCase
			get_root_case_mode _ 				= NotRootCase

	reannotate_producers group_nr component_members ti
		// determine if safe group
		# (safe,ti) = safe_producers group_nr component_members component_members main_dcl_module_n ti
		| safe
			// if safe mark all members as safe
			= mark_producers_safe component_members ti
		= ti

	safe_producers :: Int ComponentMembers ComponentMembers Int *TransformInfo -> *(!Bool,!*TransformInfo)
	safe_producers group_nr component_members (ComponentMember fun funs) main_dcl_module_n ti
		// look for occurrence of component_members in safe argument position of fun RHS
		// i.e. linearity ok && ...
		# (fun_def,fun_defs) = (ti.ti_fun_defs)![fun]
		  {fun_body = TransformedBody {tb_rhs}} = fun_def
		  prs =	{ prs_group				= component_members
				, prs_cons_args 		= ti.ti_cons_args
				, prs_main_dcl_module_n	= main_dcl_module_n
				, prs_fun_heap			= ti.ti_fun_heap
				, prs_fun_defs			= fun_defs
				, prs_group_index		= group_nr }
		# (safe,prs) = producerRequirements tb_rhs prs
		#! ti = {ti & ti_fun_defs = prs.prs_fun_defs, ti_fun_heap = prs.prs_fun_heap, ti_cons_args = prs.prs_cons_args}
		// put back prs info into ti?
		| safe
			= safe_producers group_nr component_members funs main_dcl_module_n ti
			= (False,ti)
	safe_producers group_nr component_members (GeneratedComponentMember fun fun_ptr funs) main_dcl_module_n ti
		# (FI_Function {gf_fun_def}, ti_fun_heap) = readPtr fun_ptr ti.ti_fun_heap
		  ti = {ti & ti_fun_heap=ti_fun_heap}
		  {fun_body = TransformedBody {tb_rhs}} = gf_fun_def
		  prs =	{ prs_group				= component_members
				, prs_cons_args 		= ti.ti_cons_args
				, prs_main_dcl_module_n	= main_dcl_module_n
				, prs_fun_heap			= ti.ti_fun_heap
				, prs_fun_defs			= ti.ti_fun_defs
				, prs_group_index		= group_nr }
		  (safe,prs) = producerRequirements tb_rhs prs
		#! ti = {ti & ti_fun_defs = prs.prs_fun_defs, ti_fun_heap = prs.prs_fun_heap, ti_cons_args = prs.prs_cons_args}
		| safe
			= safe_producers group_nr component_members funs main_dcl_module_n ti
			= (False,ti)
	safe_producers group_nr component_members NoComponentMembers main_dcl_module_n ti
		= (True,ti)

	mark_producers_safe (ComponentMember member members) ti
		# ti = {ti & ti_cons_args.[member].cc_producer = pIsSafe}
		= mark_producers_safe members ti
	mark_producers_safe (GeneratedComponentMember member fun_ptr members) ti
		# (FI_Function gf,ti_fun_heap) = readPtr fun_ptr ti.ti_fun_heap
		  ti_fun_heap = writePtr fun_ptr (FI_Function {gf & gf_cons_args.cc_producer = pIsSafe}) ti_fun_heap
		  ti = {ti & ti_fun_heap = ti_fun_heap}
		= mark_producers_safe members ti
	mark_producers_safe NoComponentMembers ti
		= ti

	add_new_function_to_group ::  !{# CommonDefs} !FunctionHeap  !FunctionInfoPtr
				  !(!*{!Component}, ![FunDef], !*ImportedTypes, !ImportedConstructors, !*TypeHeaps, !*VarHeap)
				-> (!*{!Component}, ![FunDef], !*ImportedTypes, !ImportedConstructors, !*TypeHeaps, !*VarHeap)
	add_new_function_to_group common_defs fun_heap fun_ptr (groups, fun_defs, imported_types, collected_imports, type_heaps, var_heap)
		# (FI_Function {gf_fun_def,gf_fun_index}) = sreadPtr fun_ptr fun_heap
		  {fun_type = Yes ft=:{st_args,st_result}, fun_info = {fi_group_index,fi_properties}} = gf_fun_def
		  ets =
		  	{ ets_type_defs							= imported_types
		  	, ets_collected_conses					= collected_imports
		  	, ets_type_heaps						= type_heaps
		  	, ets_var_heap							= var_heap
		  	, ets_main_dcl_module_n					= main_dcl_module_n
		  	, ets_contains_unexpanded_abs_syn_type	= False
		  	}
		#! (_,(st_args,st_result), {ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap})
				= expandSynTypes (if (fi_properties bitand FI_HasTypeSpec == 0) (RemoveAnnotationsMask bitor ExpandAbstractSynTypesMask) ExpandAbstractSynTypesMask) common_defs (st_args,st_result) ets
		# ft = { ft &  st_result = st_result, st_args = st_args }

		| fi_properties bitand FI_Unused<>0
			# gf_fun_def = {gf_fun_def & fun_type = Yes ft}
			= (groups, [gf_fun_def : fun_defs], ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap)

		| fi_group_index >= size groups
			= abort ("add_new_function_to_group "+++ toString fi_group_index+++ "," +++ toString (size groups) +++ "," +++ toString gf_fun_index)

		| not (isComponentMember gf_fun_index groups.[fi_group_index].component_members)
			= abort ("add_new_function_to_group INSANE!\n" +++ toString gf_fun_index +++ "," +++ toString fi_group_index)
		# gf_fun_def = {gf_fun_def & fun_type = Yes ft}
		= (groups, [gf_fun_def : fun_defs], ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap)
	where
		isComponentMember index (ComponentMember member members)
			= index==member || isComponentMember index members
		isComponentMember index (GeneratedComponentMember member _ members)
			= index==member || isComponentMember index members
		isComponentMember index NoComponentMembers
			= False

	convert_function_type common_defs fun_index (fun_defs, imported_types, collected_imports, fun_indices_with_abs_syn_types, type_heaps, var_heap)
		# (fun_def=:{fun_type = Yes fun_type, fun_info = {fi_properties}}, fun_defs)
					= fun_defs![fun_index]
		  rem_annot	= fi_properties bitand FI_HasTypeSpec == 0
		  (fun_type,contains_unexpanded_abs_syn_type,imported_types, collected_imports, type_heaps, var_heap)
		  		= convertSymbolTypeWithoutExpandingAbstractSynTypes rem_annot common_defs fun_type main_dcl_module_n imported_types collected_imports type_heaps var_heap
		# fun_def	= { fun_def & fun_type = Yes fun_type }
		  fun_defs	= { fun_defs & [fun_index] = fun_def }
		| contains_unexpanded_abs_syn_type
			= (fun_defs, imported_types, collected_imports, [fun_index : fun_indices_with_abs_syn_types], type_heaps, var_heap)
			= (fun_defs, imported_types, collected_imports, fun_indices_with_abs_syn_types, type_heaps, var_heap)

	expand_abstract_syn_types_in_function_type :: !{#.CommonDefs} !.Int !*(!*{#FunDef},!*{#{#CheckedTypeDef}},![(Global .Int)],!*TypeHeaps,!*(Heap VarInfo)) -> (!*{#FunDef},!.{#{#CheckedTypeDef}},![(Global Int)],!.TypeHeaps,!.(Heap VarInfo))
	expand_abstract_syn_types_in_function_type common_defs fun_index (fun_defs, imported_types, collected_imports, type_heaps, var_heap)
		# (fun_def=:{fun_type = Yes fun_type, fun_info = {fi_properties}}, fun_defs)
					= fun_defs![fun_index]
		  rem_annot	= fi_properties bitand FI_HasTypeSpec == 0
		  (fun_type,imported_types, collected_imports, type_heaps, var_heap)
	  		= convertSymbolType rem_annot common_defs fun_type main_dcl_module_n imported_types collected_imports type_heaps var_heap
	  	  fun_def = { fun_def & fun_type = Yes fun_type}
	  	  fun_defs = { fun_defs & [fun_index] = fun_def }
		= (fun_defs, imported_types, collected_imports, type_heaps, var_heap)

	append_ComponentMembers :: !ComponentMembers !ComponentMembers -> ComponentMembers
	append_ComponentMembers (ComponentMember member members) component_members_to_append
		= ComponentMember member (append_ComponentMembers members component_members_to_append)
	append_ComponentMembers (GeneratedComponentMember member fun_ptr members) component_members_to_append
		= GeneratedComponentMember member fun_ptr (append_ComponentMembers members component_members_to_append)
	append_ComponentMembers NoComponentMembers component_members_to_append
		= component_members_to_append

	determine_new_functions_in_component :: ![FunctionInfoPtr] !*FunctionHeap -> (ComponentMembers,!*FunctionHeap)
	determine_new_functions_in_component [fun_ptr:new_functions] fun_heap
		# (FI_Function {gf_fun_index},fun_heap) = readPtr fun_ptr fun_heap
		# (members,fun_heap) = determine_new_functions_in_component new_functions fun_heap
		= (GeneratedComponentMember gf_fun_index fun_ptr members,fun_heap)	
	determine_new_functions_in_component [] fun_heap
		= (NoComponentMembers,fun_heap)

//@	freeVariables

class clearVariables expr :: !expr !*VarHeap -> *VarHeap

instance clearVariables [a] | clearVariables a
where
	clearVariables list fvi
		= foldSt clearVariables list fvi

instance clearVariables LetBind
where
	clearVariables {lb_src} fvi
		= clearVariables lb_src fvi

instance clearVariables (Bind a b) | clearVariables a
where
	clearVariables {bind_src} fvi
		= clearVariables bind_src fvi

instance clearVariables (Optional a) | clearVariables a
where
	clearVariables (Yes x) fvi
		= clearVariables x fvi
	clearVariables No fvi
		= fvi

instance clearVariables BoundVar
where
	clearVariables bound_var=:{var_info_ptr} var_heap
		# (var_info, var_heap) = readVarInfo var_info_ptr var_heap
		= case var_info of
			VI_UsedVar _			-> writeVarInfo var_info_ptr VI_Empty var_heap
			VI_LocalVar				-> writeVarInfo var_info_ptr VI_Empty var_heap
			VI_Empty				-> var_heap
			VI_Expression _			-> writeVarInfo var_info_ptr VI_Empty var_heap
			VI_Dictionary _ _ _		-> writeVarInfo var_info_ptr VI_Empty var_heap
			VI_Variable _ _			-> writeVarInfo var_info_ptr VI_Empty var_heap
			VI_AccVar _ _			-> writeVarInfo var_info_ptr VI_Empty var_heap
			VI_ExpressionOrBody _ _	_ _ _ _
				-> writeVarInfo var_info_ptr VI_Empty var_heap
			VI_Body _ _ _ _ _
				-> writeVarInfo var_info_ptr VI_Empty var_heap

instance clearVariables Expression
where
	clearVariables (Var var) fvi
		= clearVariables var fvi
	clearVariables (App {app_args}) fvi
		= clearVariables app_args fvi
	clearVariables (fun @ args) fvi
		= clearVariables args (clearVariables fun fvi)
	clearVariables (Let {let_strict_binds,let_lazy_binds,let_expr}) fvi
		# fvi = clearVariables let_strict_binds fvi
		  fvi = clearVariables let_lazy_binds fvi
		  fvi = clearVariables let_expr fvi
		= fvi
	clearVariables (Case {case_expr,case_guards,case_default}) fvi
		# fvi = clearVariables case_expr fvi
		  fvi = clearVariables case_guards fvi
		  fvi = clearVariables case_default fvi
		= fvi
	clearVariables (Selection _ expr selectors) fvi
		= clearVariables expr (clearVariables selectors fvi)
	clearVariables (Update expr1 selectors expr2) fvi
		= clearVariables expr2 (clearVariables selectors (clearVariables expr1 fvi))
	clearVariables (RecordUpdate cons_symbol expression expressions) fvi
		= clearVariables expression (clearVariables expressions fvi)
	clearVariables (TupleSelect _ arg_nr expr) fvi
		= clearVariables expr fvi
	clearVariables (MatchExpr _ expr) fvi
		= clearVariables expr fvi
	clearVariables (IsConstructor expr _ _ _ _ _) fvi
		= clearVariables expr fvi
	clearVariables EE fvi
		= fvi
	clearVariables _ fvi
		= fvi

instance clearVariables CasePatterns
where
	clearVariables (AlgebraicPatterns _ alg_patterns) fvi
		= foldSt clearVariables alg_patterns fvi
	clearVariables (BasicPatterns _ basic_patterns) fvi
		= foldSt clearVariables basic_patterns fvi
	clearVariables (OverloadedListPatterns _ _ alg_patterns) fvi
		= foldSt clearVariables alg_patterns fvi

instance clearVariables BasicPattern
where
	clearVariables {bp_expr} fvi
		= clearVariables bp_expr fvi

instance clearVariables AlgebraicPattern
where
	clearVariables {ap_vars, ap_expr} fvi
		= clearVariables ap_expr fvi
		
instance clearVariables Selection
where
	clearVariables (RecordSelection _ _) fvi
		= fvi
	clearVariables (ArraySelection _ _ expr) fvi
		= clearVariables expr fvi
	clearVariables (DictionarySelection dict_var selections _ expr) fvi
		= clearVariables dict_var (clearVariables selections (clearVariables expr fvi))
	
////////////////

::	FreeVarInfo =
	{	fvi_var_heap	:: !.VarHeap
	,	fvi_expr_heap	:: !.ExpressionHeap
	,	fvi_variables	:: ![BoundVar]
	,	fvi_expr_ptrs	:: ![ExprInfoPtr]
	}

class freeVariables expr ::  !expr !*FreeVarInfo -> *FreeVarInfo

instance freeVariables [a] | freeVariables a
where
	freeVariables list fvi
		= foldSt freeVariables list fvi

instance freeVariables LetBind
where
	freeVariables {lb_src} fvi
		= freeVariables lb_src fvi

instance freeVariables (Bind a b) | freeVariables a
where
	freeVariables {bind_src} fvi
		= freeVariables bind_src fvi

instance freeVariables (Optional a) | freeVariables a
where
	freeVariables (Yes x) fvi
		= freeVariables x fvi
	freeVariables No fvi
		= fvi

instance freeVariables BoundVar
where
	freeVariables bound_var=:{var_info_ptr} fvi=:{fvi_var_heap, fvi_variables}
		# (var_info, fvi_var_heap) = readVarInfo var_info_ptr fvi_var_heap
		  (fvi_variables, fvi_var_heap) = adjust_var_info bound_var var_info fvi_variables fvi_var_heap
		= {fvi & fvi_variables = fvi_variables, fvi_var_heap = fvi_var_heap }
	where
		adjust_var_info _ (VI_UsedVar _) fvi_variables fvi_var_heap
			= (fvi_variables, fvi_var_heap)
		adjust_var_info bound_var=:{var_ident} _ fvi_variables fvi_var_heap
			= ([bound_var : fvi_variables], writeVarInfo var_info_ptr (VI_UsedVar var_ident) fvi_var_heap)

instance freeVariables Expression
where
	freeVariables (Var var) fvi
		= freeVariables var fvi
	freeVariables (App {app_args}) fvi
		= freeVariables app_args fvi
	freeVariables (fun @ args) fvi
		= freeVariables args (freeVariables fun fvi)
	freeVariables (Let {let_strict_binds,let_lazy_binds,let_expr,let_info_ptr}) fvi=:{fvi_variables = global_variables}
		# let_binds = let_strict_binds ++ let_lazy_binds
		  (removed_variables, fvi_var_heap) = removeVariables global_variables fvi.fvi_var_heap
		  fvi = freeVariables let_binds { fvi & fvi_variables = [], fvi_var_heap = fvi_var_heap }
		  {fvi_expr_heap, fvi_variables, fvi_var_heap, fvi_expr_ptrs} = freeVariables let_expr fvi
		  (fvi_variables, fvi_var_heap) = removeLocalVariables [lb_dst \\ {lb_dst} <- let_binds] fvi_variables [] fvi_var_heap		
		  (unbound_variables, fvi_var_heap) = determineGlobalVariables fvi_variables fvi_var_heap
		  (fvi_variables, fvi_var_heap) = restoreVariables removed_variables fvi_variables fvi_var_heap
		  (let_info, fvi_expr_heap) = readPtr let_info_ptr fvi_expr_heap
		= { fvi & fvi_variables = fvi_variables
		  , fvi_var_heap = fvi_var_heap
		  , fvi_expr_heap = fvi_expr_heap
		  , fvi_expr_ptrs = [let_info_ptr : fvi_expr_ptrs]
		  }
	freeVariables (Case kees) fvi
		= freeVariablesOfCase kees fvi
	where
		freeVariablesOfCase {case_expr,case_guards,case_default, case_info_ptr} fvi=:{fvi_variables, fvi_var_heap}
			# (removed_variables, fvi_var_heap) = removeVariables fvi_variables fvi_var_heap
			  fvi = free_variables_of_guards case_guards { fvi & fvi_variables = [], fvi_var_heap = fvi_var_heap }
			  {fvi_expr_heap, fvi_variables, fvi_var_heap, fvi_expr_ptrs} = freeVariables case_default fvi
			  (unbound_variables, fvi_var_heap) = determineGlobalVariables fvi_variables fvi_var_heap
			  (fvi_variables, fvi_var_heap) = restoreVariables removed_variables fvi_variables fvi_var_heap
			  (case_info, fvi_expr_heap) = readPtr case_info_ptr fvi_expr_heap
			= freeVariables case_expr { fvi & fvi_variables = fvi_variables, fvi_var_heap = fvi_var_heap,
					fvi_expr_heap = set_aci_free_vars_info_case unbound_variables case_info_ptr fvi_expr_heap,
					fvi_expr_ptrs = [case_info_ptr : fvi_expr_ptrs] }
		where
			free_variables_of_guards (AlgebraicPatterns _ alg_patterns) fvi
				= foldSt free_variables_of_alg_pattern alg_patterns fvi
			free_variables_of_guards (BasicPatterns _ basic_patterns) fvi
				= foldSt free_variables_of_basic_pattern basic_patterns fvi
			where
				free_variables_of_basic_pattern {bp_expr} fvi
					= freeVariables bp_expr fvi
			free_variables_of_guards (OverloadedListPatterns _ _ alg_patterns) fvi
				= foldSt free_variables_of_alg_pattern alg_patterns fvi
		
			free_variables_of_alg_pattern {ap_vars, ap_expr} fvi=:{fvi_variables}
				# fvi = freeVariables ap_expr { fvi & fvi_variables = [] }
				  (fvi_variables, fvi_var_heap) = removeLocalVariables ap_vars fvi.fvi_variables fvi_variables fvi.fvi_var_heap
				= { fvi & fvi_var_heap = fvi_var_heap, fvi_variables = fvi_variables }
		
	freeVariables (Selection _ expr selectors) fvi
		= freeVariables selectors (freeVariables expr fvi)
	freeVariables (Update expr1 selectors expr2) fvi
		= freeVariables expr2 (freeVariables selectors (freeVariables expr1 fvi))
	freeVariables (RecordUpdate cons_symbol expression expressions) fvi
		= freeVariables expressions (freeVariables expression fvi)
	freeVariables (TupleSelect _ arg_nr expr) fvi
		= freeVariables expr fvi
	freeVariables (MatchExpr _ expr) fvi
		= freeVariables expr fvi
	freeVariables (IsConstructor expr _ _ _ _ _) fvi
		= freeVariables expr fvi
	freeVariables EE fvi
		= fvi
	freeVariables _ fvi
		= fvi

instance freeVariables Selection
where
	freeVariables (RecordSelection _ _) fvi
		= fvi
	freeVariables (ArraySelection _ _ expr) fvi
		= freeVariables expr fvi
	freeVariables (DictionarySelection dict_var selections _ expr) fvi
		= freeVariables dict_var (freeVariables selections (freeVariables expr fvi))
	
removeVariables global_variables var_heap
	= foldSt remove_variable global_variables ([], var_heap)
where
	remove_variable v=:{var_info_ptr} (removed_variables, var_heap)
		# (VI_UsedVar used_var, var_heap) = readVarInfo var_info_ptr var_heap
		= ([(v, used_var) : removed_variables], writeVarInfo var_info_ptr VI_Empty var_heap)

restoreVariables removed_variables global_variables var_heap
	= foldSt restore_variable removed_variables (global_variables, var_heap)
where
	restore_variable (v=:{var_info_ptr}, var_id) (restored_variables, var_heap)
		# (var_info, var_heap) = readVarInfo var_info_ptr var_heap
		= case var_info of
			VI_UsedVar _
				-> (restored_variables, var_heap)
			_
				-> ([ v : restored_variables ], writeVarInfo var_info_ptr (VI_UsedVar var_id) var_heap)

determineGlobalVariables global_variables var_heap
	= foldSt determine_global_variable global_variables ([], var_heap)
where		
	determine_global_variable {var_info_ptr} (global_variables, var_heap)
		# (VI_UsedVar v_name, var_heap) = readVarInfo var_info_ptr var_heap
		= ([{var_ident = v_name, var_info_ptr = var_info_ptr, var_expr_ptr = nilPtr} : global_variables], var_heap)

removeLocalVariables local_variables all_variables global_variables var_heap
	# var_heap = foldSt mark_local_var local_variables var_heap
	= foldSt filter_local_var all_variables (global_variables, var_heap)
where
	mark_local_var {fv_info_ptr} var_heap
		= writeVarInfo fv_info_ptr VI_LocalVar var_heap

	filter_local_var v=:{var_info_ptr} (global_vars, var_heap)
		# (var_info, var_heap) = readVarInfo var_info_ptr var_heap
		= case var_info of
			VI_LocalVar
				-> (global_vars, var_heap)
			_
				-> ([ v : global_vars ], var_heap)

//@ fun_def & cons_arg getters...

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)

get_fun_def_and_cons_args :: !SymbKind !v:{!ConsClasses} !u:{#FunDef} !*FunctionHeap
		    -> (!FunDef, !ConsClasses, !v:{!ConsClasses},!u:{#FunDef},!*FunctionHeap)
get_fun_def_and_cons_args (SK_Function {glob_object}) cons_args fun_defs fun_heap
	# (fun_def, fun_defs) = fun_defs![glob_object]
	# (fun_args, cons_args) = cons_args![glob_object]
	= (fun_def, fun_args, cons_args, fun_defs, fun_heap)
get_fun_def_and_cons_args (SK_LocalMacroFunction glob_object) cons_args fun_defs fun_heap
	# (fun_def, fun_defs) = fun_defs![glob_object]
	# (fun_args, cons_args) = cons_args![glob_object]
	= (fun_def, fun_args, cons_args, fun_defs, fun_heap)
get_fun_def_and_cons_args (SK_GeneratedFunction fun_info_ptr fun_index) cons_args fun_defs fun_heap
	| fun_index < size fun_defs
		# (fun_def, fun_defs) = fun_defs![fun_index]
		# (fun_args, cons_args) = cons_args![fun_index]
		= (fun_def, fun_args, cons_args, fun_defs, fun_heap)
	# (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)

//@ <<<

instance <<< RootCaseMode where
	(<<<) file mode = case mode of NotRootCase -> file <<< "NotRootCase"; RootCase -> file <<< "RootCase"; RootCaseOfZombie -> file <<< "RootCaseOfZombie";

/*
instance <<< InstanceInfo
where
	(<<<) file (II_Node prods _ left right) = file <<< left <<< prods <<< right 
	(<<<) file II_Empty = file 

instance <<< Producer
where
	(<<<) file (PR_Function symbol _ index)
		= file <<< "(F)" <<< symbol.symb_ident
	(<<<) file (PR_GeneratedFunction symbol _ index)
		= file <<< "(G)" <<< symbol.symb_ident <<< index
	(<<<) file PR_Empty = file <<< 'E'
	(<<<) file (PR_Class app vars type) = file <<< "(Class(" <<< App app<<<","<<< type <<< "))"
	(<<<) file (PR_Curried {symb_ident, symb_kind} _) = file <<< "(Curried)" <<< symb_ident <<< symb_kind
	(<<<) file _ = file
*/
instance <<< Producer where
	(<<<) file PR_Empty
		= file <<< "(E)"
	(<<<) file PR_Unused
		= file <<< "(U)"
	(<<<) file (PR_Function ident int index)
		= file <<< "(F:" <<< ident <<< ")"
	(<<<) file (PR_Class app binds type)
		= file <<< "(O::" <<< app.app_symb <<< ")"
	(<<<) file (PR_Constructor ident int exprl)
		= file <<< "(C:" <<< ident <<< ")"
	(<<<) file (PR_GeneratedFunction ident arity index)
		= file <<< "(G:" <<< ident <<< ' ' <<< arity <<< ")"
	(<<<) file (PR_Curried ident arity)
		= file <<< "(P:" <<< ident <<< ' ' <<< arity <<< ")"
	(<<<) file (PR_CurriedFunction ident arity index)
		= file <<< "(CF:" <<< ident <<< ' ' <<< arity <<< ")"
	(<<<) file (PR_String _)
		= file <<< "(S)"
	(<<<) file (PR_Int _)
		= file <<< "(I)"
	(<<<) file (PR_Equal i)
		= file <<< "(=" <<< i <<< ')'
	(<<<) file (PR_EqualRemove i)
		= file <<< "(=R" <<< i <<< ')'

instance <<< {!a} | <<< a
where
	(<<<) file array
		# file = file <<< "{"
		= showBody 0 (size array) array file
	where
		showBody i m a f
			| i >= m	= f <<< "}"
						= showBody (inc i) m a (f <<< a.[i] <<< ", ")

instance <<< SymbKind
where
	(<<<) file SK_Unknown = file <<< "(SK_Unknown)"
	(<<<) file (SK_Function gi) = file <<< "(SK_Function)" <<< gi
	(<<<) file (SK_IclMacro gi) = file <<< "(SK_IclMacro)" <<< gi
	(<<<) file (SK_LocalMacroFunction gi) = file <<< "(SK_LocalMacroFunction)" <<< gi
	(<<<) file (SK_DclMacro gi) = file <<< "(SK_DclMacro)" <<< gi
	(<<<) file (SK_LocalDclMacroFunction gi) = file <<< "(SK_LocalDclMacroFunction)" <<< gi
	(<<<) file (SK_OverloadedFunction gi) = file <<< "(SK_OverloadedFunction)" <<< gi
	(<<<) file (SK_GeneratedFunction _ gi) = file <<< "(SK_GeneratedFunction)" <<< gi
	(<<<) file (SK_Constructor gi) = file <<< "(SK_Constructor)" <<< gi
	(<<<) file (SK_Generic gi tk) = file <<< "(SK_Constructor)" <<< gi
	(<<<) file SK_TypeCode = file <<< "(SK_TypeCode)"
	(<<<) file _ = file <<< "(SK_UNKNOWN)"
	
instance <<< ConsClasses
where
	(<<<) file {cc_args,cc_linear_bits,cc_producer} = file <<< cc_args <<< cc_linear_bits <<< cc_producer

instance <<< [#a!] | UTSList,<<< a
where
	(<<<) file [|] = file <<< "[]"
	(<<<) file l  = showTail (file <<< "[") l
	where
		showTail f [|x]   = f <<< x <<< "] "
		showTail f [|a:x] = showTail (f <<< a <<< ", ") x
		showTail f [|]    = f <<< "] "

instance <<< InstanceInfo
  where
	(<<<) file ii = (write_ii ii (file <<< "[")) <<< "]"
	  where
		write_ii II_Empty file
			= file
		write_ii (II_Node producers _ l r) file
			# file = write_ii l file <<< "("
			  file = foldSt (\pr file -> file<<<pr<<<",") [el \\ el<-:producers] file
			= write_ii r (file<<<")")

instance <<< (Ptr a)
where
	(<<<) file p = file <<< ptrToInt p

instance <<< SymbIdent
where
	(<<<) file symb=:{symb_kind = SK_Function symb_index }
		= file <<< symb.symb_ident <<<  '@' <<< symb_index
	(<<<) file symb=:{symb_kind = SK_LocalMacroFunction symb_index }
		= file <<< symb.symb_ident <<<  '@' <<< symb_index
	(<<<) file symb=:{symb_kind = SK_GeneratedFunction _ symb_index }
		= file <<< symb.symb_ident <<<  '@' <<< symb_index
	(<<<) file symb=:{symb_kind = SK_OverloadedFunction symb_index }
		= file <<< symb.symb_ident <<<  "[o]@" <<< symb_index
	(<<<) file symb
		= file <<< symb.symb_ident 
/*
instance <<< {!Type}
where
	(<<<) file subst
		= file <<< "{"<<<[s\\s<-:subst] <<< "}\n"
*/
// SPECIAL...
instance <<< Specials
where
	(<<<) file spec = case spec of
		(SP_ParsedSubstitutions 	_)	-> file <<< "SP_ParsedSubstitutions"
		(SP_Substitutions 		 	_)	-> file <<< "SP_Substitutions"
		(SP_ContextTypes			l)	-> file <<< "(SP_ContextTypes: " <<< l <<< ")"
		(SP_TypeOffset				_)	-> file <<< "SP_TypeOffset"
		SP_None							-> file <<< "SP_None"

instance <<< Special
where
	(<<<) file {spec_index,spec_types,spec_vars,spec_attrs}
		= file <<< "spec_index" <<< spec_index <<< "spec_types" <<< spec_types <<< "spec_vars" <<< spec_vars <<< "spec_attrs" <<< spec_attrs

instance <<< ExprInfo
where
	(<<<) file EI_Empty = file <<< "EI_Empty"
	(<<<) file (EI_DictionaryType t) = file <<< "<EI_DictionaryType: " <<< t <<< ">"
//	(<<<) file (EI_Instance symb exprs) = file <<< symb <<< exprs
//	(<<<) file (EI_Selection sels var_ptr exprs) = file <<< sels <<< var_ptr <<< exprs
//	(<<<) file (EI_Context exprs) = file <<< exprs
	(<<<) file _ = file <<< "EI_Other"

instance <<< TypeContext
where
	(<<<) file co = file <<< co.tc_class <<< " " <<< co.tc_types <<< " <" <<< co.tc_var <<< '>'

resolveContext :: ![TypeContext] ![ExprInfo] -> [[Type]]
resolveContext [tc:tcs] [EI_DictionaryType t:eis]
	= minimiseContext tc t ++ resolveContext tcs eis
resolveContext _ _ = []

minimiseContext {tc_class = TCClass gds} (TA ti ts)
	# tc_index = {glob_module = gds.glob_module, glob_object = gds.glob_object.ds_index}
	| tc_index == ti.type_index
		= [[at_type \\ {at_type} <- ts]]
		= []
minimiseContext _ _ = []

findInstInSpecials :: ![[.Type]] ![.Special] -> .(!Int,!(Global Int))
findInstInSpecials insts []
	= (0,{glob_object= -1,glob_module = -1})
findInstInSpecials insts [{spec_types,spec_index}:specials]
	| matchTypes insts spec_types
		= (length spec_types, spec_index)
	= findInstInSpecials insts specials

matchTypes [] [] = True
matchTypes [l:ls] [r:rs]
	= l == r && matchTypes ls rs
matchTypes _ _ = False

foundSpecial {glob_object= -1,glob_module = -1}	= False
foundSpecial _ = True	

// ...SPECIAL

arity_warning msg symb_ident fun_index fun_arity ti
	| fun_arity <= 32
		= ti
	= {ti & ti_error_file = ti.ti_error_file <<< "Warning: Arity > 32 " <<< msg <<< " " <<< fun_arity <<< " " <<< symb_ident <<< "@" <<< fun_index <<< "\n"}

strip_universal_quantor :: SymbolType -> SymbolType
strip_universal_quantor st=:{st_vars,st_args,st_result}
	# (st_result,st_vars)	= strip st_result st_vars
	# (st_args,st_vars)		= mapSt strip st_args st_vars
	= {st & st_vars = st_vars, st_args = st_args, st_result = st_result}
where
	strip :: AType [TypeVar] -> (AType,[TypeVar])
	strip atype=:{at_type = TFA vars type} tvs
		= ({atype & at_type = type}, map (\{atv_variable}->atv_variable) vars ++ tvs)
	strip atype=:{at_type = TFAC vars type contexts} tvs
		= ({atype & at_type = type}, map (\{atv_variable}->atv_variable) vars ++ tvs)
	strip atype tvs
		= (atype,tvs)

mapOpt f [Yes a:x]	= [Yes (f a):mapOpt f x]
mapOpt f [No:x]		= [No:mapOpt f x]
mapOpt f [] 		= []

class copy a :: !a !CopyInfo !*CopyState -> (!a, !*CopyState)

instance copy Expression
where
	copy (Var var) ci cs
		= copyVariable var ci cs
	copy (App app) ci cs
		# (app, cs) = copy app ci cs
		= (App app, cs)
	copy (expr @ exprs) ci cs
		# ((expr,exprs), cs) = copy (expr,exprs) ci cs
		= (expr @ exprs, cs)
	copy (Let lad) ci cs
		# (lad, cs) = copyLet lad No ci cs
		= (Let lad, cs)
	copy (Case case_expr) ci cs
		# (case_expr, cs) = copyCase case_expr No ci cs
		= (Case case_expr, cs)
	copy (Selection selector_kind=:NormalSelector (Var var) selectors=:[RecordSelection _ field_n]) ci cs	
		# (var_info,var_heap) = readVarInfo var.var_info_ptr cs.cs_var_heap
		  cs = {cs & cs_var_heap=var_heap}
		= case var_info of
			VI_Expression expr
				-> (Selection selector_kind expr selectors, cs)
			VI_Variable var_ident var_info_ptr
			 	# (var_expr_ptr, cs_symbol_heap) = newPtr EI_Empty cs.cs_symbol_heap
				  expr = Var {var_ident = var_ident, var_info_ptr = var_info_ptr, var_expr_ptr = var_expr_ptr}
				-> (Selection selector_kind expr selectors, {cs & cs_symbol_heap = cs_symbol_heap})
			VI_Dictionary app_symb app_args class_type
				# (expr,cs) = copy_dictionary_variable app_symb app_args class_type ci cs
				-> (Selection selector_kind expr selectors, cs)
			VI_Body fun_ident {tb_args, tb_rhs} new_aci_params original_type_vars new_type_vars
				# tb_args_ptrs = [ fv_info_ptr \\ {fv_info_ptr}<-tb_args ] 
				  (original_bindings, cs_var_heap) = mapSt readPtr tb_args_ptrs cs.cs_var_heap
				  cs_var_heap = bind_vars tb_args_ptrs new_aci_params cs_var_heap
				  cs = { cs & cs_var_heap = cs_var_heap }
				-> case tb_rhs of
					App {app_symb={symb_kind=SK_Constructor _},app_args}
						# (expr,cs) = copy (app_args!!field_n) ci cs
						  cs_var_heap = fold2St writePtr tb_args_ptrs original_bindings cs.cs_var_heap
						-> (expr, {cs & cs_var_heap = cs_var_heap})
					_
						# (expr,cs) = copy tb_rhs ci cs
						  cs_var_heap = fold2St writePtr tb_args_ptrs original_bindings cs.cs_var_heap
						-> (Selection selector_kind expr selectors, {cs & cs_var_heap = cs_var_heap})
			VI_ExpressionOrBody expr _ _ _ _ _
				-> (Selection selector_kind expr selectors, cs)
			_
				-> (Selection selector_kind (Var var) selectors, cs)
	copy (Selection selector_kind expr selectors) ci cs
		# ((expr, selectors), cs) = copy (expr, selectors) ci cs
		= (Selection selector_kind expr selectors, cs)
	copy (Update expr1 selectors expr2) ci cs
		# (((expr1, expr2), selectors), cs) = copy ((expr1, expr2), selectors) ci cs
		= (Update expr1 selectors expr2, cs)
	copy (RecordUpdate cons_symbol expression expressions) ci cs
		# ((expression, expressions), cs) = copy (expression, expressions) ci cs
		= (RecordUpdate cons_symbol expression expressions, cs)
	copy (TupleSelect symbol argn_nr expr) ci cs
		# (expr, cs) = copy expr ci cs
		= (TupleSelect symbol argn_nr expr, cs)
	copy (MatchExpr cons_ident expr) ci cs
		# (expr, cs) = copy expr ci cs
		= (MatchExpr cons_ident expr, cs)
	copy (IsConstructor expr cons_symbol cons_arity global_type_index case_ident position) ci cs
		# (expr, cs) = copy expr ci cs
		= (IsConstructor expr cons_symbol cons_arity global_type_index case_ident position, cs)
	copy (DynamicExpr expr) ci cs
		# (expr, cs) = copy expr ci cs
		= (DynamicExpr expr, cs)
	copy (TypeSignature type_function expr) ci cs
		# (expr, cs) = copy expr ci cs
		= (TypeSignature type_function expr, cs)
	copy (DictionariesFunction dictionaries expr expr_type) ci cs
		// the variables in dictionaries are not copied
		# (expr, cs) = copy expr ci cs
		= (DictionariesFunction dictionaries expr expr_type,cs)
	copy expr ci cs
		= (expr, cs)

copyVariable :: !BoundVar CopyInfo !*CopyState -> (!Expression, !*CopyState)
copyVariable var=:{var_info_ptr} ci cs
	# (var_info,var_heap) = readVarInfo var_info_ptr cs.cs_var_heap
	  cs = {cs & cs_var_heap=var_heap}
	= case var_info of
		VI_Expression expr
			-> (expr, cs)
		VI_Variable var_ident var_info_ptr
			# (var_expr_ptr, cs_symbol_heap) = newPtr EI_Empty cs.cs_symbol_heap
			-> (Var {var_ident = var_ident, var_info_ptr = var_info_ptr, var_expr_ptr = var_expr_ptr}, { cs & cs_symbol_heap = cs_symbol_heap})
		VI_Body fun_ident _ vars _ _
			-> (App {	app_symb = fun_ident,
						app_args = [ Var { var_ident=fv_ident, var_info_ptr=fv_info_ptr, var_expr_ptr=nilPtr }
									\\ {fv_ident,fv_info_ptr}<-vars],
						app_info_ptr = nilPtr }, cs)
		VI_Dictionary app_symb app_args class_type
			-> copy_dictionary_variable app_symb app_args class_type ci cs
		VI_ExpressionOrBody expr _ _ _ _ _
			-> (expr, cs)
		_
			-> (Var var, cs)

copy_dictionary_variable app_symb app_args class_type ci cs
	# (new_class_type, cs_opt_type_heaps) = substitute_class_types class_type cs.cs_opt_type_heaps
	  (new_info_ptr, cs_symbol_heap) = newPtr (EI_DictionaryType new_class_type) cs.cs_symbol_heap
	  app = App { app_symb = app_symb, app_args = app_args, app_info_ptr = new_info_ptr }
	  cs = { cs & cs_opt_type_heaps = cs_opt_type_heaps, cs_symbol_heap = cs_symbol_heap }
	= copy app ci cs
  where
	substitute_class_types class_types No
		= (class_types, No)
	substitute_class_types class_types (Yes type_heaps)
		# (_, new_class_types, type_heaps) = substitute class_types type_heaps
		= (new_class_types, Yes type_heaps)

instance copy DynamicExpr
where
	copy expr=:{dyn_expr, dyn_info_ptr} ci cs=:{cs_symbol_heap}
		# (dyn_info, cs_symbol_heap) = readPtr dyn_info_ptr cs_symbol_heap
		# (new_dyn_info_ptr, cs_symbol_heap) = newPtr dyn_info cs_symbol_heap
		# (dyn_expr, cs) = copy dyn_expr ci {cs & cs_symbol_heap=cs_symbol_heap}
		= ({ expr & dyn_expr = dyn_expr, dyn_info_ptr = new_dyn_info_ptr }, cs)

instance copy Selection
where
	copy (ArraySelection array_select expr_ptr index_expr) ci cs=:{cs_symbol_heap}
		# (new_ptr, cs_symbol_heap) = newPtr EI_Empty cs_symbol_heap
		  (index_expr, cs) = copy index_expr ci { cs & cs_symbol_heap = cs_symbol_heap}
		= (ArraySelection array_select new_ptr index_expr, cs)
	copy (DictionarySelection var selectors expr_ptr index_expr) ci cs=:{cs_symbol_heap}
		# (new_ptr, cs_symbol_heap) = newPtr EI_Empty cs_symbol_heap
		  (index_expr, cs) = copy index_expr ci { cs & cs_symbol_heap = cs_symbol_heap}
		  (var_expr, cs) = copyVariable var ci cs
		= case var_expr of 
			App {app_symb={symb_kind= SK_Constructor _ }, app_args}
				# [RecordSelection _ field_index:_] = selectors
				  (App { app_symb = {symb_ident, symb_kind = SK_Function array_select}}) =  app_args !! field_index
				-> (ArraySelection { array_select & glob_object = { ds_ident = symb_ident, ds_arity = 2, ds_index = array_select.glob_object}}
							new_ptr index_expr, cs)
			Var var
				-> (DictionarySelection var selectors new_ptr index_expr, cs)
	copy record_selection ci cs
		= (record_selection, cs)

instance copy FreeVar
where
	copy fv=:{fv_info_ptr,fv_ident} ci cs=:{cs_var_heap}
		# (new_info_ptr, cs_var_heap) = newPtr VI_Empty cs_var_heap
		= ({ fv & fv_info_ptr = new_info_ptr }, { cs & cs_var_heap = writePtr fv_info_ptr (VI_Variable fv_ident new_info_ptr) cs_var_heap })

instance copy App
where
	copy app=:{app_symb={symb_kind}, app_args, app_info_ptr} ci cs
		= case symb_kind of
			SK_Function {glob_module,glob_object}
				-> copy_function_app app ci cs
			SK_IclMacro macro_index
				-> copy_function_app app ci cs
			SK_DclMacro {glob_module,glob_object}
				-> copy_function_app app ci cs
			SK_OverloadedFunction {glob_module,glob_object}
				-> copy_function_app app ci cs
			SK_Generic {glob_module,glob_object} kind
				-> copy_function_app app ci cs
			SK_LocalMacroFunction local_macro_function_n
				-> copy_function_app app ci cs
			SK_LocalDclMacroFunction {glob_module,glob_object}
				-> copy_function_app app ci cs
			SK_Constructor _
				| not (isNilPtr app_info_ptr)
					# (app_info, cs_symbol_heap) = readPtr app_info_ptr cs.cs_symbol_heap
					  (new_app_info, cs_opt_type_heaps) = substitute_EI_DictionaryType app_info cs.cs_opt_type_heaps
					  (new_info_ptr, cs_symbol_heap) = newPtr new_app_info cs_symbol_heap
					  cs={ cs & cs_symbol_heap = cs_symbol_heap, cs_opt_type_heaps = cs_opt_type_heaps }
					  (app_args, cs) = copy app_args ci cs
					-> ({ app & app_args = app_args, app_info_ptr = new_info_ptr}, cs) 
					# (app_args, cs) = copy app_args ci cs
					-> ({ app & app_args = app_args}, cs)
			_
				# (app_args, cs) = copy app_args ci cs
				-> ({ app & app_args = app_args, app_info_ptr = nilPtr}, cs) 
	where
		copy_function_app app=:{app_args, app_info_ptr} ci cs
			# (new_info_ptr, cs_symbol_heap) = newPtr EI_Empty cs.cs_symbol_heap
			# cs={ cs & cs_symbol_heap = cs_symbol_heap }
			# (app_args, cs) = copy app_args ci cs
			= ({ app & app_args = app_args, app_info_ptr = new_info_ptr}, cs) 

		substitute_EI_DictionaryType (EI_DictionaryType class_type) (Yes type_heaps)
			# (_, new_class_type, type_heaps) = substitute class_type type_heaps
			= (EI_DictionaryType new_class_type, Yes type_heaps)
		substitute_EI_DictionaryType x opt_type_heaps
			= (x, opt_type_heaps)

instance copy LetBind
where
	copy bind=:{lb_src} ci cs
		# (lb_src, cs) = copy lb_src ci cs
		= ({ bind & lb_src = lb_src }, cs)

instance copy (Bind a b) | copy a
where
	copy bind=:{bind_src} ci cs
		# (bind_src, cs) = copy bind_src ci cs
		= ({ bind & bind_src = bind_src }, cs)

copyCaseAlt (Let lad) opt_result_type ci cs
	# (lad, cs) = copyLet lad opt_result_type ci cs
	= (Let lad, cs)
copyCaseAlt (Case case_expr) opt_result_type ci cs
	# (case_expr, cs) = copyCase case_expr opt_result_type ci cs
	= (Case case_expr, cs)
copyCaseAlt expr opt_result_type ci cs
	= copy expr ci cs

copyOptCaseAlt (Yes expr) opt_result_type ci cs
	# (expr,cs) = copyCaseAlt expr opt_result_type ci cs
	= (Yes expr, cs)
copyOptCaseAlt No opt_result_type ci cs
	= (No, cs)

copyCase :: !Case !(Optional AType) !CopyInfo !*CopyState -> (!Case, !*CopyState)
copyCase kees=:{case_expr,case_guards,case_default,case_info_ptr} opt_result_type ci cs=:{cs_cleanup_info}
	# (old_case_info, cs_symbol_heap) = readPtr case_info_ptr cs.cs_symbol_heap
	  (new_case_info, opt_result_type, cs_opt_type_heaps) = substitute_case_type old_case_info opt_result_type cs.cs_opt_type_heaps
	  (new_info_ptr, cs_symbol_heap) = newPtr new_case_info cs_symbol_heap
	  cs_cleanup_info = case old_case_info of
							EI_Extended _ _	-> [new_info_ptr:cs_cleanup_info]
							_				-> cs_cleanup_info
	  cs = { cs & cs_symbol_heap = cs_symbol_heap, cs_opt_type_heaps = cs_opt_type_heaps, cs_cleanup_info=cs_cleanup_info }
	  (case_guards, cs) = copyCasePatterns case_guards opt_result_type ci cs
	  (case_default, cs) = copyOptCaseAlt case_default opt_result_type ci cs
	  (case_expr, cs) = update_active_case_info_and_copy case_expr new_info_ptr cs
	= ({ kees & case_expr = case_expr,case_guards = case_guards, case_default = case_default, case_info_ptr = new_info_ptr}, cs)
where
	update_active_case_info_and_copy case_expr=:(Var {var_info_ptr}) case_info_ptr cs
		# (case_info, cs_symbol_heap) = readPtr case_info_ptr cs.cs_symbol_heap
		  cs = { cs & cs_symbol_heap = cs_symbol_heap }
		= case case_info of
			EI_Extended (EEI_ActiveCase aci=:{aci_free_vars}) ei
				# (new_aci_free_vars, cs) = case ci.ci_handle_aci_free_vars of
												LeaveAciFreeVars
													-> (aci_free_vars, cs)
												RemoveAciFreeVars
													-> (No, cs)
												SubstituteAciFreeVars
													-> case aci_free_vars of
															No		-> (No, cs)
															Yes fvs	# (fvs_subst, cs) = mapSt copyBoundVar fvs cs
																	-> (Yes fvs_subst, cs)
				  (var_info,var_heap) = readVarInfo var_info_ptr cs.cs_var_heap
				  cs = {cs & cs_var_heap=var_heap}
				-> case var_info of
					VI_Body fun_ident {tb_args, tb_rhs} new_aci_params original_type_vars new_type_vars
						# (old_original_type_vars_values,cs_opt_type_heaps)
							= forward_old_type_vars_to_new_type_vars original_type_vars new_type_vars cs.cs_opt_type_heaps
						  // replacing the type variables is only necessary if the consumer is the same function as the producer
						  tb_args_ptrs = [ fv_info_ptr \\ {fv_info_ptr}<-tb_args ] 
						  (original_bindings, cs_var_heap) = mapSt readPtr tb_args_ptrs cs.cs_var_heap
						  cs_var_heap = bind_vars tb_args_ptrs new_aci_params cs_var_heap
						  cs & cs_var_heap = cs_var_heap, cs_opt_type_heaps = cs_opt_type_heaps
						  (tb_rhs, cs) = copy tb_rhs ci cs
						  cs_var_heap = fold2St writePtr tb_args_ptrs original_bindings cs.cs_var_heap
						  new_aci = { aci & aci_params = new_aci_params, aci_opt_unfolder = Yes fun_ident, aci_free_vars = new_aci_free_vars }
						  new_eei = (EI_Extended (EEI_ActiveCase new_aci) ei)
						  cs_symbol_heap = writePtr case_info_ptr new_eei cs.cs_symbol_heap
						  cs_opt_type_heaps = restore_old_type_vars_values original_type_vars old_original_type_vars_values cs.cs_opt_type_heaps
						-> (tb_rhs, {cs & cs_var_heap = cs_var_heap, cs_symbol_heap = cs_symbol_heap, cs_opt_type_heaps = cs_opt_type_heaps})
					_	# new_eei = EI_Extended (EEI_ActiveCase { aci & aci_free_vars = new_aci_free_vars }) ei
						  cs_symbol_heap = writePtr case_info_ptr new_eei cs.cs_symbol_heap
						-> copy case_expr ci { cs & cs_symbol_heap = cs_symbol_heap }
			_	-> copy case_expr ci cs
	update_active_case_info_and_copy (Var var=:{var_info_ptr} @ exprs) case_info_ptr cs
		# (exprs,cs) = copy exprs ci cs
		| is_var_list exprs
			# (var_info,var_heap) = readVarInfo var_info_ptr cs.cs_var_heap
			  cs & cs_var_heap=var_heap
			= case var_info of
				VI_ExpressionOrBody _ fun_ident {tb_args, tb_rhs} new_aci_params original_type_vars new_type_vars
					# (old_original_type_vars_values,cs_opt_type_heaps)
						= forward_old_type_vars_to_new_type_vars original_type_vars new_type_vars cs.cs_opt_type_heaps
					  // replacing the type variables is only necessary if the consumer is the same function as the producer
					  tb_args_ptrs = [fv_info_ptr \\ {fv_info_ptr}<-tb_args] 
					  (original_bindings, cs_var_heap) = mapSt readPtr tb_args_ptrs cs.cs_var_heap
					  (extra_exprs,cs_var_heap) = bind_variables tb_args_ptrs new_aci_params exprs cs_var_heap
					  cs & cs_var_heap = cs_var_heap, cs_opt_type_heaps = cs_opt_type_heaps
					  (expr,cs) = copy tb_rhs ci cs

					  (case_info, cs_symbol_heap) = readPtr case_info_ptr cs.cs_symbol_heap
					  cs & cs_symbol_heap
						= case case_info of
							EI_Extended (EEI_ActiveCase aci) ei
								# aci & aci_opt_unfolder = No
								-> writePtr case_info_ptr (EI_Extended (EEI_ActiveCase aci) ei) cs_symbol_heap
							_
								-> cs_symbol_heap

					  cs_var_heap = fold2St writePtr tb_args_ptrs original_bindings cs.cs_var_heap
					  cs_opt_type_heaps = restore_old_type_vars_values original_type_vars old_original_type_vars_values cs.cs_opt_type_heaps
					  cs & cs_var_heap = cs_var_heap, cs_opt_type_heaps = cs_opt_type_heaps
					-> case extra_exprs of
						[]
							-> (expr,cs)
						extra_exprs
							-> (expr @ extra_exprs, cs)
					where
						bind_variables :: [VarInfoPtr] [FreeVar] [Expression] *VarHeap -> (![Expression],!*VarHeap)
						bind_variables [fv_info_ptr:arg_ptrs] [{fv_ident=name, fv_info_ptr=info_ptr}:new_aci_params] exprs var_heap
							# (exprs,var_heap) = bind_variables arg_ptrs new_aci_params exprs var_heap
							# var_heap = writeVarInfo fv_info_ptr (VI_Expression (Var {var_ident=name, var_info_ptr=info_ptr, var_expr_ptr = nilPtr})) var_heap
							= (exprs,var_heap)
						bind_variables arg_ptrs=:[_:_] [] exprs var_heap
							= bind_variables_for_exprs arg_ptrs exprs var_heap
						bind_variables [] [] exprs var_heap
							= (exprs,var_heap)

						bind_variables_for_exprs :: [VarInfoPtr] [Expression] *VarHeap -> (![Expression],!*VarHeap)
						bind_variables_for_exprs [fv_info_ptr:arg_ptrs] [Var {var_ident=name, var_info_ptr=info_ptr}:exprs] var_heap
							# (exprs,var_heap) = bind_variables_for_exprs arg_ptrs exprs var_heap
							# var_heap = writeVarInfo fv_info_ptr (VI_Expression (Var {var_ident=name, var_info_ptr=info_ptr, var_expr_ptr = nilPtr})) var_heap
							= (exprs,var_heap)
						bind_variables_for_exprs [] exprs var_heap
							= (exprs,var_heap)
				_
					# (expr,cs) = copyVariable var ci cs
					-> (expr @ exprs, cs)
			# (expr,cs) = copyVariable var ci cs
			= (expr @ exprs, cs)
		where
			is_var_list [Var _:exprs] = is_var_list exprs
			is_var_list [_ : _] = False
			is_var_list [] = True
	update_active_case_info_and_copy case_expr _ cs
		= copy case_expr ci cs

	copyBoundVar {var_info_ptr} cs
		# (VI_Expression (Var act_var), cs_var_heap) = readPtr var_info_ptr cs.cs_var_heap
		= (act_var, { cs & cs_var_heap = cs_var_heap })

bind_vars dest_info_ptrs src_free_vars var_heap
	= fold2St bind dest_info_ptrs src_free_vars var_heap
where
	bind fv_info_ptr {fv_ident=name, fv_info_ptr=info_ptr} var_heap
		= writeVarInfo fv_info_ptr (VI_Expression (Var {var_ident=name, var_info_ptr=info_ptr, var_expr_ptr = nilPtr})) var_heap

forward_old_type_vars_to_new_type_vars :: ![TypeVar] ![TypeVar] !*(Optional *TypeHeaps) -> (![TypeVarInfo],!*Optional *TypeHeaps)
forward_old_type_vars_to_new_type_vars original_type_vars new_type_vars No
	= ([],No)
forward_old_type_vars_to_new_type_vars original_type_vars new_type_vars (Yes type_heaps)
	# (old_type_vars_values,th_vars) = forward_old_type_vars_to_new_type_vars original_type_vars new_type_vars type_heaps.th_vars
	= (old_type_vars_values,Yes {type_heaps & th_vars=th_vars})
where
	forward_old_type_vars_to_new_type_vars :: ![TypeVar] ![TypeVar] !*TypeVarHeap -> (![TypeVarInfo],!*TypeVarHeap)
	forward_old_type_vars_to_new_type_vars [original_type_var:original_type_vars] [new_type_var:new_type_vars] type_var_heap
		# (old_type_vars_values,type_var_heap) = forward_old_type_vars_to_new_type_vars original_type_vars new_type_vars type_var_heap
		# (old_type_var_value,type_var_heap) = readPtr original_type_var.tv_info_ptr type_var_heap
		# (new_type_var_value,type_var_heap) = readPtr new_type_var.tv_info_ptr type_var_heap
		= case new_type_var_value of
			TVI_Type type
				# type_var_heap = writePtr original_type_var.tv_info_ptr new_type_var_value type_var_heap
				-> ([old_type_var_value:old_type_vars_values],type_var_heap)
			_
				# type_var_heap = writePtr original_type_var.tv_info_ptr (TVI_Type (TV new_type_var)) type_var_heap
				-> ([old_type_var_value:old_type_vars_values],type_var_heap)
	forward_old_type_vars_to_new_type_vars [] [] type_var_heap
		= ([],type_var_heap)

restore_old_type_vars_values :: ![TypeVar] ![TypeVarInfo] !*(Optional *TypeHeaps) -> *Optional *TypeHeaps
restore_old_type_vars_values original_type_vars old_original_type_vars_values No
	= No
restore_old_type_vars_values original_type_vars old_original_type_vars_values (Yes type_heaps)
	# type_heaps & th_vars = write_old_type_vars_values original_type_vars old_original_type_vars_values type_heaps.th_vars
	= Yes type_heaps
where
	write_old_type_vars_values [{tv_info_ptr}:type_vars] [type_var_value:type_var_values] type_var_heap
		# type_var_heap = writePtr tv_info_ptr type_var_value type_var_heap
		= write_old_type_vars_values type_vars type_var_values type_var_heap
	write_old_type_vars_values [] [] type_var_heap
		= type_var_heap

copyLet :: !Let !(Optional AType) !CopyInfo !*CopyState -> (!Let, !*CopyState)
copyLet lad=:{let_strict_binds, let_lazy_binds, let_expr, let_info_ptr} optional_result_type ci cs
	# (let_strict_binds, cs) = copy_bound_vars let_strict_binds cs
	# (let_lazy_binds, cs) = copy_bound_vars let_lazy_binds cs
	# (let_strict_binds, cs) = copy let_strict_binds ci cs
	# (let_lazy_binds, cs) = copy let_lazy_binds ci cs
	# (let_expr, cs) = copyCaseAlt let_expr optional_result_type ci cs
	  (old_let_info, cs_symbol_heap) = readPtr let_info_ptr cs.cs_symbol_heap
	  (new_let_info, cs_opt_type_heaps) = substitute_let_type old_let_info cs.cs_opt_type_heaps
	  (new_info_ptr, cs_symbol_heap) = newPtr new_let_info cs_symbol_heap
	= ({lad & let_strict_binds = let_strict_binds, let_lazy_binds = let_lazy_binds, let_expr = let_expr, let_info_ptr = new_info_ptr},
		{ cs & cs_symbol_heap = cs_symbol_heap, cs_opt_type_heaps = cs_opt_type_heaps })
	where
		copy_bound_vars [bind=:{lb_dst} : binds] cs
			# (lb_dst, cs) = copy lb_dst ci cs
			  (binds, cs) = copy_bound_vars binds cs
			= ([ {bind & lb_dst = lb_dst} : binds ], cs)
		copy_bound_vars [] cs
			= ([], cs)

substitute_let_type expr_info No
	= (expr_info, No)
substitute_let_type (EI_Extended extensions expr_info) yes_type_heaps
	# (new_expr_info, yes_type_heaps) = substitute_let_type expr_info yes_type_heaps
	= (EI_Extended extensions new_expr_info, yes_type_heaps)
substitute_let_type expr_info=:(EI_LetType let_type) (Yes type_heaps)
	# (changed, new_let_type, type_heaps) = substitute let_type type_heaps
	| changed
		= (EI_LetType new_let_type, Yes type_heaps)
		= (expr_info, Yes type_heaps)

substitute_case_type expr_info parent_opt_result_type No
	= (expr_info, No, No)
substitute_case_type (EI_Extended extensions expr_info) parent_opt_result_type yes_type_heaps
	# (new_expr_info, opt_result_type, yes_type_heaps)
		= substitute_case_type expr_info parent_opt_result_type yes_type_heaps
	= (EI_Extended extensions new_expr_info, opt_result_type, yes_type_heaps)
substitute_case_type expr_info=:(EI_CaseType case_type) parent_opt_result_type (Yes type_heaps)
	# (changed, new_case_type, type_heaps) = substituteCaseType case_type parent_opt_result_type type_heaps
	| changed
		= (EI_CaseType new_case_type, Yes new_case_type.ct_result_type, Yes type_heaps)
		= (expr_info, Yes new_case_type.ct_result_type, Yes type_heaps)
where
	substituteCaseType {ct_pattern_type, ct_result_type, ct_cons_types} parent_opt_result_type heaps
		# (changed_pattern_type, pattern_type_r, heaps) = substitute ct_pattern_type heaps
		  (changed_result_type, result_type_r, heaps) = substitute ct_result_type heaps
		  (changed_cons_types, cons_types_r, heaps) = substitute ct_cons_types heaps
		| changed_pattern_type
			| changed_result_type
				# result_type_r = use_parent_result_type_if_equal parent_opt_result_type result_type_r
				| changed_cons_types
					= (True, {ct_pattern_type=pattern_type_r, ct_result_type=result_type_r, ct_cons_types=cons_types_r}, heaps)
					= (True, {ct_pattern_type=pattern_type_r, ct_result_type=result_type_r, ct_cons_types=ct_cons_types}, heaps)
				| changed_cons_types
					= (True, {ct_pattern_type=pattern_type_r, ct_result_type=ct_result_type, ct_cons_types=cons_types_r}, heaps)
					= (True, {ct_pattern_type=pattern_type_r, ct_result_type=ct_result_type, ct_cons_types=ct_cons_types}, heaps)
			| changed_result_type
				# result_type_r = use_parent_result_type_if_equal parent_opt_result_type result_type_r
				| changed_cons_types
					= (True, {ct_pattern_type=ct_pattern_type, ct_result_type=result_type_r, ct_cons_types=cons_types_r}, heaps)
					= (True, {ct_pattern_type=ct_pattern_type, ct_result_type=result_type_r, ct_cons_types=ct_cons_types}, heaps)
				| changed_cons_types
					= (True, {ct_pattern_type=ct_pattern_type, ct_result_type=ct_result_type, ct_cons_types=cons_types_r}, heaps)
					= (False, {ct_pattern_type=ct_pattern_type, ct_result_type=ct_result_type, ct_cons_types=ct_cons_types}, heaps)

	use_parent_result_type_if_equal (Yes parent_result_type) result_type_r
		| equal_atype result_type_r parent_result_type
			= parent_result_type
			= result_type_r
	use_parent_result_type_if_equal No result_type_r
		= result_type_r

copyCasePatterns :: !CasePatterns !(Optional AType) !CopyInfo !*CopyState -> *(!CasePatterns,!*CopyState)
copyCasePatterns (AlgebraicPatterns type patterns) opt_result_type ci cs
	# (patterns, cs) = copyAlgebraicPatterns patterns opt_result_type ci cs
	= (AlgebraicPatterns type patterns, cs)
copyCasePatterns (BasicPatterns type patterns) opt_result_type ci cs
	# (patterns, cs) = copyBasicPatterns patterns opt_result_type ci cs
	= (BasicPatterns type patterns, cs)
copyCasePatterns (OverloadedListPatterns type decons_expr patterns) opt_result_type ci cs
	# (patterns, cs) = copyAlgebraicPatterns patterns opt_result_type ci cs
	# (decons_expr, cs) = copy decons_expr ci cs
	= (OverloadedListPatterns type decons_expr patterns, cs)
copyCasePatterns (NewTypePatterns type patterns) opt_result_type ci cs
	# (patterns, cs) = copyAlgebraicPatterns patterns opt_result_type ci cs
	= (NewTypePatterns type patterns, cs)
copyCasePatterns (DynamicPatterns patterns) opt_result_type ci cs
	# (patterns, cs) = copy patterns ci cs
	= (DynamicPatterns patterns, cs)

copyAlgebraicPatterns [guard=:{ap_vars,ap_expr} : guards] opt_result_type ci cs
	# (ap_vars, cs) = copy ap_vars ci cs
	# (ap_expr, cs) = copyCaseAlt ap_expr opt_result_type ci cs
	#! guard & ap_vars = ap_vars, ap_expr = ap_expr
	# (guards, cs) = copyAlgebraicPatterns guards opt_result_type ci cs
	#! cs = cs
	= ([guard : guards], cs)
copyAlgebraicPatterns [] opt_result_type ci cs
 	= ([], cs)

copyBasicPatterns [guard=:{bp_expr} : guards] opt_result_type ci cs
	# (bp_expr, cs) = copyCaseAlt bp_expr opt_result_type ci cs
	#! guard & bp_expr = bp_expr
	# (guards, cs) = copyBasicPatterns guards opt_result_type ci cs
	#! cs = cs
	= ([guard : guards], cs)
copyBasicPatterns [] opt_result_type ci cs
 	= ([], cs)

instance copy DynamicPattern
where
	copy guard=:{dp_var,dp_rhs} ci cs
		# (dp_var, cs) = copy dp_var ci cs
		  (dp_rhs, cs) = copy dp_rhs ci cs
		= ({ guard & dp_var = dp_var, dp_rhs = dp_rhs }, cs)

instance copy [a] | copy a
where
	copy l ci cs
		= map_st l cs
		where
			map_st [x : xs] s
			 	# (x, s) = copy x ci s
				  (xs, s) = map_st xs s
				#! s = s
				= ([x : xs], s)
			map_st [] s
			 	= ([], s)

instance copy (a,b) | copy a & copy b
where
	copy (a,b) ci cs
		# (a,cs) = copy a ci cs
		# (b,cs) = copy b ci cs
		= ((a,b),cs)

instance copy (Optional a) | copy a
where
	copy (Yes x) ci cs
		# (x, cs) = copy x ci cs
		= (Yes x, cs)
	copy no ci cs
		= (no, cs)

equal_atype :: !AType !AType -> Bool
equal_atype {at_attribute=TA_Multi,at_type=type1} {at_attribute=TA_Multi,at_type=type2}
	= equal_type type1 type2
equal_atype {at_attribute=TA_Unique,at_type=type1} {at_attribute=TA_Unique,at_type=type2}
	= equal_type type1 type2
equal_atype {at_attribute=TA_Var {av_info_ptr=av_info_ptr1},at_type=type1} {at_attribute=TA_Var {av_info_ptr=av_info_ptr2},at_type=type2}
	= av_info_ptr1==av_info_ptr2 && equal_type type1 type2
equal_atype new_type old_type
	= False

equal_type :: !Type !Type -> Bool
equal_type (TA {type_index=type_index1} types1) (TA {type_index=type_index2} types2)
	= type_index1==type_index2 && equal_atypes types1 types2
equal_type (TAS {type_index=type_index1} types1 strictness1) (TAS {type_index=type_index2} types2 strictness2)
	= type_index1==type_index2 && equal_strictness_lists strictness1 strictness2 && equal_atypes types1 types2
equal_type (TB bt1) (TB bt2)
	= equal_basic_type bt1 bt2
equal_type (TV {tv_info_ptr=tv_info_ptr1}) (TV {tv_info_ptr=tv_info_ptr2})
	= tv_info_ptr1==tv_info_ptr2
equal_type new_type old_type
	= False

equal_basic_type BT_Int BT_Int = True
equal_basic_type BT_Char BT_Char = True
equal_basic_type BT_Bool BT_Bool = True
equal_basic_type BT_Real BT_Real = True
equal_basic_type BT_Dynamic BT_Dynamic = True
equal_basic_type BT_File BT_File = True
equal_basic_type BT_World BT_World = True
equal_basic_type _ _ = False

equal_atypes [] []
	= True
equal_atypes [atype1:atypes1] [atype2:atypes2]
	= equal_atype atype1 atype2 && equal_atypes atypes1 atypes2
equal_atypes new_types old_types
	= False