convertcases.icl

implementation module convertcases

import StdStrictLists
import syntax, compare_types, utilities, expand_types, general
from checksupport import ::Component(..),::ComponentMembers(..)

// exactZip fails when its arguments are of unequal length
exactZip :: ![.a] ![.b] -> [(.a,.b)]
exactZip [x:xs][y:ys]
	=	[(x,y) : exactZip xs ys]
exactZip [] []
	=	[]

getIdent :: (Optional Ident) Int -> Ident
getIdent (Yes ident) fun_nr
	= ident
getIdent No fun_nr
	= { id_name = "_f" +++ toString fun_nr, id_info = nilPtr }

addLetVars :: [LetBind] [AType] [(FreeVar, AType)] -> [(FreeVar, AType)]
addLetVars [{lb_dst} : binds] [bind_type : bind_types] bound_vars
	= addLetVars binds bind_types [ (lb_dst, bind_type) : bound_vars ]
addLetVars [] [] bound_vars
	= bound_vars

convertCasesOfFunctions :: !*{!Component} !Int !{#{#FunType}} !{#CommonDefs}
				!*{#FunDef} !*{#{#CheckedTypeDef}} !ImportedConstructors !*VarHeap !*TypeHeaps !*ExpressionHeap
			-> (!ImportedFunctions, !*{!Component},
				!*{#FunDef},!*{#{#CheckedTypeDef}},!ImportedConstructors,!*VarHeap,!*TypeHeaps,!*ExpressionHeap)
convertCasesOfFunctions groups main_dcl_module_n dcl_functions common_defs fun_defs imported_types imported_conses var_heap type_heaps expr_heap
	#! nr_of_funs = size fun_defs
	# (groups, (fun_defs, collected_imports, {cs_new_functions, cs_var_heap, cs_expr_heap, cs_fun_heap}))
			= convert_groups 0 groups dcl_functions common_defs main_dcl_module_n
				(fun_defs, [], { cs_new_functions = [], cs_fun_heap = newHeap, cs_var_heap = var_heap, cs_expr_heap = expr_heap, cs_next_fun_nr = nr_of_funs })
	  (groups, new_fun_defs, imported_types, imported_conses, type_heaps, cs_var_heap)
			= addNewFunctionsToGroups common_defs cs_fun_heap cs_new_functions main_dcl_module_n groups imported_types imported_conses type_heaps cs_var_heap
	  (imported_functions, imported_conses) = foldSt split collected_imports ([], imported_conses)
	= (imported_functions, groups, { fundef \\ fundef <- [ fundef \\ fundef <-: fun_defs ] ++ new_fun_defs },
			imported_types, imported_conses, cs_var_heap, type_heaps, cs_expr_heap)
where
	convert_groups group_nr groups dcl_functions common_defs main_dcl_module_n fun_defs_and_ci
		| group_nr == size groups
			= (groups, fun_defs_and_ci)
		// otherwise
			# (group, groups) = groups![group_nr]
			= convert_groups (inc group_nr) groups dcl_functions common_defs main_dcl_module_n
				(convert_functions group.component_members group_nr dcl_functions common_defs main_dcl_module_n fun_defs_and_ci)

	convert_functions (ComponentMember member members) group_nr dcl_functions common_defs main_dcl_module_n fun_defs_and_ci
		# fun_defs_and_ci = convert_function group_nr dcl_functions common_defs main_dcl_module_n member fun_defs_and_ci
		= convert_functions members group_nr dcl_functions common_defs main_dcl_module_n fun_defs_and_ci
	convert_functions (GeneratedComponentMember member _ members) group_nr dcl_functions common_defs main_dcl_module_n fun_defs_and_ci
		# fun_defs_and_ci = convert_function group_nr dcl_functions common_defs main_dcl_module_n member fun_defs_and_ci
		= convert_functions members group_nr dcl_functions common_defs main_dcl_module_n fun_defs_and_ci
	convert_functions NoComponentMembers group_nr dcl_functions common_defs main_dcl_module_n fun_defs_and_ci
		= fun_defs_and_ci

	convert_function group_index dcl_functions common_defs main_dcl_module_n fun (fun_defs, collected_imports, cs)
		# ({fun_body,fun_type}, fun_defs) = fun_defs![fun]
		  (fun_body, (collected_imports, cs))
				= eliminate_code_sharing_in_function dcl_functions main_dcl_module_n common_defs fun_body (collected_imports, cs)
		  (fun_body, cs) = convertCasesInBody fun_body fun_type group_index common_defs cs
		= ({fun_defs & [fun].fun_body = fun_body}, collected_imports, cs)

	eliminate_code_sharing_in_function dcl_functions main_dcl_module_n common_defs (TransformedBody body=:{tb_rhs}) (collected_imports, cs=:{cs_expr_heap,cs_var_heap})
		# {rcs_var_heap, rcs_expr_heap, rcs_imports} = weightedRefCount {rci_imported = {cii_dcl_functions=dcl_functions, cii_common_defs=common_defs, cii_main_dcl_module_n = main_dcl_module_n}, rci_depth=1} tb_rhs
				{ rcs_var_heap = cs_var_heap, rcs_expr_heap = cs_expr_heap, rcs_free_vars = [],
				  rcs_imports = collected_imports} 
		  ds = { ds_lets = [], ds_var_heap = rcs_var_heap, ds_expr_heap = rcs_expr_heap}
		  (tb_rhs, ds) = distributeLets {di_depth=1,di_explicit_case_depth=0} tb_rhs ds
		  (tb_rhs, {ds_var_heap, ds_expr_heap}) = buildLetExpr tb_rhs ds
		  {ss_expr_heap, ss_var_heap}
		  	= findSplitCases {si_next_alt=No, si_force_next_alt=False} tb_rhs {ss_var_heap=ds_var_heap, ss_expr_heap = ds_expr_heap}
		= (TransformedBody {body & tb_rhs = tb_rhs }, (rcs_imports, {cs & cs_var_heap = ss_var_heap, cs_expr_heap = ss_expr_heap}))

	split :: SymbKind (ImportedFunctions, ImportedConstructors) -> (ImportedFunctions, ImportedConstructors) 
	split (SK_Function fun_ident) (collected_functions, collected_conses)
		= ([fun_ident : collected_functions], collected_conses)
	split (SK_Constructor cons_ident) (collected_functions, collected_conses)
		= (collected_functions, [ cons_ident : collected_conses])

:: CaseLevel = CaseLevelRoot | CaseLevelAfterGuardRoot

:: ConvertInfo =
	{	ci_bound_vars :: ![(FreeVar, AType)]
	,	ci_group_index :: !Index
	,	ci_common_defs :: !{#CommonDefs}
	,	ci_case_level	:: !CaseLevel
	}

convertCasesInBody :: FunctionBody (Optional SymbolType) Int {#CommonDefs} *ConvertState -> (FunctionBody,  *ConvertState)
convertCasesInBody (TransformedBody body) (Yes type) group_index common_defs cs
	# (body, cs) = convertRootCases
						{	ci_bound_vars = exactZip body.tb_args type.st_args
						,	ci_group_index = group_index
						,	ci_common_defs = common_defs
						,	ci_case_level=CaseLevelRoot
						}
						body cs
	= (TransformedBody body, cs)

/*
	weightedRefCount determines the reference counts of variables in an expr. Runtime behaviour
	of constructs is taken into account:  multiple occurrences of variables in different
	alternatives of the same case clause are counted only once. The outcome is used to distribute
	shared exprs (via let declarations) over cases. In this way code sharing is eliminated.
	As a side effect, weightedRefCount returns a list of all imported functions that have been used
	inside the expr.
*/

::	CheckImportedInfo =
	{	cii_dcl_functions	:: !{# {# FunType} }
	,	cii_common_defs		:: !{# CommonDefs}
	,	cii_main_dcl_module_n :: !Int
	}

::	RCInfo =
	{	rci_imported	:: !CheckImportedInfo
	,	rci_depth		:: !Int
	}

::	RCState =
	{	rcs_free_vars	:: ![VarInfoPtr]
	,	rcs_imports		:: ![SymbKind]
	,	rcs_var_heap		:: !.VarHeap
	,	rcs_expr_heap	:: !.ExpressionHeap
	}

::	LetVarInfo =
	{	lvi_count		:: !Int
	,	lvi_depth		:: !Int
	,	lvi_new			:: !Bool
	,	lvi_var			:: !Ident
	,	lvi_expression	:: !Expression	
	,   lvi_previous	:: ![PreviousLetVarInfo]
	}

::	PreviousLetVarInfo =
	{	plvi_count		:: !Int
	,	plvi_depth		:: !Int
	,	plvi_new		:: !Bool
	}

::	RefCountsInCase = 
	{	rcc_all_variables		:: ![CountedVariable]
	,	rcc_default_variables	:: ![CountedVariable]
	,	rcc_pattern_variables	:: ![[CountedVariable]]
	}

::	CountedVariable =
	{	cv_variable	:: !VarInfoPtr
	,	cv_count	:: !Int
	}

checkImportedSymbol :: SymbKind VarInfoPtr ([SymbKind], *VarHeap) -> ([SymbKind], *VarHeap)
checkImportedSymbol symb_kind symb_type_ptr (collected_imports, var_heap)
	# (type_info, var_heap) = readPtr symb_type_ptr var_heap
	= case type_info of
		VI_Used
			-> (collected_imports, var_heap)
		_
			-> ([symb_kind : collected_imports ], var_heap <:= (symb_type_ptr, VI_Used))

weightedRefCountOfVariable depth var_info_ptr lvi=:{lvi_count,lvi_var,lvi_depth,lvi_previous,lvi_new} ref_count new_vars
	| lvi_depth < depth
		= (True, {lvi & lvi_count = ref_count, lvi_depth = depth, lvi_new = True, lvi_previous =
				[{plvi_count = lvi_count, plvi_depth = lvi_depth, plvi_new = lvi_new } : lvi_previous]}, [var_info_ptr : new_vars])
	| lvi_count == 0
		= (True, { lvi & lvi_count = ref_count }, [var_info_ptr : new_vars])
	// otherwise
		= (lvi_new, { lvi & lvi_count = lvi_count + ref_count }, new_vars)

class weightedRefCount e :: RCInfo !e !*RCState -> *RCState

instance weightedRefCount BoundVar
where
	weightedRefCount rci=:{rci_depth} {var_ident,var_info_ptr} rs=:{rcs_var_heap}
		# (var_info, rcs_var_heap) = readPtr var_info_ptr rcs_var_heap
		  rs = {rs & rcs_var_heap = rcs_var_heap}
		= case var_info of
			VI_LetVar lvi
				# (is_new, lvi=:{lvi_expression}, rcs_free_vars) = weightedRefCountOfVariable rci_depth var_info_ptr lvi 1 rs.rcs_free_vars
				| is_new
					# rs = weightedRefCount rci lvi_expression
							{ rs & rcs_free_vars = rcs_free_vars,
							  rcs_var_heap = rs.rcs_var_heap  <:= (var_info_ptr, VI_LetVar {lvi & lvi_expression = EE, lvi_new = False})}
					  (VI_LetVar lvi, rcs_var_heap) = readPtr var_info_ptr rs.rcs_var_heap
					-> { rs & rcs_var_heap = rcs_var_heap <:= (var_info_ptr, VI_LetVar { lvi & lvi_expression = lvi_expression }) }
				// otherwise
					-> { rs & rcs_var_heap = rs.rcs_var_heap <:= (var_info_ptr, VI_LetVar lvi) }
			_
				-> rs

instance weightedRefCount Expression
where
	weightedRefCount rci (Var var) rs
		= weightedRefCount rci var rs
	weightedRefCount rci (App app) rs
		= weightedRefCount rci app rs
	weightedRefCount rci (fun_expr @ exprs) rs
		= weightedRefCount rci (fun_expr, exprs) rs
	weightedRefCount rci=:{rci_depth} (Let {let_strict_binds,let_lazy_binds,let_expr, let_info_ptr}) rs =:{rcs_var_heap}
		# rs = weightedRefCount rci let_strict_binds { rs & rcs_var_heap = foldSt (store_binding rci_depth) let_lazy_binds rcs_var_heap }
		  rs = weightedRefCount rci let_expr rs
		  (let_info, rcs_expr_heap) = readPtr let_info_ptr rs.rcs_expr_heap
		  rs = { rs & rcs_expr_heap = rcs_expr_heap }
		= case let_info of
			EI_LetType let_type
		  		# (ref_counts, rcs_var_heap) = mapSt get_ref_count let_lazy_binds rs.rcs_var_heap
				  (rcs_free_vars, rcs_var_heap) = foldl remove_variable (rs.rcs_free_vars, rcs_var_heap) let_lazy_binds
				-> { rs & rcs_free_vars = rcs_free_vars, rcs_var_heap = rcs_var_heap,
						rcs_expr_heap = rs.rcs_expr_heap <:= (let_info_ptr, EI_LetTypeAndRefCounts let_type ref_counts)}
			_
				# (rcs_free_vars, rcs_var_heap) = foldl remove_variable (rs.rcs_free_vars, rs.rcs_var_heap) let_lazy_binds
				-> { rs & rcs_free_vars = rcs_free_vars, rcs_var_heap = rcs_var_heap }
	where
		remove_variable ([], var_heap) let_bind
			= ([], var_heap)
		remove_variable ([var_ptr : var_ptrs], var_heap) bind=:{lb_dst={fv_ident,fv_info_ptr}}
			| fv_info_ptr == var_ptr
				# (VI_LetVar {lvi_count,lvi_depth}, var_heap) = readPtr fv_info_ptr var_heap
				= (var_ptrs, var_heap) 
			// otherwise
				# (var_ptrs, var_heap) = remove_variable (var_ptrs, var_heap) bind
				= ([var_ptr : var_ptrs], var_heap)

		store_binding depth {lb_dst={fv_ident,fv_info_ptr},lb_src} var_heap
			= var_heap <:= (fv_info_ptr, VI_LetVar {lvi_count = 0, lvi_depth = depth, lvi_previous = [],
													lvi_new = True, lvi_expression = lb_src, lvi_var = fv_ident})

		get_ref_count {lb_dst={fv_ident,fv_info_ptr}} var_heap 
			# (VI_LetVar {lvi_count}, var_heap) = readPtr fv_info_ptr var_heap
		  	= (lvi_count, var_heap)

	weightedRefCount rci (Case case_expr) rs=:{rcs_expr_heap}
		# (case_info, rcs_expr_heap) = readPtr case_expr.case_info_ptr rcs_expr_heap
		= weightedRefCountOfCase rci case_expr case_info {rs & rcs_expr_heap = rcs_expr_heap}
	weightedRefCount rci expr=:(BasicExpr _) rs
		= rs
	weightedRefCount rci (Selection opt_tuple expr selections) rs
		= weightedRefCount rci (expr, selections) rs
	weightedRefCount rci (Update expr1 selections expr2) rs
		= weightedRefCount rci (expr1, (selections, expr2)) rs
	weightedRefCount rci (RecordUpdate cons_symbol expr exprs) rs
		= weightedRefCount rci (expr, exprs) rs
	weightedRefCount rci (TupleSelect tuple_symbol arg_nr expr) rs
		= weightedRefCount rci expr rs
	weightedRefCount rci (MatchExpr constructor expr) rs
		= weightedRefCount rci expr rs
	weightedRefCount rci (IsConstructor expr _ _ _ _ _) rs
		= weightedRefCount rci expr rs
	weightedRefCount rci (AnyCodeExpr _ _ _) rs
		= rs
	weightedRefCount rci (ABCCodeExpr _ _) rs
		= rs
	weightedRefCount rci (TypeCodeExpression type_code_expr) rs
		= weightedRefCount rci type_code_expr rs
	weightedRefCount rci EE rs
		= rs
	weightedRefCount rci (NoBind ptr) rs
		= rs
	weightedRefCount rci (FailExpr _) rs
		= rs
	weightedRefCount rci expr rs
		= abort "weightedRefCount [Expression] (convertcases)"

addPatternVariable depth {cv_variable = var_info_ptr, cv_count = ref_count} (free_vars, var_heap)
 	# (var_info, var_heap) = readPtr var_info_ptr var_heap
	= case var_info of
		VI_LetVar lvi
			# (_, lvi, free_vars) = weightedRefCountOfVariable depth var_info_ptr lvi ref_count free_vars
			-> (free_vars, var_heap <:= (var_info_ptr, VI_LetVar lvi))
		_
			-> (free_vars, var_heap)

weightedRefCountOfCase rci=:{rci_depth} this_case=:{case_expr, case_guards, case_default, case_info_ptr} (EI_CaseType case_type)
			rs=:{ rcs_var_heap, rcs_expr_heap, rcs_imports }
	# (local_vars, vars_and_heaps) = weighted_ref_count_in_case_patterns {rci & rci_depth=rci_depth+1} case_guards rcs_imports rcs_var_heap rcs_expr_heap
	  (default_vars, (all_vars, rcs_imports, var_heap, expr_heap)) = weighted_ref_count_in_default {rci & rci_depth=rci_depth+1} case_default vars_and_heaps
	  rs = { rs & rcs_var_heap = var_heap, rcs_expr_heap = expr_heap, rcs_imports = rcs_imports }
	  rs = weighted_ref_count_of_decons_expr rci case_guards rs
	  rs = weightedRefCount rci case_expr rs
	  (rcs_free_vars, rcs_var_heap) = foldSt (addPatternVariable rci_depth) all_vars (rs.rcs_free_vars, rs.rcs_var_heap)
	  rcs_expr_heap = rs.rcs_expr_heap <:= (case_info_ptr, EI_CaseTypeAndRefCounts case_type 
	  		{ rcc_all_variables = all_vars, rcc_default_variables = default_vars, rcc_pattern_variables = local_vars })
	= {rs & rcs_var_heap = rcs_var_heap, rcs_expr_heap = rcs_expr_heap, rcs_free_vars = rcs_free_vars}
	where
		weighted_ref_count_in_default rci (Yes expr) info
			= weightedRefCountInPatternExpr rci expr info
		weighted_ref_count_in_default rci No info
			= ([], info)

		weighted_ref_count_in_case_patterns rci (AlgebraicPatterns type patterns) collected_imports var_heap expr_heap
			= mapSt (weighted_ref_count_in_algebraic_pattern rci) patterns ([], collected_imports, var_heap, expr_heap)
		weighted_ref_count_in_case_patterns rci (BasicPatterns type patterns) collected_imports var_heap expr_heap
			= mapSt (\{bp_expr} -> weightedRefCountInPatternExpr rci bp_expr) patterns ([], collected_imports, var_heap, expr_heap)
		weighted_ref_count_in_case_patterns rci (OverloadedListPatterns type _ patterns) collected_imports var_heap expr_heap
			= mapSt (weighted_ref_count_in_algebraic_pattern rci) patterns ([], collected_imports, var_heap, expr_heap)
		weighted_ref_count_in_case_patterns rci (DynamicPatterns patterns) collected_imports var_heap expr_heap
			= mapSt (\{dp_rhs} -> weightedRefCountInPatternExpr rci dp_rhs) patterns ([], collected_imports, var_heap, expr_heap)

		weighted_ref_count_in_algebraic_pattern rci=:{rci_imported} {ap_expr,ap_symbol} wrcs_state
			# (free_vars_with_rc, (all_free_vars, collected_imports, var_heap, expr_heap))
				= weightedRefCountInPatternExpr rci ap_expr wrcs_state
			  (collected_imports, var_heap)
				=	check_symbol rci_imported ap_symbol collected_imports var_heap
			=	(free_vars_with_rc, (all_free_vars, collected_imports, var_heap, expr_heap))
			where
				check_symbol {cii_main_dcl_module_n, cii_common_defs} {glob_module, glob_object={ds_index}} collected_imports var_heap
					| glob_module <> cii_main_dcl_module_n
						# {cons_type_ptr} = cii_common_defs.[glob_module].com_cons_defs.[ds_index]
						= checkImportedSymbol (SK_Constructor {glob_module = glob_module, glob_object = ds_index})
												cons_type_ptr (collected_imports, var_heap)
						= (collected_imports, var_heap)

	 	weighted_ref_count_of_decons_expr rci (OverloadedListPatterns _ decons_exp _) rs
	 		= weightedRefCount rci decons_exp rs;
	 	weighted_ref_count_of_decons_expr rci case_guards rs
	 		= rs;

weightedRefCountOfCase rci=:{rci_depth} this_case=:{case_expr, case_guards, case_default, case_info_ptr} (EI_CaseTypeAndRefCounts case_type {rcc_all_variables})
			rs=:{ rcs_var_heap, rcs_expr_heap, rcs_imports }
	# rs = weightedRefCount rci case_expr rs
	  (rcs_free_vars, rcs_var_heap) = foldSt (addPatternVariable rci_depth) rcc_all_variables (rs.rcs_free_vars, rs.rcs_var_heap)
	= {rs & rcs_var_heap = rcs_var_heap, rcs_free_vars = rcs_free_vars}

instance weightedRefCount Selection
where
	weightedRefCount rci=:{rci_imported} (ArraySelection {glob_module,glob_object={ds_index}} _ index_expr) rs
		# rs = weightedRefCount rci index_expr rs
		= checkImportOfDclFunction rci_imported glob_module ds_index rs
	weightedRefCount rci (DictionarySelection _ selectors _ index_expr) rs
		# rs = weightedRefCount rci index_expr rs
		= weightedRefCount rci selectors rs
	weightedRefCount {rci_imported} (RecordSelection selector _) rs
		= checkRecordSelector rci_imported selector rs

weightedRefCountInPatternExpr rci=:{rci_depth} pattern_expr (previous_free_vars, collected_imports, var_heap, expr_heap)
	# {rcs_free_vars,rcs_var_heap,rcs_imports,rcs_expr_heap} = weightedRefCount rci pattern_expr
				{ rcs_var_heap = var_heap, rcs_expr_heap = expr_heap, rcs_free_vars = [], rcs_imports = collected_imports}
	  (free_vars_with_rc, rcs_var_heap) = mapSt get_ref_count rcs_free_vars rcs_var_heap
	  (previous_free_vars, rcs_var_heap) = foldSt (select_unused_free_variable rci_depth) previous_free_vars ([], rcs_var_heap)
	  (all_free_vars, rcs_var_heap) = foldSt (collect_free_variable rci_depth) rcs_free_vars (previous_free_vars, rcs_var_heap)
	= (free_vars_with_rc, (all_free_vars, rcs_imports, rcs_var_heap, rcs_expr_heap))
where
	select_unused_free_variable depth var=:{cv_variable = var_ptr, cv_count = var_count} (collected_vars, var_heap)
		# (VI_LetVar info=:{lvi_count,lvi_depth}, var_heap) = readPtr var_ptr var_heap
		| lvi_depth == depth && lvi_count > 0
			= (collected_vars, var_heap <:= (var_ptr, VI_LetVar {info & lvi_count = max lvi_count var_count}))
		// otherwise
			= ([ var : collected_vars], var_heap) 

	get_ref_count var_ptr var_heap
		# (VI_LetVar {lvi_count}, var_heap) = readPtr var_ptr var_heap
		= ({cv_variable = var_ptr, cv_count = lvi_count}, var_heap)

	collect_free_variable depth var_ptr (collected_vars, var_heap)
		# (VI_LetVar lvi=:{lvi_count,lvi_depth,lvi_previous}, var_heap) = readPtr var_ptr var_heap
		| depth == lvi_depth
			= case lvi_previous of
				[{plvi_depth, plvi_count, plvi_new} : lvi_previous ]
					-> ([ {cv_variable = var_ptr, cv_count = lvi_count} : collected_vars ],
						(var_heap <:= (var_ptr, VI_LetVar {lvi & lvi_count = plvi_count, lvi_depth = plvi_depth,
																 lvi_new = plvi_new, lvi_previous = lvi_previous})))
				[]
					-> (collected_vars, var_heap)
			= ([ {cv_variable = var_ptr, cv_count = lvi_count} : collected_vars ], var_heap)

/*
	Here we examine the appplication to see whether an imported function has been used. If so,
	the 'ft_type_ptr' is examined. Initially this pointer contains VI_Empty. After the first
	occurrence the pointer will be set to 'VI_Used'.
*/
checkImportOfDclFunction :: CheckImportedInfo Int Int *RCState -> *RCState
checkImportOfDclFunction {cii_main_dcl_module_n, cii_dcl_functions} mod_index fun_index rs=:{rcs_imports, rcs_var_heap}
	| mod_index <> cii_main_dcl_module_n
		# {ft_type_ptr} = cii_dcl_functions.[mod_index].[fun_index]
		  (rcs_imports, rcs_var_heap) = checkImportedSymbol (SK_Function {glob_module=mod_index,glob_object=fun_index}) ft_type_ptr (rcs_imports, rcs_var_heap)
		= { rs & rcs_imports = rcs_imports, rcs_var_heap = rcs_var_heap }
	// otherwise
		= rs

checkRecordSelector {cii_main_dcl_module_n, cii_common_defs} {glob_module, glob_object={ds_index}} rs=:{rcs_imports,rcs_var_heap}
	| glob_module <> cii_main_dcl_module_n
		# {com_selector_defs,com_cons_defs,com_type_defs} = cii_common_defs.[glob_module]
		  {sd_type_index} = com_selector_defs.[ds_index]
		  {td_rhs = RecordType {rt_constructor={ds_index=cons_index}}} = com_type_defs.[sd_type_index]
		  {cons_type_ptr} = com_cons_defs.[cons_index]
		  (rcs_imports, rcs_var_heap) = checkImportedSymbol (SK_Constructor {glob_module = glob_module, glob_object = cons_index})
											cons_type_ptr (rcs_imports, rcs_var_heap)
		= { rs & rcs_imports = rcs_imports, rcs_var_heap = rcs_var_heap }
	// otherwise
		= rs

instance weightedRefCount App
where
	weightedRefCount rci=:{rci_imported} {app_symb,app_args} rs
		# rs = weightedRefCount rci app_args rs
		= check_import rci_imported app_symb rs
	where
		check_import cii {symb_kind=SK_Function {glob_module,glob_object}} rs=:{rcs_imports, rcs_var_heap}
			= checkImportOfDclFunction cii glob_module glob_object rs
		check_import {cii_main_dcl_module_n, cii_common_defs} {symb_ident,symb_kind=symb_kind=:(SK_Constructor {glob_module,glob_object})} rs=:{rcs_imports, rcs_var_heap}
			| glob_module <> cii_main_dcl_module_n
				# {cons_type_ptr} = cii_common_defs.[glob_module].com_cons_defs.[glob_object]
				  (rcs_imports, rcs_var_heap) = checkImportedSymbol symb_kind cons_type_ptr (rcs_imports, rcs_var_heap)
				= { rs & rcs_imports = rcs_imports, rcs_var_heap = rcs_var_heap }
				= rs
		check_import _ _ rs
			= rs

instance weightedRefCount TypeCodeExpression
where
	weightedRefCount rci type_code_expr rs
		= rs

instance weightedRefCount [a] | weightedRefCount a
where
	weightedRefCount rci l rs
		=	foldr (weightedRefCount rci) rs l 
		
instance weightedRefCount (a,b) | weightedRefCount a & weightedRefCount b
where
	weightedRefCount rci (x,y) rs
		=	weightedRefCount rci y (weightedRefCount rci x rs) 

instance weightedRefCount LetBind
where
	weightedRefCount rci {lb_src} rs
		=	weightedRefCount rci lb_src rs

instance weightedRefCount (Bind a b) | weightedRefCount a
where
	weightedRefCount rci bind=:{bind_src} rs
		=	weightedRefCount rci bind_src rs

/*
	distributeLets tries to move shared exprs as close as possible to the location at which they are used.
	Case-exprs may require unsharing if the shared expr is used in different alternatives. Of course
	only if the expr is neither used in the pattern nor in a surrounding expr.
*/

::	LetExpressionStatus	= LES_Untouched | LES_Moved | LES_Updated !Expression

::	LetExpressionInfo =
	{	lei_count			:: !Int
	,	lei_depth			:: !Int 
	,	lei_var				:: !FreeVar 
	,   lei_expression		:: !Expression
	,   lei_status			:: !LetExpressionStatus
	,   lei_type			:: !AType
	}

::	DistributeInfo =
	{	di_depth 				:: !Int
	,	di_explicit_case_depth	:: !Int
	}

::	DistributeState =
	{	ds_lets			:: ![VarInfoPtr]
	,	ds_var_heap		:: !.VarHeap
	,	ds_expr_heap	:: !.ExpressionHeap
	}

class distributeLets e :: !DistributeInfo !e !*DistributeState -> (!e, !*DistributeState)

instance distributeLets Expression
where
	distributeLets di=:{di_depth} (Var var=:{var_ident,var_info_ptr}) ds=:{ds_var_heap}
		#! var_info = sreadPtr var_info_ptr ds_var_heap
		= case var_info of
			VI_LetExpression lei
				| lei.lei_depth == di_depth
					| lei.lei_count == 1 && (case lei.lei_status of LES_Updated _ -> False; _ -> True)
						# (lei_updated_expr, ds) = distributeLets di lei.lei_expression ds
						-> (lei_updated_expr, { ds &  ds_var_heap = ds.ds_var_heap <:=
								(var_info_ptr, VI_LetExpression { lei & lei_status = LES_Updated lei_updated_expr }) })
						# ds = distributeLetsInLetExpression di var_info_ptr lei ds
						-> (Var { var & var_info_ptr = lei.lei_var.fv_info_ptr }, ds)
				// otherwise
					-> (Var { var & var_info_ptr = lei.lei_var.fv_info_ptr }, ds)
			VI_CaseOrStrictLetVar var_info_ptr
				-> (Var { var & var_info_ptr = var_info_ptr }, ds)
			_
				-> (Var var, ds)
	distributeLets di (Case kees) ds
		# (kees, ds) = distributeLets di kees ds
		= (Case kees, ds)
	distributeLets di (App app=:{app_args}) ds
		# (app_args, ds) = distributeLets di app_args ds
		= (App {app & app_args = app_args}, ds)
	distributeLets di (fun_expr @ exprs) ds
		# (fun_expr, ds) = distributeLets di fun_expr ds
		  (exprs, ds) = distributeLets di exprs ds
		= (fun_expr @ exprs, ds)
	distributeLets di expr=:(BasicExpr _) ds
		= (expr, ds)
	distributeLets di (Selection opt_tuple expr selectors) ds
		# (expr, ds) = distributeLets di expr ds
		# (selectors, ds) = distributeLets di selectors ds
		= (Selection opt_tuple expr selectors, ds)
	distributeLets di (Update expr1 selectors expr2) ds
		# (expr1, ds) = distributeLets di expr1 ds
		# (selectors, ds) = distributeLets di selectors ds
		# (expr2, ds) = distributeLets di expr2 ds
		= (Update expr1 selectors expr2, ds)
	distributeLets di (RecordUpdate cons_symbol expr exprs) ds
		# (expr, ds) = distributeLets di expr ds
		# (exprs, ds) = distributeLets di exprs ds
		= (RecordUpdate cons_symbol expr exprs, ds)
	distributeLets di (TupleSelect tuple_symbol arg_nr expr) ds
		# (expr, ds) = distributeLets di expr ds
		= (TupleSelect tuple_symbol arg_nr expr, ds)
	distributeLets di=:{di_depth} (Let lad=:{let_strict_binds,let_lazy_binds,let_expr,let_info_ptr}) ds=:{ds_expr_heap,ds_var_heap}
		# (let_info, ds_expr_heap) = readPtr let_info_ptr ds_expr_heap
		# (EI_LetTypeAndRefCounts let_type ref_counts) = let_info
		  nr_of_strict_lets = length let_strict_binds
		  ds_var_heap = set_let_expr_info di_depth let_lazy_binds ref_counts (drop nr_of_strict_lets let_type) ds_var_heap
		  (let_strict_binds,ds_var_heap) = mapSt set_strict_let_expr_info let_strict_binds ds_var_heap
		  (let_expr, ds) = distributeLets di let_expr { ds & ds_var_heap = ds_var_heap, ds_expr_heap = ds_expr_heap }
		  (let_strict_binds, ds) = distributeLets di let_strict_binds ds
		  ds = foldSt (distribute_lets_in_non_distributed_let di) let_lazy_binds ds
		| nr_of_strict_lets == 0
		    = (let_expr, ds)
		// otherwise
		    = case let_expr of
		    	Let inner_let=:{let_info_ptr=inner_let_info_ptr}
					# (EI_LetType strict_inner_types, ds_expr_heap) = readPtr inner_let_info_ptr ds.ds_expr_heap
					# (inner_let_info_ptr, ds_expr_heap)
						=	newPtr (EI_LetType ((take nr_of_strict_lets let_type)++strict_inner_types)) ds_expr_heap
					-> (Let { inner_let & let_strict_binds = let_strict_binds++inner_let.let_strict_binds,
									let_info_ptr = inner_let_info_ptr}, 
						{ds & ds_expr_heap = ds_expr_heap})
				_	# (let_info_ptr, ds_expr_heap)
						=	newPtr (EI_LetType (take nr_of_strict_lets let_type)) ds.ds_expr_heap
					-> (Let { lad & let_strict_binds = let_strict_binds, let_expr = let_expr, let_lazy_binds = [], let_info_ptr = let_info_ptr}, 
						{ds & ds_expr_heap = ds_expr_heap})
	where
		set_let_expr_info depth [{lb_src,lb_dst}:binds] [ref_count:ref_counts] [type:types] var_heap
			# (new_info_ptr, var_heap) = newPtr VI_LocalLetVar var_heap
			  lei = { lei_count = ref_count, lei_depth = depth, lei_var = { lb_dst & fv_info_ptr = new_info_ptr },
			  			lei_expression = lb_src, lei_type = type, lei_status =  LES_Untouched }
			= set_let_expr_info depth binds ref_counts types (var_heap <:= (lb_dst.fv_info_ptr, VI_LetExpression lei))
		set_let_expr_info _ [] _ _ var_heap
			= var_heap

		set_strict_let_expr_info lb=:{lb_dst={fv_info_ptr}} var_heap
			# (new_info_ptr, var_heap) = newPtr VI_StrictLetVar var_heap
			= ({lb & lb_dst.fv_info_ptr = new_info_ptr}, var_heap <:= (fv_info_ptr, VI_CaseOrStrictLetVar new_info_ptr))
	
		distribute_lets_in_non_distributed_let di {lb_dst={fv_ident,fv_info_ptr}} ds=:{ds_var_heap}
			# (VI_LetExpression lei=:{lei_count}, ds_var_heap) = readPtr fv_info_ptr ds_var_heap
			| lei_count > 0
//			| not lei_moved && lei_count > 0
				= distributeLetsInLetExpression di fv_info_ptr lei { ds & ds_var_heap = ds_var_heap }
				= { ds & ds_var_heap = ds_var_heap }

	distributeLets di (MatchExpr constructor expr) ds
		# (expr, ds) = distributeLets di expr ds
		= (MatchExpr constructor expr, ds)
	distributeLets di (IsConstructor expr cons_symbol cons_arity global_type_index case_ident position) ds
		# (expr, ds) = distributeLets di expr ds
		= (IsConstructor expr cons_symbol cons_arity global_type_index case_ident position, ds)
	distributeLets _ expr=:(TypeCodeExpression _) ds
		= (expr, ds)
	distributeLets _ (AnyCodeExpr in_params out_params code_expr) ds=:{ds_var_heap}
		# (in_params, ds_var_heap) = mapSt determine_input_parameter in_params ds_var_heap
		= (AnyCodeExpr in_params out_params code_expr, { ds & ds_var_heap = ds_var_heap })
		where
			determine_input_parameter bind=:{bind_dst} var_heap
				# (var_info, var_heap) = readPtr bind_dst.var_info_ptr var_heap
				= case var_info of
					VI_CaseOrStrictLetVar new_info_ptr
						-> ({ bind & bind_dst = { bind_dst & var_info_ptr = new_info_ptr }}, var_heap)
					_
						-> (bind, var_heap)
	distributeLets _ expr=:(ABCCodeExpr _ _) ds
		= (expr, ds)
	distributeLets _ EE ds
		= (EE, ds)
	distributeLets _ (NoBind ptr) ds
		= (NoBind ptr, ds)
	distributeLets _ (FailExpr id) ds
		= (FailExpr id, ds)

instance distributeLets Case
where
	distributeLets di=:{di_depth,di_explicit_case_depth} kees=:{case_info_ptr,case_guards,case_default,case_expr,case_explicit} ds=:{ds_var_heap, ds_expr_heap}
		# (case_old_info, ds_expr_heap) = readPtr case_info_ptr ds_expr_heap
		  (EI_CaseTypeAndRefCounts type
		  	{	rcc_all_variables = tot_ref_counts ,
		  		rcc_default_variables = ref_counts_in_default,
		  		rcc_pattern_variables = ref_counts_in_patterns }) = case_old_info
		  new_depth = di_depth + 1
		  new_di =	{	di
					&	di_depth = new_depth
					,	di_explicit_case_depth = if case_explicit new_depth di_explicit_case_depth
					}
		  (local_lets, ds_var_heap) = mark_local_let_vars new_depth tot_ref_counts ds_var_heap
										  	// -*-> ("ref_counts", case_expr, tot_ref_counts, ref_counts_in_patterns)
		  	with
				mark_local_let_vars new_depth tot_ref_counts var_heap

					| case_explicit
						# (local_vars,local_select_vars,var_heap) = foldSt (mark_local_let_var_of_explicit_case new_depth) tot_ref_counts ([],[],var_heap)
						= foldSt (mark_local_let_select_var_of_explicit_case new_depth) local_select_vars (local_vars,var_heap)

						= foldSt (mark_local_let_var new_depth) tot_ref_counts ([],var_heap)
		  	
	 	  ds = {ds & ds_var_heap=ds_var_heap, ds_expr_heap=ds_expr_heap}
		  (case_guards, ds)  = distribute_lets_in_patterns new_di ref_counts_in_patterns case_guards ds
		  (case_default, ds=:{ds_var_heap}) = distribute_lets_in_default new_di ref_counts_in_default case_default ds
		  (outer_vars, ds_var_heap) = foldSt (is_outer_var new_di) tot_ref_counts (False, ds.ds_var_heap)
		  
		# ds_var_heap = foldSt reset_local_let_var local_lets ds_var_heap ->> ("outer_vars", di_depth, di.di_explicit_case_depth, outer_vars)
		  (case_expr, ds) = distributeLets di case_expr { ds & ds_var_heap = ds_var_heap}
		  kees = { kees & case_guards = case_guards, case_expr = case_expr,
				case_default = case_default}
		  (kind, ds_var_heap) = case_kind outer_vars kees ds.ds_var_heap
		  case_new_info = EI_CaseTypeAndSplits type {sic_splits = [], sic_next_alt = No, sic_case_kind = kind}
		  (case_info_ptr, ds_expr_heap) = newPtr case_new_info ds.ds_expr_heap
		  kees = { kees & case_info_ptr = case_info_ptr } // ->> ("case_kind", di_depth, kind, case_explicit, ptrToInt case_info_ptr)
		= (kees, { ds & ds_expr_heap = ds_expr_heap, ds_var_heap = ds_var_heap})
	where
		case_kind _ {case_guards, case_default, case_explicit, case_expr} var_heap
			| is_guard case_guards case_default case_explicit case_expr
				=	(CaseKindGuard, var_heap)
		case_kind outer_vars {case_expr, case_explicit}  var_heap
			| case_explicit || outer_vars || not (is_lhs_var case_expr var_heap)
				=	(CaseKindTransform, var_heap)
			// otherwise
				=	(CaseKindLeave, var_heap)
			where
				is_lhs_var (Var {var_info_ptr, var_ident}) var_heap
					= 	case sreadPtr var_info_ptr var_heap of
							VI_LocalLetVar
								->	False
							VI_LetExpression _
								->	False
							VI_StrictLetVar
								->	False
							info
								->	True
				is_lhs_var _ _
					=	False
		
		is_guard (BasicPatterns BT_Bool patterns) case_default case_explicit case_expr
			=	is_guard_case patterns case_default case_explicit case_expr
		is_guard _ _ _ _
			=	False

		distribute_lets_in_patterns di ref_counts (AlgebraicPatterns conses patterns) ds
			# (patterns, ds) = mapSt (distribute_lets_in_alg_pattern di) (exactZip ref_counts patterns) ds
			= (AlgebraicPatterns conses patterns, ds)
		distribute_lets_in_patterns di ref_counts (BasicPatterns type patterns) ds
			# (patterns, ds) = mapSt (distribute_lets_in_basic_pattern di) (exactZip ref_counts patterns) ds
			= (BasicPatterns type patterns, ds)
		where
			distribute_lets_in_basic_pattern di (ref_counts,pattern) ds
				# (bp_expr, ds) = distribute_lets_in_pattern_expr di ref_counts pattern.bp_expr ds
				= ({ pattern & bp_expr = bp_expr }, ds)
		distribute_lets_in_patterns di ref_counts (OverloadedListPatterns conses decons_expr patterns) heaps
			# (patterns, heaps) = mapSt (distribute_lets_in_alg_pattern di) (exactZip ref_counts patterns) heaps
			= (OverloadedListPatterns conses decons_expr patterns, heaps)

		distribute_lets_in_alg_pattern di (ref_counts,pattern) ds=:{ds_var_heap}
			# (ap_vars, ds_var_heap) = mapSt refresh_variable pattern.ap_vars ds_var_heap
			  ds = {ds & ds_var_heap = ds_var_heap}
			  (ap_expr, ds) = distribute_lets_in_pattern_expr di ref_counts pattern.ap_expr ds
			= ({ pattern & ap_vars = ap_vars, ap_expr = ap_expr }, ds) 

		distribute_lets_in_default di ref_counts_in_default (Yes expr) ds
			# (expr, ds) = distribute_lets_in_pattern_expr di ref_counts_in_default expr ds
			= (Yes expr, ds)
		distribute_lets_in_default _ ref_counts_in_default No ds
			= (No, ds)

		refresh_variable fv=:{fv_info_ptr} var_heap
			# (new_info_ptr, var_heap) = newPtr VI_Empty var_heap
			= ({ fv & fv_info_ptr = new_info_ptr }, var_heap <:= (fv_info_ptr, VI_CaseOrStrictLetVar new_info_ptr))

		mark_local_let_var depth {cv_variable, cv_count} (local_vars, var_heap)
			# (VI_LetExpression lei=:{lei_count,lei_depth,lei_var}, var_heap) = readPtr cv_variable var_heap
			| lei_count == cv_count && lei_depth==depth-1
				= ([(cv_variable, lei_count, lei_depth) : local_vars ], var_heap <:= (cv_variable, VI_LetExpression { lei & lei_depth = depth}))
				= (local_vars, var_heap)

		mark_local_let_var_of_explicit_case depth {cv_variable, cv_count} (local_vars,local_select_vars,var_heap)
			# (VI_LetExpression lei=:{lei_count,lei_depth,lei_expression}, var_heap) = readPtr cv_variable var_heap
			| lei_count == cv_count && lei_depth==depth-1
				= case lei_expression of
					TupleSelect _ _ (Var var=:{var_ident,var_info_ptr})
						# (var_info,var_heap) = readPtr var_info_ptr var_heap
						-> case var_info of
							VI_LetExpression lei2
								-> (local_vars,[(cv_variable,lei_depth):local_select_vars],var_heap <:= (cv_variable, VI_LetExpression { lei & lei_depth = depth}))
							_
								-> ([(cv_variable, lei_count, lei_depth) : local_vars ],local_select_vars,var_heap <:= (cv_variable, VI_LetExpression { lei & lei_depth = depth}))
					Selection NormalSelector (Var var=:{var_ident,var_info_ptr}) [RecordSelection _ _]
						# (var_info,var_heap) = readPtr var_info_ptr var_heap
						-> case var_info of
							VI_LetExpression lei2
								-> (local_vars,[(cv_variable,lei_depth):local_select_vars],var_heap <:= (cv_variable, VI_LetExpression { lei & lei_depth = depth}))
							_
								-> ([(cv_variable, lei_count, lei_depth) : local_vars ],local_select_vars,var_heap <:= (cv_variable, VI_LetExpression { lei & lei_depth = depth}))
					_
						-> ([(cv_variable, lei_count, lei_depth) : local_vars ],local_select_vars,var_heap <:= (cv_variable, VI_LetExpression { lei & lei_depth = depth}))

				= (local_vars,local_select_vars,var_heap)

		mark_local_let_select_var_of_explicit_case depth (cv_variable,old_depth) (local_vars,var_heap)
			# (VI_LetExpression lei=:{lei_count,lei_expression}, var_heap) = readPtr cv_variable var_heap
			= case lei_expression of
				TupleSelect _ _ (Var var=:{var_ident,var_info_ptr})
					# (var_info,var_heap) = readPtr var_info_ptr var_heap
					-> case var_info of
						VI_LetExpression lei2
							| lei2.lei_depth < depth
								-> (local_vars,var_heap <:= (cv_variable, VI_LetExpression {lei & lei_depth = old_depth}))
						_
								-> ([(cv_variable, lei_count, old_depth) : local_vars ],var_heap)
				Selection NormalSelector (Var var=:{var_ident,var_info_ptr}) [RecordSelection _ _]
					# (var_info,var_heap) = readPtr var_info_ptr var_heap
					-> case var_info of
						VI_LetExpression lei2
							| lei2.lei_depth < depth
								-> (local_vars,var_heap <:= (cv_variable, VI_LetExpression {lei & lei_depth = old_depth}))
						_
								-> ([(cv_variable, lei_count, old_depth) : local_vars ],var_heap)

		reset_local_let_var (var_info_ptr, lei_count, lei_depth)  var_heap
			# (VI_LetExpression lei, var_heap) = readPtr var_info_ptr var_heap
			= var_heap <:= (var_info_ptr, VI_LetExpression { lei & lei_depth = lei_depth, lei_count = lei_count, lei_status = LES_Moved })
   
		is_outer_var {di_depth, di_explicit_case_depth} {cv_variable}  (outer, var_heap)
			| outer
				= (True,var_heap)
			# (VI_LetExpression {lei_depth,lei_status}, var_heap) = readPtr cv_variable var_heap
			| di_explicit_case_depth < lei_depth &&
				(lei_depth < di_depth || (lei_depth == di_depth && case lei_status of LES_Moved -> False; _ -> True))
			= (True,var_heap)
			= (False,var_heap);

		distribute_lets_in_pattern_expr di=:{di_depth} local_vars pattern_expr ds=:{ds_var_heap}
			# ds_var_heap = foldSt (mark_local_let_var_of_pattern_expr di_depth) local_vars ds_var_heap
			  (ds=:{ds_lets}) = {ds & ds_var_heap = ds_var_heap}
			  ds = {ds & ds_lets = []}
			  (pattern_expr, ds) = distributeLets di pattern_expr ds
			  (ds_lets2, ds) = ds!ds_lets
			  ds = foldSt (reexamine_local_let_expr di) local_vars ds
			# (letExpr, ds) = buildLetExpr pattern_expr ds
				-*-> ("distribute_lets_in_pattern_expr", ds_lets2)
			  ds = {ds & ds_lets = ds_lets}
			= (letExpr, ds)

		mark_local_let_var_of_pattern_expr depth {cv_variable, cv_count} var_heap
			# (VI_LetExpression lei, var_heap) = readPtr cv_variable var_heap
			| depth == lei.lei_depth
				= (var_heap <:= (cv_variable, VI_LetExpression { lei & lei_count = cv_count, lei_status = LES_Untouched }))
				= var_heap

		reexamine_local_let_expr di=:{di_depth} {cv_variable, cv_count} ds=:{ds_var_heap}
			| cv_count >= 1
				# (VI_LetExpression lei, ds_var_heap) = readPtr cv_variable ds_var_heap
				| di_depth == lei.lei_depth
					= distributeLetsInLetExpression di cv_variable lei { ds & ds_var_heap = ds_var_heap }
					= { ds & ds_var_heap = ds_var_heap<