convertcases.icl 91.9 KB
Newer Older
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
1
2
implementation module convertcases

3
import StdStrictLists
4
import syntax, compare_types, utilities, expand_types, general
5
from checksupport import ::Component(..),::ComponentMembers(..)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
6

7
// exactZip fails when its arguments are of unequal length
8
9
exactZip :: ![.a] ![.b] -> [(.a,.b)]
exactZip [x:xs][y:ys]
10
	=	[(x,y) : exactZip xs ys]
11
12
exactZip [] []
	=	[]
13

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
14
getIdent :: (Optional Ident) Int -> Ident
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
15
16
17
18
19
getIdent (Yes ident) fun_nr
	= ident
getIdent No fun_nr
	= { id_name = "_f" +++ toString fun_nr, id_info = nilPtr }

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
20
addLetVars :: [LetBind] [AType] [(FreeVar, AType)] -> [(FreeVar, AType)]
21
22
addLetVars [{lb_dst} : binds] [bind_type : bind_types] bound_vars
	= addLetVars binds bind_types [ (lb_dst, bind_type) : bound_vars ]
23
addLetVars [] [] bound_vars
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
24
25
	= bound_vars

26
convertCasesOfFunctions :: !*{!Component} !Int !{#{#FunType}} !{#CommonDefs}
27
				!*{#FunDef} !*{#{#CheckedTypeDef}} !ImportedConstructors !*VarHeap !*TypeHeaps !*ExpressionHeap
28
			-> (!ImportedFunctions, !*{!Component},
29
				!*{#FunDef},!*{#{#CheckedTypeDef}},!ImportedConstructors,!*VarHeap,!*TypeHeaps,!*ExpressionHeap)
30
31
32
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}))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
33
			= convert_groups 0 groups dcl_functions common_defs main_dcl_module_n
34
35
36
37
38
				(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 },
39
			imported_types, imported_conses, cs_var_heap, type_heaps, cs_expr_heap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
40
where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
41
	convert_groups group_nr groups dcl_functions common_defs main_dcl_module_n fun_defs_and_ci
42
43
		| group_nr == size groups
			= (groups, fun_defs_and_ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
44
		// otherwise
45
			# (group, groups) = groups![group_nr]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
46
			= convert_groups (inc group_nr) groups dcl_functions common_defs main_dcl_module_n
47
48
49
50
51
52
53
54
55
56
				(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
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
57

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
58
	convert_function group_index dcl_functions common_defs main_dcl_module_n fun (fun_defs, collected_imports, cs)
59
60
61
		# ({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)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
62
		  (fun_body, cs) = convertCasesInBody fun_body fun_type group_index common_defs cs
63
		= ({fun_defs & [fun].fun_body = fun_body}, collected_imports, cs)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
64
65
66
67
68
69

	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}
70
71
		  (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
72
		  {ss_expr_heap, ss_var_heap}
73
74
		  	= 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}))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
75
76

	split :: SymbKind (ImportedFunctions, ImportedConstructors) -> (ImportedFunctions, ImportedConstructors) 
77
78
79
80
	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])
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
81

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
82
:: CaseLevel = CaseLevelRoot | CaseLevelAfterGuardRoot
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
83

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
84
85
86
87
88
89
:: ConvertInfo =
	{	ci_bound_vars :: ![(FreeVar, AType)]
	,	ci_group_index :: !Index
	,	ci_common_defs :: !{#CommonDefs}
	,	ci_case_level	:: !CaseLevel
	}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
90

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
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.
109
*/
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
110

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
111
112
113
114
115
116
::	CheckImportedInfo =
	{	cii_dcl_functions	:: !{# {# FunType} }
	,	cii_common_defs		:: !{# CommonDefs}
	,	cii_main_dcl_module_n :: !Int
	}

117
::	RCInfo =
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
118
119
120
121
122
123
124
125
126
	{	rci_imported	:: !CheckImportedInfo
	,	rci_depth		:: !Int
	}

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

129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
::	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
	}

144
145
146
147
148
149
150
151
152
153
154
::	RefCountsInCase = 
	{	rcc_all_variables		:: ![CountedVariable]
	,	rcc_default_variables	:: ![CountedVariable]
	,	rcc_pattern_variables	:: ![[CountedVariable]]
	}

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

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
155
checkImportedSymbol :: SymbKind VarInfoPtr ([SymbKind], *VarHeap) -> ([SymbKind], *VarHeap)
156
checkImportedSymbol symb_kind symb_type_ptr (collected_imports, var_heap)
157
	# (type_info, var_heap) = readPtr symb_type_ptr var_heap
158
159
160
161
162
	= case type_info of
		VI_Used
			-> (collected_imports, var_heap)
		_
			-> ([symb_kind : collected_imports ], var_heap <:= (symb_type_ptr, VI_Used))
163

164
weightedRefCountOfVariable depth var_info_ptr lvi=:{lvi_count,lvi_var,lvi_depth,lvi_previous,lvi_new} ref_count new_vars
165
	| lvi_depth < depth
166
167
168
169
		= (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])
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
170
	// otherwise
171
172
		= (lvi_new, { lvi & lvi_count = lvi_count + ref_count }, new_vars)

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
173
class weightedRefCount e :: RCInfo !e !*RCState -> *RCState
174
175

instance weightedRefCount BoundVar
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
176
where
177
	weightedRefCount rci=:{rci_depth} {var_ident,var_info_ptr} rs=:{rcs_var_heap}
178
		# (var_info, rcs_var_heap) = readPtr var_info_ptr rcs_var_heap
179
		  rs = {rs & rcs_var_heap = rcs_var_heap}
180
181
		= case var_info of
			VI_LetVar lvi
182
				# (is_new, lvi=:{lvi_expression}, rcs_free_vars) = weightedRefCountOfVariable rci_depth var_info_ptr lvi 1 rs.rcs_free_vars
183
				| is_new
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
184
185
186
187
188
189
190
					# 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) }
191
			_
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
192
193
				-> rs

194
195
instance weightedRefCount Expression
where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
196
197
198
199
200
201
202
203
204
205
206
	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 }
207
208
		= case let_info of
			EI_LetType let_type
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
209
210
211
212
		  		# (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)}
213
			_
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
214
215
				# (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 }
216
217
218
	where
		remove_variable ([], var_heap) let_bind
			= ([], var_heap)
219
		remove_variable ([var_ptr : var_ptrs], var_heap) bind=:{lb_dst={fv_ident,fv_info_ptr}}
220
221
222
			| fv_info_ptr == var_ptr
				# (VI_LetVar {lvi_count,lvi_depth}, var_heap) = readPtr fv_info_ptr var_heap
				= (var_ptrs, var_heap) 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
223
			// otherwise
224
225
				# (var_ptrs, var_heap) = remove_variable (var_ptrs, var_heap) bind
				= ([var_ptr : var_ptrs], var_heap)
226

227
		store_binding depth {lb_dst={fv_ident,fv_info_ptr},lb_src} var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
228
			= var_heap <:= (fv_info_ptr, VI_LetVar {lvi_count = 0, lvi_depth = depth, lvi_previous = [],
229
													lvi_new = True, lvi_expression = lb_src, lvi_var = fv_ident})
230

231
		get_ref_count {lb_dst={fv_ident,fv_info_ptr}} var_heap 
232
233
			# (VI_LetVar {lvi_count}, var_heap) = readPtr fv_info_ptr var_heap
		  	= (lvi_count, var_heap)
234

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
235
	weightedRefCount rci (Case case_expr) rs=:{rcs_expr_heap}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
236
		# (case_info, rcs_expr_heap) = readPtr case_expr.case_info_ptr rcs_expr_heap
237
		= weightedRefCountOfCase rci case_expr case_info {rs & rcs_expr_heap = rcs_expr_heap}
238
	weightedRefCount rci expr=:(BasicExpr _) rs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
239
240
241
242
243
244
245
246
247
		= 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
248
249
250
251
	weightedRefCount rci (MatchExpr constructor expr) rs
		= weightedRefCount rci expr rs
	weightedRefCount rci (IsConstructor expr _ _ _ _ _) rs
		= weightedRefCount rci expr rs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
252
253
254
255
256
257
258
259
260
261
	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
262
263
	weightedRefCount rci (FailExpr _) rs
		= rs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
264
	weightedRefCount rci expr rs
265
		= abort "weightedRefCount [Expression] (convertcases)"
266

267
addPatternVariable depth {cv_variable = var_info_ptr, cv_count = ref_count} (free_vars, var_heap)
268
 	# (var_info, var_heap) = readPtr var_info_ptr var_heap
269
270
271
272
273
274
	= 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)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
275

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
276
weightedRefCountOfCase rci=:{rci_depth} this_case=:{case_expr, case_guards, case_default, case_info_ptr} (EI_CaseType case_type)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
277
			rs=:{ rcs_var_heap, rcs_expr_heap, rcs_imports }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
278
279
	# (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
280
281
282
	  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
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
283
284
	  (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 
285
	  		{ rcc_all_variables = all_vars, rcc_default_variables = default_vars, rcc_pattern_variables = local_vars })
286
	= {rs & rcs_var_heap = rcs_var_heap, rcs_expr_heap = rcs_expr_heap, rcs_free_vars = rcs_free_vars}
287
	where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
288
289
290
		weighted_ref_count_in_default rci (Yes expr) info
			= weightedRefCountInPatternExpr rci expr info
		weighted_ref_count_in_default rci No info
291
			= ([], info)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
292

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
293
294
295
296
		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)
297
298
		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)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
299
		weighted_ref_count_in_case_patterns rci (DynamicPatterns patterns) collected_imports var_heap expr_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
300
			= mapSt (\{dp_rhs} -> weightedRefCountInPatternExpr rci dp_rhs) patterns ([], collected_imports, var_heap, expr_heap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
301

302
303
304
305
306
307
308
309
310
311
		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]
312
313
						= checkImportedSymbol (SK_Constructor {glob_module = glob_module, glob_object = ds_index})
												cons_type_ptr (collected_imports, var_heap)
314
315
316
317
318
319
320
						= (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;

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
321
weightedRefCountOfCase rci=:{rci_depth} this_case=:{case_expr, case_guards, case_default, case_info_ptr} (EI_CaseTypeAndRefCounts case_type {rcc_all_variables})
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
322
323
324
			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)
325
	= {rs & rcs_var_heap = rcs_var_heap, rcs_free_vars = rcs_free_vars}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
326

327
instance weightedRefCount Selection
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
328
where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
329
330
331
332
333
334
335
336
	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
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
337
338
339
340
341
342
343
344

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))
345
346
347
348
349
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}))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
350
		// otherwise
351
			= ([ var : collected_vars], var_heap) 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
352

353
354
355
	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)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
356

357
358
359
360
361
362
363
364
365
366
367
	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)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
368

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
369
370
371
372
/*
	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'.
373
*/
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
374
checkImportOfDclFunction :: CheckImportedInfo Int Int *RCState -> *RCState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
375
checkImportOfDclFunction {cii_main_dcl_module_n, cii_dcl_functions} mod_index fun_index rs=:{rcs_imports, rcs_var_heap}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
376
377
378
	| 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)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
379
380
381
		= { rs & rcs_imports = rcs_imports, rcs_var_heap = rcs_var_heap }
	// otherwise
		= rs
382

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
383
checkRecordSelector {cii_main_dcl_module_n, cii_common_defs} {glob_module, glob_object={ds_index}} rs=:{rcs_imports,rcs_var_heap}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
384
385
	| glob_module <> cii_main_dcl_module_n
		# {com_selector_defs,com_cons_defs,com_type_defs} = cii_common_defs.[glob_module]
386
		  {sd_type_index} = com_selector_defs.[ds_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
387
		  {td_rhs = RecordType {rt_constructor={ds_index=cons_index}}} = com_type_defs.[sd_type_index]
388
		  {cons_type_ptr} = com_cons_defs.[cons_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
389
390
		  (rcs_imports, rcs_var_heap) = checkImportedSymbol (SK_Constructor {glob_module = glob_module, glob_object = cons_index})
											cons_type_ptr (rcs_imports, rcs_var_heap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
391
392
393
		= { rs & rcs_imports = rcs_imports, rcs_var_heap = rcs_var_heap }
	// otherwise
		= rs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
394

395
396
instance weightedRefCount App
where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
397
398
399
	weightedRefCount rci=:{rci_imported} {app_symb,app_args} rs
		# rs = weightedRefCount rci app_args rs
		= check_import rci_imported app_symb rs
400
	where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
401
402
		check_import cii {symb_kind=SK_Function {glob_module,glob_object}} rs=:{rcs_imports, rcs_var_heap}
			= checkImportOfDclFunction cii glob_module glob_object rs
403
		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}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
404
405
406
			| 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)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
407
408
409
410
				= { rs & rcs_imports = rcs_imports, rcs_var_heap = rcs_var_heap }
				= rs
		check_import _ _ rs
			= rs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
411

412
413
instance weightedRefCount TypeCodeExpression
where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
414
415
	weightedRefCount rci type_code_expr rs
		= rs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
416

417
instance weightedRefCount [a] | weightedRefCount a
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
418
where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
419
420
	weightedRefCount rci l rs
		=	foldr (weightedRefCount rci) rs l 
421
422
		
instance weightedRefCount (a,b) | weightedRefCount a & weightedRefCount b
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
423
where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
424
425
	weightedRefCount rci (x,y) rs
		=	weightedRefCount rci y (weightedRefCount rci x rs) 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
426

427
instance weightedRefCount LetBind
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
428
where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
429
430
	weightedRefCount rci {lb_src} rs
		=	weightedRefCount rci lb_src rs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
431

432
433
instance weightedRefCount (Bind a b) | weightedRefCount a
where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
434
435
	weightedRefCount rci bind=:{bind_src} rs
		=	weightedRefCount rci bind_src rs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
436

437
/*
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
438
439
440
	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.
441
*/
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
442

443
444
445
446
447
448
449
450
451
452
453
::	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
	}

454
455
456
457
458
::	DistributeInfo =
	{	di_depth 				:: !Int
	,	di_explicit_case_depth	:: !Int
	}

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
459
460
461
462
::	DistributeState =
	{	ds_lets			:: ![VarInfoPtr]
	,	ds_var_heap		:: !.VarHeap
	,	ds_expr_heap	:: !.ExpressionHeap
463
	}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
464

465
class distributeLets e :: !DistributeInfo !e !*DistributeState -> (!e, !*DistributeState)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
466

467
instance distributeLets Expression
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
468
where
469
	distributeLets di=:{di_depth} (Var var=:{var_ident,var_info_ptr}) ds=:{ds_var_heap}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
470
		#! var_info = sreadPtr var_info_ptr ds_var_heap
471
472
		= case var_info of
			VI_LetExpression lei
473
				| lei.lei_depth == di_depth
474
					| lei.lei_count == 1 && (case lei.lei_status of LES_Updated _ -> False; _ -> True)
475
						# (lei_updated_expr, ds) = distributeLets di lei.lei_expression ds
476
477
						-> (lei_updated_expr, { ds &  ds_var_heap = ds.ds_var_heap <:=
								(var_info_ptr, VI_LetExpression { lei & lei_status = LES_Updated lei_updated_expr }) })
478
						# ds = distributeLetsInLetExpression di var_info_ptr lei ds
479
						-> (Var { var & var_info_ptr = lei.lei_var.fv_info_ptr }, ds)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
480
				// otherwise
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
481
					-> (Var { var & var_info_ptr = lei.lei_var.fv_info_ptr }, ds)
482
			VI_CaseOrStrictLetVar var_info_ptr
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
483
				-> (Var { var & var_info_ptr = var_info_ptr }, ds)
484
			_
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
485
				-> (Var var, ds)
486
487
	distributeLets di (Case kees) ds
		# (kees, ds) = distributeLets di kees ds
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
488
		= (Case kees, ds)
489
490
	distributeLets di (App app=:{app_args}) ds
		# (app_args, ds) = distributeLets di app_args ds
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
491
		= (App {app & app_args = app_args}, ds)
492
493
494
	distributeLets di (fun_expr @ exprs) ds
		# (fun_expr, ds) = distributeLets di fun_expr ds
		  (exprs, ds) = distributeLets di exprs ds
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
495
		= (fun_expr @ exprs, ds)
496
	distributeLets di expr=:(BasicExpr _) ds
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
497
		= (expr, ds)
498
499
500
	distributeLets di (Selection opt_tuple expr selectors) ds
		# (expr, ds) = distributeLets di expr ds
		# (selectors, ds) = distributeLets di selectors ds
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
501
		= (Selection opt_tuple expr selectors, ds)
502
503
504
505
	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
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
506
		= (Update expr1 selectors expr2, ds)
507
508
509
	distributeLets di (RecordUpdate cons_symbol expr exprs) ds
		# (expr, ds) = distributeLets di expr ds
		# (exprs, ds) = distributeLets di exprs ds
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
510
		= (RecordUpdate cons_symbol expr exprs, ds)
511
512
	distributeLets di (TupleSelect tuple_symbol arg_nr expr) ds
		# (expr, ds) = distributeLets di expr ds
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
513
		= (TupleSelect tuple_symbol arg_nr expr, ds)
514
	distributeLets di=:{di_depth} (Let lad=:{let_strict_binds,let_lazy_binds,let_expr,let_info_ptr}) ds=:{ds_expr_heap,ds_var_heap}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
515
		# (let_info, ds_expr_heap) = readPtr let_info_ptr ds_expr_heap
516
517
		# (EI_LetTypeAndRefCounts let_type ref_counts) = let_info
		  nr_of_strict_lets = length let_strict_binds
518
		  ds_var_heap = set_let_expr_info di_depth let_lazy_binds ref_counts (drop nr_of_strict_lets let_type) ds_var_heap
519
		  (let_strict_binds,ds_var_heap) = mapSt set_strict_let_expr_info let_strict_binds ds_var_heap
520
521
522
		  (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
523
		| nr_of_strict_lets == 0
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
524
		    = (let_expr, ds)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
525
		// otherwise
526
527
		    = case let_expr of
		    	Let inner_let=:{let_info_ptr=inner_let_info_ptr}
528
					# (EI_LetType strict_inner_types, ds_expr_heap) = readPtr inner_let_info_ptr ds.ds_expr_heap
529
530
531
532
533
534
535
536
					# (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}, 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
537
						{ds & ds_expr_heap = ds_expr_heap})
538
	where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
539
		set_let_expr_info depth [{lb_src,lb_dst}:binds] [ref_count:ref_counts] [type:types] var_heap
540
			# (new_info_ptr, var_heap) = newPtr VI_LocalLetVar var_heap
541
			  lei = { lei_count = ref_count, lei_depth = depth, lei_var = { lb_dst & fv_info_ptr = new_info_ptr },
542
			  			lei_expression = lb_src, lei_type = type, lei_status =  LES_Untouched }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
543
			= set_let_expr_info depth binds ref_counts types (var_heap <:= (lb_dst.fv_info_ptr, VI_LetExpression lei))
544
		set_let_expr_info _ [] _ _ var_heap
545
			= var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
546

547
		set_strict_let_expr_info lb=:{lb_dst={fv_info_ptr}} var_heap
548
			# (new_info_ptr, var_heap) = newPtr VI_StrictLetVar var_heap
549
			= ({lb & lb_dst.fv_info_ptr = new_info_ptr}, var_heap <:= (fv_info_ptr, VI_CaseOrStrictLetVar new_info_ptr))
550
	
551
		distribute_lets_in_non_distributed_let di {lb_dst={fv_ident,fv_info_ptr}} ds=:{ds_var_heap}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
552
			# (VI_LetExpression lei=:{lei_count}, ds_var_heap) = readPtr fv_info_ptr ds_var_heap
553
554
			| lei_count > 0
//			| not lei_moved && lei_count > 0
555
				= distributeLetsInLetExpression di fv_info_ptr lei { ds & ds_var_heap = ds_var_heap }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
556
				= { ds & ds_var_heap = ds_var_heap }
557

558
559
560
561
562
563
	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)
564
	distributeLets _ expr=:(TypeCodeExpression _) ds
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
565
		= (expr, ds)
566
	distributeLets _ (AnyCodeExpr in_params out_params code_expr) ds=:{ds_var_heap}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
567
		# (in_params, ds_var_heap) = mapSt determine_input_parameter in_params ds_var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
568
		= (AnyCodeExpr in_params out_params code_expr, { ds & ds_var_heap = ds_var_heap })
569
		where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
570
			determine_input_parameter bind=:{bind_dst} var_heap
571
572
				# (var_info, var_heap) = readPtr bind_dst.var_info_ptr var_heap
				= case var_info of
573
					VI_CaseOrStrictLetVar new_info_ptr
574
575
576
						-> ({ bind & bind_dst = { bind_dst & var_info_ptr = new_info_ptr }}, var_heap)
					_
						-> (bind, var_heap)
577
	distributeLets _ expr=:(ABCCodeExpr _ _) ds
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
578
		= (expr, ds)
579
	distributeLets _ EE ds
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
580
		= (EE, ds)
581
	distributeLets _ (NoBind ptr) ds
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
582
		= (NoBind ptr, ds)
583
	distributeLets _ (FailExpr id) ds
584
		= (FailExpr id, ds)
585
586

instance distributeLets Case
587
where
588
589
590
	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
591
592
		  	{	rcc_all_variables = tot_ref_counts ,
		  		rcc_default_variables = ref_counts_in_default,
593
594
		  		rcc_pattern_variables = ref_counts_in_patterns }) = case_old_info
		  new_depth = di_depth + 1
595
596
597
598
		  new_di =	{	di
					&	di_depth = new_depth
					,	di_explicit_case_depth = if case_explicit new_depth di_explicit_case_depth
					}
599
		  (local_lets, ds_var_heap) = mark_local_let_vars new_depth tot_ref_counts ds_var_heap
600
										  	// -*-> ("ref_counts", case_expr, tot_ref_counts, ref_counts_in_patterns)
601
602
603
604
605
606
607
608
609
		  	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)
		  	
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
610
	 	  ds = {ds & ds_var_heap=ds_var_heap, ds_expr_heap=ds_expr_heap}
611
612
613
		  (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)
614
		  
615
		# ds_var_heap = foldSt reset_local_let_var local_lets ds_var_heap ->> ("outer_vars", di_depth, di.di_explicit_case_depth, outer_vars)
616
617
618
619
620
		  (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}
621
		  (case_info_ptr, ds_expr_heap) = newPtr case_new_info ds.ds_expr_heap
622
		  kees = { kees & case_info_ptr = case_info_ptr } // ->> ("case_kind", di_depth, kind, case_explicit, ptrToInt case_info_ptr)
623
		= (kees, { ds & ds_expr_heap = ds_expr_heap, ds_var_heap = ds_var_heap})
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
624
	where
625
626
627
628
		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
629
			| case_explicit || outer_vars || not (is_lhs_var case_expr var_heap)
630
631
632
633
				=	(CaseKindTransform, var_heap)
			// otherwise
				=	(CaseKindLeave, var_heap)
			where
634
				is_lhs_var (Var {var_info_ptr, var_ident}) var_heap
635
636
					= 	case sreadPtr var_info_ptr var_heap of
							VI_LocalLetVar
637
								->	False
638
							VI_LetExpression _
639
640
641
								->	False
							VI_StrictLetVar
								->	False
642
							info
643
								->	True
644
645
646
647
648
649
650
651
652
653
				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
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
654
			= (AlgebraicPatterns conses patterns, ds)
655
656
		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
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
657
			= (BasicPatterns type patterns, ds)
658
		where
659
660
			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
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
661
				= ({ pattern & bp_expr = bp_expr }, ds)
662
663
		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
664
665
			= (OverloadedListPatterns conses decons_expr patterns, heaps)

666
		distribute_lets_in_alg_pattern di (ref_counts,pattern) ds=:{ds_var_heap}
667
668
			# (ap_vars, ds_var_heap) = mapSt refresh_variable pattern.ap_vars ds_var_heap
			  ds = {ds & ds_var_heap = ds_var_heap}
669
			  (ap_expr, ds) = distribute_lets_in_pattern_expr di ref_counts pattern.ap_expr ds
670
			= ({ pattern & ap_vars = ap_vars, ap_expr = ap_expr }, ds) 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
671

672
673
		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
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
674
			= (Yes expr, ds)
675
		distribute_lets_in_default _ ref_counts_in_default No ds
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
676
			= (No, ds)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
677

678
		refresh_variable fv=:{fv_info_ptr} var_heap
679
680
			# (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))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
681

682
		mark_local_let_var depth {cv_variable, cv_count} (local_vars, var_heap)
683
			# (VI_LetExpression lei=:{lei_count,lei_depth,lei_var}, var_heap) = readPtr cv_variable var_heap
684
			| lei_count == cv_count && lei_depth==depth-1
685
686
				= ([(cv_variable, lei_count, lei_depth) : local_vars ], var_heap <:= (cv_variable, VI_LetExpression { lei & lei_depth = depth}))
				= (local_vars, var_heap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
687

688
689
690
691
		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
692
					TupleSelect _ _ (Var var=:{var_ident,var_info_ptr})
693
694
695
696
697
698
						# (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}))
699
					Selection NormalSelector (Var var=:{var_ident,var_info_ptr}) [RecordSelection _ _]
700
701
702
703
704
705
706
707
708
709
710
711
712
713
						# (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
714
				TupleSelect _ _ (Var var=:{var_ident,var_info_ptr})
715
716
717
718
719
720
721
					# (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)
722
				Selection NormalSelector (Var var=:{var_ident,var_info_ptr}) [RecordSelection _ _]
723
724
725
726
727
728
729
730
					# (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)

731
732
733
		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 })
734
   
735
		is_outer_var {di_depth, di_explicit_case_depth} {cv_variable}  (outer, var_heap)
736
737
738
739
740
741
742
			| 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);
743

744
745
		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
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
746
747
			  (ds=:{ds_lets}) = {ds & ds_var_heap = ds_var_heap}
			  ds = {ds & ds_lets = []}
748
			  (pattern_expr, ds) = distributeLets di pattern_expr ds
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
749
			  (ds_lets2, ds) = ds!ds_lets
750
			  ds = foldSt (reexamine_local_let_expr di) local_vars ds
751
			# (letExpr, ds) = buildLetExpr pattern_expr ds
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
752
753
754
				-*-> ("distribute_lets_in_pattern_expr", ds_lets2)
			  ds = {ds & ds_lets = ds_lets}
			= (letExpr, ds)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
755

756
757
758
759
760
		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
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
761

762
		reexamine_local_let_expr di=:{di_depth} {cv_variable, cv_count} ds=:{ds_var_heap}
763
			| cv_count >= 1
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
764
				# (VI_LetExpression lei, ds_var_heap) = readPtr cv_variable ds_var_heap
765
766
				| di_depth == lei.lei_depth
					= distributeLetsInLetExpression di cv_variable lei { ds & ds_var_heap = ds_var_heap }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
767
768
769
					= { ds & ds_var_heap = ds_var_heap<