trans.icl 165 KB
Newer Older
1
2
3
/*
	module owner: Diederik van Arkel
*/
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
4
5
6
7
implementation module trans

import StdEnv

8
import syntax, transform, checksupport, StdCompare, check, utilities, unitype, typesupport, type
9
import classify, partition
10

11
12
13
14
15
SwitchCaseFusion			fuse dont_fuse :== dont_fuse // fuse
SwitchGeneratedFusion		fuse dont_fuse :== fuse
SwitchFunctionFusion		fuse dont_fuse :== fuse
SwitchConstructorFusion		fuse dont_fuse :== dont_fuse // fuse
SwitchCurriedFusion			fuse dont_fuse :== fuse
16
SwitchTrivialFusion			fuse dont_fuse :== fuse
17
SwitchUnusedFusion			fuse dont_fuse :== fuse
18
SwitchTransformConstants	tran dont_tran :== dont_tran // can argue that if you want constant functions to be inlined you should define them as a macro
19
SwitchSpecialFusion			fuse dont_fuse :== fuse
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
20

21
22
(-!->) infix
(-!->) a b :== a // ---> b
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43

fromYes (Yes x) = x

is_SK_Function_or_SK_LocalMacroFunction (SK_Function _) = True
is_SK_Function_or_SK_LocalMacroFunction (SK_LocalMacroFunction _) = True
is_SK_Function_or_SK_LocalMacroFunction _ = False

undeff :== -1

empty_atype = { at_attribute = TA_Multi, at_type = TE }

get_producer_symbol (PR_Curried symbol arity)
	= (symbol,arity)
get_producer_symbol (PR_Function symbol arity _)
	= (symbol,arity)
get_producer_symbol (PR_GeneratedFunction symbol arity _)
	= (symbol,arity)
get_producer_symbol (PR_Constructor symbol arity _)
	= (symbol,arity)

// Extended variable info accessors...
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
44

45
46
47
48
49
50
51
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)

52
53
54
55
56
readExtendedVarInfo :: VarInfoPtr *VarHeap -> (ExtendedVarInfo, !*VarHeap)
readExtendedVarInfo var_info_ptr var_heap
	# (var_info, var_heap) = readPtr var_info_ptr var_heap
	= case var_info of
		VI_Extended extensions _	-> (extensions, var_heap)
Diederik van Arkel's avatar
Diederik van Arkel committed
57
		_							-> abort "sanity check 'readExtendedVarInfo' failed in module trans.\n"
58

59
60
61
62
63
64
65
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

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
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
setExtendedVarInfo :: !VarInfoPtr !ExtendedVarInfo !*VarHeap -> *VarHeap
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

// Extended expression info accessors...

readExprInfo :: !ExprInfoPtr !*ExpressionHeap -> (!ExprInfo,!*ExpressionHeap)
readExprInfo expr_info_ptr symbol_heap
	# (expr_info, symbol_heap) = readPtr expr_info_ptr symbol_heap
	= case expr_info of
		EI_Extended _ ei	-> (ei, symbol_heap)
		_					-> (expr_info, symbol_heap)

writeExprInfo :: !ExprInfoPtr !ExprInfo !*ExpressionHeap -> *ExpressionHeap
writeExprInfo expr_info_ptr new_expr_info symbol_heap
	# (expr_info, symbol_heap) = readPtr expr_info_ptr symbol_heap
	= case expr_info of
		EI_Extended extensions _	-> writePtr expr_info_ptr (EI_Extended extensions new_expr_info) symbol_heap
		_							-> writePtr expr_info_ptr new_expr_info symbol_heap

app_EEI_ActiveCase transformer expr_info_ptr expr_heap
	# (expr_info, expr_heap) = readPtr expr_info_ptr expr_heap
	= case expr_info of
		(EI_Extended (EEI_ActiveCase aci) original_expr_info)
			-> writePtr expr_info_ptr (EI_Extended (EEI_ActiveCase (transformer aci)) original_expr_info) expr_heap
		_	-> expr_heap

set_aci_free_vars_info_case unbound_variables case_info_ptr expr_heap
	= app_EEI_ActiveCase (\aci -> { aci & aci_free_vars=Yes unbound_variables }) case_info_ptr expr_heap

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

cleanup_attributes expr_info_ptr symbol_heap
	# (expr_info, symbol_heap) = readPtr expr_info_ptr symbol_heap
	= case expr_info of
		EI_Extended _ expr_info -> writePtr expr_info_ptr expr_info symbol_heap
		_ -> symbol_heap

/*
 *	TRANSFORM
 */

112
113
114
::	TransformInfo =
	{	ti_fun_defs				:: !.{# FunDef}
	,	ti_instances 			:: !.{! InstanceInfo }
115
	,	ti_cons_args 			:: !.{! ConsClasses}
116
	,	ti_new_functions 		:: ![FunctionInfoPtr]
117
118
119
120
	,	ti_fun_heap				:: !.FunctionHeap
	,	ti_var_heap				:: !.VarHeap
	,	ti_symbol_heap			:: !.ExpressionHeap
	,	ti_type_heaps			:: !.TypeHeaps
121
	,	ti_type_def_infos		:: !.TypeDefInfos
122
123
124
	,	ti_next_fun_nr			:: !Index
	,	ti_cleanup_info			:: !CleanupInfo
	,	ti_recursion_introduced	:: !Optional Index
125
//	,	ti_trace				:: !Bool // XXX just for tracing
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
126
127
	}

128
129
::	ReadOnlyTI = 
	{	ro_imported_funs	:: !{# {# FunType} }
130
	,	ro_common_defs		:: !{# CommonDefs }
131
132
133
134
135
136
137
138
139
140
// the following four are used when possibly generating functions for cases...
	,	ro_root_case_mode		:: !RootCaseMode
	,	ro_fun_root				:: !SymbIdent		// original function
	,	ro_fun_case				:: !SymbIdent		// original function or possibly generated case
	,	ro_fun_args				:: ![FreeVar]		// args of above

	,	ro_main_dcl_module_n 	:: !Int

	,	ro_transform_fusion		:: !Bool			// fusion switch

141
	,	ro_stdStrictLists_module_n :: !Int
142
143
	}

144
145
::	RootCaseMode = NotRootCase | RootCase | RootCaseOfZombie

146
147
148
149
150
151
neverMatchingCase = { case_expr = EE, case_guards = NoPattern, case_default = No, case_ident = No, case_info_ptr = nilPtr, 
// RWS ...
						case_explicit = False,
// ... RWS
						case_default_pos = NoPos }

152
class transform a :: !a !ReadOnlyTI !*TransformInfo -> (!a, !*TransformInfo)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
153
154
155

instance transform Expression
where
156
157
158
159
160
161
	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
162
163
		= case expr of
			App app
164
				-> transformApplication app exprs ro ti
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
165
166
			_
				-> (expr @ exprs, ti)
Sjaak Smetsers's avatar
Sjaak Smetsers committed
167
	transform (Let lad=:{let_strict_binds, let_lazy_binds, let_expr}) ro ti
168
		# ti = store_type_info_of_bindings_in_heap lad ti
Sjaak Smetsers's avatar
Sjaak Smetsers committed
169
170
		  (let_strict_binds, ti) = transform let_strict_binds ro ti
		  (let_lazy_binds, ti) = transform let_lazy_binds ro ti
171
		  (let_expr, ti) = transform let_expr ro ti
Sjaak Smetsers's avatar
Sjaak Smetsers committed
172
		= (Let { lad & let_lazy_binds = let_lazy_binds, let_strict_binds = let_strict_binds, let_expr = let_expr}, ti)
173
	  where
Sjaak Smetsers's avatar
Sjaak Smetsers committed
174
175
		store_type_info_of_bindings_in_heap {let_strict_binds, let_lazy_binds,let_info_ptr} ti
			# let_binds = let_strict_binds ++ let_lazy_binds
176
			# (EI_LetType var_types, ti_symbol_heap) = readExprInfo let_info_ptr ti.ti_symbol_heap
Diederik van Arkel's avatar
Diederik van Arkel committed
177
			  ti_var_heap								= foldSt store_type_info_let_bind
178
179
								   (zip2 var_types let_binds) ti.ti_var_heap
			= { ti & ti_symbol_heap = ti_symbol_heap, ti_var_heap = ti_var_heap }
Diederik van Arkel's avatar
Diederik van Arkel committed
180
181
182
		store_type_info_let_bind (var_type, {lb_dst={fv_info_ptr}}) var_heap
			= setExtendedVarInfo fv_info_ptr (EVI_VarType var_type) var_heap

183
184
185
186
187
188
189
	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
Diederik van Arkel's avatar
Diederik van Arkel committed
190
191
					# (EI_CaseType {ct_cons_types},ti_symbol_heap)
										= readExprInfo case_info_ptr ti.ti_symbol_heap
192
193
194
195
					  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
196
				OverloadedListPatterns _ _ patterns
Diederik van Arkel's avatar
Diederik van Arkel committed
197
198
					# (EI_CaseType {ct_cons_types},ti_symbol_heap)
										= readExprInfo case_info_ptr ti.ti_symbol_heap
199
200
					  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 }
201
202
203
				NoPattern
					-> ti
		store_type_info_of_alg_pattern (var_types,{ap_vars}) var_heap
Diederik van Arkel's avatar
Diederik van Arkel committed
204
205
206
207
			= foldSt store_type_info_of_pattern_var (zip2 var_types ap_vars) var_heap
		store_type_info_of_pattern_var (var_type, {fv_info_ptr}) var_heap
			= setExtendedVarInfo fv_info_ptr (EVI_VarType var_type) var_heap

208
209
	transform (Selection opt_type expr selectors) ro ti
		# (expr, ti) = transform expr ro ti
210
		= transformSelection opt_type selectors expr ro ti
211
212
	transform (Update expr1 selectors expr2) ro ti
		# (expr1,ti) = transform expr1 ro ti
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
		# (selectors,ti) = transform_expressions_in_selectors selectors ti
			with
				transform_expressions_in_selectors [selection=:RecordSelection _ _ : selections] ti
					# (selections,ti) = transform_expressions_in_selectors selections ti
					= ([selection:selections],ti)
				transform_expressions_in_selectors [ArraySelection ds ep expr : selections] ti
					# (expr,ti) = transform expr ro ti
					# (selections,ti) = transform_expressions_in_selectors selections ti
					= ([ArraySelection ds ep expr:selections],ti)
				transform_expressions_in_selectors [DictionarySelection bv dictionary_selections ep expr : selections] ti
					# (expr,ti) = transform expr ro ti
					# (dictionary_selections,ti) = transform_expressions_in_selectors dictionary_selections ti
					# (selections,ti) = transform_expressions_in_selectors selections ti
					= ([DictionarySelection bv dictionary_selections ep expr:selections],ti)
				transform_expressions_in_selectors [] ti
					= ([],ti)
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
		# (expr2,ti) = transform expr2 ro ti
		= (Update expr1 selectors expr2,ti)
	transform (RecordUpdate cons_symbol expr exprs) ro ti
		# (expr,ti) = transform expr ro ti
		# (exprs,ti) = transform_fields exprs ro ti
		=(RecordUpdate cons_symbol expr exprs,ti)
	where	
		transform_fields [] ro ti
			= ([],ti)
		transform_fields [bind=:{bind_src} : fields] ro ti
			# (bind_src,ti) = transform bind_src ro ti
			# (fields,ti) = transform_fields fields ro ti
			= ([{bind & bind_src=bind_src} : fields],ti)
	transform (TupleSelect a1 arg_nr expr) ro ti
		# (expr,ti) = transform expr ro ti
		= (TupleSelect a1 arg_nr expr,ti)
245
	transform (MatchExpr a1 expr) ro ti
246
		# (expr,ti) = transform expr ro ti
247
		= (MatchExpr a1 expr,ti)
248
249
	transform (DynamicExpr dynamic_expr) ro ti
		# (dynamic_expr, ti) = transform dynamic_expr ro ti
250
		= (DynamicExpr dynamic_expr, ti)	
251
	transform expr ro ti
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
252
253
254
		= (expr, ti)

instance transform DynamicExpr where
255
256
	transform dyn=:{dyn_expr} ro ti
		# (dyn_expr, ti) = transform dyn_expr ro ti
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
257
258
		= ({dyn & dyn_expr = dyn_expr}, ti)

259
transformCase this_case=:{case_expr,case_guards,case_default,case_ident,case_info_ptr} ro ti
Diederik van Arkel's avatar
Diederik van Arkel committed
260
261
262
	| SwitchCaseFusion (not ro.ro_transform_fusion) True
		= skip_over this_case ro ti
	| isNilPtr case_info_ptr			// encountered neverMatchingCase?!
263
		= skip_over this_case ro ti
264
265
266
267
268
269
270
271
272
273
274
	# (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
275
	= (removeNeverMatchingSubcases result_expr, ti)
Diederik van Arkel's avatar
Diederik van Arkel committed
276
where
277
278
279
	is_variable (Var _) = True
	is_variable _ 		= False

Diederik van Arkel's avatar
Diederik van Arkel committed
280
281
282
283
284
285
skip_over this_case=:{case_expr,case_guards,case_default} ro ti
	# ro_lost_root = { ro & ro_root_case_mode = NotRootCase }
	  (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)
286

Diederik van Arkel's avatar
Diederik van Arkel committed
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
transCase is_active opt_aci this_case=:{case_expr = Case case_in_case} ro ti
	| is_active
		= lift_case case_in_case this_case ro ti
		= skip_over this_case ro ti
where
	lift_case nested_case=:{case_guards,case_default} outer_case ro ti
		| isNilPtr nested_case.case_info_ptr	// neverMatchingCase ?!
			= skip_over 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

	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 default_exists (OverloadedListPatterns type decons_expr 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
		= (OverloadedListPatterns type decons_expr [ { case_guard & ap_expr=guard_expr } \\ case_guard<-case_guards & guard_expr<-guard_exprs_with_case], ti)
	lift_patterns _ _ _ _ _
		= abort "lift_patterns does not match"

	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_local_macro_functions = No }
334
		  ui = {ui_handle_aci_free_vars = LeaveThem }
Diederik van Arkel's avatar
Diederik van Arkel committed
335
336
337
338
339
340
341
342
343
344
345
346
347
348
		  (outer_guards, us=:{us_cleanup_info})	= unfold outer_case.case_guards ui 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
		  (guard_exprs, ti) = lift_patterns_2 default_exists guard_exprs outer_case ro ti
		= ([guard_expr : guard_exprs], ti)
	lift_patterns_2 _ [] _ _ ti
		= ([], ti)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
349
		
Diederik van Arkel's avatar
Diederik van Arkel committed
350
351
352
353
354
355
356
357
358
359
360
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
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
	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)

transCase is_active opt_aci this_case=:{case_expr = (App app=:{app_symb,app_args}),case_guards,case_default,case_explicit} ro ti
	= case app_symb.symb_kind of
		SK_Constructor cons_index
			| not is_active
				-> skip_over this_case ro ti // XXX currently only active cases are matched at runtime (multimatch problem)
			# 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									//---> ("transCase","No opt unfolder")
						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								//---> ("transCase","Diff opt unfolder",app_symb,unfolder)
							# 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						//---> ("transCase","Yes opt unfolder")
							  (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_case
											-> (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_root)
							  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
where
	equal (SK_Function glob_index1) (SK_Function glob_index2)
		= glob_index1==glob_index2
	equal (SK_LocalMacroFunction glob_index1) (SK_LocalMacroFunction glob_index2)
		= glob_index1==glob_index2
	equal (SK_GeneratedFunction _ index1) (SK_GeneratedFunction _ index2)
		= index1==index2
	equal _ _
		= False

	replace_arg [] _ f
		= f
	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
	getAlgebraicPatterns (OverloadedListPatterns _ _ algebraicPatterns)
		= algebraicPatterns

	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
			  {cons_type} = ro.ro_common_defs.[glob_module].com_cons_defs.[ds_index]
			  unfoldables = [ ((not (arg_is_strict i cons_type.st_args_strictness)) && linear) || in_normal_form app_arg \\ linear <- linearity & app_arg <- app_args & i <- [0..]]
			  unfoldable_args = filterWith unfoldables zipped
			  not_unfoldable = map not unfoldables
			  non_unfoldable_args = filterWith not_unfoldable zipped
			  ti_var_heap = foldSt (\({fv_info_ptr}, arg) -> writeVarInfo fv_info_ptr (VI_Expression arg)) unfoldable_args ti.ti_var_heap
			  (new_expr, ti_symbol_heap) = possibly_add_let non_unfoldable_args ap_expr not_unfoldable glob_module ds_index ro ti.ti_symbol_heap
			  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_local_macro_functions = No }
440
			  ui= {ui_handle_aci_free_vars = LeaveThem }
Diederik van Arkel's avatar
Diederik van Arkel committed
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
			  (unfolded_expr, unfold_state) = unfold new_expr ui unfold_state
			  (final_expr, ti) = transform unfolded_expr
			  						{ ro & ro_root_case_mode = NotRootCase }
			  						{ ti & ti_var_heap = unfold_state.us_var_heap, ti_symbol_heap = unfold_state.us_symbol_heap,ti_cleanup_info=unfold_state.us_cleanup_info }
			= (Yes final_expr, ti)
		= match_and_instantiate linearities cons_index app_args guards case_default ro ti
	  where
	  	in_normal_form (Var _)			= True
	  	in_normal_form (BasicExpr _)	= True
	  	in_normal_form _				= False
	  	
		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_unfoldable_args ap_expr not_unfoldable 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_unfoldable cons_type.st_args
			  (new_info_ptr, ti_symbol_heap) = newPtr (EI_LetType let_type) ti_symbol_heap
465
/* DvA... STRICT_LET
Diederik van Arkel's avatar
Diederik van Arkel committed
466
467
468
469
470
471
472
473
			= ( Let	{	let_strict_binds	= [ {lb_src=lb_src, lb_dst=lb_dst, lb_position = NoPos}
												\\ (lb_dst,lb_src)<-non_unfoldable_args
												& type <- let_type | type.at_annotation == AN_Strict
												]
					,	let_lazy_binds		= [ {lb_src=lb_src, lb_dst=lb_dst, lb_position = NoPos}
												\\ (lb_dst,lb_src)<-non_unfoldable_args
												& type <- let_type | type.at_annotation == AN_None
												]
474
...DvA */
Diederik van Arkel's avatar
Diederik van Arkel committed
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
			= ( Let	{	let_strict_binds	= []
					,	let_lazy_binds		= [ {lb_src=lb_src, lb_dst=lb_dst, lb_position = NoPos}
												\\ (lb_dst,lb_src)<-non_unfoldable_args]
					,	let_expr			= ap_expr
					,	let_info_ptr		= new_info_ptr
					,	let_expr_position	= NoPos
					}
			  , 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

transCase is_active opt_aci this_case=:{case_expr = (BasicExpr basic_value),case_guards,case_default} ro ti
	| not is_active
		= skip_over this_case ro ti // XXX currently only active cases are matched at runtime (multimatch problem)
	# 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
where
	getBasicPatterns (BasicPatterns _ basicPatterns)
		= basicPatterns
503

Diederik van Arkel's avatar
Diederik van Arkel committed
504
505
506
507
508
509
510
511
512
513
514
515
transCase is_active opt_aci this_case=:{case_expr = (Let lad)} ro ti
	| not is_active
		= skip_over this_case ro ti
	# ro_not_root = { ro & ro_root_case_mode = NotRootCase }
	  (new_let_strict_binds, ti) = transform lad.let_strict_binds ro_not_root ti
	  (new_let_lazy_binds, ti) = transform lad.let_lazy_binds ro_not_root ti
	  (new_let_expr, ti) = transform (Case { this_case & case_expr = lad.let_expr }) ro ti
	= (Let { lad & let_expr = new_let_expr, let_strict_binds = new_let_strict_binds, let_lazy_binds = new_let_lazy_binds }, ti)

transCase is_active opt_aci this_case ro ti
	= skip_over this_case ro ti
	
516
possibly_generate_case_function :: !Case !ActiveCaseInfo !ReadOnlyTI !*TransformInfo -> *(!Expression, !*TransformInfo)
517
possibly_generate_case_function kees=:{case_info_ptr} aci=:{aci_free_vars} ro ti=:{ti_recursion_introduced=old_ti_recursion_introduced}
518
519
//	| False -!-> ("possibly_generate_case_function",ro.ro_fun_root.symb_name.id_name,ro.ro_fun_case.symb_name.id_name,ro.ro_root_case_mode)
//		= undef
520
	// determine free variables
521
522
523
524
	# (free_vars, ti)
		 = case aci_free_vars of
			Yes free_vars
				-> (free_vars, ti)
525
			No	# fvi	= { fvi_var_heap = ti.ti_var_heap, fvi_expr_heap = ti.ti_symbol_heap, fvi_variables = [],
526
						  fvi_expr_ptrs = ti.ti_cleanup_info }
527
528
529
				  {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 }
530
				-> (fvi_variables, ti)
531
532
533
534
535
	// search function definition and consumer arguments
	  (outer_fun_def, outer_cons_args, ti_cons_args, ti_fun_defs, ti_fun_heap)
	  		= get_fun_def_and_cons_args ro.ro_fun_root.symb_kind ti.ti_cons_args ti.ti_fun_defs ti.ti_fun_heap
	  outer_arguments
	  		= case outer_fun_def.fun_body of
536
537
							TransformedBody {tb_args} 	-> tb_args
							Expanding args				-> args
538
539
540
541
542
543
544
545
546
547
	  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}
548
							\\ {var_name, var_info_ptr} <- free_vars | not (isMember var_info_ptr outer_info_ptrs)]
549
550
551
552
553
554
555
	  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_root.symb_name.id_name+++"_case", id_info = nilPtr }
	  fun_symb
556
	  		= { symb_name = fun_ident, symb_kind=SK_GeneratedFunction fun_info_ptr undeff }
557
558
559
560
561
562
563
564
565
	  new_ro
	  		= { ro & ro_root_case_mode = RootCaseOfZombie , ro_fun_case = fun_symb, ro_fun_args = all_args }
	  ti
	  		= { ti & ti_cons_args = ti_cons_args, 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
	  ti	= { ti & ti_recursion_introduced = old_ti_recursion_introduced }
566
567
	= case ti_recursion_introduced of
		Yes fun_index
568
			-> generate_case_function fun_index case_info_ptr new_expr outer_fun_def outer_cons_args used_mask new_ro ti
569
		No	-> (new_expr, ti)
570

571
572
573
generate_case_function :: !Int !ExprInfoPtr !Expression FunDef .ConsClasses [.Bool] !.ReadOnlyTI !*TransformInfo -> (!Expression,!*TransformInfo)
generate_case_function fun_index case_info_ptr new_expr outer_fun_def outer_cons_args used_mask
					{ro_fun_case=ro_fun=:{symb_kind=SK_GeneratedFunction fun_info_ptr _}, ro_fun_args} ti
574
//	| False -!-> ("generate_case_function",ro_fun.symb_name)		= undef
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
	# 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_expr_var ro_fun_args ti_var_heap

	  arg_types								= lifted_types++types_from_outer_fun

	# {ti_type_heaps}						= ti
	  {th_vars}								= ti_type_heaps
	  (type_variables, th_vars)				= getTypeVars [ct_result_type:arg_types] th_vars
	  (fresh_type_vars, th_vars)			= mapSt bind_to_fresh_type_variable type_variables th_vars
	  ti_type_heaps							= { ti_type_heaps & th_vars = th_vars }

	  (_, fresh_arg_types, ti_type_heaps)	= substitute arg_types ti_type_heaps
	  (_, fresh_result_type, ti_type_heaps)	= substitute ct_result_type ti_type_heaps

	  // unfold...
	  us =		{ us_var_heap				= ti_var_heap
	  			, us_symbol_heap			= ti_symbol_heap
	  			, us_opt_type_heaps			= Yes ti_type_heaps
	  			, us_cleanup_info			= ti.ti_cleanup_info
	  			, us_local_macro_functions	= No 
	  			}
	  ui =
	  			{ ui_handle_aci_free_vars	= SubstituteThem
	  			}
	  (copied_expr, us)
			= unfold new_expr ui us
	  {us_var_heap=ti_var_heap, us_symbol_heap=ti_symbol_heap, us_cleanup_info=ti_cleanup_info, us_opt_type_heaps = Yes ti_type_heaps}
	  		= us
	  // generated function...
	  fun_type =
	  			{ st_vars					= fresh_type_vars
	  			, st_args					= fresh_arg_types
	  			, st_arity					= fun_arity
	  			, st_args_strictness		= NotStrict
	  			, st_result					= fresh_result_type
	  			, st_context				= []
	  			, st_attr_vars				= []
	  			, st_attr_env				= []
	  			}
	  fun_def =	{ fun_symb					= ro_fun.symb_name
				, fun_arity					= fun_arity
				, fun_priority				= NoPrio
				, fun_body					= TransformedBody { tb_args = form_vars, tb_rhs = copied_expr}
				, fun_type					= Yes fun_type
				, fun_pos					= NoPos
				, fun_kind					= FK_Function cNameNotLocationDependent
				, fun_lifted				= undeff
				, fun_info = 	{	fi_calls		= []
								,	fi_group_index	= outer_fun_def.fun_info.fi_group_index
								,	fi_def_level	= NotALevel
								,	fi_free_vars	= []
								,	fi_local_vars	= []
								,	fi_dynamics		= []
633
// Sjaak: 							,	fi_is_macro_fun = outer_fun_def.fun_info.fi_is_macro_fun
634
635
636
637
638
639
640
								,	fi_properties	= outer_fun_def.fun_info.fi_properties
								}	
				}
	# cc_args_from_outer_fun		= [ cons_arg \\ cons_arg <- outer_cons_args.cc_args & used <- used_mask | used ]
	  cc_linear_bits_from_outer_fun	= [ cons_arg \\ cons_arg <- outer_cons_args.cc_linear_bits & used <- used_mask | used ]
	  new_cons_args =
	  			{ cc_size			= fun_arity
641
	  			, cc_args			= repeatn nr_of_lifted_vars CPassive ++ cc_args_from_outer_fun
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
	  			, cc_linear_bits	= repeatn nr_of_lifted_vars    False ++ cc_linear_bits_from_outer_fun
	  			, cc_producer		= False
	  			}
	  gf =
	  			{ gf_fun_def		= fun_def
	  			, gf_instance_info	= II_Empty
	  			, gf_cons_args		= new_cons_args
	  			, gf_fun_index		= fun_index
	  			}
	  ti_fun_heap = writePtr fun_info_ptr (FI_Function gf) ti.ti_fun_heap
	  ti =
	  			{ ti 
	  			& ti_new_functions	= [fun_info_ptr:ti.ti_new_functions]
	  			, ti_var_heap		= ti_var_heap
	  			, ti_fun_heap		= ti_fun_heap
	  			, ti_symbol_heap	= ti_symbol_heap
	  			, ti_type_heaps		= ti_type_heaps
	  			, ti_cleanup_info	= ti_cleanup_info 
	  			}
	  app_symb = { ro_fun & symb_kind = SK_GeneratedFunction fun_info_ptr fun_index}
	  app_args = map free_var_to_bound_var ro_fun_args
	= ( App {app_symb = app_symb, app_args = app_args, app_info_ptr = nilPtr}, ti)
where
	get_type_of_local_var {fv_info_ptr} var_heap
		# (EVI_VarType a_type, var_heap)	= readExtendedVarInfo fv_info_ptr var_heap
		= (a_type, var_heap)
	free_var_to_bound_var {fv_name, fv_info_ptr}
		= Var { var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = nilPtr}
670

671
removeNeverMatchingSubcases :: Expression -> Expression
Martin Wierich's avatar
Martin Wierich committed
672
673
674
675
676
677
678
679
removeNeverMatchingSubcases keesExpr=:(Case kees)
	// remove those case guards whose right hand side is a never matching case
	| is_never_matching_case keesExpr
		= keesExpr
	# {case_guards, case_default} = kees
	  filtered_default = get_filtered_default case_default
	= case case_guards of
		AlgebraicPatterns i alg_patterns
680
			| not (any (is_never_matching_case o get_alg_rhs) alg_patterns) && not (is_never_matching_default case_default)
681
				-> keesExpr // frequent case: all subexpressions can't fail
Martin Wierich's avatar
Martin Wierich committed
682
683
684
685
686
687
688
			# filtered_case_guards = filter (not o is_never_matching_case o get_alg_rhs) alg_patterns
			| has_become_never_matching filtered_default filtered_case_guards
				-> Case neverMatchingCase
			| is_default_only filtered_default filtered_case_guards
				-> fromYes case_default
			-> Case {kees & case_guards = AlgebraicPatterns i filtered_case_guards, case_default = filtered_default }
		BasicPatterns bt basic_patterns
689
			| not (any (is_never_matching_case o get_basic_rhs) basic_patterns) && not (is_never_matching_default case_default)
690
				-> keesExpr // frequent case: all subexpressions can't fail
Martin Wierich's avatar
Martin Wierich committed
691
692
693
694
695
696
			# filtered_case_guards = filter (not o is_never_matching_case o get_basic_rhs) basic_patterns
			| has_become_never_matching filtered_default filtered_case_guards
				-> Case neverMatchingCase
			| is_default_only filtered_default filtered_case_guards
				-> fromYes case_default
			-> Case {kees & case_guards = BasicPatterns bt filtered_case_guards, case_default = filtered_default }
697
698
699
700
701
702
703
704
705
		OverloadedListPatterns i decons_expr alg_patterns
			| not (any (is_never_matching_case o get_alg_rhs) alg_patterns) && not (is_never_matching_default case_default)
				-> keesExpr // frequent case: all subexpressions can't fail
			# filtered_case_guards = filter (not o is_never_matching_case o get_alg_rhs) alg_patterns
			| has_become_never_matching filtered_default filtered_case_guards
				-> Case neverMatchingCase
			| is_default_only filtered_default filtered_case_guards
				-> fromYes case_default
			-> Case {kees & case_guards = OverloadedListPatterns i decons_expr filtered_case_guards, case_default = filtered_default }
Diederik van Arkel's avatar
Diederik van Arkel committed
706
		_	-> abort "removeNeverMatchingSubcases does not match"
707
where
Martin Wierich's avatar
Martin Wierich committed
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
	get_filtered_default y=:(Yes c_default)
		| is_never_matching_case c_default
			= No
		= y
	get_filtered_default no
		= no
	has_become_never_matching No [] = True
	has_become_never_matching _ _ = False
	is_default_only (Yes _) [] = True
	is_default_only _ _ = False
	is_never_matching_case (Case {case_guards = NoPattern, case_default = No })
		= True
	is_never_matching_case _
		= False
	get_alg_rhs {ap_expr} = ap_expr
	get_basic_rhs {bp_expr} = bp_expr
724
725
726
727
	is_never_matching_default No
		= False
	is_never_matching_default (Yes expr)
		= is_never_matching_case expr
Martin Wierich's avatar
Martin Wierich committed
728
729
730
731
removeNeverMatchingSubcases expr
	= expr

	
732
instance transform LetBind
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
733
where
734
735
736
	transform bind=:{lb_src} ro ti
		# (lb_src, ti) = transform lb_src ro ti
		= ({ bind & lb_src = lb_src }, ti)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
737
738
739

instance transform BasicPattern
where
740
741
	transform pattern=:{bp_expr} ro ti
		# (bp_expr, ti) = transform bp_expr ro ti
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
742
743
744
745
		= ({ pattern & bp_expr = bp_expr }, ti)

instance transform AlgebraicPattern
where
746
747
	transform pattern=:{ap_expr} ro ti
		# (ap_expr, ti) = transform ap_expr ro ti
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
748
749
750
751
		= ({ pattern & ap_expr = ap_expr }, ti)

instance transform CasePatterns
where
752
753
	transform (AlgebraicPatterns type patterns) ro ti
		# (patterns, ti) = transform patterns ro ti
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
754
		= (AlgebraicPatterns type patterns, ti)
755
756
	transform (BasicPatterns type patterns) ro ti
		# (patterns, ti) = transform patterns ro ti
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
757
		= (BasicPatterns type patterns, ti)
758
759
760
761
762
763
764
765
	transform (OverloadedListPatterns type=:(OverloadedList _ _ _ _) decons_expr patterns) ro ti
		# (patterns, ti) = transform patterns ro ti
		# (decons_expr, ti) = transform decons_expr ro ti
		= (OverloadedListPatterns type decons_expr patterns, ti)
	transform (OverloadedListPatterns type decons_expr patterns) ro ti
		# (patterns, ti) = transform patterns ro ti
		# (decons_expr, ti) = transform decons_expr ro ti
		= (OverloadedListPatterns type decons_expr patterns, ti)
Diederik van Arkel's avatar
Diederik van Arkel committed
766
767
768
769
	transform NoPattern ro ti
		= (NoPattern, ti)
	transform _ ro ti
		= abort "transform CasePatterns does not match"
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
770

771
instance transform (Optional a) | transform a
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
772
where
773
774
	transform (Yes x) ro ti
		# (x, ti) = transform x ro ti
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
775
		= (Yes x, ti)
776
	transform no ro ti
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
777
778
779
780
		= (no, ti)

instance transform [a] | transform a
where
781
782
783
	transform [x : xs]  ro ti
		# (x, ti) = transform x ro ti
		  (xs, ti) = transform xs ro ti
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
784
		= ([x : xs], ti)
785
	transform [] ro ti
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
786
787
		= ([], ti)

788
789
790
791
792
//@ tryToFindInstance: 

cIsANewFunction		:== True
cIsNotANewFunction	:== False

793
tryToFindInstance :: !{! Producer} !InstanceInfo !*(Heap FunctionInfo) -> *(!Bool, !FunctionInfoPtr, !InstanceInfo, !.FunctionHeap)
794
795
796
797
tryToFindInstance new_prods II_Empty fun_heap
	# (fun_def_ptr, fun_heap) = newPtr FI_Empty fun_heap
	= (cIsANewFunction, fun_def_ptr, II_Node new_prods fun_def_ptr II_Empty II_Empty, fun_heap)
tryToFindInstance new_prods instances=:(II_Node prods fun_def_ptr left right) fun_heap
798
799
800
801
802
803
	| size new_prods > size prods
		# (is_new, new_fun_def_ptr, right, fun_heap) = tryToFindInstance new_prods right fun_heap
		= (is_new, new_fun_def_ptr, II_Node prods fun_def_ptr left right, fun_heap)
	| size new_prods < size prods
		# (is_new, new_fun_def_ptr, left, fun_heap) = tryToFindInstance new_prods left fun_heap
		= (is_new, new_fun_def_ptr, II_Node prods fun_def_ptr left right, fun_heap)
804
805
806
807
808
809
810
811
812
	# cmp = compareProducers new_prods prods
	| cmp == Equal
		= (cIsNotANewFunction, fun_def_ptr, instances, fun_heap)
	| cmp == Greater
		# (is_new, new_fun_def_ptr, right, fun_heap) = tryToFindInstance new_prods right fun_heap
		= (is_new, new_fun_def_ptr, II_Node prods fun_def_ptr left right, fun_heap)
		# (is_new, new_fun_def_ptr, left, fun_heap) = tryToFindInstance new_prods left fun_heap
		= (is_new, new_fun_def_ptr, II_Node prods fun_def_ptr left right, fun_heap)

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
813
814
815
816
817
818
819
compareProducers prods1 prods2
	#! nr_of_prods = size prods1
	= compare_producers 0 nr_of_prods prods1 prods2
where
	compare_producers prod_index nr_of_prods prods1 prods2
		| prod_index == nr_of_prods
			= Equal
820
821
822
823
		# cmp = prods1.[prod_index] =< prods2.[prod_index]
		| cmp == Equal
			= compare_producers (inc prod_index) nr_of_prods prods1 prods2
		= cmp
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
824
825
826
827
828
829
830
831
832
833

instance =< Producer
where
	(=<) pr1 pr2
		| equal_constructor pr1 pr2
			= compare_constructor_arguments  pr1 pr2
		| less_constructor pr1 pr2
			= Smaller
			= Greater
	where
834
		compare_constructor_arguments (PR_Function _ _ index1) (PR_Function _ _ index2)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
835
			= index1 =< index2
836
		compare_constructor_arguments (PR_GeneratedFunction _ _ index1) (PR_GeneratedFunction _ _ index2)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
837
			= index1 =< index2
Martin Wierich's avatar
Martin Wierich committed
838
839
		compare_constructor_arguments 	(PR_Class app1 lifted_vars_with_types1 t1) 
										(PR_Class app2 lifted_vars_with_types2 t2) 
840
//			= app1.app_args =< app2.app_args
Martin Wierich's avatar
Martin Wierich committed
841
842
843
844
			# cmp = smallerOrEqual t1 t2
			| cmp<>Equal
				= cmp
			= compare_types lifted_vars_with_types1 lifted_vars_with_types2
845
		compare_constructor_arguments (PR_Curried symb_ident1 _) (PR_Curried symb_ident2 _)
846
847
			= symb_ident1 =< symb_ident2
		compare_constructor_arguments PR_Empty PR_Empty
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
848
			= Equal
849
850
		compare_constructor_arguments PR_Unused PR_Unused
			= Equal
851
		compare_constructor_arguments (PR_Constructor symb_ident1 _ _) (PR_Constructor symb_ident2 _ _)
852
			= symb_ident1 =< symb_ident2
Martin Wierich's avatar
Martin Wierich committed
853
854
855
856
857
858
859
860
861
862
			
		compare_types [(_, type1):types1] [(_, type2):types2]
			# cmp = smallerOrEqual type1 type2
			| cmp<>Equal
				= cmp
			= compare_types types1 types2
		compare_types [] [] = Equal
		compare_types [] _ = Smaller
		compare_types _ [] = Greater
		
863
864
865
/*
 *	UNIQUENESS STUFF...
 */
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
866

867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
create_fresh_type_vars :: !Int !*TypeVarHeap -> (!{!TypeVar}, !*TypeVarHeap)
create_fresh_type_vars nr_of_all_type_vars th_vars
	# fresh_array = createArray  nr_of_all_type_vars {tv_name = {id_name="",id_info=nilPtr}, tv_info_ptr=nilPtr}
	= iFoldSt allocate_fresh_type_var 0 nr_of_all_type_vars (fresh_array,th_vars)
where
	allocate_fresh_type_var i (array, th_vars)
		# (new_tv_info_ptr, th_vars) = newPtr TVI_Empty th_vars
		  tv = { tv_name = { id_name = "a"+++toString i, id_info = nilPtr }, tv_info_ptr=new_tv_info_ptr }
		= ({array & [i] = tv}, th_vars)

create_fresh_attr_vars :: !{!CoercionTree} !Int !*AttrVarHeap -> (!{!TypeAttribute}, !.AttrVarHeap)
create_fresh_attr_vars demanded nr_of_attr_vars th_attrs
	# fresh_array = createArray nr_of_attr_vars TA_None
	= iFoldSt (allocate_fresh_attr_var demanded) 0 nr_of_attr_vars (fresh_array, th_attrs)
where
	allocate_fresh_attr_var demanded i (attr_var_array, th_attrs)
		= case demanded.[i] of
			CT_Unique
				-> ({ attr_var_array & [i] = TA_Unique}, th_attrs)
			CT_NonUnique
				-> ({ attr_var_array & [i] = TA_Multi}, th_attrs)
			_
				# (new_info_ptr, th_attrs) = newPtr AVI_Empty th_attrs
				-> ({ attr_var_array & [i] = TA_Var { av_name = NewAttrVarId i, av_info_ptr = new_info_ptr }}, th_attrs)
891

892
893
894
895
896
897
898
899
900
coercionsToAttrEnv :: !{!TypeAttribute} !Coercions -> [AttrInequality]
coercionsToAttrEnv attr_vars {coer_demanded, coer_offered}
	= flatten [ [ {ai_offered = toAttrVar attr_vars.[offered],
					ai_demanded = toAttrVar attr_vars.[demanded] }
				\\ offered <- fst (flattenCoercionTree offered_tree) ]
			  \\ offered_tree<-:coer_offered & demanded<-[0..] ]
  where
	toAttrVar (TA_Var av) = av

901
902
903
904
905
906
907
908
909
910
911
912
substitute_attr_inequality {ai_offered, ai_demanded} th_attrs
	#! ac_offered = pointer_to_int ai_offered th_attrs
	   ac_demanded = pointer_to_int ai_demanded th_attrs
	= ({ ac_offered = ac_offered, ac_demanded = ac_demanded }, th_attrs)
  where
	pointer_to_int {av_info_ptr} th_attrs
		# (AVI_Attr (TA_TempVar i)) = sreadPtr av_info_ptr th_attrs
		= i

new_inequality {ac_offered, ac_demanded} coercions
	= newInequality ac_offered ac_demanded coercions

913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
:: UniquenessRequirement =
	{	ur_offered		:: !AType
	,	ur_demanded		:: !AType
	,	ur_attr_ineqs	:: ![AttrCoercion]
	}

readableCoercions {coer_demanded}
	= [ (i, readable coer_demanded.[i]) \\ i<-[0..size coer_demanded - 1] ]
  where
	readable CT_Unique
	 	= [TA_Unique]
	readable CT_NonUnique
	 	= [TA_Multi]
	readable ct
		# (vars, _) = flattenCoercionTree ct
		= map TA_TempVar vars

930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
:: ATypesWithStrictness = {ats_types::![AType],ats_strictness::!StrictnessList};

compute_args_strictness new_arg_types_array = compute_args_strictness 0 0 NotStrict 0 new_arg_types_array
  	where
  		compute_args_strictness strictness_index strictness strictness_list array_index new_arg_types_array
  			| array_index==size new_arg_types_array
  				| strictness==0
  					= strictness_list
  					= append_strictness strictness strictness_list
  				# {ats_types,ats_strictness} = new_arg_types_array.[array_index]
  				# (strictness_index,strictness) = add_strictness_for_arguments ats_types 0 strictness_index strictness strictness_list
  					with
  						add_strictness_for_arguments [] ats_strictness_index strictness_index strictness strictness_list
  							= (strictness_index,strictness)
  						add_strictness_for_arguments [_:ats_types] ats_strictness_index strictness_index strictness strictness_list
  							| arg_is_strict ats_strictness_index ats_strictness
  								# (strictness_index,strictness,strictness_list) = add_next_strict strictness_index strictness strictness_list
  								= add_strictness_for_arguments ats_types (ats_strictness_index+1) strictness_index strictness strictness_list
  								# (strictness_index,strictness,strictness_list) = add_next_not_strict strictness_index strictness strictness_list
  								= add_strictness_for_arguments ats_types (ats_strictness_index+1) strictness_index strictness strictness_list
  				= compute_args_strictness strictness_index strictness strictness_list (array_index+1) new_arg_types_array
	
952
953
954
955
/*
 * GENERATE FUSED FUNCTION
 */

956
generateFunction :: !FunDef ![ConsClass] ![Bool] !{! Producer} !FunctionInfoPtr !ReadOnlyTI !*TransformInfo -> (!Index, !Int, !*TransformInfo)
957
generateFunction fd=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_info = {fi_group_index}} 
958
				 cc_args cc_linear_bits prods fun_def_ptr ro
959
960
				 ti=:{ti_var_heap,ti_next_fun_nr,ti_new_functions,ti_fun_heap,ti_symbol_heap,ti_fun_defs,
				 		ti_type_heaps,ti_cons_args,ti_cleanup_info, ti_type_def_infos}
961
/*
962
963
964
965
	| False-!->("generating new function",fd.fun_symb.id_name,"->",ti_next_fun_nr)		= undef
	| False-!->("with type",fd.fun_type)												= undef
	| False-!->("producers:",II_Node prods nilPtr II_Empty II_Empty,("cc_args",cc_args,("cc_linear_bits",cc_linear_bits)))		= undef
//	| False-!->("body:",tb_args, tb_rhs)												= undef
966
*/
967
	#!(fi_group_index, ti_cons_args, ti_fun_defs, ti_fun_heap)
968
			= max_group_index 0 prods ro.ro_main_dcl_module_n fi_group_index ti_fun_defs ti_fun_heap ti_cons_args
969
	# opt_consumer_symbol_type 
970
			= fd.fun_type
971

972
973
974
975
	  (function_producer_types, ti_fun_defs, ti_fun_heap)
	  		= iFoldSt (accum_function_producer_type prods ro) 0 (size prods) 
	  				([], ti_fun_defs, ti_fun_heap)
	  (fresh_function_producer_types, ti_type_heaps)
976
977
978
979
	  		= mapSt copy_opt_symbol_type function_producer_types
	  				ti_type_heaps
	  ([opt_sound_consumer_symbol_type:opt_sound_function_producer_types], (ti_type_heaps, ti_type_def_infos))
	  		= mapSt (add_propagation_attributes ro.ro_common_defs) [opt_consumer_symbol_type: fresh_function_producer_types]
980
	  				(ti_type_heaps, ti_type_def_infos)
981
982
983
984
985
986
987

	  (Yes sound_consumer_symbol_type)
	  		= opt_sound_consumer_symbol_type

	  sound_function_producer_types
	  		= [x \\ Yes x <- opt_sound_function_producer_types]

988
	  ({st_attr_vars,st_args,st_args_strictness,st_result,st_attr_env})
989
	  		= sound_consumer_symbol_type
990

991
992
993
994
995
	  (class_types, ti_fun_defs, ti_fun_heap)
	  		= iFoldSt (accum_class_type prods ro) 0 (size prods) 
	  				([], ti_fun_defs, ti_fun_heap)
	  (type_vars_in_class_types, th_vars)
	  		= mapSt getTypeVars class_types ti_type_heaps.th_vars
996

997
998
999
1000
	  all_involved_types
	  		= class_types ++ (flatten (map (\{st_args, st_result}-> [st_result:st_args]) 
					  					[sound_consumer_symbol_type:sound_function_producer_types]))
	  (propagating_cons_vars, th_vars)
For faster browsing, not all history is shown. View entire blame