trans.icl 204 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
SwitchCaseFusion			fuse dont_fuse :== fuse
12
13
SwitchGeneratedFusion		fuse dont_fuse :== fuse
SwitchFunctionFusion		fuse dont_fuse :== fuse
14
15
SwitchConstructorFusion		fuse dont_fuse :== dont_fuse
SwitchRnfConstructorFusion  rnf  linear	   :== rnf
16
17
SwitchCurriedFusion			fuse xtra dont_fuse :== fuse 
SwitchExtraCurriedFusion	fuse macro :== (fuse && macro)//fuse
18
SwitchTrivialFusion			fuse dont_fuse :== fuse
19
SwitchUnusedFusion			fuse dont_fuse :== fuse
20
21
SwitchReanalyseFunction		rean dont_rean :== dont_rean
SwitchTransformConstants	tran dont_tran :== tran
22
SwitchSpecialFusion			fuse dont_fuse :== fuse
23
SwitchArityChecks			check dont_check :== check
24
25
SwitchNWayFusion			fuse dont_fuse :== dont_fuse
SwitchDirectConsumerUnfold	unfold dont    :== dont
26
27
SwitchAutoFoldCaseInCase	fold dont	   :== fold
SwitchAutoFoldAppInCase		fold dont	   :== fold
28
SwitchAlwaysIntroduceCaseFunction yes no   :== no//yes
29
30
31
SwitchNonRecFusion			fuse dont_fuse :== dont_fuse
SwitchHOFusion				fuse dont_fuse :== fuse
SwitchHOFusion`				fuse dont_fuse :== fuse
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
32

33
34
//import RWSDebug

35
(-!->) infix
36
37
38
(-!->) a b :== a  // ---> b
(<-!-) infix
(<-!-) a b :== a  // <--- b
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59

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
60

61
62
63
64
65
66
67
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)

68
69
70
71
72
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
73
		_							-> abort "sanity check 'readExtendedVarInfo' failed in module trans.\n"
74

75
76
77
78
79
80
81
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

82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
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
 */

128
129
130
131
::	*TransformInfo =
	{	ti_fun_defs				:: !*{# FunDef}
	,	ti_instances 			:: !*{! InstanceInfo }
	,	ti_cons_args 			:: !*{! ConsClasses}
132
	,	ti_new_functions 		:: ![FunctionInfoPtr]
133
134
135
136
137
	,	ti_fun_heap				:: !*FunctionHeap
	,	ti_var_heap				:: !*VarHeap
	,	ti_symbol_heap			:: !*ExpressionHeap
	,	ti_type_heaps			:: !*TypeHeaps
	,	ti_type_def_infos		:: !*TypeDefInfos
138
139
140
	,	ti_next_fun_nr			:: !Index
	,	ti_cleanup_info			:: !CleanupInfo
	,	ti_recursion_introduced	:: !Optional Index
141
//	,	ti_trace				:: !Bool // XXX just for tracing
142
143
	,	ti_error_file			:: !*File
	,	ti_predef_symbols		:: !*PredefinedSymbols
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
144
145
	}

146
147
::	ReadOnlyTI = 
	{	ro_imported_funs	:: !{# {# FunType} }
148
	,	ro_common_defs		:: !{# CommonDefs }
149
150
151
152
153
// 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
154
	,	ro_fun_geni				:: !(!Int,!Int)
155
	,	ro_fun_orig				:: !SymbIdent		// original consumer
156
157
158
159
160

	,	ro_main_dcl_module_n 	:: !Int

	,	ro_transform_fusion		:: !Bool			// fusion switch

161
	,	ro_stdStrictLists_module_n :: !Int
162
163
	}

164
165
::	RootCaseMode = NotRootCase | RootCase | RootCaseOfZombie

166
167
168
169
170
171
172
173
neverMatchingCase (Yes ident)
	# ident = ident -!-> ("neverMatchingCase",ident)
	= FailExpr ident
neverMatchingCase _ 
	# ident = {id_name = "neverMatchingCase", id_info = nilPtr}  -!-> "neverMatchingCase without ident\n"
	= FailExpr ident
/*
	= Case { case_expr = EE, case_guards = NoPattern, case_default = No, case_ident = ident, case_info_ptr = nilPtr, 
174
175
// RWS ...
						case_explicit = False,
176
				//		case_explicit = True,	// DvA better?
177
178
// ... RWS
						case_default_pos = NoPos }
179
*/
180
class transform a :: !a !ReadOnlyTI !*TransformInfo -> (!a, !*TransformInfo)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
181
182
183

instance transform Expression
where
184
185
186
187
188
189
	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
190
191
		= case expr of
			App app
192
				-> transformApplication app exprs ro ti
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
193
194
			_
				-> (expr @ exprs, ti)
Sjaak Smetsers's avatar
Sjaak Smetsers committed
195
	transform (Let lad=:{let_strict_binds, let_lazy_binds, let_expr}) ro ti
196
		# ti = store_type_info_of_bindings_in_heap lad ti
Sjaak Smetsers's avatar
Sjaak Smetsers committed
197
198
		  (let_strict_binds, ti) = transform let_strict_binds ro ti
		  (let_lazy_binds, ti) = transform let_lazy_binds ro ti
199
		  (let_expr, ti) = transform let_expr ro ti
200
201
202
		  lad = { lad & let_lazy_binds = let_lazy_binds, let_strict_binds = let_strict_binds, let_expr = let_expr}
//		  ti = check_type_info lad ti
		= (Let lad, ti)
203
	  where
Sjaak Smetsers's avatar
Sjaak Smetsers committed
204
205
		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
206
			# (EI_LetType var_types, ti_symbol_heap) = readExprInfo let_info_ptr ti.ti_symbol_heap
Diederik van Arkel's avatar
Diederik van Arkel committed
207
			  ti_var_heap								= foldSt store_type_info_let_bind
208
								   (zip2 var_types let_binds) ti.ti_var_heap
209
								   //  ---> ("store_type_info_of_bindings_in_heap",let_strict_binds,let_lazy_binds,var_types)
210
			= { ti & ti_symbol_heap = ti_symbol_heap, ti_var_heap = ti_var_heap }
Diederik van Arkel's avatar
Diederik van Arkel committed
211
212
		store_type_info_let_bind (var_type, {lb_dst={fv_info_ptr}}) var_heap
			= setExtendedVarInfo fv_info_ptr (EVI_VarType var_type) var_heap
213
214
215
216
		check_type_info {let_strict_binds,let_lazy_binds,let_info_ptr} ti
			# (EI_LetType var_types, ti_symbol_heap) = readExprInfo let_info_ptr ti.ti_symbol_heap
			= { ti & ti_symbol_heap = ti_symbol_heap }
				//  ---> ("check_type_info_of_bindings_in_heap",let_strict_binds,let_lazy_binds,var_types)
Diederik van Arkel's avatar
Diederik van Arkel committed
217

218
219
220
221
222
223
224
	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
225
226
					# (EI_CaseType {ct_cons_types},ti_symbol_heap)
										= readExprInfo case_info_ptr ti.ti_symbol_heap
227
228
229
230
					  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
231
				OverloadedListPatterns _ _ patterns
Diederik van Arkel's avatar
Diederik van Arkel committed
232
233
					# (EI_CaseType {ct_cons_types},ti_symbol_heap)
										= readExprInfo case_info_ptr ti.ti_symbol_heap
234
235
					  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 }
236
237
238
				NoPattern
					-> ti
		store_type_info_of_alg_pattern (var_types,{ap_vars}) var_heap
Diederik van Arkel's avatar
Diederik van Arkel committed
239
240
241
242
			= 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

243
244
	transform (Selection opt_type expr selectors) ro ti
		# (expr, ti) = transform expr ro ti
245
		= transformSelection opt_type selectors expr ro ti
246
247
	transform (Update expr1 selectors expr2) ro ti
		# (expr1,ti) = transform expr1 ro ti
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
		# (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)
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
		# (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)
280
	transform (MatchExpr a1 expr) ro ti
281
		# (expr,ti) = transform expr ro ti
282
		= (MatchExpr a1 expr,ti)
283
284
	transform (DynamicExpr dynamic_expr) ro ti
		# (dynamic_expr, ti) = transform dynamic_expr ro ti
285
		= (DynamicExpr dynamic_expr, ti)	
286
	transform expr ro ti
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
287
288
289
		= (expr, ti)

instance transform DynamicExpr where
290
291
	transform dyn=:{dyn_expr} ro ti
		# (dyn_expr, ti) = transform dyn_expr ro ti
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
292
293
		= ({dyn & dyn_expr = dyn_expr}, ti)

294
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
295
296
297
	| SwitchCaseFusion (not ro.ro_transform_fusion) True
		= skip_over this_case ro ti
	| isNilPtr case_info_ptr			// encountered neverMatchingCase?!
298
		= skip_over this_case ro ti
299
300
301
302
303
304
305
306
307
308
309
	# (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 }
310
	= (removeNeverMatchingSubcases result_expr ro, ti)
Diederik van Arkel's avatar
Diederik van Arkel committed
311
where
312
313
314
	is_variable (Var _) = True
	is_variable _ 		= False

Diederik van Arkel's avatar
Diederik van Arkel committed
315
316
317
318
319
320
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)
321

Diederik van Arkel's avatar
Diederik van Arkel committed
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
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
Diederik van Arkel's avatar
Diederik van Arkel committed
364
		# (guard_expr, ti)						= possiblyFoldOuterCase True guard_expr outer_case ro ti
Diederik van Arkel's avatar
Diederik van Arkel committed
365
366
		= ([guard_expr], ti)
	lift_patterns_2 default_exists [guard_expr : guard_exprs] outer_case ro ti
Diederik van Arkel's avatar
Diederik van Arkel committed
367
		# (guard_expr, ti)						= possiblyFoldOuterCase False guard_expr outer_case ro ti
Diederik van Arkel's avatar
Diederik van Arkel committed
368
369
370
371
		  (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
372
		
Diederik van Arkel's avatar
Diederik van Arkel committed
373
	lift_default (Yes default_expr) outer_case ro ti
Diederik van Arkel's avatar
Diederik van Arkel committed
374
		# (default_expr, ti)					= possiblyFoldOuterCase True default_expr outer_case ro ti
Diederik van Arkel's avatar
Diederik van Arkel committed
375
376
377
378
		= (Yes default_expr, ti)
	lift_default No _ _ ti
		= (No, ti)

Diederik van Arkel's avatar
Diederik van Arkel committed
379
380
	possiblyFoldOuterCase final guard_expr outer_case ro ti
		| SwitchAutoFoldCaseInCase (isFoldExpression guard_expr) False // otherwise GOTO next alternative
381
382
383
			| False -!-> ("possiblyFoldOuterCase","Case",bef < 0 || act < 0,ro.ro_fun_args,aci.aci_params) = undef
			| bef < 0 || act < 0
				= possiblyFoldOuterCase` final guard_expr outer_case ro ti	//abort "possiblyFoldOuterCase: unexpected!\n"
Diederik van Arkel's avatar
Diederik van Arkel committed
384
			= transformApplication { app_symb = folder, app_args = folder_args, app_info_ptr = nilPtr } [] ro ti
385
		= possiblyFoldOuterCase` final guard_expr outer_case ro ti
Diederik van Arkel's avatar
Diederik van Arkel committed
386
	where
387
388
389
390
391
392
393
394
395
		(bef,act)	= ro.ro_fun_geni
		new_f_a_before	= take bef ro.ro_fun_args
		new_f_a_after	= drop (bef+act) ro.ro_fun_args
		
		f_a_before	= new_f_a_before	//| new_f_a_before <> old_f_a_before	= abort "!!!"
		f_a_after	= new_f_a_after

//			= transformApplication { app_symb = folder, app_args = folder_args, app_info_ptr = nilPtr } [] ro ti
//	where
Diederik van Arkel's avatar
Diederik van Arkel committed
396
397
398
399
400
401
402
403
404
405
406
407
		isFoldExpression (App app)	= isFoldSymbol app.app_symb.symb_kind
		isFoldExpression (Var _)	= True
//		isFoldExpression (Case _)	= True
		isFoldExpression _			= False
		
		isFoldSymbol (SK_Function _)			= True
		isFoldSymbol (SK_LocalMacroFunction _)	= True
		isFoldSymbol (SK_GeneratedFunction _ _)	= True
		isFoldSymbol _							= False
		
		folder		= ro.ro_fun_orig
		folder_args = f_a_before` ++ [guard_expr:f_a_after`]
408
409
410
		old_f_a_before	= takeWhile (\e -> not (isMember e aci.aci_params)) ro.ro_fun_args
		old_f_a_help	= dropWhile (\e -> not (isMember e aci.aci_params)) ro.ro_fun_args
		old_f_a_after	= dropWhile (\e -> isMember e aci.aci_params) old_f_a_help
Diederik van Arkel's avatar
Diederik van Arkel committed
411
412
413
414
415
416
417
		f_a_before`	= [Var {var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = nilPtr} \\ {fv_name,fv_info_ptr} <- f_a_before]
		f_a_after`	= [Var {var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = nilPtr} \\ {fv_name,fv_info_ptr} <- f_a_after]
		(Yes aci)	= opt_aci

		isMember x [hd:tl] = hd.fv_info_ptr==x.fv_info_ptr || isMember x tl
		isMember x []	= False

418
	possiblyFoldOuterCase` final guard_expr outer_case ro ti
Diederik van Arkel's avatar
Diederik van Arkel committed
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
		| final
			= transformCase {outer_case & case_expr = guard_expr} 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 }
		  ui									= {ui_handle_aci_free_vars = LeaveThem }
		  (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 }
		= transformCase new_case ro ti
	
transCase is_active opt_aci this_case=:{case_expr = case_expr=:(App app=:{app_symb,app_args}),case_guards,case_default,case_explicit} ro ti
Diederik van Arkel's avatar
Diederik van Arkel committed
436
437
438
439
440
441
442
443
444
445
446
447
	= 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
448
449
450
451
452
					-> (neverMatchingCase never_ident, ti) <-!- ("transCase:App:neverMatchingCase",never_ident)
					with
						never_ident = case ro.ro_root_case_mode of
							NotRootCase -> this_case.case_ident
							_ -> Yes ro.ro_fun_case.symb_name
Diederik van Arkel's avatar
Diederik van Arkel committed
453
454
455
456
		// otherwise it's a function application
		_	-> case opt_aci of
				Yes aci=:{ aci_params, aci_opt_unfolder }
					-> case aci_opt_unfolder of
457
						No	-> skip_over this_case ro ti									-!-> ("transCase","No opt unfolder")
Diederik van Arkel's avatar
Diederik van Arkel committed
458
459
460
						Yes unfolder
							| not (equal app_symb.symb_kind unfolder.symb_kind)
								// in this case a third function could be fused in
461
								-> possiblyFoldOuterCase this_case ro ti					-!-> ("transCase","Diff opt unfolder",unfolder,app_symb)
Diederik van Arkel's avatar
Diederik van Arkel committed
462
463
							# 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 ]
464
							  (ti_next_fun_nr, ti) = ti!ti_next_fun_nr						-!-> ("transCase","Yes opt unfolder",unfolder)
Diederik van Arkel's avatar
Diederik van Arkel committed
465
466
467
468
469
470
							  (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 })
471
												-!-> ("Recursion","RootCaseOfZombie",ti_next_fun_nr,ti.ti_recursion_introduced)
Diederik van Arkel's avatar
Diederik van Arkel committed
472
473
										RootCase
											-> (ti_next_fun_nr, ro.ro_fun_root)
474
475
476
477
478
479
												-!-> ("Recursion","RootCase",ti_next_fun_nr,ro.ro_fun_root,ti.ti_recursion_introduced)
							  ti = case ro.ro_root_case_mode of
										RootCaseOfZombie
											-> { ti & ti_next_fun_nr = new_next_fun_nr, ti_recursion_introduced = Yes ti_next_fun_nr }
										RootCase
											-> { ti & ti_next_fun_nr = new_next_fun_nr, ti_recursion_introduced = No }
Diederik van Arkel's avatar
Diederik van Arkel committed
480
481
482
483
484
							  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
Diederik van Arkel's avatar
Diederik van Arkel committed
485
486
	possiblyFoldOuterCase outer_case ro ti
		| SwitchAutoFoldAppInCase True False
487
488
			| False -!-> ("possiblyFoldOuterCase","App",bef < 0 || act < 0,ro.ro_fun_args,aci.aci_params) = undef
			| bef < 0 || act < 0	= skip_over this_case ro ti	//abort "possiblyFoldOuterCase: unexpected!\n"
Diederik van Arkel's avatar
Diederik van Arkel committed
489
490
491
			= transformApplication { app_symb = folder, app_args = folder_args, app_info_ptr = nilPtr } [] ro ti
		= skip_over this_case ro ti
	where
492
493
494
495
496
497
498
		(bef,act)	= ro.ro_fun_geni
		new_f_a_before	= take bef ro.ro_fun_args
		new_f_a_after	= drop (bef+act) ro.ro_fun_args
		
		f_a_before	= new_f_a_before
		f_a_after	= new_f_a_after

Diederik van Arkel's avatar
Diederik van Arkel committed
499
500
		folder		= ro.ro_fun_orig
		folder_args = f_a_before` ++ [case_expr:f_a_after`]
501
502
503
		old_f_a_before	= takeWhile (\e -> not (isMember e aci.aci_params)) ro.ro_fun_args
		old_f_a_help	= dropWhile (\e -> not (isMember e aci.aci_params)) ro.ro_fun_args
		old_f_a_after	= dropWhile (\e -> isMember e aci.aci_params) old_f_a_help
Diederik van Arkel's avatar
Diederik van Arkel committed
504
505
506
507
508
509
510
		f_a_before`	= [Var {var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = nilPtr} \\ {fv_name,fv_info_ptr} <- f_a_before]
		f_a_after`	= [Var {var_name = fv_name, var_info_ptr = fv_info_ptr, var_expr_ptr = nilPtr} \\ {fv_name,fv_info_ptr} <- f_a_after]
		(Yes aci)	= opt_aci

		isMember x [hd:tl] = hd.fv_info_ptr==x.fv_info_ptr || isMember x tl
		isMember x []	= False

Diederik van Arkel's avatar
Diederik van Arkel committed
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
	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
552
			  (new_expr, ti_symbol_heap) = possibly_add_let non_unfoldable_args ap_expr not_unfoldable cons_type ro ti.ti_symbol_heap
Diederik van Arkel's avatar
Diederik van Arkel committed
553
554
			  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 }
555
			  ui= {ui_handle_aci_free_vars = LeaveThem }
Diederik van Arkel's avatar
Diederik van Arkel committed
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
			  (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
	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
575
576
577
578
579
			No				-> (neverMatchingCase never_ident, ti) <-!- ("transCase:BasicExpr:neverMatchingCase",never_ident)
					with
						never_ident = case ro.ro_root_case_mode of
							NotRootCase -> this_case.case_ident
							_ -> Yes ro.ro_fun_case.symb_name
Diederik van Arkel's avatar
Diederik van Arkel committed
580
581
582
583
	= transform (hd may_be_match_pattern).bp_expr { ro & ro_root_case_mode = NotRootCase } ti
where
	getBasicPatterns (BasicPatterns _ basicPatterns)
		= basicPatterns
584

Diederik van Arkel's avatar
Diederik van Arkel committed
585
586
587
588
589
590
591
592
593
594
595
596
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
	
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
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 cons_type ro ti_symbol_heap
	# let_type = filterWith not_unfoldable cons_type.st_args
	  (new_info_ptr, ti_symbol_heap) = newPtr (EI_LetType let_type) ti_symbol_heap
/* DvA... STRICT_LET
	= ( 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
										]
...DvA */
	= ( 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
	  ) 

633
possibly_generate_case_function :: !Case !ActiveCaseInfo !ReadOnlyTI !*TransformInfo -> *(!Expression, !*TransformInfo)
634
possibly_generate_case_function kees=:{case_info_ptr} aci=:{aci_free_vars} ro ti=:{ti_recursion_introduced=old_ti_recursion_introduced}
635
636
//	| 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
637
638
	| not aci.aci_safe
		= skip_over kees ro ti
639
	// determine free variables
640
641
642
643
644
645
646
	# ti_var_heap = clearVariables (Case kees) ti.ti_var_heap
	  fvi	= { fvi_var_heap = 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 }
	  free_vars	= fvi_variables
647
648
649
650
651
	// 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
652
653
							TransformedBody {tb_args} 	-> tb_args
							Expanding args				-> args
654
655
656
657
658
659
660
661
662
663
	  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}
664
							\\ {var_name, var_info_ptr} <- free_vars | not (isMember var_info_ptr outer_info_ptrs)]
665
666
	  all_args
	  		= lifted_arguments++arguments_from_outer_fun
Diederik van Arkel's avatar
Diederik van Arkel committed
667
668
669
	| SwitchArityChecks (length all_args > 32) False
		# ti
		  		= { ti & ti_cons_args = ti_cons_args, ti_fun_defs = ti_fun_defs, ti_fun_heap = ti_fun_heap, ti_recursion_introduced = No }
670
671
672
		| ro.ro_transform_fusion
			#  ti	= { ti & ti_error_file = ti.ti_error_file <<< "Possibly missed fusion oppurtunity: Case Arity > 32 " <<< ro.ro_fun_root.symb_name.id_name <<< "\n"}
			= skip_over kees ro ti
Diederik van Arkel's avatar
Diederik van Arkel committed
673
674
		= skip_over kees ro ti
	# (fun_info_ptr, ti_fun_heap)
675
676
677
678
	  		= newPtr FI_Empty ti_fun_heap
	  fun_ident
	  		= { id_name = ro.ro_fun_root.symb_name.id_name+++"_case", id_info = nilPtr }
	  fun_symb
679
	  		= { symb_name = fun_ident, symb_kind=SK_GeneratedFunction fun_info_ptr undeff }
680
	  			<-!- ("<<<transformCaseFunction",fun_ident)
681
682
683
684
685
686
687
688
	| SwitchAlwaysIntroduceCaseFunction True False
		# ti
	  		= { ti & ti_cons_args = ti_cons_args, ti_fun_defs = ti_fun_defs, ti_fun_heap = ti_fun_heap }
	  	# fun_index
	  		= ti.ti_next_fun_nr
	  	# ti
	  		= { ti & ti_next_fun_nr = fun_index + 1 }
		# new_ro
689
	  		= { ro & ro_root_case_mode = RootCaseOfZombie , ro_fun_case = fun_symb, ro_fun_args = all_args }
690
691
692
	  	= generate_case_function fun_index case_info_ptr (Case kees) outer_fun_def outer_cons_args used_mask new_ro ti
	# new_ro
	  		= { ro & ro_root_case_mode = RootCaseOfZombie , ro_fun_case = fun_symb, ro_fun_args = all_args, ro_fun_geni = (-1,-1) }
693
694
695
696
697
698
	  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
699
	  			<-!- ("transformCaseFunction>>>",fun_ident)
700
	  ti	= { ti & ti_recursion_introduced = old_ti_recursion_introduced }
701
702
	= case ti_recursion_introduced of
		Yes fun_index
703
			-> generate_case_function fun_index case_info_ptr new_expr outer_fun_def outer_cons_args used_mask new_ro ti
704
		No	-> (new_expr, ti)
705

706
707
708
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
709
//	| False -!-> ("generate_case_function",ro_fun.symb_name)		= undef
710
	# fun_arity								= length ro_fun_args
Diederik van Arkel's avatar
Diederik van Arkel committed
711
	# ti = arity_warning "generate_case_function" ro_fun.symb_name fun_index fun_arity ti
712
	  (Yes {st_vars,st_args,st_attr_env})	= outer_fun_def.fun_type
713
714
715
716
717
718
719
720
	  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

721
722
	# ti = {ti & ti_var_heap = ti_var_heap, ti_symbol_heap = ti_symbol_heap}
	# (fun_type,ti)							= determine_case_function_type fun_arity ct_result_type arg_types st_attr_env ti
723
724

	  // unfold...
725
726
727
	  us =		{ us_var_heap				= ti.ti_var_heap
	  			, us_symbol_heap			= ti.ti_symbol_heap
	  			, us_opt_type_heaps			= Yes ti.ti_type_heaps
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
	  			, 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_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		= []
753
// Sjaak: 							,	fi_is_macro_fun = outer_fun_def.fun_info.fi_is_macro_fun
754
755
756
757
758
759
760
								,	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
761
	  			, cc_args			= repeatn nr_of_lifted_vars CPassive ++ cc_args_from_outer_fun
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
	  			, 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}
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
	determine_case_function_type fun_arity ct_result_type arg_types st_attr_env ti
		# {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
		  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				= []
		  			}
		  ti									= { ti & ti_type_heaps = ti_type_heaps }
		= (fun_type,ti)
810

811
812
removeNeverMatchingSubcases :: Expression !.ReadOnlyTI -> Expression
removeNeverMatchingSubcases keesExpr=:(Case kees) ro
Martin Wierich's avatar
Martin Wierich committed
813
814
815
816
817
818
819
	// 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
820
			| not (any (is_never_matching_case o get_alg_rhs) alg_patterns) && not (is_never_matching_default case_default)
821
				-> keesExpr // frequent case: all subexpressions can't fail
Martin Wierich's avatar
Martin Wierich committed
822
823
			# 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
824
				-> neverMatchingCase never_ident <-!- ("removeNeverMatchingSubcases:AlgebraicPatterns:neverMatchingCase",never_ident)
Martin Wierich's avatar
Martin Wierich committed
825
826
827
828
			| 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
829
			| not (any (is_never_matching_case o get_basic_rhs) basic_patterns) && not (is_never_matching_default case_default)
830
				-> keesExpr // frequent case: all subexpressions can't fail
Martin Wierich's avatar
Martin Wierich committed
831
832
			# 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
833
				-> neverMatchingCase never_ident <-!- ("removeNeverMatchingSubcases:BasicPatterns:neverMatchingCase",never_ident)
Martin Wierich's avatar
Martin Wierich committed
834
835
836
			| is_default_only filtered_default filtered_case_guards
				-> fromYes case_default
			-> Case {kees & case_guards = BasicPatterns bt filtered_case_guards, case_default = filtered_default }
837
838
839
840
841
		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
842
				-> neverMatchingCase never_ident <-!- ("removeNeverMatchingSubcases:OverloadedListPatterns:neverMatchingCase",never_ident)
843
844
845
			| 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
846
		_	-> abort "removeNeverMatchingSubcases does not match"
847
where
Martin Wierich's avatar
Martin Wierich committed
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
	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
864
865
866
867
	is_never_matching_default No
		= False
	is_never_matching_default (Yes expr)
		= is_never_matching_case expr
868
869
870
871
	never_ident = case ro.ro_root_case_mode of
		NotRootCase -> kees.case_ident
		_ -> Yes ro.ro_fun_case.symb_name
removeNeverMatchingSubcases expr ro
Martin Wierich's avatar
Martin Wierich committed
872
873
874
	= expr

	
875
instance transform LetBind
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
876
where
877
878
879
	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
880
881
882

instance transform BasicPattern
where
883
884
	transform pattern=:{bp_expr} ro ti
		# (bp_expr, ti) = transform bp_expr ro ti
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
885
886
887
888
		= ({ pattern & bp_expr = bp_expr }, ti)

instance transform AlgebraicPattern
where
889
890
	transform pattern=:{ap_expr} ro ti
		# (ap_expr, ti) = transform ap_expr ro ti
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
891
892
893
894
		= ({ pattern & ap_expr = ap_expr }, ti)

instance transform CasePatterns
where
895
896
	transform (AlgebraicPatterns type patterns) ro ti
		# (patterns, ti) = transform patterns ro ti
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
897
		= (AlgebraicPatterns type patterns, ti)
898
899
	transform (BasicPatterns type patterns) ro ti
		# (patterns, ti) = transform patterns ro ti
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
900
		= (BasicPatterns type patterns, ti)
901
902
903
904
905
906
907
908
	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
909
910
911
912
	transform NoPattern ro ti
		= (NoPattern, ti)
	transform _ ro ti
		= abort "transform CasePatterns does not match"
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
913

914
instance transform (Optional a) | transform a
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
915
where
916
917
	transform (Yes x) ro ti
		# (x, ti) = transform x ro ti
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
918
		= (Yes x, ti)
919
	transform no ro ti
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
920
921
922
923
		= (no, ti)

instance transform [a] | transform a
where
924
925
926
	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
927
		= ([x : xs], ti)
928
	transform [] ro ti
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
929
930
		= ([], ti)

931
932
933
934
935
//@ tryToFindInstance: 

cIsANewFunction		:== True
cIsNotANewFunction	:== False

936
tryToFindInstance :: !{! Producer} !InstanceInfo !*(Heap FunctionInfo) -> *(!Bool, !FunctionInfoPtr, !InstanceInfo, !.FunctionHeap)
937
938
939
940
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
941
942
943
944
945
946
	| 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)
947
948
949
950
951
952
953
954
955
	# 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
956
957
958
959
960
961
962
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
963
964
965
966
		# 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
967
968
969
970
971
972
973
974
975
976

instance =< Producer
where
	(=<) pr1 pr2
		| equal_constructor pr1 pr2
			= compare_constructor_arguments  pr1 pr2
		| less_constructor pr1 pr2
			= Smaller
			= Greater
	where
977
		compare_constructor_arguments (PR_Function _ _ index1) (PR_Function _ _ index2)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
978
			= index1 =< index2
979
		compare_constructor_arguments (PR_GeneratedFunction _ _ index1) (PR_GeneratedFunction _ _ index2)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
980
			= index1 =< index2
Martin Wierich's avatar
Martin Wierich committed
981
982
		compare_constructor_arguments 	(PR_Class app1 lifted_vars_with_types1 t1) 
										(PR_Class app2 lifted_vars_with_types2 t2) 
983
//			= app1.app_args =< app2.app_args
Martin Wierich's avatar
Martin Wierich committed
984
985
986
987
			# cmp = smallerOrEqual t1 t2
			| cmp<>Equal
				= cmp
			= compare_types lifted_vars_with_types1 lifted_vars_with_types2
988
		compare_constructor_arguments (PR_Curried symb_ident1 _) (PR_Curried symb_ident2 _)
989
990
			= symb_ident1 =< symb_ident2
		compare_constructor_arguments PR_Empty PR_Empty
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
991
			= Equal
992
993
		compare_constructor_arguments PR_Unused PR_Unused
			= Equal
994
		compare_constructor_arguments (PR_Constructor symb_ident1 _ _) (PR_Constructor symb_ident2 _ _)
995
			= symb_ident1 =< symb_ident2
Martin Wierich's avatar
Martin Wierich committed
996
997
998
999
1000
1001
1002
1003
1004
1005
			
		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
		
1006
1007
1008
/*
 *	UNIQUENESS STUFF...
 */
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
1009

1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
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)
1034

1035
1036
1037
1038
1039
1040
1041
1042
1043
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

1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
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

1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
:: 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

1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
:: 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
	
1095
1096
1097
1098
/*
 * GENERATE FUSED FUNCTION
 */

Diederik van Arkel's avatar
Diederik van Arkel committed
1099
1100
generateFunction :: !SymbIdent !FunDef ![ConsClass] ![Bool] !{! Producer} !FunctionInfoPtr !ReadOnlyTI !*TransformInfo -> (!Index, !Int, !*TransformInfo)
generateFunction app_symb fd=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_info = {fi_group_index}} 
1101
				 cc_args cc_linear_bits prods fun_def_ptr ro
Martin Wierich's avatar