classify.icl 55.1 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
/*
	module owner: Diederik van Arkel
*/
implementation module classify

SwitchMultimatchClassification multi no_multi	:== multi

import syntax, checksupport, transform

::	CleanupInfo :== [ExprInfoPtr]

setExtendedExprInfo :: !ExprInfoPtr !ExtendedExprInfo !*ExpressionHeap -> *ExpressionHeap
setExtendedExprInfo expr_info_ptr extension expr_info_heap
	# (expr_info, expr_info_heap) = readPtr expr_info_ptr expr_info_heap
	= case expr_info of
		EI_Extended _ ei
			-> expr_info_heap <:= (expr_info_ptr, EI_Extended extension ei)
		ei	-> expr_info_heap <:= (expr_info_ptr, EI_Extended extension ei)
		
is_nil_cons_or_decons_of_UList_or_UTSList glob_object glob_module imported_funs
	:== not (isEmpty imported_funs.[glob_module].[glob_object].ft_type.st_context);

/*
 *	ANALYSIS: only determines consumerClass; producerClasses are determined after each group is transformed.
 */

IsAVariable cons_class	:== cons_class >= 0

combineClasses :: !ConsClass !ConsClass -> ConsClass
combineClasses cc1 cc2
	| IsAVariable cc1
32
		= CAccumulating
33
	| IsAVariable cc2
34
		= CAccumulating
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
		= min cc1 cc2
 
aiUnifyClassifications cc1 cc2 ai
	:== {ai & ai_class_subst = unifyClassifications cc1 cc2 ai.ai_class_subst}

unifyClassifications :: !ConsClass !ConsClass !*ConsClassSubst -> *ConsClassSubst
unifyClassifications cc1 cc2 subst
	#  (cc1,subst) = skip_indirections_of_variables cc1 subst
	   (cc2,subst) = skip_indirections_of_variables cc2 subst
	= combine_cons_classes cc1 cc2 subst
where		   
	skip_indirections_of_variables :: !ConsClass !*ConsClassSubst -> (!ConsClass,!*ConsClassSubst)
	skip_indirections_of_variables cc subst
		| IsAVariable cc
			#! cc = skip_indirections cc subst
			= (cc, subst)
			= (cc, subst)
	where	
		skip_indirections cons_var subst
			#! redir = subst.[cons_var]
			| IsAVariable redir
				= skip_indirections redir subst
				= cons_var
			
	combine_cons_classes :: !ConsClass !ConsClass !*ConsClassSubst -> *ConsClassSubst
	combine_cons_classes cc1 cc2 subst
		| cc1 == cc2
			= subst
		| IsAVariable cc1
			#! cc_val1 = subst.[cc1]
			| IsAVariable cc2
				#! cc_val2 = subst.[cc2]
				= { subst & [cc2] = cc1, [cc1] = combine_cons_constants cc_val1 cc_val2 }

				= { subst & [cc1] = combine_cons_constants cc_val1 cc2 }
		| IsAVariable cc2
			#! cc_val2 = subst.[cc2]
			= { subst & [cc2] = combine_cons_constants cc1 cc_val2 }
			= subst
				   
	combine_cons_constants :: !ConsClass !ConsClass -> ConsClass
	combine_cons_constants cc1 cc2
		= min cc1 cc2

determine_classification :: !ConsClasses !.ConsClassSubst -> ConsClasses
determine_classification cc class_subst
	# (cc_size, cc_args) = mapAndLength (skip_indirections class_subst) cc.cc_args
	= { cc & cc_size = cc_size, cc_args = cc_args }
where
	mapAndLength f [x : xs]
		#! x = f x
		   (length, xs) = mapAndLength f xs
		=  (inc length, [x : xs])
	mapAndLength f []
		= (0, [])
Diederik van Arkel's avatar
Diederik van Arkel committed
90
	
91
92
93
94
95
96
97
98
99
100
101
	skip_indirections subst cc
		| IsAVariable cc
			= skip_indirections subst subst.[cc]
			= cc

//@ Consumer Analysis datatypes...

:: RefCounts	:== {#Int}

::	*AnalyseInfo =
	{	ai_var_heap						:: !*VarHeap
Diederik van Arkel's avatar
Diederik van Arkel committed
102
	,	ai_cons_class					:: !*{!ConsClasses}
103
	,	ai_cur_ref_counts				:: !*RefCounts // for each variable 0,1 or 2
Diederik van Arkel's avatar
Diederik van Arkel committed
104
	,	ai_class_subst					:: !*ConsClassSubst
105
106
	,	ai_next_var						:: !Int
	,	ai_next_var_of_fun				:: !Int
107
	,	ai_cases_of_vars_for_function	:: ![(!Bool,!Case)]
Diederik van Arkel's avatar
Diederik van Arkel committed
108
109
	,	ai_fun_heap						:: !*FunctionHeap
	,	ai_def_ref_counts				:: !RefCounts
110
111
112
113
114
115
116
117
118
119
120
121
122
	}

/*	defined in syntax.dcl:

::	ConsClasses =
	{	cc_size			::!Int
	,	cc_args			::![ConsClass]
	,	cc_linear_bits	::![Bool]
	,	cc_producer		::!ProdClass
	}
::	ConsClass		:== Int
*/

123
124
125
126
127
CUnused					:== -1
CPassive   				:== -2
CActive					:== -3
CAccumulating   		:== -4
CVarOfMultimatchCase	:== -5
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176

/*
	NOTE: ordering of above values is relevant since unification
	is defined later as:
	
	combine_cons_constants :: !ConsClass !ConsClass -> ConsClass
	combine_cons_constants cc1 cc2
		= min cc1 cc2
*/

::	ConsClassSubst	:== {# ConsClass}

cNope			:== -1

/*
	The argument classification (i.e. 'accumulating', 'active' or 'passive') of consumers
	is represented by a negative integer value.
	Positive classifications are used to identify variables.
	Unification of classifications is done on-the-fly
*/

:: ConsumerAnalysisRO = ConsumerAnalysisRO !ConsumerAnalysisRORecord;

:: ConsumerAnalysisRORecord =
	{ common_defs				:: !{# CommonDefs}
	, imported_funs				:: !{#{#FunType}}
	, main_dcl_module_n			:: !Int
	, stdStrictLists_module_n	:: !Int
	}

::	UnsafePatternBool :== Bool

not_an_unsafe_pattern (cc, _, ai) = (cc, False, ai)

//@ consumerRequirements

class consumerRequirements a :: !a !ConsumerAnalysisRO !AnalyseInfo -> (!ConsClass, !UnsafePatternBool, !AnalyseInfo)

instance consumerRequirements BoundVar
where
	consumerRequirements {var_name,var_info_ptr} _ ai=:{ai_var_heap}
		# (var_info, ai_var_heap)	= readPtr var_info_ptr ai_var_heap
		  ai						= { ai & ai_var_heap=ai_var_heap }
		= case var_info of
			VI_AccVar temp_var arg_position
				#! (ref_count,ai)	= ai!ai_cur_ref_counts.[arg_position] 
				   ai				= { ai & ai_cur_ref_counts.[arg_position] = min (ref_count+1) 2 }
				-> (temp_var, False, ai)
			_
177
				-> abort ("consumerRequirements [BoundVar] " ---> (var_name))
178
179
180
181
182
183
184
185

instance consumerRequirements Expression where
	consumerRequirements (Var var) common_defs ai
		= consumerRequirements var common_defs ai
	consumerRequirements (App app) common_defs ai
		= consumerRequirements app common_defs ai
	consumerRequirements (fun_expr @ exprs) common_defs ai
		# (cc_fun, _, ai)			= consumerRequirements fun_expr common_defs ai
186
		  ai						= aiUnifyClassifications CActive cc_fun ai
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
		= consumerRequirements exprs common_defs ai
	consumerRequirements (Let {let_strict_binds, let_lazy_binds,let_expr}) common_defs ai=:{ai_next_var,ai_next_var_of_fun,ai_var_heap}
		# let_binds					= let_strict_binds ++ let_lazy_binds
		# (new_next_var, new_ai_next_var_of_fun, ai_var_heap)
									= init_variables let_binds ai_next_var ai_next_var_of_fun ai_var_heap
		# ai						= { ai & ai_next_var = new_next_var, ai_next_var_of_fun = new_ai_next_var_of_fun, ai_var_heap = ai_var_heap }
		# ai						= acc_requirements_of_let_binds let_binds ai_next_var common_defs ai
		= consumerRequirements let_expr common_defs ai // XXX why not not_an_unsafe_pattern
		where
			init_variables [{lb_dst={fv_count, fv_info_ptr}} : binds] ai_next_var ai_next_var_of_fun ai_var_heap
				| fv_count > 0
					# ai_var_heap = writePtr fv_info_ptr (VI_AccVar ai_next_var ai_next_var_of_fun) ai_var_heap
					= init_variables binds (inc ai_next_var) (inc ai_next_var_of_fun) ai_var_heap
						
					= init_variables binds ai_next_var ai_next_var_of_fun ai_var_heap
			init_variables [] ai_next_var ai_next_var_of_fun ai_var_heap
				= (ai_next_var, ai_next_var_of_fun, ai_var_heap)
				
			acc_requirements_of_let_binds [ {lb_src, lb_dst} : binds ] ai_next_var common_defs ai
				| lb_dst.fv_count > 0
					# (bind_var, _, ai) = consumerRequirements lb_src common_defs ai
			  		  ai = aiUnifyClassifications ai_next_var bind_var ai
					= acc_requirements_of_let_binds binds (inc ai_next_var) common_defs ai
					= acc_requirements_of_let_binds binds ai_next_var common_defs ai
			acc_requirements_of_let_binds [] ai_next_var _ ai
				= ai
				
	consumerRequirements (Case case_expr) common_defs ai
		= consumerRequirements case_expr common_defs ai
	consumerRequirements (BasicExpr _) _ ai
217
		= (CPassive, False, ai)
218
219
220
221
	consumerRequirements (MatchExpr _ expr) common_defs ai
		= consumerRequirements expr common_defs ai
	consumerRequirements (Selection _ expr selectors) common_defs ai
		# (cc, _, ai) = consumerRequirements expr common_defs ai
222
		  ai = aiUnifyClassifications CActive cc ai
223
		  ai = requirementsOfSelectors selectors common_defs ai
224
		= (CPassive, False, ai)
225
226
227
228
	consumerRequirements (Update expr1 selectors expr2) common_defs ai
		# (cc, _, ai) = consumerRequirements expr1 common_defs ai
		  ai = requirementsOfSelectors selectors common_defs ai
		  (cc, _, ai) = consumerRequirements expr2 common_defs ai
229
		= (CPassive, False, ai)
230
231
232
	consumerRequirements (RecordUpdate cons_symbol expression expressions) common_defs ai
		# (cc, _, ai) = consumerRequirements expression common_defs ai
		  (cc, _, ai) = consumerRequirements expressions common_defs ai
233
		= (CPassive, False, ai)
234
235
	consumerRequirements (TupleSelect tuple_symbol arg_nr expr) common_defs ai
		= consumerRequirements expr common_defs ai
236
237
238
239
240
241
242
243
244
245
	consumerRequirements (AnyCodeExpr _ _ _) _ ai=:{ai_cur_ref_counts}
		#! s							= size ai_cur_ref_counts
		   twos_array					= createArray s 2
		   ai							= { ai & ai_cur_ref_counts=twos_array }
		= (CPassive, False, ai)
	consumerRequirements (ABCCodeExpr _ _) _ ai=:{ai_cur_ref_counts}
		#! s							= size ai_cur_ref_counts
		   twos_array					= createArray s 2
		   ai							= { ai & ai_cur_ref_counts=twos_array }
		= (CPassive, False, ai)
246
247
248
	consumerRequirements (DynamicExpr dynamic_expr) common_defs ai
		= consumerRequirements dynamic_expr common_defs ai
	consumerRequirements (TypeCodeExpression _) _ ai
249
		= (CPassive, False, ai)
250
	consumerRequirements EE _ ai
251
		= (CPassive, False, ai)
252
	consumerRequirements (NoBind _) _ ai
253
		= (CPassive, False, ai)
254
255
	consumerRequirements (FailExpr _) _ ai
		= (CPassive, False, ai)
256
	consumerRequirements expr _ ai
257
		= abort ("consumerRequirements [Expression]" ---> expr)
258
259
260
261
262
263
264
265
266
267

requirementsOfSelectors selectors common_defs ai
	= foldSt (reqs_of_selector common_defs) selectors ai
where
	reqs_of_selector common_defs (ArraySelection _ _ index_expr) ai
		# (_, _, ai) = consumerRequirements index_expr common_defs ai
		= ai
	reqs_of_selector common_defs (DictionarySelection dict_var _ _ index_expr) ai
		# (_, _, ai) = consumerRequirements index_expr common_defs ai
		  (cc_var, _, ai) = consumerRequirements dict_var common_defs ai
268
269
		= aiUnifyClassifications CActive cc_var ai
	// record selection missing?!
270
271
272
273
	reqs_of_selector _ _ ai
		= ai
			
instance consumerRequirements App where
Diederik van Arkel's avatar
Diederik van Arkel committed
274
	consumerRequirements {app_symb={symb_kind = SK_Function {glob_module,glob_object},symb_name}, app_args}
275
276
277
278
			common_defs=:(ConsumerAnalysisRO {main_dcl_module_n,stdStrictLists_module_n,imported_funs})
			ai=:{ai_cons_class}

		| glob_module == main_dcl_module_n
279
280
			| glob_object < size ai_cons_class
				#! fun_class = ai_cons_class.[glob_object]
281
				= reqs_of_args fun_class.cc_args app_args CPassive common_defs ai
282
283
				= consumerRequirements app_args common_defs ai

Diederik van Arkel's avatar
Diederik van Arkel committed
284
		| glob_module == stdStrictLists_module_n && (not (isEmpty app_args))
285
				&& is_nil_cons_or_decons_of_UList_or_UTSList glob_object glob_module imported_funs
286
287
			# [app_arg:app_args]=app_args;
			# (cc, _, ai) = consumerRequirements app_arg common_defs ai
288
			# ai = aiUnifyClassifications CActive cc ai
289
			= consumerRequirements app_args common_defs ai
290
/*
291
292
293
294
295
296
297
298
299
300
301
302
303
304
// SPECIAL...
		# num_specials = case imported_funs.[glob_module].[glob_object].ft_specials of
			(SP_ContextTypes [sp:_])	-> length sp.spec_types
			_	-> 0
		| num_specials > 0 && num_specials <= length app_args
			= activeArgs num_specials app_args common_defs ai
			with
				activeArgs 0 app_args common_defs ai
					= consumerRequirements app_args common_defs ai			// treat remaining args normally...
				activeArgs n [app_arg:app_args] common_defs ai
					# (cc, _, ai)	= consumerRequirements app_arg common_defs ai
					# ai			= aiUnifyClassifications CActive cc ai	// make args for which specials exist active...
					= activeArgs (n-1) app_args common_defs ai
// ...SPECIAL
305
306
307
308
*/
// ACTIVATE DICTIONARIES... [SUBSUMES SPECIAL]
		# num_dicts = length imported_funs.[glob_module].[glob_object].ft_type.st_context
		| num_dicts > 0 && num_dicts <= length app_args
309
310
			= reqs_of_args (repeatn num_dicts CActive ++ repeatn (imported_funs.[glob_module].[glob_object].ft_arity) CPassive) app_args CPassive common_defs ai
/* wrong version...
311
312
313
314
315
316
317
318
			= activeArgs num_dicts app_args common_defs ai
			with
				activeArgs 0 app_args common_defs ai
					= consumerRequirements app_args common_defs ai
				activeArgs n [app_arg:app_args] common_defs ai
					# (cc, _, ai)	= consumerRequirements app_arg common_defs ai
					# ai			= aiUnifyClassifications CActive cc ai
					= activeArgs (n-1) app_args common_defs ai
319
...*/
320
321
// ...ACTIVATE DICTIONARIES
		= consumerRequirements app_args common_defs ai
Diederik van Arkel's avatar
Diederik van Arkel committed
322
	consumerRequirements {app_symb={symb_kind = SK_LocalMacroFunction glob_object,symb_name}, app_args}
323
324
			common_defs=:(ConsumerAnalysisRO {main_dcl_module_n})
			ai=:{ai_cons_class}
325
326
		| glob_object < size ai_cons_class
			#! fun_class = ai_cons_class.[glob_object]
327
			= reqs_of_args fun_class.cc_args app_args CPassive common_defs ai
328
			= consumerRequirements app_args common_defs ai
Diederik van Arkel's avatar
Diederik van Arkel committed
329
330
331
332
333
334
335
336
337
	
	// new alternative for generated function + reanalysis...
	consumerRequirements {app_symb={symb_kind = SK_GeneratedFunction fun_info_ptr index,symb_name}, app_args}
			common_defs
			ai
		# (FI_Function {gf_cons_args={cc_args,cc_linear_bits}}, ai_fun_heap)
			= readPtr fun_info_ptr ai.ai_fun_heap
		= reqs_of_args cc_args app_args CPassive common_defs {ai & ai_fun_heap = ai_fun_heap}
	
338
339
340
	consumerRequirements {app_args} common_defs ai
		=  not_an_unsafe_pattern (consumerRequirements app_args common_defs ai)

341
342
343
344
345
346
instance <<< TypeContext
where
	(<<<) file co = file <<< co.tc_class <<< " " <<< co.tc_types <<< " <" <<< co.tc_var <<< '>'
instance <<< (Ptr a)
where
	(<<<) file p = file <<< ptrToInt p
Diederik van Arkel's avatar
Diederik van Arkel committed
347
348

reqs_of_args :: ![ConsClass] !.[Expression] ConsClass ConsumerAnalysisRO !*AnalyseInfo -> *(!ConsClass,!.Bool,!*AnalyseInfo)
349
350
351
352
353
354
355
356
reqs_of_args _ [] cumm_arg_class _ ai
	= (cumm_arg_class, False, ai)
reqs_of_args [] _ cumm_arg_class _ ai
	= (cumm_arg_class, False, ai)
reqs_of_args [form_cc : ccs] [arg : args] cumm_arg_class common_defs ai
	# (act_cc, _, ai) = consumerRequirements arg common_defs ai
	  ai = aiUnifyClassifications form_cc act_cc ai
	= reqs_of_args ccs args (combineClasses act_cc cumm_arg_class) common_defs ai
Diederik van Arkel's avatar
Diederik van Arkel committed
357
358
reqs_of_args cc xp _ _ _ = abort "classify:reqs_of_args doesn't match" ---> (cc,xp)

359
360
361
showRefCount :: !String !*AnalyseInfo -> *AnalyseInfo
showRefCount msg ai=:{ai_cur_ref_counts}
	= ai <--- (msg,display ai_cur_ref_counts)
Diederik van Arkel's avatar
Diederik van Arkel committed
362
	
363
364
365
display :: !RefCounts -> String
display rc = {show c \\ c <-: rc}
where
Diederik van Arkel's avatar
Diederik van Arkel committed
366
367
368
369
	show 0 = '0'
	show 1 = '1'
	show 2 = '2'
	show _ = '?'
370
371

instance consumerRequirements Case where
Diederik van Arkel's avatar
Diederik van Arkel committed
372
	consumerRequirements kees=:{case_expr,case_guards,case_default,case_info_ptr,case_explicit}
373
374
				ro=:(ConsumerAnalysisRO {common_defs=common_defs_parameter}) ai=:{ai_cur_ref_counts}
		#  (cce, _, ai)					= consumerRequirements case_expr ro ai
Diederik van Arkel's avatar
Diederik van Arkel committed
375
376
377
378
		#! env_counts					= ai.ai_cur_ref_counts
		   (s,env_counts)				= usize env_counts
		   zero_array					= createArray s 0
		   ai							= {ai & ai_cur_ref_counts = zero_array}
379
380
381
382
		   (ccd, default_is_unsafe, ai)	= consumerRequirements case_default ro ai
		# (ccgs, unsafe_bits, guard_counts, ai)
										= consumer_requirements_of_guards case_guards ro ai
		# default_counts				= ai.ai_cur_ref_counts
Diederik van Arkel's avatar
Diederik van Arkel committed
383
384
		# (every_constructor_appears_in_safe_pattern, may_be_active)
		  								= inspect_patterns common_defs_parameter has_default case_guards unsafe_bits
385
386
387
		  ref_counts = combine_pattern_counts has_default case_guards unsafe_bits guard_counts default_counts
		  ref_counts = combine_counts s ref_counts env_counts
		  ai = {ai & ai_cur_ref_counts = ref_counts }
Diederik van Arkel's avatar
Diederik van Arkel committed
388
389
390
391
392
		  safe = case_explicit || (has_default && not default_is_unsafe) || every_constructor_appears_in_safe_pattern
		  ai = aiUnifyClassifications (SwitchMultimatchClassification
		  		(if may_be_active CActive CVarOfMultimatchCase) 
		  		CActive)
		  		cce ai
393
394
		  ai = case case_expr of
				Var {var_info_ptr}
395
396
397
398
399
400
401
402
					| SwitchMultimatchClassification may_be_active True
						-> { ai & ai_cases_of_vars_for_function=[(safe,kees):ai.ai_cases_of_vars_for_function] }
						-> ai
// N-WAY...
//				_	-> ai
				_
					| SwitchMultimatchClassification may_be_active True
						-> { ai & ai_cases_of_vars_for_function=[(safe,kees):ai.ai_cases_of_vars_for_function] }
403
						-> ai
404
// ...N-WAY
405
/*		# ai = case case_guards of
406
407
					OverloadedListPatterns (OverloadedList _ _ _ _) decons_expr=:(App {app_symb={symb_kind=SK_Function _},app_args=[app_arg]}) patterns
						// decons_expr will be optimized to a decons_u Selector in transform
408
						# (cc, _, ai)	= consumerRequirements app_arg ro ai
409
						# ai = aiUnifyClassifications CActive cc ai
410
411
						-> ai
					OverloadedListPatterns _ decons_expr _
412
						# (_,_,ai) = consumerRequirements decons_expr ro ai
413
414
415
						-> ai
					_
						-> ai
416
417
*/
		# ai = handle_overloaded_list_patterns case_guards ai
418
419
		= (combineClasses ccgs ccd, not safe, ai)
	  where
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
		handle_overloaded_list_patterns
					(OverloadedListPatterns (OverloadedList _ _ _ _) decons_expr=:(App {app_symb={symb_kind=SK_Function _},app_args=[app_arg]}) patterns)
					ai
						// decons_expr will be optimized to a decons_u Selector in transform
						# (cc, _, ai)	= consumerRequirements app_arg ro ai
						# ai = aiUnifyClassifications CActive cc ai
						= ai
		handle_overloaded_list_patterns
					(OverloadedListPatterns _ decons_expr _) ai
						# (_,_,ai) = consumerRequirements decons_expr ro ai
						= ai
		handle_overloaded_list_patterns
					_ ai
						= ai
		
Diederik van Arkel's avatar
Diederik van Arkel committed
435
436
437
		has_default					= case case_default of
										  		Yes _ -> True
										  		_ -> False
438
439
//		use_context_default			= not (case_explicit || has_default)

440
		combine_counts :: !Int !*{#Int} !{#Int} -> *{#Int}
441
442
443
444
445
446
447
448
449
		combine_counts 0 accu env
			= accu
		combine_counts i accu env
			#! i1			= dec i
			   rca			= accu.[i1]
			   rce			= env.[i1]
			   accu			= { accu & [i1] = unify_counts rca rce }
			= combine_counts i1 accu env
		where
450
			unify_counts :: !Int !Int -> Int
451
452
453
454
			unify_counts 0 x = x
			unify_counts 1 x = if (x==2) 2 (inc x)
			unify_counts 2 x = 2

455
		inspect_patterns :: !{#.CommonDefs} !.Bool !.CasePatterns ![.Bool] -> (!.Bool,!Bool)
456
		inspect_patterns common_defs has_default (AlgebraicPatterns {glob_object, glob_module} algebraic_patterns) unsafe_bits
Diederik van Arkel's avatar
Diederik van Arkel committed
457
458
459
460
461
462
463
464
465
466
467
468
469
			# type_def						= common_defs.[glob_module].com_type_defs.[glob_object]
			  defined_symbols				= case type_def.td_rhs of
													AlgType defined_symbols		-> defined_symbols
													RecordType {rt_constructor}	-> [rt_constructor]
			  all_constructors				= [ ds_index \\ {ds_index}<-defined_symbols ]
			  pattern_constructors			= [ glob_object.ds_index \\ {ap_symbol={glob_object}}<-algebraic_patterns]	
			  sorted_pattern_constructors	= sort pattern_constructors unsafe_bits
			  all_sorted_constructors		= if (is_sorted all_constructors)
			  										all_constructors
			  										(sortBy (<) all_constructors)
			= ( appearance_loop all_sorted_constructors sorted_pattern_constructors
			  , not (multimatch_loop has_default sorted_pattern_constructors)
			  )
470
		inspect_patterns common_defs has_default (BasicPatterns BT_Bool basic_patterns) unsafe_bits
Diederik van Arkel's avatar
Diederik van Arkel committed
471
472
			# bools_indices					= [ if bool 1 0 \\ {bp_value=BVB bool}<-basic_patterns ]
			  sorted_pattern_constructors	= sort bools_indices unsafe_bits
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
			= (appearance_loop [0,1] sorted_pattern_constructors,
				not (multimatch_loop has_default sorted_pattern_constructors))
		inspect_patterns common_defs has_default (OverloadedListPatterns overloaded_list _ algebraic_patterns) unsafe_bits
			# type_def = case overloaded_list of
							UnboxedList {glob_object, glob_module} _ _ _
								-> common_defs.[glob_module].com_type_defs.[glob_object]
							UnboxedTailStrictList {glob_object, glob_module} _ _ _
								-> common_defs.[glob_module].com_type_defs.[glob_object]
							OverloadedList {glob_object, glob_module} _ _ _
								-> common_defs.[glob_module].com_type_defs.[glob_object]
			  defined_symbols = case type_def.td_rhs of
									AlgType defined_symbols		-> defined_symbols
									RecordType {rt_constructor}	-> [rt_constructor]
			  all_constructors = [ ds_index \\ {ds_index}<-defined_symbols ]
			  pattern_constructors = [ glob_object.ds_index \\ {ap_symbol={glob_object}}<-algebraic_patterns]	
			  sorted_pattern_constructors = sort pattern_constructors unsafe_bits
			  all_sorted_constructors = if (is_sorted all_constructors) all_constructors (sortBy (<) all_constructors)
			= (appearance_loop all_sorted_constructors sorted_pattern_constructors, not (multimatch_loop has_default sorted_pattern_constructors))
		inspect_patterns _ _ _ _
			= (False, False)

		is_sorted [x]
			= True
		is_sorted [h1:t=:[h2:_]]
			= h1 < h2 && is_sorted t

		sort constr_indices unsafe_bits
			= sortBy smaller (zip3 constr_indices [0..] unsafe_bits)
		  where
			smaller (i1,si1,_) (i2,si2,_)
				| i1<i2		= True
				| i1>i2		= False
							= si1<si2
			zip3 [h1:t1] [h2:t2] [h3:t3]
				= [(h1,h2,h3):zip3 t1 t2 t3]
			zip3 _ _ _
				= []

		appearance_loop [] _
			= True
		appearance_loop _ []
			= False
		appearance_loop l1=:[constructor_in_type:constructors_in_type] [(constructor_in_pattern,_,is_unsafe_pattern):constructors_in_pattern]
			| constructor_in_type < constructor_in_pattern
				= False
			// constructor_in_type==constructor_in_pattern
			| is_unsafe_pattern
				 // maybe there is another pattern that is safe for this constructor
				= appearance_loop l1 constructors_in_pattern
			// the constructor will match safely. Skip over patterns with the same constructor and test the following constructor
			= appearance_loop constructors_in_type (dropWhile (\(ds_index,_,_)->ds_index==constructor_in_pattern) constructors_in_pattern)

		multimatch_loop has_default []
			= False
		multimatch_loop has_default [(cip, _, iup):t]
			= a_loop has_default cip iup t
		  where
			a_loop has_default cip iup []
				= iup && has_default
			a_loop has_default cip iup [(constructor_in_pattern, _, is_unsafe_pattern):constructors_in_pattern]
				| cip<constructor_in_pattern
					| iup && has_default
						= True
					= a_loop has_default constructor_in_pattern is_unsafe_pattern constructors_in_pattern
				| iup
					= True
				= multimatch_loop has_default (dropWhile (\(ds_index,_,_)->ds_index==cip) constructors_in_pattern)

541
combine_pattern_counts :: !.Bool !.CasePatterns ![.Bool] ![{#.Int}] !{#Int} -> *{#Int}
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
combine_pattern_counts has_default patterns unsafe_bits guard_counts default_counts
	| not ok_pattern_type
		= createArray (size default_counts) 2
	# sorted_pattern_constructors`	= sort3 pattern_constructors unsafe_bits guard_counts
	# initial_count					= case has_default of
	  										True	-> default_counts
	  										_		-> zero_array
	= count_loop default_counts initial_count sorted_pattern_constructors`
	
where
	rc2str (a,b,c,d) = (a,b,c,display d)
	
	ok_pattern_type = case patterns of
		(AlgebraicPatterns _ _)
			-> True
		(BasicPatterns BT_Bool _)
			-> True
		(BasicPatterns BT_Int _)
			-> True
//		(BasicPatterns (BT_String _) basic_patterns)
//			-> [ string \\ {bp_value=BVS string}<-basic_patterns ] ---> ("BasicPatterns String")
		(OverloadedListPatterns overloaded_list _ algebraic_patterns)
			-> True
		_ -> False //---> ("not ok_pattern_type",patterns)
	pattern_constructors = case patterns of
		(AlgebraicPatterns {glob_object, glob_module} algebraic_patterns)
			-> [ glob_object.ds_index \\ {ap_symbol={glob_object}}<-algebraic_patterns] //---> ("AlgebraicPatterns")
		(BasicPatterns BT_Bool basic_patterns)
			-> [ if bool 1 0 \\ {bp_value=BVB bool}<-basic_patterns ] //---> ("BasicPatterns Bool")
		(BasicPatterns BT_Int basic_patterns)
			-> [ int \\ {bp_value=BVInt int}<-basic_patterns ] //---> ("BasicPatterns Int")
//		(BasicPatterns (BT_String _) basic_patterns)
//			-> [ string \\ {bp_value=BVS string}<-basic_patterns ] ---> ("BasicPatterns String")
		(OverloadedListPatterns overloaded_list _ algebraic_patterns)
			-> [ glob_object.ds_index \\ {ap_symbol={glob_object}}<-algebraic_patterns] //---> ("OverloadedListPatterns")
		_ -> abort "unsupported?!" ---> ("pattern_constructors",patterns) //[]	// ???

	count_size					= size default_counts
	zero_array					= createArray count_size 0

582
	sort3 :: !.[Int] !.[a] !.[b] -> .[(!Int,!Int,!a,!b)]
583
584
585
586
587
588
589
590
591
592
593
594
	sort3 constr_indices unsafe_bits counts
		= sortBy smaller (zip4 constr_indices [0..] unsafe_bits counts)
	  where
		smaller (i1,si1,_,_) (i2,si2,_,_)
			| i1<i2		= True
			| i1>i2		= False
						= si1<si2
		zip4 [h1:t1] [h2:t2] [h3:t3] [h4:t4]
			= [(h1,h2,h3,h4):zip4 t1 t2 t3 t4]
		zip4 _ _ _ _
			= []

595
	count_loop :: !RefCounts !RefCounts ![(!Int,!Int,!Bool,!RefCounts)] -> *RefCounts
596
597
598
599
600
601
602
603
604
	count_loop default_counts unified_counts []
		= {e \\ e <-: unified_counts}
	count_loop default_counts unified_counts [(c_index,p_index,unsafe,counts):patterns]
		# (same,next)	= splitWhile (\(ds_index,_,_,_)->ds_index==c_index) patterns
		# ccount= case unsafe of
					True 	-> count_constructor default_counts counts same
					_		-> counts
		= count_loop default_counts (unify_counts ccount unified_counts) next
	where
605
		splitWhile :: !(a -> .Bool) !u:[a] -> (!.[a],!v:[a]), [u <= v];
606
607
608
609
610
611
612
613
		splitWhile f []
			= ([],[])
		splitWhile f cons=:[a:x]
			| f a
				# (t,d)	= splitWhile f x
				= ([a:t],d)
				= ([],cons)
	
614
	count_constructor :: !RefCounts !RefCounts ![(!Int,!Int,!Bool,!RefCounts)] -> RefCounts
615
616
617
618
619
620
621
	count_constructor default_counts combined_counts []
		= combine_counts combined_counts default_counts
	count_constructor default_counts combined_counts [(_,_,unsafe,counts):patterns]
		| unsafe
			= count_constructor default_counts (combine_counts combined_counts counts) patterns
			= combine_counts combined_counts counts

622
	combine_counts :: !RefCounts !RefCounts -> RefCounts
623
624
625
626
627
628
629
630
631
632
633
634
	combine_counts c1 c2
		= {unify_counts e1 e2 \\ e1 <-: c1 & e2 <-: c2}
	where
		combine 0 accu env
			= accu
		combine i accu env
			#! i1			= dec i
			   rca			= accu.[i1]
			   rce			= env.[i1]
			   accu			= { accu & [i1] = unify_counts rca rce }
			= combine i1 accu env

635
		unify_counts :: !Int !Int -> Int
636
637
638
639
		unify_counts 0 x = x
		unify_counts 1 x = if (x==2) 2 (inc x)
		unify_counts 2 x = 2
	
640
	unify_counts :: !RefCounts !RefCounts -> *RefCounts
641
642
643
644
645
646
647
648
649
650
651
652
653
	unify_counts c1 c2
		= {unify_counts e1 e2 \\ e1 <-: c1 & e2 <-: c2}
	where
		unify :: !Int !*RefCounts !RefCounts -> *RefCounts
		unify 0 accu env
			= accu
		unify i accu env
			#! i1			= dec i
			   rca			= accu.[i1]
			   rce			= env.[i1]
			   accu			= { accu & [i1] = unify_counts rce rca }
			= unify i1 accu env

654
		unify_counts :: !Int !Int -> Int
655
656
657
658
659
		unify_counts 0 x = x
		unify_counts 1 x = if (x==0) 1 x
		unify_counts 2 x = 2

//consumer_requirements_of_guards :: !CasePatterns ConsumerAnalysisRO !*AnalyseInfo -> (!Int,.[Bool],!*AnalyseInfo)
660
consumer_requirements_of_guards :: !.CasePatterns !.ConsumerAnalysisRO !*AnalyseInfo -> *(!Int,!.[Bool],![{#Int}],!*AnalyseInfo)
661
consumer_requirements_of_guards (AlgebraicPatterns type patterns) common_defs ai
Diederik van Arkel's avatar
Diederik van Arkel committed
662
663
664
665
666
667
668
	# pattern_exprs
			= [ ap_expr \\ {ap_expr}<-patterns]
	  pattern_vars
	  		= flatten [ ap_vars \\ {ap_vars}<-patterns]
	  (ai_next_var, ai_next_var_of_fun, ai_var_heap)
	  		= bindPatternVars pattern_vars ai.ai_next_var ai.ai_next_var_of_fun ai.ai_var_heap
	  ai	= { ai & ai_var_heap=ai_var_heap, ai_next_var=ai_next_var, ai_next_var_of_fun = ai_next_var_of_fun }
669
	= independentConsumerRequirements pattern_exprs common_defs ai
670
	
671
consumer_requirements_of_guards (BasicPatterns type patterns) common_defs ai
Diederik van Arkel's avatar
Diederik van Arkel committed
672
673
	# pattern_exprs
			= [ bp_expr \\ {bp_expr}<-patterns]
674
675
	= independentConsumerRequirements pattern_exprs common_defs ai
consumer_requirements_of_guards (OverloadedListPatterns type _ patterns) common_defs ai
Diederik van Arkel's avatar
Diederik van Arkel committed
676
677
678
679
680
681
682
	# pattern_exprs
			= [ ap_expr \\ {ap_expr}<-patterns]
	  pattern_vars
	  		= flatten [ ap_vars \\ {ap_vars}<-patterns]
	  (ai_next_var, ai_next_var_of_fun, ai_var_heap)
	  		= bindPatternVars pattern_vars ai.ai_next_var ai.ai_next_var_of_fun ai.ai_var_heap
	  ai	= { ai & ai_var_heap=ai_var_heap, ai_next_var=ai_next_var, ai_next_var_of_fun = ai_next_var_of_fun }
683
	= independentConsumerRequirements pattern_exprs common_defs ai
Diederik van Arkel's avatar
Diederik van Arkel committed
684
685
consumer_requirements_of_guards NoPattern common_defs ai
	= independentConsumerRequirements [] common_defs ai
686
687
688
689

bindPatternVars :: !.[FreeVar] !Int !Int !*VarHeap -> (!Int,!Int,!*VarHeap)
bindPatternVars [fv=:{fv_info_ptr,fv_count} : vars] next_var next_var_of_fun var_heap
	| fv_count > 0
690
691
692
693
694
		# var_heap	= writePtr fv_info_ptr (VI_AccVar next_var next_var_of_fun) var_heap
		= bindPatternVars vars (inc next_var) (inc next_var_of_fun) var_heap
	// otherwise
		# var_heap	= writePtr fv_info_ptr (VI_Count 0 False) var_heap
		= bindPatternVars vars next_var next_var_of_fun var_heap
695
696
697
bindPatternVars [] next_var next_var_of_fun var_heap
	= (next_var, next_var_of_fun, var_heap)

698
independentConsumerRequirements :: !.[Expression] !ConsumerAnalysisRO !*AnalyseInfo -> (!ConsClass,!.[Bool],![RefCounts],!*AnalyseInfo)
699
700
701
702
703
704
705
independentConsumerRequirements exprs info ai
	# ref_counts					= ai.ai_cur_ref_counts
	# (count_size,ref_counts)		= usize ref_counts
	# zero_array					= createArray count_size 0
	# (counts_unsafe,(cc,ai))		= mapSt cons_reqs exprs (CPassive,{ ai & ai_cur_ref_counts = zero_array})
	# (counts,unsafe)				= unzip counts_unsafe
	= (cc,unsafe,counts,{ ai & ai_cur_ref_counts = ref_counts})
Diederik van Arkel's avatar
Diederik van Arkel committed
706
where
707
	cons_reqs :: !Expression !*(!.Int,!*AnalyseInfo) -> *(!.(!{#Int},!Bool),!*(!Int,!*AnalyseInfo))
708
709
710
711
712
713
714
	cons_reqs expr (cc,ai)
		# (cce, unsafe, ai)		= consumerRequirements expr info ai
		# cc					= combineClasses cce cc
		# ref_counts			= ai.ai_cur_ref_counts
		# count_size			= size ref_counts
		# zero_array			= createArray count_size 0
		= ((ref_counts,unsafe),(cc, { ai & ai_cur_ref_counts=zero_array }))
Diederik van Arkel's avatar
Diederik van Arkel committed
715

716
717
718
719
720
721
722
723
724
725
726
727
instance consumerRequirements DynamicExpr where
	consumerRequirements {dyn_expr} common_defs ai
		= consumerRequirements dyn_expr common_defs ai

instance consumerRequirements BasicPattern where
	consumerRequirements {bp_expr} common_defs ai
		= consumerRequirements bp_expr common_defs ai

instance consumerRequirements (Optional a) | consumerRequirements a where
	consumerRequirements (Yes x) common_defs ai
		= consumerRequirements x common_defs ai
	consumerRequirements No _ ai
728
		= (CPassive, False, ai)
729
730
731
732
733
734
735
736
737

instance consumerRequirements (!a,!b) | consumerRequirements a & consumerRequirements b where
	consumerRequirements (x, y) common_defs ai
		# (ccx, _, ai) = consumerRequirements x common_defs ai
		  (ccy, _, ai) = consumerRequirements y common_defs ai
		= (combineClasses ccx ccy, False, ai)
		
instance consumerRequirements [a] | consumerRequirements a where
	consumerRequirements [x : xs] common_defs ai
Diederik van Arkel's avatar
Diederik van Arkel committed
738
		# (ccx,  _, ai) = consumerRequirements x  common_defs ai
739
740
741
		  (ccxs, _, ai) = consumerRequirements xs common_defs ai
		= (combineClasses ccx ccxs, False, ai)
	consumerRequirements [] _ ai
742
		= (CPassive, False, ai)
743
744
745
746
747
748
749
750
751
752
753

instance consumerRequirements (Bind a b) | consumerRequirements a where
	consumerRequirements {bind_src} common_defs ai
		= consumerRequirements bind_src common_defs ai

//@ Analysis

// determine consumerRequirements for functions
analyseGroups	:: !{# CommonDefs} !{#{#FunType}} !IndexRange !Int !Int !*{! Group} !*{#FunDef} !*VarHeap !*ExpressionHeap 
				-> (!CleanupInfo, !*{! ConsClasses}, !*{! Group}, !*{#FunDef}, !*VarHeap, !*ExpressionHeap)
analyseGroups common_defs imported_funs {ir_from, ir_to} main_dcl_module_n stdStrictLists_module_n groups fun_defs var_heap expr_heap
Diederik van Arkel's avatar
Diederik van Arkel committed
754
755
	#! nr_of_funs	= size fun_defs + ir_from - ir_to /* Sjaak */
	   nr_of_groups	= size groups
756
757
758
759
760
761
762
	# consumerAnalysisRO=ConsumerAnalysisRO
		{ common_defs				= common_defs
		, imported_funs				= imported_funs
		, main_dcl_module_n			= main_dcl_module_n
		, stdStrictLists_module_n	= stdStrictLists_module_n
		}
	# class_env = createArray nr_of_funs { cc_size = 0, cc_args = [], cc_linear_bits = [], cc_producer=False}
763
	= iFoldSt (analyse_group consumerAnalysisRO) 0 nr_of_groups
764
				([], class_env, groups, fun_defs, var_heap, expr_heap)
765
766
where	
	analyse_group common_defs group_nr (cleanup_info, class_env, groups, fun_defs, var_heap, expr_heap)
Diederik van Arkel's avatar
Diederik van Arkel committed
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
		# ({group_members}, groups)
				= groups![group_nr]

		# (next_var, nr_of_local_vars, var_heap, class_env, fun_defs)
				= foldSt initial_cons_class group_members (0, 0, var_heap, class_env, fun_defs)

		# ai =
						{	ai_var_heap						= var_heap
						, 	ai_cons_class					= class_env
						,	ai_cur_ref_counts				= {}
						,	ai_class_subst					= createArray (next_var + nr_of_local_vars) CPassive
						,	ai_next_var						= next_var
						,	ai_next_var_of_fun				= 0
						,	ai_cases_of_vars_for_function	= []
						,	ai_fun_heap						= newHeap
						,	ai_def_ref_counts				= {}
						}

		# (ai_cases_of_vars_for_group, ai, fun_defs)
				= foldSt (analyse_functions common_defs) group_members ([], ai, fun_defs)

		  class_env
		  		= ai.ai_cons_class
		  class_env
		  		= foldSt (collect_classifications ai.ai_class_subst) group_members class_env
792
		  (cleanup_info, class_env, fun_defs, var_heap, expr_heap)
793
				= foldSt (set_case_expr_info ai.ai_class_subst) (flatten ai_cases_of_vars_for_group)
Diederik van Arkel's avatar
Diederik van Arkel committed
794
					(cleanup_info, class_env, fun_defs, ai.ai_var_heap, expr_heap)
795
796
797
		= (cleanup_info, class_env, groups, fun_defs, var_heap, expr_heap)
	  where
//initial classification...
Diederik van Arkel's avatar
Diederik van Arkel committed
798
799
800
801
802
803
804
805
806
807
808
809
		initial_cons_class fun (next_var, nr_of_local_vars, var_heap, class_env, fun_defs)
			# (fun_def, fun_defs)					= fun_defs![fun]
			  (TransformedBody {tb_args})			= fun_def.fun_body
			  
			  nr_of_locals							= length fun_def.fun_info.fi_local_vars
			  nr_of_local_vars						= nr_of_local_vars + nr_of_locals
			  
			# (fresh_vars, next_var, var_heap)
			   										= fresh_variables tb_args 0 next_var var_heap
			# fun_class								= { cc_size = 0, cc_args = fresh_vars, cc_linear_bits=[], cc_producer=False}
			  class_env								= { class_env & [fun] = fun_class}
			= (next_var, nr_of_local_vars, var_heap, class_env, fun_defs)
810
//determine classification...
Diederik van Arkel's avatar
Diederik van Arkel committed
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
		analyse_functions common_defs fun (cfvog_accu, ai, fun_defs)
			#  (fun_def, fun_defs)					= fun_defs![fun]
	 		   (TransformedBody {tb_args, tb_rhs})	= fun_def.fun_body

	 		   nr_of_locals							= length fun_def.fun_info.fi_local_vars
			   nr_of_args							= length tb_args

			   ai = { ai
			   		& ai_cur_ref_counts				= createArray (nr_of_args + nr_of_locals) 0
			   		, ai_def_ref_counts				= createArray (nr_of_args + nr_of_locals) 0
			   		, ai_next_var_of_fun			= nr_of_args 
			   		}
			// classify
			   (_, _, ai)							= consumerRequirements tb_rhs common_defs ai
			// set linearity info based on cur_ref_counts
			#  ai_cur_ref_counts					= ai.ai_cur_ref_counts
			   ai_cons_class						= ai.ai_cons_class
			   (fun_cons_class,ai_cons_class)		= ai_cons_class![fun]
			   linear_bits							= [ ref_count<2 \\ ref_count <-: ai_cur_ref_counts ]
			   fun_cons_class						= { fun_cons_class & cc_linear_bits=linear_bits }
			   cc_args								= add_unused_args fun_cons_class.cc_args ai_cur_ref_counts
			   fun_cons_class						= { fun_cons_class & cc_args = cc_args }
			   ai_cons_class						= {ai_cons_class & [fun] = fun_cons_class}
			   cases_of_vars_for_function			= [(a,fun) \\ a <- ai.ai_cases_of_vars_for_function ]
			   cfvog_accu							= [cases_of_vars_for_function:cfvog_accu]

			   ai = { ai
			   		& ai_cons_class					= ai_cons_class
			   		, ai_cases_of_vars_for_function	= [] 
			   		, ai_cur_ref_counts				= {}
			   		}
842
843
			= (cfvog_accu, ai, fun_defs)
//final classification...
Diederik van Arkel's avatar
Diederik van Arkel committed
844
845
846
		collect_classifications class_subst fun class_env
			# (fun_class, class_env)	= class_env![fun]
			  fun_class					= determine_classification fun_class class_subst
Diederik van Arkel's avatar
Diederik van Arkel committed
847
	 		= { class_env & [fun] = fun_class }
Diederik van Arkel's avatar
Diederik van Arkel committed
848

849
		set_case_expr_info class_subst ((safe,{case_expr=(Var {var_info_ptr}), case_guards, case_info_ptr}),fun_index)
Diederik van Arkel's avatar
Diederik van Arkel committed
850
				(cleanup_acc, class_env, fun_defs, var_heap, expr_heap)
851
			# (VI_AccVar cc arg_position, var_heap)				= readPtr var_info_ptr var_heap
Diederik van Arkel's avatar
Diederik van Arkel committed
852
853
			  ({cc_size, cc_args, cc_linear_bits},class_env)	= class_env![fun_index]
			  (aci_linearity_of_patterns, var_heap)				= get_linearity_info cc_linear_bits case_guards var_heap
854
855
//* Try always marking
//			| arg_position<cc_size && (arg_position>=cc_size || cc_args!!arg_position==CActive) && cc_linear_bits!!arg_position
856
				// mark non multimatch cases whose case_expr is an active linear function argument
857
858
859
860
			| ((arg_position>=cc_size && CActive==skip_indirections class_subst cc) || (arg_position<cc_size && cc_args!!arg_position==CActive)) && cc_linear_bits!!arg_position

//*/
//			| True
Diederik van Arkel's avatar
Diederik van Arkel committed
861
862
863
864
865
				# aci =
					{ aci_params				= []
					, aci_opt_unfolder			= No
					, aci_free_vars				= No
					, aci_linearity_of_patterns = aci_linearity_of_patterns
866
					, aci_safe					= safe
Diederik van Arkel's avatar
Diederik van Arkel committed
867
					}
868
869
870
				= ([case_info_ptr:cleanup_acc], class_env, fun_defs, var_heap, 
					setExtendedExprInfo case_info_ptr (EEI_ActiveCase aci) expr_heap)
			= (cleanup_acc, class_env, fun_defs, var_heap, expr_heap)
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
				  where
					skip_indirections subst cc
						| IsAVariable cc
							= skip_indirections subst subst.[cc]
							= cc

// N-WAY...
		set_case_expr_info class_subst ((safe,{case_expr=(App _), case_guards, case_info_ptr}),fun_index)
				(cleanup_acc, class_env, fun_defs, var_heap, expr_heap)
			# ({cc_size, cc_args, cc_linear_bits},class_env)	= class_env![fun_index]
			  (aci_linearity_of_patterns, var_heap)				= get_linearity_info cc_linear_bits case_guards var_heap
			# aci =
				{ aci_params				= []
				, aci_opt_unfolder			= No
				, aci_free_vars				= No
				, aci_linearity_of_patterns = aci_linearity_of_patterns
				, aci_safe					= safe
				}
			= ([case_info_ptr:cleanup_acc], class_env, fun_defs, var_heap, 
				setExtendedExprInfo case_info_ptr (EEI_ActiveCase aci) expr_heap)
		set_case_expr_info class_subst ((safe,{case_expr=(_ @ _), case_guards, case_info_ptr}),fun_index)
				(cleanup_acc, class_env, fun_defs, var_heap, expr_heap)
			# ({cc_size, cc_args, cc_linear_bits},class_env)	= class_env![fun_index]
			  (aci_linearity_of_patterns, var_heap)				= get_linearity_info cc_linear_bits case_guards var_heap
			# aci =
				{ aci_params				= []
				, aci_opt_unfolder			= No
				, aci_free_vars				= No
				, aci_linearity_of_patterns = aci_linearity_of_patterns
				, aci_safe					= safe
				}
			= ([case_info_ptr:cleanup_acc], class_env, fun_defs, var_heap, 
				setExtendedExprInfo case_info_ptr (EEI_ActiveCase aci) expr_heap)
		set_case_expr_info _ _ s = s
// ...N-WAY
906
907
908
909
910
911
912
913
914
915
		get_linearity_info cc_linear_bits (AlgebraicPatterns _ algebraic_patterns) var_heap
			= mapSt (get_linearity_info_of_pattern cc_linear_bits) algebraic_patterns var_heap
		get_linearity_info cc_linear_bits (OverloadedListPatterns _ _ algebraic_patterns) var_heap
			= mapSt (get_linearity_info_of_pattern cc_linear_bits) algebraic_patterns var_heap
		get_linearity_info cc_linear_bits _ var_heap
			= ([], var_heap)

		get_linearity_info_of_pattern cc_linear_bits {ap_vars} var_heap
			# (var_indices, var_heap) = mapSt get_var_index ap_vars var_heap
			= ([if (index==cNope) True (cc_linear_bits!!index) \\ index<-var_indices], var_heap)
Diederik van Arkel's avatar
Diederik van Arkel committed
916
917
918
919
920
921
922
923
924

		get_var_index {fv_info_ptr} var_heap
			# (vi, var_heap) = readPtr fv_info_ptr var_heap
			  index = case vi of
						VI_AccVar _ index	-> index
						VI_Count 0 False	-> cNope
			= (index, var_heap) 

reanalyseGroups	:: !{# CommonDefs} !{#{#FunType}} !Int !Int ![FunctionInfoPtr]  ![Group] !*{#FunDef} !*VarHeap !*ExpressionHeap !*FunctionHeap !*{!ConsClasses}
925
				-> (!CleanupInfo, !*{#FunDef}, !*VarHeap, !*ExpressionHeap, !*FunctionHeap, !*{!ConsClasses}, !Bool)
Diederik van Arkel's avatar
Diederik van Arkel committed
926
927
reanalyseGroups common_defs imported_funs main_dcl_module_n stdStrictLists_module_n new_functions
	groups fun_defs var_heap expr_heap fun_heap class_env
928
//	#! nr_of_groups	= size groups
Diederik van Arkel's avatar
Diederik van Arkel committed
929
930
931
932
933
934
935
	# consumerAnalysisRO=ConsumerAnalysisRO
		{ common_defs				= common_defs
		, imported_funs				= imported_funs
		, main_dcl_module_n			= main_dcl_module_n
		, stdStrictLists_module_n	= stdStrictLists_module_n
		}
	= foldSt (analyse_group consumerAnalysisRO) groups
936
				([], fun_defs, var_heap, expr_heap, fun_heap, class_env, True)
Diederik van Arkel's avatar
Diederik van Arkel committed
937
where	
938
	analyse_group common_defs group (cleanup_info, fun_defs, var_heap, expr_heap, fun_heap, class_env, same)
Diederik van Arkel's avatar
Diederik van Arkel committed
939
940
		# {group_members}	= group

941
942
		# (next_var, nr_of_local_vars, var_heap, class_env, fun_defs, fun_heap, old_cons_class)
				= foldSt initial_cons_class group_members (0, 0, var_heap, class_env, fun_defs, fun_heap, [])
Diederik van Arkel's avatar
Diederik van Arkel committed
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962

		# ai =
						{	ai_var_heap						= var_heap
						, 	ai_cons_class					= class_env
						,	ai_cur_ref_counts				= {}
						,	ai_class_subst					= createArray (next_var + nr_of_local_vars) CPassive
						,	ai_next_var						= next_var
						,	ai_next_var_of_fun				= 0
						,	ai_cases_of_vars_for_function	= []
						,	ai_fun_heap						= fun_heap
						,	ai_def_ref_counts				= {}
						}

		# (ai_cases_of_vars_for_group, ai, fun_defs)
				= foldSt (analyse_functions common_defs) group_members ([], ai, fun_defs)

		  class_env
		  		= ai.ai_cons_class
		  fun_heap
		  		= ai.ai_fun_heap
963
964
		  (class_env,fun_heap,same,_)
		  		= foldSt (collect_classifications ai.ai_class_subst) group_members (class_env,fun_heap,same,reverse old_cons_class)
Diederik van Arkel's avatar
Diederik van Arkel committed
965
966
967
		  (cleanup_info, class_env, fun_defs, var_heap, expr_heap, fun_heap)
				= foldSt set_case_expr_info (flatten ai_cases_of_vars_for_group)
					(cleanup_info, class_env, fun_defs, ai.ai_var_heap, expr_heap, fun_heap)
968
		= (cleanup_info, fun_defs, var_heap, expr_heap, fun_heap, class_env, same)
Diederik van Arkel's avatar
Diederik van Arkel committed
969
970
	  where
//initial classification...
971
		initial_cons_class fun (next_var, nr_of_local_vars, var_heap, class_env, fun_defs, fun_heap, old_acc)
Diederik van Arkel's avatar
Diederik van Arkel committed
972
973
974
975
976
977
978
979
980
			# (fun_def, fun_defs, fun_heap)			= get_fun_def fun fun_defs fun_heap
			# (TransformedBody {tb_args,tb_rhs})	= fun_def.fun_body
			  
			  nr_of_locals							= count_locals tb_rhs 0
			  nr_of_local_vars						= nr_of_local_vars + nr_of_locals
			  
			# (fresh_vars, next_var, var_heap)
			   										= fresh_variables tb_args 0 next_var var_heap
			# fun_class								= { cc_size = 0, cc_args = fresh_vars, cc_linear_bits=[], cc_producer=False}
981
982
			# (fun_heap,class_env,old_class)		= set_fun_class` fun fun_class fun_heap class_env
			= (next_var, nr_of_local_vars, var_heap, class_env, fun_defs, fun_heap, [old_class:old_acc])
Diederik van Arkel's avatar
Diederik van Arkel committed
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999


		set_fun_class fun fun_class fun_heap class_env
			| fun < size class_env
				# class_env							= { class_env & [fun] = fun_class}
				= (fun_heap,class_env)

			# (fun_def_ptr,fun_heap)				= lookup_ptr fun new_functions fun_heap
				with
					lookup_ptr fun [] ti_fun_heap = abort "drat"
					lookup_ptr fun [fun_def_ptr:new_functions] ti_fun_heap
						# (FI_Function {gf_fun_index}, ti_fun_heap)
								= readPtr fun_def_ptr ti_fun_heap
						| gf_fun_index == fun
							= (fun_def_ptr, ti_fun_heap)
							= lookup_ptr fun new_functions ti_fun_heap
			# (FI_Function gf, fun_heap)			= readPtr fun_def_ptr fun_heap
1000
1001
			# gf									= {gf & gf_cons_args = fun_class}
			# fun_heap								= writePtr fun_def_ptr (FI_Function gf) fun_heap
Diederik van Arkel's avatar
Diederik van Arkel committed
1002
1003
			= (fun_heap,class_env)

1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
		set_fun_class` fun fun_class fun_heap class_env
			| fun < size class_env
//				# class_env							= { class_env & [fun] = fun_class}
				# (old,class_env)					= replace class_env fun fun_class
				= (fun_heap,class_env,old)

			# (fun_def_ptr,fun_heap)				= lookup_ptr fun new_functions fun_heap
				with
					lookup_ptr fun [] ti_fun_heap = abort "drat"
					lookup_ptr fun [fun_def_ptr:new_functions] ti_fun_heap
						# (FI_Function {gf_fun_index}, ti_fun_heap)
								= readPtr fun_def_ptr ti_fun_heap
						| gf_fun_index == fun
							= (fun_def_ptr, ti_fun_heap)
							= lookup_ptr fun new_functions ti_fun_heap
			# (FI_Function gf, fun_heap)			= readPtr fun_def_ptr fun_heap
//			# gf									= {gf & gf_cons_args = fun_class}
			# (old,gf)								= (gf.gf_cons_args, {gf & gf_cons_args = fun_class})
			# fun_heap								= writePtr fun_def_ptr (FI_Function gf) fun_heap
			= (fun_heap,class_env,old)

Diederik van Arkel's avatar
Diederik van Arkel committed
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
//determine classification...
		analyse_functions common_defs fun (cfvog_accu, ai, fun_defs)
			#  (fun_def, fun_defs, fun_heap)		= get_fun_def fun fun_defs ai.ai_fun_heap
	 		   ai									= {ai & ai_fun_heap = fun_heap}
	 		   (TransformedBody {tb_args, tb_rhs})	= fun_def.fun_body

			   nr_of_locals							= count_locals tb_rhs 0
			   nr_of_args							= length tb_args

			   ai = { ai
			   		& ai_cur_ref_counts				= createArray (nr_of_args + nr_of_locals) 0
			   		, ai_def_ref_counts				= createArray (nr_of_args + nr_of_locals) 0
			   		, ai_next_var_of_fun			= nr_of_args 
			   		}
			// classify
			   (_, _, ai)							= consumerRequirements tb_rhs common_defs ai
			// set linearity info based on cur_ref_counts
			#  ai_cur_ref_counts					= ai.ai_cur_ref_counts
			   ai_cons_class						= ai.ai_cons_class

			#  fun_heap								= ai.ai_fun_heap
			#  (fun_cons_class,fun_heap,ai_cons_class)	= get_fun_class fun fun_heap ai_cons_class

			   linear_bits							= [ ref_count<2 \\ ref_count <-: ai_cur_ref_counts ]
			   fun_cons_class						= { fun_cons_class & cc_linear_bits=linear_bits }
			   cc_args								= add_unused_args fun_cons_class.cc_args ai_cur_ref_counts
			   fun_cons_class						= { fun_cons_class & cc_args = cc_args }
			#  (fun_heap,ai_cons_class)				= set_fun_class fun fun_cons_class fun_heap ai_cons_class
			   cases_of_vars_for_function			= [(a,fun) \\ a <- ai.ai_cases_of_vars_for_function ]
			   cfvog_accu							= [cases_of_vars_for_function:cfvog_accu]

			   ai = { ai
			   		& ai_cons_class					= ai_cons_class
			   		, ai_cases_of_vars_for_function	= [] 
			   		, ai_cur_ref_counts				= {}
			   		, ai_fun_heap					= fun_heap
			   		}
			= (cfvog_accu, ai, fun_defs)
//final classification...
1064
1065
		collect_classifications :: !.{#Int} !Int !*(!*{!ConsClasses},!*FunctionHeap,!Bool,!u:[w:ConsClasses]) -> *(!*{!ConsClasses},!*FunctionHeap,!Bool,!v:[x:ConsClasses]), [w <= x, u <= v];
		collect_classifications class_subst fun (class_env,fun_heap,same,[old_class:old_acc])
Diederik van Arkel's avatar
Diederik van Arkel committed
1066
1067
1068
			# (fun_class,fun_heap,class_env)	= get_fun_class fun fun_heap class_env
			  fun_class					= determine_classification fun_class class_subst
			# (fun_heap,class_env)		= set_fun_class fun fun_class fun_heap class_env
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
	 		= (class_env,fun_heap,same && equalCCs fun_class old_class,old_acc)

		equalCCs l r
			= equalCCArgs l.cc_args r.cc_args && equalCCBits l.cc_size l.cc_linear_bits r.cc_linear_bits
		equalCCArgs [] [] = True
		equalCCArgs [l:ls] [r:rs] = equalCC l r && equalCCArgs ls rs
		equalCC l r = l == r
		equalCCBits 0 _ _ = True
		equalCCBits n [l:ls] [r:rs] = l == r && equalCCBits (dec n) ls rs
		
1079
		set_case_expr_info ((safe,{case_expr=case_expr=:(Var {var_info_ptr}), case_guards, case_info_ptr}),fun_index)
Diederik van Arkel's avatar
Diederik van Arkel committed
1080
1081
1082
1083
				(cleanup_acc, class_env, fun_defs, var_heap, expr_heap, fun_heap)
			# (VI_AccVar _ arg_position, var_heap)				= readPtr var_info_ptr var_heap
			  ({cc_size, cc_args, cc_linear_bits},fun_heap,class_env)	= get_fun_class fun_index fun_heap class_env
			  (aci_linearity_of_patterns, var_heap)				= get_linearity_info cc_linear_bits case_guards var_heap
1084
//* Try always marking...
Diederik van Arkel's avatar
Diederik van Arkel committed
1085
1086
			| arg_position<cc_size && (arg_position>=cc_size || cc_args!!arg_position==CActive) && cc_linear_bits!!arg_position
				// mark non multimatch cases whose case_expr is an active linear function argument
1087
1088
//*/
			| True
Diederik van Arkel's avatar
Diederik van Arkel committed
1089
1090
1091
1092
1093
				# aci =
					{ aci_params				= []
					, aci_opt_unfolder			= No
					, aci_free_vars				= No
					, aci_linearity_of_patterns = aci_linearity_of_patterns
1094
					, aci_safe					= safe
Diederik van Arkel's avatar
Diederik van Arkel committed
1095
1096
1097
1098
					}
				= ([case_info_ptr:cleanup_acc], class_env, fun_defs, var_heap, 
					setExtendedExprInfo case_info_ptr (EEI_ActiveCase aci) expr_heap, fun_heap)
			= (cleanup_acc, class_env, fun_defs, var_heap, expr_heap, fun_heap)
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
// N-WAY...
		set_case_expr_info ((safe,{case_expr=(App _), case_guards, case_info_ptr}),fun_index)
				(cleanup_acc, class_env, fun_defs, var_heap, expr_heap, fun_heap)
			# ({cc_size, cc_args, cc_linear_bits},fun_heap,class_env)	= get_fun_class fun_index fun_heap class_env
			  (aci_linearity_of_patterns, var_heap)				= get_linearity_info cc_linear_bits case_guards var_heap
			# aci =
				{ aci_params				= []
				, aci_opt_unfolder			= No
				, aci_free_vars				= No
				, aci_linearity_of_patterns = aci_linearity_of_patterns
				, aci_safe					= safe
				}
			= ([case_info_ptr:cleanup_acc], class_env, fun_defs, var_heap, 
				setExtendedExprInfo case_info_ptr (EEI_ActiveCase aci) expr_heap, fun_heap)
		set_case_expr_info _ s = s
// ...N-WAY
Diederik van Arkel's avatar
Diederik van Arkel committed
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142

		get_fun_class fun fun_heap class_env
			| fun < size class_env
				# (fun_cons_class,class_env)		= class_env![fun]
				= (fun_cons_class,fun_heap,class_env)
			# (fun_def_ptr,fun_heap)				= lookup_ptr fun new_functions fun_heap
														with
															lookup_ptr fun [] ti_fun_heap = abort "drat"
															lookup_ptr fun [fun_def_ptr:new_functions] ti_fun_heap
																# (FI_Function {gf_fun_index}, ti_fun_heap)
																		= readPtr fun_def_ptr ti_fun_heap
																| gf_fun_index == fun
																	= (fun_def_ptr, ti_fun_heap)
																	= lookup_ptr fun new_functions ti_fun_heap
			# (FI_Function {gf_cons_args}, fun_heap)		= readPtr fun_def_ptr fun_heap
			= (gf_cons_args, fun_heap, class_env)

		get_linearity_info cc_linear_bits (AlgebraicPatterns _ algebraic_patterns) var_heap
			= mapSt (get_linearity_info_of_pattern cc_linear_bits) algebraic_patterns var_heap
		get_linearity_info cc_linear_bits (OverloadedListPatterns _ _ algebraic_patterns) var_heap
			= mapSt (get_linearity_info_of_pattern cc_linear_bits) algebraic_patterns var_heap
		get_linearity_info cc_linear_bits _ var_heap
			= ([], var_heap)

		get_linearity_info_of_pattern cc_linear_bits {ap_vars} var_heap
			# (var_indices, var_heap) = mapSt get_var_index ap_vars var_heap
			= ([if (index==cNope) True (cc_linear_bits!!index) \\ index<-var_indices], var_heap)

1143
1144
1145
1146
1147
1148
1149
		get_var_index {fv_info_ptr} var_heap
			# (vi, var_heap) = readPtr fv_info_ptr var_heap
			  index = case vi of
						VI_AccVar _ index	-> index
						VI_Count 0 False	-> cNope
			= (index, var_heap) 

Diederik van Arkel's avatar
Diederik van Arkel committed
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
		get_fun_def fun fun_defs fun_heap
			| fun < size fun_defs
				# (fun_def, fun_defs)						= fun_defs![fun]
				= (fun_def, fun_defs, fun_heap)
			# (fun_def_ptr, fun_heap)			= lookup_ptr fun new_functions fun_heap
				with
					lookup_ptr fun [] ti_fun_heap = abort "drat"
					lookup_ptr fun [fun_def_ptr:new_functions] ti_fun_heap
						# (FI_Function {gf_fun_index}, ti_fun_heap)
								= readPtr fun_def_ptr ti_fun_heap
						| gf_fun_index == fun
							= (fun_def_ptr, ti_fun_heap)
							= lookup_ptr fun new_functions ti_fun_heap
			# (FI_Function {gf_fun_def}, fun_heap)
												= readPtr fun_def_ptr fun_heap
			= (gf_fun_def, fun_defs, fun_heap)

reanalyseFunction
	:: !Int !FunctionInfoPtr !{# CommonDefs} !{#{#FunType}} !Int !Int !*{#FunDef} !*VarHeap !*FunctionHeap !*{!ConsClasses}
	-> *(!ConsClasses,!*{#FunDef},!*VarHeap,!*FunctionHeap,!*{!ConsClasses})
reanalyseFunction fun fun_info_ptr common_defs imported_funs main_dcl_module_n stdStrictLists_module_n fun_defs var_heap fun_heap class_env
	# consumerAnalysisRO=ConsumerAnalysisRO
		{ common_defs				= common_defs
		, imported_funs				= imported_funs
		, main_dcl_module_n			= main_dcl_module_n
		, stdStrictLists_module_n	= stdStrictLists_module_n
		}

	#  (fifun, fun_heap)					= readPtr fun_info_ptr fun_heap
	   fun_def								= case fifun of
												FI_Function {gf_fun_def}	-> gf_fun_def
												FI_Empty					-> abort "unexpected FI_Empty.\n"

	   ({tb_args, tb_rhs})					= case fun_def.fun_body of
	   											TransformedBody body		-> body
	   											body						-> abort "unexpected non-Transformed body?\n"

	   nr_of_locals							= count_locals tb_rhs 0
	   nr_of_args							= length tb_args

	# (fresh_vars, next_var, var_heap)
	   										= fresh_variables tb_args 0 0 var_heap
	# fun_class								= { cc_size = 0, cc_args = fresh_vars, cc_linear_bits=[], cc_producer=False}

	# (fun_info, fun_heap)					= readPtr fun_info_ptr fun_heap
	# fun_info								= case fun_info of
												FI_Function gf
													-> FI_Function {gf & gf_cons_args = fun_class}
	# fun_heap								= writePtr fun_info_ptr fun_info fun_heap

	# ai =
					{	ai_var_heap						= var_heap
					, 	ai_cons_class					= class_env
					,	ai_cur_ref_counts				= createArray (nr_of_args + nr_of_locals) 0
					,	ai_class_subst					= createArray (nr_of_args + nr_of_locals) CPassive
					,	ai_next_var						= next_var
					,	ai_next_var_of_fun				= nr_of_args
					,	ai_cases_of_vars_for_function	= []
					,	ai_fun_heap						= fun_heap
					,	ai_def_ref_counts				= createArray (nr_of_args + nr_of_locals) 0
					}

	// classify
	#  (_, _, ai)							= consumerRequirements tb_rhs consumerAnalysisRO ai
	// set linearity info based on cur_ref_counts?
	   ai_cur_ref_counts					= ai.ai_cur_ref_counts
	   ai_cons_class						= ai.ai_cons_class
	   fun_cons_class						= determine_classification fun_class ai.ai_class_subst
	   linear_bits							= [ ref_count<2 \\ ref_count <-: ai_cur_ref_counts ]
	   fun_cons_class						= { fun_cons_class & cc_linear_bits=linear_bits }
	   cc_args								= add_unused_args fun_cons_class.cc_args ai_cur_ref_counts
	   fun_cons_class						= { fun_cons_class & cc_args = cc_args }
	   cases_of_vars_for_function			= [(a,fun) \\ a <- ai.ai_cases_of_vars_for_function ]
	// set_case_expr_info cases_of_vars_for_function
	= (fun_cons_class,fun_defs,ai.ai_var_heap,ai.ai_fun_heap,ai_cons_class)

			
1227
fresh_variables :: ![.FreeVar] !Int !Int !*(Heap VarInfo) -> *(!.[Int],!Int,!*(Heap VarInfo))
Diederik van Arkel's avatar
Diederik van Arkel committed
1228
fresh_variables [{fv_info_ptr} : vars] arg_position next_var_number var_heap
1229
1230
	# var_heap
	  		= writePtr fv_info_ptr (VI_AccVar next_var_number arg_position) var_heap
Diederik van Arkel's avatar
Diederik van Arkel committed
1231
1232
	# (fresh_vars, last_var_number, var_heap)
			= fresh_variables vars (inc arg_position) (inc next_var_number) var_heap
1233
1234
1235
	= ([next_var_number : fresh_vars], last_var_number, var_heap)
fresh_variables [] _ next_var_number var_heap
	= ([], next_var_number, var_heap)
Diederik van Arkel's avatar
Diederik van Arkel committed
1236
1237
1238

// count_locals determines number of local variables...

1239
count_locals :: !Expression !Int -> Int
Diederik van Arkel's avatar
Diederik van Arkel committed
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
count_locals (Var _) n
	= n
count_locals (App {app_args}) n
	= foldSt count_locals app_args n
count_locals (fun_expr @ exprs) n
	= foldSt count_locals exprs (count_locals fun_expr n)
count_locals (Let {let_strict_binds,let_lazy_binds,let_expr}) n
	# let_binds	= let_strict_binds ++ let_lazy_binds
	= count_let_bind_locals let_binds (count_locals let_expr n)
count_locals (Case {case_expr,case_guards,case_default}) n
	= count_case_locals case_guards (count_locals case_expr (count_optional_locals case_default n))
count_locals (BasicExpr _) n
	= n
count_locals (MatchExpr _ expr) n
	= count_locals expr n
count_locals (Selection _ expr selectors) n
	= count_selector_locals selectors (count_locals expr n)
count_locals (Update expr1 selectors expr2) n
	# n = count_locals expr1 n
	# n = count_locals expr2 n
	# n = count_selector_locals selectors n
	= n
count_locals (RecordUpdate _ expr exprs) n
	= foldSt count_bind_locals exprs (count_locals expr n)
count_locals (TupleSelect _ _ expr) n
	= count_locals expr n
count_locals (AnyCodeExpr _ _ _) n
	= n
count_locals (ABCCodeExpr _ _) n
	= n
count_locals (DynamicExpr {dyn_expr}) n
	= count_locals dyn_expr n
count_locals (TypeCodeExpression _) n
	= n
count_locals EE n
	= n
1276
count_locals (FailExpr _) n = n
Diederik van Arkel's avatar
Diederik van Arkel committed
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
count_locals (NoBind _) n
	= n

count_optional_locals (Yes e) n
	= count_locals e n
count_optional_locals No n
	= n

count_bind_locals {bind_src} n
	= count_locals bind_src n

count_let_bind_locals binds n
	= foldSt count_let_bind_locals binds n
where
	count_let_bind_locals {lb_src,lb_dst} n
		| lb_dst.fv_count > 0
			= count_locals lb_src (inc n)
			= n

count_case_locals (AlgebraicPatterns _ patterns) n
	# pattern_exprs		= [ ap_expr \\ {ap_expr} <- patterns ]
	  pattern_vars		= flatten [ ap_vars \\ {ap_vars} <- patterns ]
	= foldSt count_locals pattern_exprs (foldSt count_case_guard_locals pattern_vars n)
count_case_locals (BasicPatterns _ patterns) n
	# pattern_exprs		= [ bp_expr \\ {bp_expr} <- patterns ]
	= foldSt count_locals pattern_exprs n
count_case_locals (OverloadedListPatterns _ _ patterns) n
	# pattern_exprs		= [ ap_expr \\ {ap_expr} <- patterns ]
	  pattern_vars		= flatten [ ap_vars \\ {ap_vars} <- patterns ]
	= foldSt count_locals pattern_exprs (foldSt count_case_guard_locals pattern_vars n)
count_case_locals NoPattern n
	= n

count_case_guard_locals {fv_count} n
	| fv_count > 0
		= inc n
		= n

count_selector_locals selectors n
	= foldSt count_selector_locals selectors n
where
	count_selector_locals (ArraySelection _ _ index_expr) n
		= count_locals index_expr n
	count_selector_locals (DictionarySelection _ _ _ index_expr) n
		= count_locals index_expr n
	// record selection missing?!
	count_selector_locals _ n
		= n

add_unused_args args ref_counts
	= [if (ref_count > 0) arg CUnused \\ arg<