convertcases.icl 95.1 KB
Newer Older
1
2
3
/*
	module owner: Ronny Wichers Schreur
*/
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
4
5
implementation module convertcases

6
import syntax, transform, checksupport, StdCompare, check, utilities, trans, general; //, RWSDebug
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
7

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

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

29
30
31
32
33
34
convertCasesOfFunctions :: !*{! Group} !Int !{# {# FunType} } !{# CommonDefs} !*{#FunDef} !*{#{# CheckedTypeDef}}
		!ImportedConstructors !*VarHeap !*TypeHeaps !*ExpressionHeap
			-> (!ImportedFunctions, !*{! Group}, !*{#FunDef}, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap)
convertCasesOfFunctions groups main_dcl_module_n dcl_functions common_defs fun_defs imported_types imported_conses var_heap type_heaps expr_heap
	#! nr_of_funs = size fun_defs
	# (groups, (fun_defs, collected_imports, {cs_new_functions, cs_var_heap, cs_expr_heap, cs_fun_heap}))
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, /* abort "that's enough" */ 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
49
			= convert_groups (inc group_nr) groups dcl_functions common_defs main_dcl_module_n
				(foldSt (convert_function group_nr dcl_functions common_defs main_dcl_module_n) group.group_members fun_defs_and_ci)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
50

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
51
	convert_function group_index dcl_functions common_defs main_dcl_module_n fun (fun_defs, collected_imports, cs)
52
		# (fun_def, fun_defs) = fun_defs![fun]
53
		# {fun_body,fun_type} = fun_def -*-> ("*** converting ****", fun_def.fun_ident.id_name)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
54
		  (fun_body, (collected_imports, cs)) = eliminate_code_sharing_in_function dcl_functions main_dcl_module_n common_defs fun_body /* (fun_body 
55
		   ("convert_function", fun_def.fun_ident, fun_body)) */ (collected_imports, cs)		  		
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
56
57
58
59
60
61
62
63
64
		  (fun_body, cs) = convertCasesInBody fun_body fun_type group_index common_defs cs
		= ({fun_defs & [fun].fun_body = fun_body }, collected_imports, cs)

	eliminate_code_sharing_in_function dcl_functions main_dcl_module_n common_defs (TransformedBody body=:{tb_rhs}) (collected_imports, cs=:{cs_expr_heap,cs_var_heap})
		# {rcs_var_heap, rcs_expr_heap, rcs_imports} = weightedRefCount {rci_imported = {cii_dcl_functions=dcl_functions, cii_common_defs=common_defs, cii_main_dcl_module_n = main_dcl_module_n}, rci_depth=1} tb_rhs
				{ rcs_var_heap = cs_var_heap, rcs_expr_heap = cs_expr_heap, rcs_free_vars = [],
				  rcs_imports = collected_imports} 
		  	-*-> ("eliminate_code_sharing_in_function (weightedRefCount)", tb_rhs)
		  ds = { ds_lets = [], ds_var_heap = rcs_var_heap, ds_expr_heap = rcs_expr_heap}
65
		  (tb_rhs, ds) = distributeLets {di_depth=1,di_explicit_case_depth=0} tb_rhs ds -*-> "dis"
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
66
		  (tb_rhs, {ds_var_heap, ds_expr_heap}) = buildLetExpr tb_rhs ds -*-> "build"
67

68
		  {ss_expr_heap, ss_var_heap}
69
		  	= findSplitCases {si_next_alt=No, si_force_next_alt=False} tb_rhs
70
71
72
		  						{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
73
74
75
		  	-*-> ("eliminate_code_sharing_in_function (distributeLets)", 2, tb_rhs)

	split :: SymbKind (ImportedFunctions, ImportedConstructors) -> (ImportedFunctions, ImportedConstructors) 
76
77
78
79
	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
80

81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
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
148
// 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
		# (info, expr_heap)
			= readPtr case_info_ptr expr_heap
		# {ct_cons_types}
			= case_type info
		# (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
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
233
234
235
weightedRefCountOfVariable depth var_info_ptr lvi=:{lvi_count,lvi_var,lvi_depth,lvi_previous,lvi_new} ref_count new_vars
	| lvi_depth < depth 
		= (True, {lvi & lvi_count = ref_count, lvi_depth = depth, lvi_new = True, lvi_previous =
				[{plvi_count = lvi_count, plvi_depth = lvi_depth, plvi_new = lvi_new } : lvi_previous]}, [var_info_ptr : new_vars])
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
236
//					-*-> (lvi_var, " PUSHED ",lvi_depth)
237
238
	| lvi_count == 0
		= (True, { lvi & lvi_count = ref_count }, [var_info_ptr : new_vars])
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
239
	// otherwise
240
241
		= (lvi_new, { lvi & lvi_count = lvi_count + ref_count }, new_vars)

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

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

264
265
instance weightedRefCount Expression
where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
266
267
268
269
270
271
272
273
274
275
276
	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 }
277
278
		= case let_info of
			EI_LetType let_type
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
279
280
281
282
		  		# (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)}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
283
//							-*-> ("weightedRefCount (EI_LetType)", ptrToInt let_info_ptr, [ x.bind_dst \\ x <- let_lazy_binds])
284
			_
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
285
286
				# (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 }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
287
//							-*-> ("weightedRefCount (_)", ptrToInt let_info_ptr, [ x.bind_dst \\ x <- let_lazy_binds])
288
289
290
	where
		remove_variable ([], var_heap) let_bind
			= ([], var_heap)
291
		remove_variable ([var_ptr : var_ptrs], var_heap) bind=:{lb_dst={fv_ident,fv_info_ptr}}
292
293
294
			| fv_info_ptr == var_ptr
				# (VI_LetVar {lvi_count,lvi_depth}, var_heap) = readPtr fv_info_ptr var_heap
				= (var_ptrs, var_heap) 
295
//						-*-> ("remove_variable (lvi_count,lvi_dpeth) ", fv_ident, lvi_count, lvi_depth)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
296
			// otherwise
297
298
				# (var_ptrs, var_heap) = remove_variable (var_ptrs, var_heap) bind
				= ([var_ptr : var_ptrs], var_heap)
299

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

304
		get_ref_count {lb_dst={fv_ident,fv_info_ptr}} var_heap 
305
306
			# (VI_LetVar {lvi_count}, var_heap) = readPtr fv_info_ptr var_heap
		  	= (lvi_count, var_heap)
307
//				-*-> (fv_ident,fv_info_ptr,lvi_count)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
308
	weightedRefCount rci (Case case_expr) rs=:{rcs_expr_heap}
309
310
311
312
313
314
315
/*
// 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
316
		# (case_info, rcs_expr_heap) = readPtr case_expr.case_info_ptr rcs_expr_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
317
		= weightedRefCountOfCase rci case_expr case_info { rs & rcs_expr_heap = rcs_expr_heap }
318
	weightedRefCount rci expr=:(BasicExpr _) rs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
319
		= rs
320
	weightedRefCount rci (MatchExpr constructor expr) rs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
		= 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
340
341
	weightedRefCount rci (FailExpr _) rs
		= rs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
342
	weightedRefCount rci expr rs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
343
		= abort ("weightedRefCount [Expression] (convertcases, 864))" -*-> expr)
344

345
addPatternVariable depth {cv_variable = var_info_ptr, cv_count = ref_count} (free_vars, var_heap)
346
 	# (var_info, var_heap) = readPtr var_info_ptr var_heap
347
348
349
350
351
352
	= 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
353

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
354
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
355
			rs=:{ rcs_var_heap, rcs_expr_heap, rcs_imports }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
356
357
	# (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
358
359
360
	  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
361
362
	  (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 
363
	  		{ rcc_all_variables = all_vars, rcc_default_variables = default_vars, rcc_pattern_variables = local_vars })
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
364
	= { rs & rcs_var_heap = rcs_var_heap, rcs_expr_heap = rcs_expr_heap, rcs_free_vars = rcs_free_vars   }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
365
//			-*-> ("weightedRefCountOfCase", ptrToInt case_info_ptr, case_expr)
366
	where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
367
368
369
		weighted_ref_count_in_default rci (Yes expr) info
			= weightedRefCountInPatternExpr rci expr info
		weighted_ref_count_in_default rci No info
370
			= ([], info)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
371

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
372
373
374
375
		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)
376
377
		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
378
		weighted_ref_count_in_case_patterns rci (DynamicPatterns patterns) collected_imports var_heap expr_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
379
			= mapSt (\{dp_rhs} -> weightedRefCountInPatternExpr rci dp_rhs) patterns ([], collected_imports, var_heap, expr_heap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
380

381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
		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
402
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
403
404
405
406
			rs=:{ rcs_var_heap, rcs_expr_heap, rcs_imports }
	# rs = weightedRefCount rci case_expr rs
	  (rcs_free_vars, rcs_var_heap) = foldSt (addPatternVariable rci_depth) rcc_all_variables (rs.rcs_free_vars, rs.rcs_var_heap)
	= { rs & rcs_var_heap = rcs_var_heap, rcs_free_vars = rcs_free_vars }	
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
407
//			-*-> ("weightedRefCountOfCase 2", ptrToInt case_info_ptr, case_expr)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
408

409
instance weightedRefCount Selection
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
410
where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
411
412
413
414
415
416
417
418
	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
419
420
421
422
423
424
425
426
427

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)
//			-*-> ("remove_vars ", depth, free_vars_with_rc)
	= (free_vars_with_rc, (all_free_vars, rcs_imports, rcs_var_heap, rcs_expr_heap))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
428

429
430
431
432
433
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
434
		// otherwise
435
			= ([ var : collected_vars], var_heap) 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
436

437
438
439
	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
440

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

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
454
455
456
457
/*
	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'.
458
*/
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
459
checkImportOfDclFunction :: CheckImportedInfo Int Int *RCState -> *RCState
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
460
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
461
462
463
	| 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
464
465
466
467
		= { 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
468
469
	| glob_module <> cii_main_dcl_module_n
		# {com_selector_defs,com_cons_defs,com_type_defs} = cii_common_defs.[glob_module]
470
		  {sd_type_index} = com_selector_defs.[ds_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
471
		  {td_rhs = RecordType {rt_constructor={ds_index=cons_index}}} = com_type_defs.[sd_type_index]
472
		  {cons_type_ptr} = com_cons_defs.[cons_index]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
473
474
		  (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
475
476
477
		= { rs & rcs_imports = rcs_imports, rcs_var_heap = rcs_var_heap }
	// otherwise
		= rs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
478

479
480
instance weightedRefCount App
where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
481
482
483
	weightedRefCount rci=:{rci_imported} {app_symb,app_args} rs
		# rs = weightedRefCount rci app_args rs
		= check_import rci_imported app_symb rs
484
	where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
485
486
		check_import cii {symb_kind=SK_Function {glob_module,glob_object}} rs=:{rcs_imports, rcs_var_heap}
			= checkImportOfDclFunction cii glob_module glob_object rs
487
		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
488
489
490
			| 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
491
492
493
494
				= { 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
495

496
497
instance weightedRefCount TypeCodeExpression
where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
498
499
	weightedRefCount rci type_code_expr rs
		= rs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
500

501
instance weightedRefCount [a] | weightedRefCount a
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
502
where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
503
504
	weightedRefCount rci l rs
		=	foldr (weightedRefCount rci) rs l 
505
506
		
instance weightedRefCount (a,b) | weightedRefCount a & weightedRefCount b
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
507
where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
508
509
	weightedRefCount rci (x,y) rs
		=	weightedRefCount rci y (weightedRefCount rci x rs) 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
510

511
instance weightedRefCount LetBind
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
512
where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
513
514
	weightedRefCount rci {lb_src} rs
		=	weightedRefCount rci lb_src rs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
515

516
517
instance weightedRefCount (Bind a b) | weightedRefCount a
where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
518
519
	weightedRefCount rci bind=:{bind_src} rs
		=	weightedRefCount rci bind_src rs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
520

521
/*
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
522
523
524
	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.
525
*/
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
526

527
528
529
530
531
532
533
534
535
536
537
::	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
	}

538
539
540
541
542
::	DistributeInfo =
	{	di_depth 				:: !Int
	,	di_explicit_case_depth	:: !Int
	}

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
543
544
545
546
::	DistributeState =
	{	ds_lets			:: ![VarInfoPtr]
	,	ds_var_heap		:: !.VarHeap
	,	ds_expr_heap	:: !.ExpressionHeap
547
	}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
548

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

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

636
637
638
		set_strict_let_expr_info {lb_dst} var_heap
			= var_heap <:= (lb_dst.fv_info_ptr, VI_LocalLetVar)
	
639
		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
640
			# (VI_LetExpression lei=:{lei_count}, ds_var_heap) = readPtr fv_info_ptr ds_var_heap
641
642
			| lei_count > 0
//			| not lei_moved && lei_count > 0
643
				= distributeLetsInLetExpression di fv_info_ptr lei { ds & ds_var_heap = ds_var_heap }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
644
			// otherwise
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
645
				= { ds & ds_var_heap = ds_var_heap }
646
					-*-> ("distribute_lets_in_non_distributed_let (moved or not used)", lei_count, fv_ident)
647

648
	distributeLets _ expr=:(TypeCodeExpression _) ds
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
649
		= (expr, ds)
650
	distributeLets _ (AnyCodeExpr in_params out_params code_expr) ds=:{ds_var_heap}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
651
		# (in_params, ds_var_heap) = mapSt determine_input_parameter in_params ds_var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
652
		= (AnyCodeExpr in_params out_params code_expr, { ds & ds_var_heap = ds_var_heap })
653
		where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
654
			determine_input_parameter bind=:{bind_dst} var_heap
655
656
657
658
659
660
				# (var_info, var_heap) = readPtr bind_dst.var_info_ptr var_heap
				= case var_info of
					VI_CaseVar new_info_ptr
						-> ({ bind & bind_dst = { bind_dst & var_info_ptr = new_info_ptr }}, var_heap)
					_
						-> (bind, var_heap)
661
	distributeLets _ expr=:(ABCCodeExpr _ _) ds
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
662
		= (expr, ds)
663
	distributeLets _ EE ds
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
664
		= (EE, ds)
665
	distributeLets _ (NoBind ptr) ds
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
666
		= (NoBind ptr, ds)
667
	distributeLets _ (FailExpr id) ds
668
		= (FailExpr id, ds)
669
670
671

instance distributeLets Case
where 
672
673
674
	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
675
676
		  	{	rcc_all_variables = tot_ref_counts ,
		  		rcc_default_variables = ref_counts_in_default,
677
678
679
680
681
682
683
		  		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
		  		}
684
		  (local_lets, ds_var_heap) = mark_local_let_vars new_depth tot_ref_counts ds_var_heap
685
										  	// -*-> ("ref_counts", case_expr, tot_ref_counts, ref_counts_in_patterns)
686
687
688
689
690
691
692
693
694
		  	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
695
	 	  ds = {ds & ds_var_heap=ds_var_heap, ds_expr_heap=ds_expr_heap}
696
697
698
		  (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)
699
		  
700
		# ds_var_heap = foldSt reset_local_let_var local_lets ds_var_heap ->> ("outer_vars", di_depth, di.di_explicit_case_depth, outer_vars)
701
702
703
704
705
		  (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}
706
707
		  (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)
708
		= (kees, { ds & ds_expr_heap = ds_expr_heap, ds_var_heap = ds_var_heap})
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
709
	where
710
711
712
713
		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
714
			| case_explicit || outer_vars || not (is_lhs_var case_expr var_heap)
715
716
717
718
719
				=	(CaseKindTransform, var_heap)
			// otherwise
				=	(CaseKindLeave, var_heap)
			where

720
				is_lhs_var (Var {var_info_ptr, var_ident}) var_heap
721
722
					= 	case sreadPtr var_info_ptr var_heap of
							VI_LocalLetVar
723
								->	False ->> (var_ident.id_name, "rhs1")
724
							VI_LetExpression _
725
								->	False ->> (var_ident.id_name, "rhs2")
726
							info
727
								->	True ->> (var_ident.id_name, "lhs", info)
728
729
730
731
732
733
734
735
736
737
				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
738
			= (AlgebraicPatterns conses patterns, ds)
739
740
		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
741
			= (BasicPatterns type patterns, ds)
742
		where
743
744
			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
745
				= ({ pattern & bp_expr = bp_expr }, ds)
746
747
		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
748
749
			= (OverloadedListPatterns conses decons_expr patterns, heaps)

750
		distribute_lets_in_alg_pattern di (ref_counts,pattern) ds=:{ds_var_heap}
751
752
			# (ap_vars, ds_var_heap) = mapSt refresh_variable pattern.ap_vars ds_var_heap
			  ds = {ds & ds_var_heap = ds_var_heap}
753
			  (ap_expr, ds) = distribute_lets_in_pattern_expr di ref_counts pattern.ap_expr ds
754
			= ({ pattern & ap_vars = ap_vars, ap_expr = ap_expr }, ds) 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
755

756
757
		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
758
			= (Yes expr, ds)
759
		distribute_lets_in_default _ ref_counts_in_default No ds
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
760
			= (No, ds)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
761

762
		refresh_variable fv=:{fv_info_ptr} var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
763
			# (new_info_ptr, var_heap) = newPtr (VI_Labelled_Empty "refresh_variable") var_heap
764
			= ({ fv & fv_info_ptr = new_info_ptr }, var_heap <:= (fv_info_ptr, VI_CaseVar new_info_ptr))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
765

766
		mark_local_let_var depth {cv_variable, cv_count} (local_vars, var_heap)
767
			# (VI_LetExpression lei=:{lei_count,lei_depth,lei_var}, var_heap) = readPtr cv_variable var_heap
768
			| lei_count == cv_count && lei_depth==depth-1	// -*-> ("mark_test", lei_count, cv_count)
769
				= ([(cv_variable, lei_count, lei_depth) : local_vars ], var_heap <:= (cv_variable, VI_LetExpression { lei & lei_depth = depth}))
770
771
//						-*-> ("mark_local_let_var ", lei.lei_var.fv_ident, cv_variable, (lei.lei_var.fv_info_ptr, cv_count, depth))
						->> ("mark_local_let_var ", lei_var.fv_ident.id_name, lei_depth, " ->> ", depth)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
772
			// otherwise
773
				= (local_vars, var_heap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
774

775
776
777
778
		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
779
					TupleSelect _ _ (Var var=:{var_ident,var_info_ptr})
780
781
782
783
784
785
						# (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}))
786
					Selection NormalSelector (Var var=:{var_ident,var_info_ptr}) [RecordSelection _ _]
787
788
789
790
791
792
793
794
795
796
797
798
799
800
						# (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
801
				TupleSelect _ _ (Var var=:{var_ident,var_info_ptr})
802
803
804
805
806
807
808
					# (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)
809
				Selection NormalSelector (Var var=:{var_ident,var_info_ptr}) [RecordSelection _ _]
810
811
812
813
814
815
816
817
					# (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)

818
819
820
		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 })
821
//					-*-> ("reset_local_let_var", var_info_ptr)
822
					->> ("reset_local_let_var", lei.lei_var.fv_ident.id_name, lei.lei_depth, lei.lei_count, " ->> ", lei_depth, lei_count)
823
   
824
		is_outer_var {di_depth, di_explicit_case_depth} {cv_variable}  (outer, var_heap