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

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

7
// exactZip fails when its arguments are of unequal length
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
8
9
exactZip` :: ![.a] ![.b] -> [(.a,.b)]
exactZip` [] []
10
	=	[]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
11
exactZip` [x:xs][y:ys]
12
	=	[(x,y) : exactZip xs ys]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
13
exactZip
14
	:==	exactZip`
15

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
16
getIdent :: (Optional Ident) Int -> Ident
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
17
18
19
20
21
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
22
addLetVars :: [LetBind] [AType] [(FreeVar, AType)] -> [(FreeVar, AType)]
23
24
addLetVars [{lb_dst} : binds] [bind_type : bind_types] bound_vars
	= addLetVars binds bind_types [ (lb_dst, bind_type) : bound_vars ]
25
addLetVars [] [] bound_vars
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
26
27
	= bound_vars

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

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

	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}
72
73
		  (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
74
		  {ss_expr_heap, ss_var_heap}
75
76
		  	= 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
77
78

	split :: SymbKind (ImportedFunctions, ImportedConstructors) -> (ImportedFunctions, ImportedConstructors) 
79
80
81
82
	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
83

84
85
86
87
88
89
90
91
92
93
94
95
96
// sanity check ...
class checkCaseTypes a :: !a !*ExpressionHeap -> (!Bool, !*ExpressionHeap)

instance checkCaseTypes Expression where
	checkCaseTypes (Let {let_expr}) expr_heap
		= checkCaseTypes let_expr expr_heap
	checkCaseTypes (Case kees) expr_heap
		= checkCaseTypes kees expr_heap
	checkCaseTypes _ expr_heap
		=	(True, expr_heap)

instance checkCaseTypes Case where
	checkCaseTypes kees=:{case_expr, case_guards, case_default, case_explicit, case_info_ptr} expr_heap
97
98
		# (info, expr_heap) = readPtr case_info_ptr expr_heap
		# {ct_cons_types} = case_type info
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
		# (guards_ok, expr_heap) = checkCaseTypesCasePatterns case_guards ct_cons_types expr_heap
	  	# (default_ok, expr_heap)= checkCaseTypes case_default expr_heap
		= (guards_ok && default_ok, expr_heap)
	where
		case_type (EI_CaseTypeAndSplits type _)
			=	type
		case_type (EI_CaseType type)
			=	type

checkCaseTypesCasePatterns :: CasePatterns [[AType]] *ExpressionHeap -> (Bool, *ExpressionHeap)
checkCaseTypesCasePatterns (BasicPatterns bt patterns) _ expr_heap
	=	(True, expr_heap)
checkCaseTypesCasePatterns (AlgebraicPatterns gi patterns) arg_types expr_heap
	| length patterns <> length arg_types
		=	abort ("checkCaseTypesCasePatterns error number of cases " +++ toString (length patterns) +++ " <> " +++ toString (length arg_types)) <<- arg_types
	=	checkCaseTypesAlgebraicPatterns (exactZip patterns arg_types) expr_heap
checkCaseTypesCasePatterns (OverloadedListPatterns type decons_expr patterns) arg_types expr_heap
	| length patterns <> length arg_types
		=	abort ("checkCaseTypesCasePatterns error number of cases " +++ toString (length patterns) +++ " <> " +++ toString (length arg_types)) <<- arg_types
	=	checkCaseTypesAlgebraicPatterns (exactZip patterns arg_types) expr_heap

checkCaseTypesAlgebraicPatterns :: [(AlgebraicPattern, [AType])] *ExpressionHeap -> (Bool, *ExpressionHeap)
checkCaseTypesAlgebraicPatterns l expr_heap
	# (oks, expr_heap)
		=	mapSt checkCaseTypesAlgebraicPattern l expr_heap
	=	(and oks, expr_heap)
where
	checkCaseTypesAlgebraicPattern :: (AlgebraicPattern, [AType]) *ExpressionHeap -> (Bool, *ExpressionHeap)
	checkCaseTypesAlgebraicPattern (pattern=:{ap_expr, ap_vars}, arg_types) expr_heap
		| length ap_vars <> length arg_types
			=	abort ("checkCaseTypesCasePattern error number of pattern args " +++ toString (length ap_vars) +++ " <> " +++ toString (length arg_types)) <<- arg_types
		=	(length ap_vars == length arg_types, expr_heap)

instance checkCaseTypes (Optional a) | checkCaseTypes a where
	checkCaseTypes (Yes expr) cs
		= checkCaseTypes expr cs
	checkCaseTypes No cs
		= (True, cs)

instance checkCaseTypes [a] | checkCaseTypes a where
	checkCaseTypes l cs
		# (oks, expr_heap)
			=	mapSt checkCaseTypes l cs 
		=	(and oks, expr_heap)

instance checkCaseTypes BasicPattern where
	checkCaseTypes pattern=:{bp_expr} cs
		=	checkCaseTypes bp_expr cs
// ... sanity check
148

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
149
:: CaseLevel = CaseLevelRoot | CaseLevelAfterGuardRoot
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
150

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
151
152
153
154
155
156
:: 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
157

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
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.
177
*/
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
178

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
179
180
181
182
183
184
::	CheckImportedInfo =
	{	cii_dcl_functions	:: !{# {# FunType} }
	,	cii_common_defs		:: !{# CommonDefs}
	,	cii_main_dcl_module_n :: !Int
	}

185
::	RCInfo =
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
186
187
188
189
190
191
192
193
194
	{	rci_imported	:: !CheckImportedInfo
	,	rci_depth		:: !Int
	}

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

197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
::	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
	}

212
213
214
215
216
217
218
219
220
221
222
::	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
223
checkImportedSymbol :: SymbKind VarInfoPtr ([SymbKind], *VarHeap) -> ([SymbKind], *VarHeap)
224
checkImportedSymbol symb_kind symb_type_ptr (collected_imports, var_heap)
225
	# (type_info, var_heap) = readPtr symb_type_ptr var_heap
226
227
228
229
230
	= case type_info of
		VI_Used
			-> (collected_imports, var_heap)
		_
			-> ([symb_kind : collected_imports ], var_heap <:= (symb_type_ptr, VI_Used))
231

232
weightedRefCountOfVariable depth var_info_ptr lvi=:{lvi_count,lvi_var,lvi_depth,lvi_previous,lvi_new} ref_count new_vars
233
	| lvi_depth < depth
234
235
236
237
		= (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
238
	// otherwise
239
240
		= (lvi_new, { lvi & lvi_count = lvi_count + ref_count }, new_vars)

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
241
class weightedRefCount e :: RCInfo !e !*RCState -> *RCState
242
243

instance weightedRefCount BoundVar
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
244
where
245
	weightedRefCount rci=:{rci_depth} {var_ident,var_info_ptr} rs=:{rcs_var_heap}
246
		# (var_info, rcs_var_heap) = readPtr var_info_ptr rcs_var_heap
247
		  rs = {rs & rcs_var_heap = rcs_var_heap}
248
249
		= case var_info of
			VI_LetVar lvi
250
				# (is_new, lvi=:{lvi_expression}, rcs_free_vars) = weightedRefCountOfVariable rci_depth var_info_ptr lvi 1 rs.rcs_free_vars
251
				| is_new
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
252
253
254
255
256
257
258
					# 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) }
259
			_
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
260
261
				-> rs

262
263
instance weightedRefCount Expression
where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
264
265
266
267
268
269
270
271
272
273
274
	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 }
275
276
		= case let_info of
			EI_LetType let_type
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
277
278
279
280
		  		# (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)}
281
			_
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
282
283
				# (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 }
284
285
286
	where
		remove_variable ([], var_heap) let_bind
			= ([], var_heap)
287
		remove_variable ([var_ptr : var_ptrs], var_heap) bind=:{lb_dst={fv_ident,fv_info_ptr}}
288
289
290
			| 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
291
			// otherwise
292
293
				# (var_ptrs, var_heap) = remove_variable (var_ptrs, var_heap) bind
				= ([var_ptr : var_ptrs], var_heap)
294

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

299
		get_ref_count {lb_dst={fv_ident,fv_info_ptr}} var_heap 
300
301
			# (VI_LetVar {lvi_count}, var_heap) = readPtr fv_info_ptr var_heap
		  	= (lvi_count, var_heap)
302

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
303
	weightedRefCount rci (Case case_expr) rs=:{rcs_expr_heap}
304
305
306
307
308
309
310
/*
// sanity check ...
		# (ok, rcs_expr_heap) = checkCaseTypes case_expr rcs_expr_heap
		| not ok
			=	abort "error in case types (weightedRefCount)"
// ... sanity check
*/
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
311
		# (case_info, rcs_expr_heap) = readPtr case_expr.case_info_ptr rcs_expr_heap
312
		= weightedRefCountOfCase rci case_expr case_info {rs & rcs_expr_heap = rcs_expr_heap}
313
	weightedRefCount rci expr=:(BasicExpr _) rs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
314
		= rs
315
	weightedRefCount rci (MatchExpr constructor expr) rs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
		= weightedRefCount rci expr 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 (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
335
336
	weightedRefCount rci (FailExpr _) rs
		= rs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
337
	weightedRefCount rci expr rs
338
		= abort ("weightedRefCount [Expression] (convertcases))" -*-> expr)
339

340
addPatternVariable depth {cv_variable = var_info_ptr, cv_count = ref_count} (free_vars, var_heap)
341
 	# (var_info, var_heap) = readPtr var_info_ptr var_heap
342
343
344
345
346
347
	= 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
348

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
349
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
350
			rs=:{ rcs_var_heap, rcs_expr_heap, rcs_imports }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
351
352
	# (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
353
354
355
	  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
356
357
	  (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 
358
	  		{ rcc_all_variables = all_vars, rcc_default_variables = default_vars, rcc_pattern_variables = local_vars })
359
	= {rs & rcs_var_heap = rcs_var_heap, rcs_expr_heap = rcs_expr_heap, rcs_free_vars = rcs_free_vars}
360
	where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
361
362
363
		weighted_ref_count_in_default rci (Yes expr) info
			= weightedRefCountInPatternExpr rci expr info
		weighted_ref_count_in_default rci No info
364
			= ([], info)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
365

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
366
367
368
369
		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)
370
371
		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
372
		weighted_ref_count_in_case_patterns rci (DynamicPatterns patterns) collected_imports var_heap expr_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
373
			= mapSt (\{dp_rhs} -> weightedRefCountInPatternExpr rci dp_rhs) patterns ([], collected_imports, var_heap, expr_heap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
374

375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
		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]
						  (collected_imports, var_heap) = checkImportedSymbol (SK_Constructor {glob_module = glob_module, glob_object = ds_index})
								cons_type_ptr (collected_imports, var_heap)
						= (collected_imports, var_heap)
					// otherwise
						= (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
396
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
397
398
399
			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)
400
	= {rs & rcs_var_heap = rcs_var_heap, rcs_free_vars = rcs_free_vars}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
401

402
instance weightedRefCount Selection
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
403
where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
404
405
406
407
408
409
410
411
	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
412
413
414
415
416
417
418
419

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))
420
421
422
423
424
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
425
		// otherwise
426
			= ([ var : collected_vars], var_heap) 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
427

428
429
430
	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
431

432
433
434
435
436
437
438
439
440
441
442
443
	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
444

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
445
446
447
448
/*
	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'.
449
*/
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
450
checkImportOfDclFunction :: CheckImportedInfo Int Int *RCState -> *RCState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
451
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
452
453
454
	| 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
455
456
457
458
		= { 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}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
459
460
	| glob_module <> cii_main_dcl_module_n
		# {com_selector_defs,com_cons_defs,com_type_defs} = cii_common_defs.[glob_module]
461
		  {sd_type_index} = com_selector_defs.[ds_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
462
		  {td_rhs = RecordType {rt_constructor={ds_index=cons_index}}} = com_type_defs.[sd_type_index]
463
		  {cons_type_ptr} = com_cons_defs.[cons_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
464
465
		  (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
466
467
468
		= { rs & rcs_imports = rcs_imports, rcs_var_heap = rcs_var_heap }
	// otherwise
		= rs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
469

470
471
instance weightedRefCount App
where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
472
473
474
	weightedRefCount rci=:{rci_imported} {app_symb,app_args} rs
		# rs = weightedRefCount rci app_args rs
		= check_import rci_imported app_symb rs
475
	where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
476
477
		check_import cii {symb_kind=SK_Function {glob_module,glob_object}} rs=:{rcs_imports, rcs_var_heap}
			= checkImportOfDclFunction cii glob_module glob_object rs
478
		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
479
480
481
			| 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
482
483
484
485
				= { 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
486

487
488
instance weightedRefCount TypeCodeExpression
where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
489
490
	weightedRefCount rci type_code_expr rs
		= rs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
491

492
instance weightedRefCount [a] | weightedRefCount a
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
493
where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
494
495
	weightedRefCount rci l rs
		=	foldr (weightedRefCount rci) rs l 
496
497
		
instance weightedRefCount (a,b) | weightedRefCount a & weightedRefCount b
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
498
where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
499
500
	weightedRefCount rci (x,y) rs
		=	weightedRefCount rci y (weightedRefCount rci x rs) 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
501

502
instance weightedRefCount LetBind
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
503
where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
504
505
	weightedRefCount rci {lb_src} rs
		=	weightedRefCount rci lb_src rs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
506

507
508
instance weightedRefCount (Bind a b) | weightedRefCount a
where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
509
510
	weightedRefCount rci bind=:{bind_src} rs
		=	weightedRefCount rci bind_src rs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
511

512
/*
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
513
514
515
	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.
516
*/
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
517

518
519
520
521
522
523
524
525
526
527
528
::	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
	}

529
530
531
532
533
::	DistributeInfo =
	{	di_depth 				:: !Int
	,	di_explicit_case_depth	:: !Int
	}

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
534
535
536
537
::	DistributeState =
	{	ds_lets			:: ![VarInfoPtr]
	,	ds_var_heap		:: !.VarHeap
	,	ds_expr_heap	:: !.ExpressionHeap
538
	}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
539

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

542
instance distributeLets Expression
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
543
where
544
	distributeLets di=:{di_depth} (Var var=:{var_ident,var_info_ptr}) ds=:{ds_var_heap}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
545
		#! var_info = sreadPtr var_info_ptr ds_var_heap
546
547
		= case var_info of
			VI_LetExpression lei
548
				| lei.lei_depth == di_depth
549
					| lei.lei_count == 1 && (case lei.lei_status of LES_Updated _ -> False; _ -> True)
550
						# (lei_updated_expr, ds) = distributeLets di lei.lei_expression ds
551
552
						-> (lei_updated_expr, { ds &  ds_var_heap = ds.ds_var_heap <:=
								(var_info_ptr, VI_LetExpression { lei & lei_status = LES_Updated lei_updated_expr }) })
553
						# ds = distributeLetsInLetExpression di var_info_ptr lei ds
554
						-> (Var { var & var_info_ptr = lei.lei_var.fv_info_ptr }, ds)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
555
				// otherwise
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
556
					-> (Var { var & var_info_ptr = lei.lei_var.fv_info_ptr }, ds)
557
			VI_CaseOrStrictLetVar var_info_ptr
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
558
				-> (Var { var & var_info_ptr = var_info_ptr }, ds)
559
			_
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
560
				-> (Var var, ds)
561
562
	distributeLets di (Case kees) ds
		# (kees, ds) = distributeLets di kees ds
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
563
		= (Case kees, ds)
564
565
	distributeLets di (App app=:{app_args}) ds
		# (app_args, ds) = distributeLets di app_args ds
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
566
		= (App {app & app_args = app_args}, ds)
567
568
569
	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
570
		= (fun_expr @ exprs, ds)
571
	distributeLets di expr=:(BasicExpr _) ds
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
572
		= (expr, ds)
573
574
	distributeLets di (MatchExpr constructor expr) ds
		# (expr, ds) = distributeLets di expr ds
575
		= (MatchExpr constructor expr, ds)
576
577
578
	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
579
		= (Selection opt_tuple expr selectors, ds)
580
581
582
583
	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
584
		= (Update expr1 selectors expr2, ds)
585
586
587
	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
588
		= (RecordUpdate cons_symbol expr exprs, ds)
589
590
	distributeLets di (TupleSelect tuple_symbol arg_nr expr) ds
		# (expr, ds) = distributeLets di expr ds
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
591
		= (TupleSelect tuple_symbol arg_nr expr, ds)
592
	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
593
		# (let_info, ds_expr_heap) = readPtr let_info_ptr ds_expr_heap
594
595
		# (EI_LetTypeAndRefCounts let_type ref_counts) = let_info
		  nr_of_strict_lets = length let_strict_binds
596
		  ds_var_heap = set_let_expr_info di_depth let_lazy_binds ref_counts (drop nr_of_strict_lets let_type) ds_var_heap
597
		  (let_strict_binds,ds_var_heap) = mapSt set_strict_let_expr_info let_strict_binds ds_var_heap
598
599
600
		  (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
601
		| nr_of_strict_lets == 0
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
602
		    = (let_expr, ds)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
603
		// otherwise
604
605
		    = case let_expr of
		    	Let inner_let=:{let_info_ptr=inner_let_info_ptr}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
606
		    		# (EI_LetType strict_inner_types, ds_expr_heap) = readPtr inner_let_info_ptr ds.ds_expr_heap
607
608
609
610
611
612
613
614
					# (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
615
						{ds & ds_expr_heap = ds_expr_heap})
616
	where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
617
		set_let_expr_info depth [{lb_src,lb_dst}:binds] [ref_count:ref_counts] [type:types] var_heap
618
			# (new_info_ptr, var_heap) = newPtr VI_LocalLetVar var_heap
619
			  lei = { lei_count = ref_count, lei_depth = depth, lei_var = { lb_dst & fv_info_ptr = new_info_ptr },
620
			  			lei_expression = lb_src, lei_type = type, lei_status =  LES_Untouched }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
621
			= set_let_expr_info depth binds ref_counts types (var_heap <:= (lb_dst.fv_info_ptr, VI_LetExpression lei))
622
		set_let_expr_info _ [] _ _ var_heap
623
			= var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
624

625
		set_strict_let_expr_info lb=:{lb_dst={fv_info_ptr}} var_heap
626
			# (new_info_ptr, var_heap) = newPtr VI_StrictLetVar var_heap
627
			= ({lb & lb_dst.fv_info_ptr = new_info_ptr}, var_heap <:= (fv_info_ptr, VI_CaseOrStrictLetVar new_info_ptr))
628
	
629
		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
630
			# (VI_LetExpression lei=:{lei_count}, ds_var_heap) = readPtr fv_info_ptr ds_var_heap
631
632
			| lei_count > 0
//			| not lei_moved && lei_count > 0
633
				= distributeLetsInLetExpression di fv_info_ptr lei { ds & ds_var_heap = ds_var_heap }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
634
				= { ds & ds_var_heap = ds_var_heap }
635

636
	distributeLets _ expr=:(TypeCodeExpression _) ds
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
637
		= (expr, ds)
638
	distributeLets _ (AnyCodeExpr in_params out_params code_expr) ds=:{ds_var_heap}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
639
		# (in_params, ds_var_heap) = mapSt determine_input_parameter in_params ds_var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
640
		= (AnyCodeExpr in_params out_params code_expr, { ds & ds_var_heap = ds_var_heap })
641
		where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
642
			determine_input_parameter bind=:{bind_dst} var_heap
643
644
				# (var_info, var_heap) = readPtr bind_dst.var_info_ptr var_heap
				= case var_info of
645
					VI_CaseOrStrictLetVar new_info_ptr
646
647
648
						-> ({ bind & bind_dst = { bind_dst & var_info_ptr = new_info_ptr }}, var_heap)
					_
						-> (bind, var_heap)
649
	distributeLets _ expr=:(ABCCodeExpr _ _) ds
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
650
		= (expr, ds)
651
	distributeLets _ EE ds
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
652
		= (EE, ds)
653
	distributeLets _ (NoBind ptr) ds
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
654
		= (NoBind ptr, ds)
655
	distributeLets _ (FailExpr id) ds
656
		= (FailExpr id, ds)
657
658

instance distributeLets Case
659
where
660
661
662
	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
663
664
		  	{	rcc_all_variables = tot_ref_counts ,
		  		rcc_default_variables = ref_counts_in_default,
665
666
667
668
669
670
671
		  		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
		  		}
672
		  (local_lets, ds_var_heap) = mark_local_let_vars new_depth tot_ref_counts ds_var_heap
673
										  	// -*-> ("ref_counts", case_expr, tot_ref_counts, ref_counts_in_patterns)
674
675
676
677
678
679
680
681
682
		  	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
683
	 	  ds = {ds & ds_var_heap=ds_var_heap, ds_expr_heap=ds_expr_heap}
684
685
686
		  (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)
687
		  
688
		# ds_var_heap = foldSt reset_local_let_var local_lets ds_var_heap ->> ("outer_vars", di_depth, di.di_explicit_case_depth, outer_vars)
689
690
691
692
693
		  (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}
694
695
		  (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)
696
		= (kees, { ds & ds_expr_heap = ds_expr_heap, ds_var_heap = ds_var_heap})
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
697
	where
698
699
700
701
		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
702
			| case_explicit || outer_vars || not (is_lhs_var case_expr var_heap)
703
704
705
706
707
				=	(CaseKindTransform, var_heap)
			// otherwise
				=	(CaseKindLeave, var_heap)
			where

708
				is_lhs_var (Var {var_info_ptr, var_ident}) var_heap
709
710
					= 	case sreadPtr var_info_ptr var_heap of
							VI_LocalLetVar
711
								->	False
712
							VI_LetExpression _
713
714
715
								->	False
							VI_StrictLetVar
								->	False
716
							info
717
								->	True
718
719
720
721
722
723
724
725
726
727
				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
728
			= (AlgebraicPatterns conses patterns, ds)
729
730
		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
731
			= (BasicPatterns type patterns, ds)
732
		where
733
734
			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
735
				= ({ pattern & bp_expr = bp_expr }, ds)
736
737
		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
738
739
			= (OverloadedListPatterns conses decons_expr patterns, heaps)

740
		distribute_lets_in_alg_pattern di (ref_counts,pattern) ds=:{ds_var_heap}
741
742
			# (ap_vars, ds_var_heap) = mapSt refresh_variable pattern.ap_vars ds_var_heap
			  ds = {ds & ds_var_heap = ds_var_heap}
743
			  (ap_expr, ds) = distribute_lets_in_pattern_expr di ref_counts pattern.ap_expr ds
744
			= ({ pattern & ap_vars = ap_vars, ap_expr = ap_expr }, ds) 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
745

746
747
		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
748
			= (Yes expr, ds)
749
		distribute_lets_in_default _ ref_counts_in_default No ds
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
750
			= (No, ds)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
751

752
		refresh_variable fv=:{fv_info_ptr} var_heap
753
754
			# (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
755

756
		mark_local_let_var depth {cv_variable, cv_count} (local_vars, var_heap)
757
			# (VI_LetExpression lei=:{lei_count,lei_depth,lei_var}, var_heap) = readPtr cv_variable var_heap
758
			| lei_count == cv_count && lei_depth==depth-1
759
760
				= ([(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
761

762
763
764
765
		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
766
					TupleSelect _ _ (Var var=:{var_ident,var_info_ptr})
767
768
769
770
771
772
						# (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}))
773
					Selection NormalSelector (Var var=:{var_ident,var_info_ptr}) [RecordSelection _ _]
774
775
776
777
778
779
780
781
782
783
784
785
786
787
						# (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
788
				TupleSelect _ _ (Var var=:{var_ident,var_info_ptr})
789
790
791
792
793
794
795
					# (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)
796
				Selection NormalSelector (Var var=:{var_ident,var_info_ptr}) [RecordSelection _ _]
797
798
799
800
801
802
803
804
					# (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)

805
806
807
		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 })
808
   
809
		is_outer_var {di_depth, di_explicit_case_depth} {cv_variable}  (outer, var_heap)
810
811
812
813
814
815
816
			| 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);
817