trans.icl 112 KB
Newer Older
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
1
2
3
4
5
6
implementation module trans

import StdEnv

import syntax, transform, checksupport, StdCompare, check, utilities

7
import RWSDebug, StdDebug
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
8
9
10
11
12
13
14
15
16
17

::	PartitioningInfo = 
	{	pi_marks :: 		!.{# Int}
	,	pi_next_num ::		!Int
	,	pi_next_group ::	!Int
	,	pi_groups ::		![[Int]]
	,	pi_deps ::			![Int]
	}

NotChecked :== -1	
18
implies a b :== not a || b
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
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
90

partitionateFunctions :: !*{# FunDef} ![IndexRange] -> (!*{! Group}, !*{# FunDef})
partitionateFunctions fun_defs ranges
	#! max_fun_nr = size fun_defs
	# partitioning_info = { pi_marks = createArray max_fun_nr NotChecked, pi_deps = [], pi_next_num = 0, pi_next_group = 0, pi_groups = [] }
	  (fun_defs, {pi_groups,pi_next_group}) = 
	  		foldSt (partitionate_functions max_fun_nr) ranges (fun_defs, partitioning_info)
	  groups = { {group_members = group} \\ group <- reverse pi_groups }
	= (groups, fun_defs)
where
	partitionate_functions :: !Index !IndexRange !(!*{# FunDef}, !*PartitioningInfo) -> (!*{# FunDef}, !*PartitioningInfo)
	partitionate_functions max_fun_nr ir=:{ir_from,ir_to} (fun_defs, pi=:{pi_marks})
		| ir_from == ir_to
			= (fun_defs, pi)
		| pi_marks.[ir_from] == NotChecked
			# (_, fun_defs, pi) = partitionate_function ir_from max_fun_nr fun_defs pi
			= partitionate_functions max_fun_nr { ir & ir_from = inc ir_from } (fun_defs, pi)
			= partitionate_functions max_fun_nr { ir & ir_from = inc ir_from } (fun_defs, pi)

	partitionate_function :: !Int !Int !*{# FunDef} !*PartitioningInfo -> *(!Int, !*{# FunDef}, !*PartitioningInfo)
	partitionate_function fun_index max_fun_nr fun_defs pi=:{pi_next_num}
		#! fd = fun_defs.[fun_index]
		# {fi_calls} = fd.fun_info
		  (min_dep, fun_defs, pi) = visit_functions fi_calls max_fun_nr max_fun_nr fun_defs (push_on_dep_stack fun_index pi)
		= try_to_close_group fun_index pi_next_num min_dep max_fun_nr fun_defs pi

/*				  
	partitionate_function :: !Int !Int !*{# FunDef} !*PartitioningInfo -> *(!Int, !*{# FunDef}, !*PartitioningInfo)
	partitionate_function fun_index max_fun_nr fun_defs pi=:{pi_next_num}
		#! fd = fun_defs.[fun_index]
		| fd.fun_kind
			# {fi_calls} = fd.fun_info
			  (min_dep, fun_defs, pi) = visit_functions fi_calls max_fun_nr max_fun_nr fun_defs (push_on_dep_stack fun_index pi)
			= try_to_close_group fun_index pi_next_num min_dep max_fun_nr fun_defs pi
			= (max_fun_nr, fun_defs, pi)
*/
	push_on_dep_stack :: !Int !*PartitioningInfo -> *PartitioningInfo;
	push_on_dep_stack fun_index pi=:{pi_deps,pi_marks,pi_next_num}
		= { pi & pi_deps = [fun_index : pi_deps], pi_marks = { pi_marks & [fun_index] = pi_next_num}, pi_next_num = inc pi_next_num}

	visit_functions :: ![FunCall] !Int !Int !*{# FunDef} !*PartitioningInfo -> *(!Int, !*{# FunDef}, !*PartitioningInfo)
	visit_functions [{fc_index}:funs] min_dep max_fun_nr fun_defs pi=:{pi_marks} 
		#! mark = pi_marks.[fc_index]
		| mark == NotChecked
			# (mark, fun_defs, pi) = partitionate_function fc_index max_fun_nr fun_defs  pi
			= visit_functions funs (min min_dep mark) max_fun_nr fun_defs pi
			= visit_functions funs (min min_dep mark) max_fun_nr fun_defs pi
	visit_functions [] min_dep max_fun_nr fun_defs pi
		= (min_dep, fun_defs, pi)
		

	try_to_close_group :: !Int !Int !Int !Int !*{# FunDef} !*PartitioningInfo -> *(!Int, !*{# FunDef}, !*PartitioningInfo)
	try_to_close_group fun_index fun_nr min_dep max_fun_nr fun_defs pi=:{pi_marks, pi_deps, pi_groups, pi_next_group}
		| fun_nr <= min_dep
			# (pi_deps, pi_marks, group, fun_defs)
				= close_group fun_index pi_deps pi_marks [] max_fun_nr pi_next_group fun_defs
			  pi = { pi & pi_deps = pi_deps, pi_marks = pi_marks, pi_next_group = inc pi_next_group,  pi_groups = [group : pi_groups] }
			= (max_fun_nr, fun_defs, pi)
			= (min_dep, fun_defs, pi)
	where
		close_group :: !Int ![Int] !*{# Int} ![Int] !Int !Int !*{# FunDef} -> (![Int], !*{# Int}, ![Int], !*{# FunDef})
		close_group fun_index [d:ds] marks group max_fun_nr group_number fun_defs
			# marks = { marks & [d] = max_fun_nr }
			#! fd = fun_defs.[d]
			# fun_defs = { fun_defs & [d] = { fd & fun_info.fi_group_index = group_number }}
			| d == fun_index
				= (ds, marks, [d : group], fun_defs)
				= close_group fun_index ds marks [d : group] max_fun_nr group_number fun_defs

::	BitVector :== Int

::	*AnalyseInfo =
91
	{	ai_var_heap						:: !*VarHeap
92
93
94
95
	,	ai_cons_class					:: !*{! ConsClasses}
	,	ai_cur_ref_counts				:: !*{#Int} // for each variable 0,1 or 2
	,	ai_class_subst					:: !* ConsClassSubst
	,	ai_next_var						:: !Int
96
97
98
99
100
101
102
	,	ai_next_var_of_fun				:: !Int
	,	ai_cases_of_vars_for_function	:: ![Case]
	}

::	SharedAI =
	{	sai_common_defs		:: !{# CommonDefs }
	,	sai_imported_funs	:: !{# {# FunType} }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
103
104
105
106
	}

::	ConsClassSubst	:== {# ConsClass}

107
::	CleanupInfo :== [ExprInfoPtr]
108
109
110
111

cNoFunArg		:== -1
cNope			:== -1

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
112
113
/*
	The argument classification (i.e. 'accumulating', 'active' or 'passive') of consumers
114
115
	is represented by a negative integer value.
	Positive classifications are used to identify variables.
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
116
117
118
	Unification of classifications is done on-the-fly
*/

Martin Wierich's avatar
Martin Wierich committed
119
120
121
122
cPassive   				:== -1
cActive					:== -2
cAccumulating   		:== -3
cVarOfMultimatchCase	:== -4
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
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
149
150
151
152
153
154
155
156
157
158
159
160
161

IsAVariable cons_class :== cons_class >= 0

combineClasses cc1 cc2
	| IsAVariable cc1
		= cAccumulating
	| IsAVariable cc2
		= cAccumulating
		= min cc1 cc2
 
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 :: Int !*ConsClassSubst -> (!Int,!*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 :: !Int !Int !*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 }
162

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
163
164
165
166
167
168
169
170
171
172
173
174
175
176
				= { 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 cc1 cc2
		= min cc1 cc2

write_ptr ptr val heap mess
	| isNilPtr ptr
		= abort mess
		= heap <:=  (ptr,val)

177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
readVarInfo :: VarInfoPtr *VarHeap -> (VarInfo, !*VarHeap)
readVarInfo var_info_ptr var_heap
	# (var_info, var_heap) = readPtr var_info_ptr var_heap
	= case var_info of
		VI_Extended _ original_var_info	-> (original_var_info, var_heap)
		_								-> (var_info, var_heap)

writeVarInfo :: VarInfoPtr VarInfo *VarHeap -> *VarHeap
writeVarInfo var_info_ptr new_var_info var_heap
	# (old_var_info, var_heap) = readPtr var_info_ptr var_heap
	= case old_var_info of
		VI_Extended extensions _	-> writePtr var_info_ptr (VI_Extended extensions new_var_info) var_heap
		_							-> writePtr var_info_ptr new_var_info var_heap

class consumerRequirements a :: !a !{# CommonDefs} !AnalyseInfo -> (!ConsClass, !UnsafePatternBool, !AnalyseInfo)

::	UnsafePatternBool :== Bool

not_an_unsafe_pattern (cc, _, ai) = (cc, False, ai)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
196
197
198

instance consumerRequirements BoundVar
where
Sjaak Smetsers's avatar
bug fix    
Sjaak Smetsers committed
199
	consumerRequirements {var_name,var_info_ptr} _ ai=:{ai_var_heap}
200
201
		# (var_info, ai_var_heap) = readPtr var_info_ptr ai_var_heap
		= continuation var_info { ai & ai_var_heap=ai_var_heap }
202
203
	  where
		continuation (VI_AccVar temp_var arg_position) ai=:{ai_cur_ref_counts}
204
205
//			| arg_position<0
//				= (temp_var, ai)
206
207
			#! ref_count = ai_cur_ref_counts.[arg_position] 
			   ai_cur_ref_counts = { ai_cur_ref_counts & [arg_position]=min (ref_count+1) 2 }
208
			= (temp_var, False, { ai & ai_cur_ref_counts=ai_cur_ref_counts })
Sjaak Smetsers's avatar
bug fix    
Sjaak Smetsers committed
209
		continuation var_info ai=:{ai_cur_ref_counts}
Sjaak Smetsers's avatar
Sjaak Smetsers committed
210
			=  abort ("consumerRequirements" ---> (var_name))//  <<- var_info))
211
212
//		continuation vi ai
//			= (cPassive, ai)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
213
214

instance consumerRequirements Expression where
215
216
217
218
219
220
	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
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
221
		  ai_class_subst = unifyClassifications cActive cc_fun ai.ai_class_subst
222
223
224
225
226
227
		= consumerRequirements exprs common_defs { ai & ai_class_subst = ai_class_subst }
	consumerRequirements (Let {let_binds,let_expr}) common_defs ai=:{ai_next_var,ai_next_var_of_fun,ai_var_heap}
		# (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 = acc_requirements_of_let_binds let_binds ai_next_var common_defs
					{ ai & ai_next_var = new_next_var, ai_next_var_of_fun = new_ai_next_var_of_fun, ai_var_heap = ai_var_heap }
		= consumerRequirements let_expr common_defs ai // XXX why not not_an_unsafe_pattern
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
228
		where
Sjaak Smetsers's avatar
bug fix    
Sjaak Smetsers committed
229
			init_variables [{bind_dst={fv_name, fv_count, fv_info_ptr}} : binds] ai_next_var ai_next_var_of_fun ai_var_heap
230
231
232
233
				| fv_count > 0
					= init_variables binds (inc ai_next_var) (inc ai_next_var_of_fun)
						(writePtr fv_info_ptr (VI_AccVar ai_next_var ai_next_var_of_fun) ai_var_heap)
					= init_variables binds ai_next_var ai_next_var_of_fun ai_var_heap
234
235
			init_variables [] ai_next_var ai_next_var_of_fun ai_var_heap
				= (ai_next_var, ai_next_var_of_fun, ai_var_heap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
236
				
237
238
239
240
241
242
			acc_requirements_of_let_binds [ {bind_src, bind_dst} : binds ] ai_next_var common_defs ai
				| bind_dst.fv_count > 0
					# (bind_var, _, ai) = consumerRequirements bind_src common_defs ai
			  		  ai_class_subst = unifyClassifications ai_next_var bind_var ai.ai_class_subst
					= acc_requirements_of_let_binds binds (inc ai_next_var) common_defs { ai & ai_class_subst = ai_class_subst }
					= acc_requirements_of_let_binds binds ai_next_var common_defs ai
243
			acc_requirements_of_let_binds [] ai_next_var _ ai
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
244
245
				= ai
				
246
247
248
249
250
251
252
253
	consumerRequirements (Case case_expr) common_defs ai
		= consumerRequirements case_expr common_defs ai
	consumerRequirements (BasicExpr _ _) _ ai
		= (cPassive, False, ai)
	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
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
254
		  ai_class_subst = unifyClassifications cActive cc ai.ai_class_subst
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
		  ai = requirementsOfSelectors selectors common_defs { ai & ai_class_subst = ai_class_subst }
		= (cPassive, False, ai)
	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
		= (cPassive, False, ai)
	consumerRequirements (RecordUpdate cons_symbol expression expressions) common_defs ai
		# (cc, _, ai) = consumerRequirements expression common_defs ai
		  (cc, _, ai) = consumerRequirements expressions common_defs ai
		= (cPassive, False, ai)
	consumerRequirements (TupleSelect tuple_symbol arg_nr expr) common_defs ai
		= consumerRequirements expr common_defs ai
	consumerRequirements (AnyCodeExpr _ _ _) _ ai
		= (cPassive, False, ai)
	consumerRequirements (ABCCodeExpr _ _) _ ai
		= (cPassive, False, ai)
	consumerRequirements (DynamicExpr dynamic_expr) common_defs ai
		= consumerRequirements dynamic_expr common_defs ai
	consumerRequirements (TypeCodeExpression _) _ ai
		= (cPassive, False, ai)
	consumerRequirements EE _ ai
		= (cPassive, False, ai)
	consumerRequirements expr _ ai
Sjaak Smetsers's avatar
Sjaak Smetsers committed
279
		= abort ("consumerRequirements ") // <<- expr)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
280

281
282
requirementsOfSelectors selectors common_defs ai
	= foldSt (reqs_of_selector common_defs) selectors ai
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
283
where
284
285
	reqs_of_selector common_defs (ArraySelection _ _ index_expr) ai
		# (_, _, ai) = consumerRequirements index_expr common_defs ai
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
286
		= ai
287
288
289
	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
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
290
		= { ai & ai_class_subst = unifyClassifications cActive cc_var ai.ai_class_subst }
291
	reqs_of_selector _ _ ai
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
292
293
294
		= ai
			
instance consumerRequirements App where
295
	consumerRequirements {app_symb={symb_kind = SK_Function {glob_module,glob_object}, symb_arity, symb_name}, app_args} common_defs ai=:{ai_cons_class}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
296
297
298
		| glob_module == cIclModIndex
			| glob_object < size ai_cons_class
				#! fun_class = ai_cons_class.[glob_object]
299
300
301
				= reqs_of_args fun_class.cc_args app_args cPassive common_defs ai
				= consumerRequirements app_args common_defs ai
			= consumerRequirements app_args common_defs ai
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
302
	where
303
304
305
306
307
308
		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
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
309
			  ai_class_subst = unifyClassifications form_cc act_cc ai.ai_class_subst
310
			= reqs_of_args ccs args (combineClasses act_cc cumm_arg_class) common_defs { ai & ai_class_subst = ai_class_subst }
311

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
312
313
314
315
316
317
/*
	consumerRequirements {app_symb={symb_kind = SK_InternalFunction _}, app_args=[arg:_]} ai
		# (cc, ai) = consumerRequirements arg ai
		  ai_class_subst = unifyClassifications cActive cc ai.ai_class_subst
		= (cPassive, { ai & ai_class_subst = ai_class_subst })
*/
318
319
	consumerRequirements {app_args} common_defs ai
		=  not_an_unsafe_pattern (consumerRequirements app_args common_defs ai)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
320

321
instance consumerRequirements Case where
322
323
324
325
326
	consumerRequirements kees=:{case_expr,case_guards,case_default,case_info_ptr} common_defs ai
		# (cce, _, ai) = consumerRequirements case_expr common_defs ai
		  (ccgs, unsafe_bits, ai) = consumer_requirements_of_guards case_guards common_defs ai
		  has_default = case case_default of { Yes _ -> True; _ -> False }
		  (ccd, default_is_unsafe, ai) = consumerRequirements case_default common_defs ai
327
		  (every_constructor_appears_in_safe_pattern, may_be_active) = inspect_patterns common_defs has_default case_guards unsafe_bits
328
		  safe = (has_default && not default_is_unsafe) || every_constructor_appears_in_safe_pattern
329
		  ai_class_subst = unifyClassifications (if may_be_active cActive cVarOfMultimatchCase) cce ai.ai_class_subst
330
331
		  ai = { ai & ai_class_subst = ai_class_subst }
		  ai = case case_expr of
332
333
334
335
				Var {var_info_ptr}
					| may_be_active
						-> { ai & ai_cases_of_vars_for_function=[kees:ai.ai_cases_of_vars_for_function] }
						-> ai
336
337
338
339
340
341
342
343
344
345
346
347
				_	-> ai
		= (combineClasses ccgs ccd, not safe, ai)
	  where
		inspect_patterns common_defs has_default (AlgebraicPatterns {glob_object, glob_module} algebraic_patterns) unsafe_bits
			# 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 (quicksort (<) all_constructors)
348
			= (appearance_loop all_sorted_constructors sorted_pattern_constructors, not (multimatch_loop has_default sorted_pattern_constructors))
349
350
351
352
353
354
355
356
357
		  where
			is_sorted [x]
				= True
			is_sorted [h1:t=:[h2:_]]
				= h1 < h2 && is_sorted t
		inspect_patterns common_defs has_default (BasicPatterns BT_Bool basic_patterns) unsafe_bits
			# bools_indices = [ if bool 1 0 \\ {bp_value=BVB bool}<-basic_patterns ]
			  sorted_pattern_constructors = sort bools_indices unsafe_bits
			= (appearance_loop [0,1] sorted_pattern_constructors,
358
				not (multimatch_loop has_default sorted_pattern_constructors))
359
		inspect_patterns _ _ _ _
360
			= (False, False)
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387

		sort constr_indices unsafe_bits
			= quicksort 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)

Martin Wierich's avatar
Martin Wierich committed
388
		multimatch_loop has_default []
389
			= False
Martin Wierich's avatar
Martin Wierich committed
390
		multimatch_loop has_default [(cip, _, iup):t]
391
392
393
394
395
396
397
398
399
400
401
			= 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
Martin Wierich's avatar
Martin Wierich committed
402
				= multimatch_loop has_default (dropWhile (\(ds_index,_,_)->ds_index==cip) constructors_in_pattern)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
403
404

instance consumerRequirements DynamicExpr where
405
406
	consumerRequirements {dyn_expr} common_defs ai
		= consumerRequirements dyn_expr common_defs ai
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
407
408
409
410
411
412
413
414
415
416

/*
instance consumerRequirements TypeCase where
	consumerRequirements {type_case_dynamic,type_case_patterns,type_case_default} ai
		# (_, ai) = consumerRequirements type_case_dynamic ai
		  (ccgs, ai) = consumerRequirements (type_case_patterns,type_case_default) ai
		= (ccgs, ai)
*/

instance consumerRequirements DynamicPattern where
417
418
419
	consumerRequirements {dp_rhs} common_defs ai
		= consumerRequirements dp_rhs common_defs ai

420
bindPatternVars [fv=:{fv_info_ptr,fv_count} : vars] next_var next_var_of_fun var_heap
421
	| fv_count > 0
422
		= bindPatternVars vars (inc next_var) (inc next_var_of_fun) (writePtr fv_info_ptr (VI_AccVar next_var next_var_of_fun) var_heap)
423
		= bindPatternVars vars next_var next_var_of_fun (writePtr fv_info_ptr (VI_Count 0 False) var_heap)
424
425
426
bindPatternVars [] next_var next_var_of_fun var_heap
	= (next_var, next_var_of_fun, var_heap)

427
428
429
consumer_requirements_of_guards (AlgebraicPatterns type patterns) common_defs ai
	# pattern_exprs = [ ap_expr \\ {ap_expr}<-patterns]
	  pattern_vars = flatten [ ap_vars \\ {ap_vars}<-patterns]
430
	  (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
431
432
433
434
435
436
	  ai = { ai & ai_var_heap=ai_var_heap, ai_next_var=ai_next_var, ai_next_var_of_fun = ai_next_var_of_fun }
	= independentConsumerRequirements pattern_exprs common_defs ai
consumer_requirements_of_guards (BasicPatterns type patterns) common_defs ai
	# pattern_exprs = [ bp_expr \\ {bp_expr}<-patterns]
	= independentConsumerRequirements pattern_exprs common_defs ai
consumer_requirements_of_guards (DynamicPatterns dyn_patterns) common_defs ai
437
438
439
440
441
	# pattern_exprs = [ dp_rhs \\ {dp_rhs}<-dyn_patterns]
	  pattern_vars = [ dp_var \\ {dp_var}<-dyn_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 }
	= independentConsumerRequirements pattern_exprs common_defs ai
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
442
443

instance consumerRequirements BasicPattern where
444
445
	consumerRequirements {bp_expr} common_defs ai
		= consumerRequirements bp_expr common_defs ai
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
446
447

instance consumerRequirements (Optional a) | consumerRequirements a where
448
449
450
451
	consumerRequirements (Yes x) common_defs ai
		= consumerRequirements x common_defs ai
	consumerRequirements No _ ai
		= (cPassive, False, ai)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
452
453

instance consumerRequirements (!a,!b) | consumerRequirements a & consumerRequirements b where
454
455
456
457
	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)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
458
459
		
instance consumerRequirements [a] | consumerRequirements a where
460
461
462
463
464
465
	consumerRequirements [x : xs] common_defs ai
		# (ccx, _, ai) = consumerRequirements x common_defs ai
		  (ccxs, _, ai) = consumerRequirements xs common_defs ai
		= (combineClasses ccx ccxs, False, ai)
	consumerRequirements [] _ ai
		= (cPassive, False, ai)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
466
467

instance consumerRequirements (Bind a b) | consumerRequirements a where
468
469
	consumerRequirements {bind_src} common_defs ai
		= consumerRequirements bind_src common_defs ai
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
470

471
independentConsumerRequirements exprs common_defs ai=:{ai_cur_ref_counts}
472
473
474
// reference counting happens independently for each pattern expression
	#! s = size ai_cur_ref_counts
	   zero_array = createArray s 0
475
476
	   (_, cc, r_unsafe_bits ,ai) = foldSt (independent_consumer_requirements common_defs) exprs (zero_array, cPassive, [], ai)
	= (cc, reverse r_unsafe_bits, ai)
477
  where	
478
	independent_consumer_requirements common_defs expr (zero_array, cc, unsafe_bits_accu, ai=:{ai_cur_ref_counts})
479
480
		#! s = size ai_cur_ref_counts
		   ai = { ai & ai_cur_ref_counts=zero_array }
481
		   (cce, is_unsafe_case, ai) = consumerRequirements expr common_defs ai
482
483
		   (unused, unified_ref_counts) = unify_ref_count_arrays s ai_cur_ref_counts ai.ai_cur_ref_counts
		   ai = { ai & ai_cur_ref_counts=unified_ref_counts }
484
		= ({ unused & [i]=0 \\ i<-[0..s-1]}, combineClasses cce cc, [is_unsafe_case:unsafe_bits_accu], ai)
485
486
487
488
489
490
491
492
493
494
495
496
497
498
	unify_ref_count_arrays 0 src1 src2_dest
		= (src1, src2_dest)
	unify_ref_count_arrays i src1 src2_dest
		#! i1 = dec i
		   rc1 = src1.[i1]
		   rc2 = src2_dest.[i1]
		= unify_ref_count_arrays i1 src1 { src2_dest & [i1]= unify_ref_counts rc1 rc2} 

	// unify_ref_counts outer_ref_count ref_count_in_pattern
	unify_ref_counts 0 x = if (x==2) 2 0
	unify_ref_counts 1 x = if (x==0) 1 2
	unify_ref_counts 2 _ = 2


499
analyseGroups	:: !{# CommonDefs} !*{! Group} !*{#FunDef} !*VarHeap !*ExpressionHeap 
500
				-> (!CleanupInfo, !*{! ConsClasses}, !*{! Group}, !*{#FunDef}, !*VarHeap, !*ExpressionHeap)
501
analyseGroups common_defs groups fun_defs var_heap expr_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
502
	#! nr_of_funs = size fun_defs
503
	   nr_of_groups = size groups
504
	= iFoldSt (analyse_group common_defs) 0 nr_of_groups
505
				([], createArray nr_of_funs { cc_size = 0, cc_args = [], cc_linear_bits = []}, groups, fun_defs, var_heap, expr_heap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
506
where	
507
	analyse_group common_defs group_nr (cleanup_info, class_env, groups, fun_defs, var_heap, expr_heap)
508
509
		#! {group_members} = groups.[group_nr]
		# (nr_of_vars, nr_of_local_vars, var_heap, class_env, fun_defs) = initial_cons_class group_members 0 0 var_heap class_env fun_defs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
510
		  initial_subst = createArray (nr_of_vars + nr_of_local_vars) cPassive
511
		  (ai_cases_of_vars_for_group, ai, fun_defs)
512
513
				 = analyse_functions common_defs group_members []
						{	ai_var_heap = var_heap,
514
515
516
						 	ai_cons_class = class_env, 
							ai_cur_ref_counts = {}, ai_class_subst = initial_subst,
							ai_next_var = nr_of_vars,
517
							ai_next_var_of_fun = 0,
518
519
520
							ai_cases_of_vars_for_function = [] } fun_defs
		  class_env = collect_classifications group_members ai.ai_cons_class ai.ai_class_subst
		  (cleanup_info, class_env, fun_defs, var_heap, expr_heap)
521
				 = foldSt set_case_expr_info (flatten ai_cases_of_vars_for_group) (cleanup_info,class_env, fun_defs, ai.ai_var_heap, expr_heap)
522
523
		= (cleanup_info, class_env, groups, fun_defs, var_heap, expr_heap)
	  where
524
		set_case_expr_info ({case_expr=(Var {var_info_ptr}), case_guards, case_info_ptr},fun_index) (cleanup_acc, class_env, fun_defs, var_heap, expr_heap)
525
			# (VI_AccVar _ arg_position, var_heap) = readPtr var_info_ptr var_heap
526
527
528
			  ({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
			| /*XXX*/arg_position<cc_size && (arg_position>=cc_size || cc_args!!arg_position==cActive) && cc_linear_bits!!arg_position
Martin Wierich's avatar
Martin Wierich committed
529
				// mark non multimatch cases whose case_expr is an active linear function argument
530
531
532
				# aci = { aci_params = [], aci_opt_unfolder = No, aci_free_vars=No, aci_linearity_of_patterns = aci_linearity_of_patterns }
				= ([case_info_ptr:cleanup_acc], class_env, fun_defs, var_heap, 
					set_extended_expr_info case_info_ptr (EEI_ActiveCase aci) expr_heap)
533
			= (cleanup_acc, class_env, fun_defs, var_heap, expr_heap)
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
		get_linearity_info cc_linear_bits (AlgebraicPatterns _ algebraic_patterns) var_heap
			= mapSt (get_linearity_info_of_pattern cc_linear_bits) algebraic_patterns var_heap
		  where
			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)
			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) 
		get_linearity_info cc_linear_bits _ var_heap
			= ([], var_heap)

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
549
550
551
	initial_cons_class [fun : funs] next_var_number nr_of_local_vars var_heap class_env fun_defs
		#! fun_def = fun_defs.[fun]
		#  (TransformedBody {tb_args}) = fun_def.fun_body
552
		   (fresh_vars, next_var_number, var_heap) = fresh_variables tb_args 0 next_var_number var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
553
		= initial_cons_class funs next_var_number (length fun_def.fun_info.fi_local_vars + nr_of_local_vars) var_heap
554
			{ class_env & [fun] = { cc_size = 0, cc_args = fresh_vars, cc_linear_bits=[]}} fun_defs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
555
556
557
	initial_cons_class [] next_var_number nr_of_local_vars var_heap class_env fun_defs
		= (next_var_number, nr_of_local_vars, var_heap, class_env, fun_defs)
		
558
559
	fresh_variables [{fv_name,fv_info_ptr} : vars] arg_position next_var_number var_heap
		# (fresh_vars, last_var_number, var_heap) = fresh_variables vars (inc arg_position) (inc next_var_number) var_heap
560
		  var_heap = writePtr fv_info_ptr (VI_AccVar next_var_number arg_position) var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
561
		= ([next_var_number : fresh_vars], last_var_number, var_heap)
562
	fresh_variables [] _ next_var_number var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
563
564
		= ([], next_var_number, var_heap)

565
	analyse_functions common_defs [fun : funs] cfvog_accu ai fun_defs
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
566
		#! fun_def = fun_defs.[fun]
567
		#  (TransformedBody {tb_args, tb_rhs}) = fun_def.fun_body
568
569
570
571
		   nr_of_args = length tb_args
		   ai = { ai & ai_cur_ref_counts = createArray (nr_of_args + length fun_def.fun_info.fi_local_vars) 0,
						ai_next_var_of_fun = nr_of_args }
		   (_, _, ai) = consumerRequirements tb_rhs common_defs ai
572
573
574
575
576
577
		   ai_cur_ref_counts = ai.ai_cur_ref_counts
		   ai = { ai & ai_cur_ref_counts={} }
		   ai_cons_class = update_array_element ai.ai_cons_class fun
		   						(\cc->{ cc & cc_linear_bits=[ ref_count<2 \\ ref_count<-:ai_cur_ref_counts] })
		   cases_of_vars_for_function = [(a,fun) \\ a<-ai.ai_cases_of_vars_for_function ]
		   ai = { ai & ai_cons_class=ai_cons_class, ai_cases_of_vars_for_function=[] }
578
		= analyse_functions common_defs funs [cases_of_vars_for_function:cfvog_accu] ai fun_defs
579
580
581
582
	  where
		update_array_element array index transition
			# (before, array) = array![index]
			= { array & [index]=transition before }
583
	analyse_functions common_defs [] cfvog_accu ai fun_defs
584
		= (cfvog_accu, ai, fun_defs)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
585
586
587
588
589

	collect_classifications [] class_env class_subst
		= class_env
	collect_classifications [fun : funs] class_env class_subst
		#! fun_class = class_env.[fun]
590
		# fun_class = determine_classification fun_class class_subst
591
		= collect_classifications funs { class_env & [fun] = fun_class /*---> (fun, fun_class)*/} class_subst
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
592
593
	where
		determine_classification cc class_subst
594
595
			# (cc_size, cc_args) = mapAndLength (skip_indirections class_subst) cc.cc_args
			= { cc & cc_size = cc_size, cc_args = cc_args }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
596
597
598
599
600
601
602
603
604
605
606
607
608
609

		skip_indirections class_subst cc
			| IsAVariable cc
				= skip_indirections class_subst class_subst.[cc]
				= cc

mapAndLength f [x : xs]
	#! x = f x
	   (length, xs) = mapAndLength f xs
	=  (inc length, [x : xs])
mapAndLength f []
	= (0, [])
	
::	*TransformInfo =
610
611
612
613
614
615
616
617
618
619
620
621
	{	ti_fun_defs				:: !*{# FunDef}
	,	ti_instances 			:: !*{! InstanceInfo }
	,	ti_cons_args 			:: !{! ConsClasses}
	,	ti_new_functions 		:: ![FunctionInfoPtr]
	,	ti_fun_heap				:: !*FunctionHeap
	,	ti_var_heap				:: !*VarHeap
	,	ti_symbol_heap			:: !*ExpressionHeap
	,	ti_type_heaps			:: !*TypeHeaps
	,	ti_next_fun_nr			:: !Index
	,	ti_cleanup_info			:: !CleanupInfo
	,	ti_recursion_introduced	:: !Optional Index
	,	ti_trace				:: !Bool // XXX just for tracing
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
622
623
	}

624
625
::	ReadOnlyTI = 
	{	ro_imported_funs	:: !{# {# FunType} }
626
627
	,	ro_common_defs		:: !{# CommonDefs }
	,	ro_root_case_mode	:: !RootCaseMode
628
629
630
631
	,	ro_fun				:: !SymbIdent
	,	ro_fun_args			:: ![FreeVar]
	}

632
633
::	RootCaseMode = NotRootCase | RootCase | RootCaseOfZombie

634
class transform a :: !a !ReadOnlyTI !TransformInfo -> (!a, !TransformInfo)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
635
636
637

instance transform Expression
where
638
639
640
641
642
643
	transform expr=:(App app=:{app_symb,app_args}) ro ti
		# (app_args, ti) = transform app_args ro ti
		= transformApplication { app & app_args = app_args } [] ro ti
	transform appl_expr=:(expr @ exprs) ro ti
		# (expr, ti) = transform expr ro ti
		  (exprs, ti) = transform exprs ro ti
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
644
645
		= case expr of
			App app
646
				-> transformApplication app exprs ro ti
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
647
648
			_
				-> (expr @ exprs, ti)
649
	transform (Let lad=:{let_binds, let_expr}) ro ti
650
651
		# ti = store_type_info_of_bindings_in_heap lad ti
		  (let_binds, ti) = transform let_binds ro ti
652
		  (let_expr, ti) = transform let_expr ro ti
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
653
		= (Let { lad & let_binds = let_binds, let_expr = let_expr}, ti)
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
	  where
		store_type_info_of_bindings_in_heap {let_binds,let_info_ptr} ti
			# (EI_LetType var_types, ti_symbol_heap) = readExprInfo let_info_ptr ti.ti_symbol_heap
			  ti_var_heap = foldSt (\(var_type, {bind_dst={fv_info_ptr}}) var_heap
										 ->setExtendedVarInfo fv_info_ptr (EVI_VarType var_type) var_heap)
								   (zip2 var_types let_binds) ti.ti_var_heap
			= { ti & ti_symbol_heap = ti_symbol_heap, ti_var_heap = ti_var_heap }
	transform (Case kees) ro ti
		# ti = store_type_info_of_patterns_in_heap kees ti
		= transformCase kees ro ti
	  where
		store_type_info_of_patterns_in_heap {case_guards,case_info_ptr} ti
			= case case_guards of
				AlgebraicPatterns _ patterns
					# (EI_CaseType {ct_cons_types},ti_symbol_heap) = readExprInfo case_info_ptr ti.ti_symbol_heap
					  ti_var_heap = foldSt store_type_info_of_alg_pattern (zip2 ct_cons_types patterns) ti.ti_var_heap
					-> { ti & ti_symbol_heap = ti_symbol_heap, ti_var_heap = ti_var_heap }
				BasicPatterns _ _
					-> ti // no variables occur
				DynamicPatterns dynamic_patterns
674
675
676
					# (EI_CaseType {ct_cons_types},ti_symbol_heap) = readExprInfo case_info_ptr ti.ti_symbol_heap
					  ti_var_heap = foldSt store_type_info_of_dyn_pattern (zip2 ct_cons_types dynamic_patterns) ti.ti_var_heap
					-> { ti & ti_symbol_heap = ti_symbol_heap, ti_var_heap = ti_var_heap }
677
678
679
680
681
				NoPattern
					-> ti
		store_type_info_of_alg_pattern (var_types,{ap_vars}) var_heap
			= foldSt (\(var_type, {fv_info_ptr}) var_heap
						->setExtendedVarInfo fv_info_ptr (EVI_VarType var_type) var_heap) (zip2 var_types ap_vars) var_heap
682
683
684
685

		store_type_info_of_dyn_pattern ([var_type:_],{dp_var}) var_heap
			= setExtendedVarInfo dp_var.fv_info_ptr (EVI_VarType var_type) var_heap

686
687
	transform (Selection opt_type expr selectors) ro ti
		# (expr, ti) = transform expr ro ti
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
688
		= transformSelection opt_type selectors expr ti
689
690
	transform (DynamicExpr dynamic_expr) ro ti
		# (dynamic_expr, ti) = transform dynamic_expr ro ti
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
691
		= (DynamicExpr dynamic_expr, ti)
692
	transform expr ro ti
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
693
694
		= (expr, ti)

695
696
697
698
699
setExtendedVarInfo var_info_ptr extension var_heap
	# (old_var_info, var_heap) = readPtr var_info_ptr var_heap
	= case old_var_info of
		VI_Extended _ original_var_info	-> writePtr var_info_ptr (VI_Extended extension original_var_info) var_heap
		_								-> writePtr var_info_ptr (VI_Extended extension old_var_info) var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
700
701
702
neverMatchingCase = { case_expr = EE, case_guards = NoPattern, case_default = No, case_ident = No, case_info_ptr = nilPtr }

instance transform DynamicExpr where
703
704
	transform dyn=:{dyn_expr} ro ti
		# (dyn_expr, ti) = transform dyn_expr ro ti
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
705
706
707
		= ({dyn & dyn_expr = dyn_expr}, ti)

instance transform DynamicPattern where
708
709
	transform dp=:{dp_rhs} ro ti
		# (dp_rhs, ti) = transform dp_rhs ro ti
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
710
711
		= ({ dp & dp_rhs = dp_rhs }, ti)

712
713
714
715
unfold_state_to_ti us ti
	:== { ti & ti_var_heap = us.us_var_heap, ti_symbol_heap = us.us_symbol_heap, ti_cleanup_info=us.us_cleanup_info }

transformCase this_case=:{case_expr,case_guards,case_default,case_ident,case_info_ptr} ro ti
716
	| SwitchFusion False True
717
		= skip_over this_case ro ti
718
719
720
721
722
723
724
725
726
727
728
	# (case_info, ti_symbol_heap) = readPtr case_info_ptr ti.ti_symbol_heap
	  ti = { ti & ti_symbol_heap=ti_symbol_heap }
	  (result_expr, ti)	= case case_info of
							EI_Extended (EEI_ActiveCase aci) _
								| is_variable case_expr
									-> skip_over this_case ro ti
								-> case ro.ro_root_case_mode of
									NotRootCase	-> possibly_generate_case_function this_case aci ro ti
									_			-> transCase True (Yes aci) this_case ro ti
							_	-> transCase False No this_case ro ti
	  ti = { ti & ti_symbol_heap = remove_aci_free_vars_info case_info_ptr ti.ti_symbol_heap }
Martin Wierich's avatar
Martin Wierich committed
729
	= (removeNeverMatchingSubcases result_expr, ti)
730
  where
731
	skip_over this_case=:{case_expr,case_guards,case_default} ro ti
732
		# ro_lost_root = { ro & ro_root_case_mode = NotRootCase }
733
734
735
736
737
		  (new_case_expr, ti) = transform case_expr ro_lost_root ti
		  (new_case_guards, ti) = transform case_guards ro_lost_root ti
		  (new_case_default, ti) = transform case_default ro_lost_root ti
		= (Case { this_case & case_expr=new_case_expr, case_guards=new_case_guards, case_default=new_case_default }, ti)

738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
	is_variable (Var _) = True
	is_variable _ 		= False

	remove_aci_free_vars_info case_info_ptr ti_symbol_heap
		= app_EEI_ActiveCase (\aci->{aci & aci_free_vars = No }) case_info_ptr ti_symbol_heap

	transCase is_active opt_aci this_case=:{case_expr,case_guards,case_default,case_ident,case_info_ptr} ro ti
		| ti.ti_trace && (False--->("transCase",Case this_case))
			= undef
		= case case_expr of
			Case case_in_case
		  		| is_active
					-> lift_case case_in_case this_case ro ti
				-> skip_over this_case ro ti
			App app=:{app_symb,app_args}
				-> case app_symb.symb_kind of
					SK_Constructor cons_index
						| not is_active
Martin Wierich's avatar
Martin Wierich committed
756
							-> skip_over this_case ro ti // XXX currently only active cases are matched at runtime (multimatch problem)
757
758
759
760
761
762
763
764
765
766
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
						# algebraicPatterns = getAlgebraicPatterns case_guards
						  aci = case opt_aci of { Yes aci -> aci }
						  (may_be_match_expr, ti) = match_and_instantiate aci.aci_linearity_of_patterns cons_index app_args algebraicPatterns case_default ro ti
						-> case may_be_match_expr of
							Yes match_expr
								-> (match_expr, ti)
							No
								-> (Case neverMatchingCase, ti)
					// otherwise it's a function application
					_	-> case opt_aci of
							Yes aci=:{ aci_params, aci_opt_unfolder }
								-> case aci_opt_unfolder of
									No	-> skip_over this_case ro ti
									Yes unfolder
										| not (equal app_symb.symb_kind unfolder.symb_kind)
											// in this case a third function could be fused in
											-> skip_over this_case ro ti
										# variables = [ Var {var_name=fv_name, var_info_ptr=fv_info_ptr, var_expr_ptr=nilPtr}
														\\ {fv_name, fv_info_ptr} <- ro.ro_fun_args ]
										  (ti_next_fun_nr, ti) = ti!ti_next_fun_nr
										  (new_next_fun_nr, app_symb)
											= case ro.ro_root_case_mode of
													RootCaseOfZombie
														# (ro_fun=:{symb_kind=SK_GeneratedFunction fun_info_ptr _}) = ro.ro_fun
														-> (inc ti_next_fun_nr,
														    { ro_fun & symb_kind=SK_GeneratedFunction fun_info_ptr ti_next_fun_nr })
													RootCase
														-> (ti_next_fun_nr, ro.ro_fun)
										  ti = { ti & ti_next_fun_nr = new_next_fun_nr, ti_recursion_introduced = Yes ti_next_fun_nr }
										  app_args1 = replace_arg [ fv_info_ptr \\ {fv_info_ptr}<-aci_params ] app_args variables
										  (app_args2, ti) = transform app_args1 { ro & ro_root_case_mode = NotRootCase } ti
										-> (App {app_symb=app_symb, app_args=app_args2, app_info_ptr=nilPtr}, ti)
							No	-> skip_over this_case ro ti
			BasicExpr basic_value _
				| not is_active
Martin Wierich's avatar
Martin Wierich committed
792
					-> skip_over this_case ro ti // XXX currently only active cases are matched at runtime (multimatch problem)
793
794
795
796
797
798
799
				# basicPatterns = getBasicPatterns case_guards
				  may_be_match_pattern = dropWhile (\{bp_value} -> bp_value<>basic_value) basicPatterns
				| isEmpty may_be_match_pattern
					-> case case_default of
						Yes default_expr-> transform default_expr { ro & ro_root_case_mode = NotRootCase } ti
						No				-> (Case neverMatchingCase, ti)
				-> transform (hd may_be_match_pattern).bp_expr { ro & ro_root_case_mode = NotRootCase } ti
800
801
802
803
804
805
			Let lad
				| not is_active
					-> skip_over this_case ro ti
				# (new_let_binds, ti) = transform lad.let_binds { ro & ro_root_case_mode = NotRootCase } ti
				  (new_let_expr, ti) = transform (Case { this_case & case_expr = lad.let_expr }) ro ti
				-> (Let { lad & let_expr = new_let_expr, let_binds = new_let_binds }, ti)
806
807
808
809
810
811
812
813
		  	_	-> skip_over this_case ro ti
	where
		equal (SK_Function glob_index1) (SK_Function glob_index2)
			= glob_index1==glob_index2
		equal (SK_GeneratedFunction _ index1) (SK_GeneratedFunction _ index2)
			= index1==index2
		equal _ _
			= False
814
	
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
		replace_arg producer_vars=:[fv_info_ptr:_] act_pars form_pars=:[h_form_pars=:(Var {var_info_ptr}):t_form_pars]
			| fv_info_ptr<>var_info_ptr
				= [h_form_pars:replace_arg producer_vars act_pars t_form_pars]
			= replacement producer_vars act_pars form_pars
		  where
			replacement producer_vars [] form_pars
				= form_pars
			replacement producer_vars _ []
				= []
			replacement producer_vars [h_act_pars:t_act_pars] [form_par=:(Var {var_info_ptr}):form_pars]
				| isMember var_info_ptr producer_vars
					= [h_act_pars:replacement producer_vars t_act_pars form_pars]
				= replacement producer_vars t_act_pars form_pars
	
		getAlgebraicPatterns (AlgebraicPatterns _ algebraicPatterns)
			= algebraicPatterns
		getBasicPatterns (BasicPatterns _ basicPatterns)
			= basicPatterns
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
833
		
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
		lift_case nested_case=:{case_guards,case_default} outer_case ro ti
			# default_exists = case case_default of
								Yes _	-> True
								No		-> False
			  (case_guards, ti) = lift_patterns default_exists case_guards outer_case ro ti
			  (case_default, ti) = lift_default case_default outer_case ro ti
			  (EI_CaseType outer_case_type, ti_symbol_heap) = readExprInfo outer_case.case_info_ptr ti.ti_symbol_heap
			// the result type of the nested case becomes the result type of the outer case
			  ti_symbol_heap = overwrite_result_type nested_case.case_info_ptr outer_case_type.ct_result_type ti_symbol_heap
			// after this transformation the aci_free_vars information doesn't hold anymore
			  ti_symbol_heap = remove_aci_free_vars_info nested_case.case_info_ptr ti_symbol_heap
			  ti = { ti & ti_symbol_heap = ti_symbol_heap }
			= (Case {nested_case & case_guards = case_guards, case_default = case_default}, ti)
		  where
			overwrite_result_type case_info_ptr new_result_type ti_symbol_heap
				#! (EI_CaseType case_type, ti_symbol_heap)	= readExprInfo case_info_ptr ti_symbol_heap
				= writeExprInfo case_info_ptr (EI_CaseType { case_type & ct_result_type = new_result_type}) ti_symbol_heap
Martin Wierich's avatar
Martin Wierich committed
851

852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
		lift_patterns default_exists (AlgebraicPatterns type case_guards) outer_case ro ti
			# guard_exprs	= [ ap_expr \\ {ap_expr} <- case_guards ]
			# (guard_exprs_with_case, ti) = lift_patterns_2 default_exists guard_exprs outer_case ro ti
			= (AlgebraicPatterns type [ { case_guard & ap_expr=guard_expr } \\ case_guard<-case_guards & guard_expr<-guard_exprs_with_case], ti)
		lift_patterns default_exists (BasicPatterns basic_type case_guards) outer_case ro ti
			# guard_exprs	= [ bp_expr \\ {bp_expr} <- case_guards ]
			# (guard_exprs_with_case, ti) = lift_patterns_2 default_exists guard_exprs outer_case ro ti
			= (BasicPatterns basic_type [ { case_guard & bp_expr=guard_expr } \\ case_guard<-case_guards & guard_expr<-guard_exprs_with_case], ti)
	
		lift_patterns_2 False [guard_expr] outer_case ro ti
			// if no default pattern exists, then the outer case expression does not have to be copied for the last pattern
			# (guard_expr, ti) = transformCase {outer_case & case_expr = guard_expr} ro ti
			= ([guard_expr], ti)
		lift_patterns_2 default_exists [guard_expr : guard_exprs] outer_case ro ti
			# us = { us_var_heap = ti.ti_var_heap, us_symbol_heap = ti.ti_symbol_heap, us_opt_type_heaps = No,
					 us_cleanup_info=ti.ti_cleanup_info, us_subst_vars = False, us_handle_aci_free_vars = LeaveThem }
Martin Wierich's avatar
Martin Wierich committed
868
869
870
871
872
873
874
			  (outer_guards, us=:{us_cleanup_info}) = unfold outer_case.case_guards us
			  (expr_info, ti_symbol_heap) = readPtr outer_case.case_info_ptr us.us_symbol_heap
			  (new_info_ptr, ti_symbol_heap) = newPtr expr_info ti_symbol_heap
			  new_cleanup_info = case expr_info of {(EI_Extended _ _) -> [new_info_ptr:us_cleanup_info]; _ -> us_cleanup_info}
			  ti = { ti & ti_var_heap = us.us_var_heap, ti_symbol_heap = ti_symbol_heap, ti_cleanup_info=new_cleanup_info }
			  new_case = { outer_case & case_expr = guard_expr, case_guards=outer_guards, case_info_ptr=new_info_ptr }
			  (guard_expr, ti) = transformCase new_case ro ti
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
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
			  (guard_exprs, ti) = lift_patterns_2 default_exists guard_exprs outer_case ro ti
			= ([guard_expr : guard_exprs], ti)
		lift_patterns_2 _ [] _ _ ti
			= ([], ti)
			
		lift_default (Yes default_expr) outer_case ro ti
			# (default_expr, ti) = transformCase { outer_case & case_expr = default_expr } ro ti
			= (Yes default_expr, ti)
		lift_default No _ _ ti
			= (No, ti)
	
		match_and_instantiate [linearity:linearities] cons_index app_args 
								[{ap_symbol={glob_module,glob_object={ds_index}}, ap_vars, ap_expr} : guards] case_default ro ti
			| cons_index.glob_module == glob_module && cons_index.glob_object == ds_index
				# zipped = zip2 ap_vars app_args
				  linear_args = filterWith linearity zipped
				  not_linearity = map not linearity
				  non_linear_args = filterWith not_linearity zipped
				  ti_var_heap = foldSt (\({fv_info_ptr}, arg) -> writeVarInfo fv_info_ptr (VI_Expression arg)) linear_args ti.ti_var_heap
				  (new_expr, ti_symbol_heap) = possibly_add_let non_linear_args ap_expr not_linearity glob_module ds_index ro ti.ti_symbol_heap
//												True -> (ap_expr, ti.ti_symbol_heap)
//								(let_expr non_linear_args ap_expr ro.ro_common_defs.[glob_module].com_cons_defs.[glob_index])
				  unfold_state = { us_var_heap = ti_var_heap, us_symbol_heap = ti_symbol_heap, us_opt_type_heaps = No,
									us_cleanup_info=ti.ti_cleanup_info, us_subst_vars = True, us_handle_aci_free_vars = LeaveThem }
				  (unfolded_expr, unfold_state) = unfold new_expr unfold_state
				  (final_expr, ti) = transform unfolded_expr { ro & ro_root_case_mode = NotRootCase } (unfold_state_to_ti unfold_state ti)
				= (Yes final_expr, ti)
				= match_and_instantiate linearities cons_index app_args guards case_default ro ti
		  where
			filterWith [True:t2] [h1:t1]
				= [h1:filterWith t2 t1]
			filterWith [False:t2] [h1:t1]
				= filterWith t2 t1
			filterWith _ _
				= []
			
			possibly_add_let [] ap_expr _ _ _ _ ti_symbol_heap
				= (ap_expr, ti_symbol_heap)
			possibly_add_let non_linear_args ap_expr not_linearity glob_module glob_index ro ti_symbol_heap
				# {cons_type} = ro.ro_common_defs.[glob_module].com_cons_defs.[glob_index]
				  let_type = filterWith not_linearity cons_type.st_args
				  (new_info_ptr, ti_symbol_heap) = newPtr (EI_LetType let_type) ti_symbol_heap
				= ( Let	{	let_strict		= False
						,	let_binds		= [ {bind_src=bind_src, bind_dst=bind_dst} \\ (bind_dst,bind_src)<-non_linear_args]
						,	let_expr		= ap_expr
						,	let_info_ptr	= new_info_ptr
						}
				  , ti_symbol_heap
				  ) 

		match_and_instantiate [linearity:linearities] cons_index app_args [guard : guards] case_default ro ti
			= match_and_instantiate linearities cons_index app_args guards case_default ro ti
		match_and_instantiate _ cons_index app_args [] default_expr ro ti
			= transform default_expr { ro & ro_root_case_mode = NotRootCase } ti


possibly_generate_case_function kees=:{case_info_ptr} aci=:{aci_free_vars} ro ti=:{ti_recursion_introduced=old_ti_recursion_introduced}
//	| False->>("possibly_generate_case_function")
//		= undef
	# (free_vars, ti)
		 = case aci_free_vars of
			Yes free_vars
				-> (free_vars, ti)
			No	# fvi = { fvi_var_heap = ti.ti_var_heap, fvi_expr_heap = ti.ti_symbol_heap, fvi_variables = [],
						  fvi_expr_ptrs = ti.ti_cleanup_info }
				  {fvi_var_heap, fvi_expr_heap, fvi_variables, fvi_expr_ptrs} = freeVariables (Case kees) fvi
				  ti = { ti & ti_var_heap = fvi_var_heap, ti_symbol_heap = fvi_expr_heap, ti_cleanup_info = fvi_expr_ptrs }
				-> (fvi_variables, ti)
	  (outer_fun_def, outer_cons_args, ti_fun_defs, ti_fun_heap) = get_fun_def_and_cons_args ro.ro_fun.symb_kind ti.ti_cons_args ti.ti_fun_defs ti.ti_fun_heap
		// ti.ti_cons_args shared
	  outer_arguments = case outer_fun_def.fun_body of
946
947
							TransformedBody {tb_args} 	-> tb_args
							Expanding args				-> args
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
	  outer_info_ptrs = [ fv_info_ptr \\ {fv_info_ptr}<-outer_arguments]
	  free_var_info_ptrs = [ var_info_ptr \\ {var_info_ptr}<-free_vars ]
	  used_mask = [isMember fv_info_ptr free_var_info_ptrs \\ {fv_info_ptr}<-outer_arguments]
	  arguments_from_outer_fun = [ outer_argument \\ outer_argument<-outer_arguments & used<-used_mask | used ]
	  lifted_arguments = [ { fv_def_level = undeff, fv_name = var_name, fv_info_ptr = var_info_ptr, fv_count = undeff}
							\\ {var_name, var_info_ptr} <- free_vars | not (isMember var_info_ptr outer_info_ptrs)]
	  all_args = lifted_arguments++arguments_from_outer_fun
	  (fun_info_ptr, ti_fun_heap) = newPtr FI_Empty ti_fun_heap
	  fun_ident = { id_name = ro.ro_fun.symb_name.id_name+++"_case", id_info = nilPtr }
	  fun_symb = { symb_name = fun_ident, symb_kind=SK_GeneratedFunction fun_info_ptr undeff, symb_arity = length all_args }
	  new_ro = { ro & ro_root_case_mode = RootCaseOfZombie , ro_fun = fun_symb, ro_fun_args = all_args }
	  ti = { ti & ti_fun_defs = ti_fun_defs, ti_fun_heap = ti_fun_heap, ti_recursion_introduced = No }
	  (new_expr, ti) = transformCase kees new_ro ti
	  (ti_recursion_introduced, ti) = ti!ti_recursion_introduced
	= case ti_recursion_introduced of
		Yes fun_index
			-> generate_case_function old_ti_recursion_introduced fun_index case_info_ptr new_expr
										outer_fun_def outer_cons_args used_mask new_ro ti
		No	-> (new_expr, { ti & ti_recursion_introduced = old_ti_recursion_introduced })
  where
968
969
970
971
972
973
974
975
976
977
978

	get_fun_def_and_cons_args (SK_Function {glob_object}) cons_args fun_defs fun_heap
		# (fun_def, fun_defs) = fun_defs![glob_object]
		= (fun_def, cons_args.[glob_object], fun_defs, fun_heap)
	get_fun_def_and_cons_args (SK_GeneratedFunction fun_info_ptr fun_index) cons_args fun_defs fun_heap
		| fun_index < size fun_defs
			# (fun_def, fun_defs) = fun_defs![fun_index]
			= (fun_def, cons_args.[fun_index], fun_defs, fun_heap)
		# (FI_Function {gf_fun_def, gf_cons_args}, fun_heap) = readPtr fun_info_ptr fun_heap
		= (gf_fun_def, gf_cons_args, fun_defs, fun_heap)
/*
979
980
981
982
983
984
	get_fun_def_and_cons_args (SK_Function {glob_object}) cons_args fun_defs fun_heap
		# (fun_def, fun_defs) = fun_defs![glob_object]
		= (fun_def, cons_args.[glob_object], fun_defs, fun_heap)
	get_fun_def_and_cons_args (SK_GeneratedFunction fun_info_ptr _) cons_args fun_defs fun_heap
		# (FI_Function {gf_fun_def, gf_cons_args}, fun_heap) = readPtr fun_info_ptr fun_heap
		= (gf_fun_def, gf_cons_args, fun_defs, fun_heap)
985
*/
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
	generate_case_function old_ti_recursion_introduced fun_index case_info_ptr new_expr outer_fun_def outer_cons_args used_mask
						{ro_fun=ro_fun=:{symb_kind=SK_GeneratedFunction fun_info_ptr _}, ro_fun_args} ti
//		| False->>"generate_case_function"
//			= undef
		# fun_arity = length ro_fun_args
		  (Yes {st_vars,st_args,st_attr_vars}) = outer_fun_def.fun_type
		  types_from_outer_fun = [ st_arg \\ st_arg <- st_args & used <- used_mask | used ]
		  nr_of_lifted_vars = fun_arity-(length types_from_outer_fun)
		  (lifted_types, ti_var_heap) = mapSt get_type_of_local_var (take nr_of_lifted_vars ro_fun_args) ti.ti_var_heap
		  (EI_CaseType {ct_result_type}, ti_symbol_heap) = readExprInfo case_info_ptr ti.ti_symbol_heap 
		  (form_vars, ti_var_heap) = mapSt bind_to_fresh_var ro_fun_args ti_var_heap
		  arg_types = lifted_types++types_from_outer_fun
		  type_variables = getTypeVars [ct_result_type:arg_types]
		  {th_vars,th_attrs} = ti.ti_type_heaps
		  (fresh_type_vars, th_vars) = mapSt bind_to_fresh_type_var type_variables th_vars
For faster browsing, not all history is shown. View entire blame