trans.icl 192 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
16
17
SwitchConstructorFusion		fuse dont_fuse :== dont_fuse
SwitchRnfConstructorFusion  rnf  linear	   :== rnf
SwitchCurriedFusion			fuse xtra dont_fuse :== fuse //&& xtra
SwitchExtraCurriedFusion	fuse dont_fuse :== fuse//dont_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
24
25
26
27
28
29
30
31
SwitchArityChecks			check dont_check :== check
SwitchNWayFusion			fuse dont_fuse :== dont_fuse//fuse
SwitchDirectConsumerUnfold	unfold dont    :== dont//unfold
SwitchAutoFoldCaseInCase	fold dont	   :== fold
SwitchAutoFoldAppInCase		fold dont	   :== fold
SwitchAlwaysIntroduceCaseFunction yes no   :== yes
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
(-!->) infix
34
35
36
(-!->) a b :== a  // ---> b
(<-!-) infix
(<-!-) a b :== a  // <--- b
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57

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
58

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

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

73
74
75
76
77
78
79
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

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

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

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

	,	ro_main_dcl_module_n 	:: !Int

	,	ro_transform_fusion		:: !Bool			// fusion switch

158
	,	ro_stdStrictLists_module_n :: !Int
159
160
	}

161
162
::	RootCaseMode = NotRootCase | RootCase | RootCaseOfZombie

163
164
165
166
167
168
169
170
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, 
171
172
// RWS ...
						case_explicit = False,
173
				//		case_explicit = True,	// DvA better?
174
175
// ... RWS
						case_default_pos = NoPos }
176
*/
177
class transform a :: !a !ReadOnlyTI !*TransformInfo -> (!a, !*TransformInfo)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
178
179
180

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

208
209
210
211
212
213
214
	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
215
216
					# (EI_CaseType {ct_cons_types},ti_symbol_heap)
										= readExprInfo case_info_ptr ti.ti_symbol_heap
217
218
219
220
					  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
221
				OverloadedListPatterns _ _ patterns
Diederik van Arkel's avatar
Diederik van Arkel committed
222
223
					# (EI_CaseType {ct_cons_types},ti_symbol_heap)
										= readExprInfo case_info_ptr ti.ti_symbol_heap
224
225
					  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 }
226
227
228
				NoPattern
					-> ti
		store_type_info_of_alg_pattern (var_types,{ap_vars}) var_heap
Diederik van Arkel's avatar
Diederik van Arkel committed
229
230
231
232
			= 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

233
234
	transform (Selection opt_type expr selectors) ro ti
		# (expr, ti) = transform expr ro ti
235
		= transformSelection opt_type selectors expr ro ti
236
237
	transform (Update expr1 selectors expr2) ro ti
		# (expr1,ti) = transform expr1 ro ti
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
		# (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)
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
		# (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)
270
	transform (MatchExpr a1 expr) ro ti
271
		# (expr,ti) = transform expr ro ti
272
		= (MatchExpr a1 expr,ti)
273
274
	transform (DynamicExpr dynamic_expr) ro ti
		# (dynamic_expr, ti) = transform dynamic_expr ro ti
275
		= (DynamicExpr dynamic_expr, ti)	
276
	transform expr ro ti
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
277
278
279
		= (expr, ti)

instance transform DynamicExpr where
280
281
	transform dyn=:{dyn_expr} ro ti
		# (dyn_expr, ti) = transform dyn_expr ro ti
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
282
283
		= ({dyn & dyn_expr = dyn_expr}, ti)

284
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
285
286
287
	| SwitchCaseFusion (not ro.ro_transform_fusion) True
		= skip_over this_case ro ti
	| isNilPtr case_info_ptr			// encountered neverMatchingCase?!
288
		= skip_over this_case ro ti
289
290
291
292
293
294
295
296
297
298
299
	# (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 }
300
	= (removeNeverMatchingSubcases result_expr ro, ti)
Diederik van Arkel's avatar
Diederik van Arkel committed
301
where
302
303
304
	is_variable (Var _) = True
	is_variable _ 		= False

Diederik van Arkel's avatar
Diederik van Arkel committed
305
306
307
308
309
310
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)
311

Diederik van Arkel's avatar
Diederik van Arkel committed
312
313
314
315
316
317
318
319
320
321
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
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
354
		# (guard_expr, ti)						= possiblyFoldOuterCase True guard_expr outer_case ro ti
Diederik van Arkel's avatar
Diederik van Arkel committed
355
356
		= ([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
357
		# (guard_expr, ti)						= possiblyFoldOuterCase False guard_expr outer_case ro ti
Diederik van Arkel's avatar
Diederik van Arkel committed
358
359
360
361
		  (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
362
		
Diederik van Arkel's avatar
Diederik van Arkel committed
363
	lift_default (Yes default_expr) outer_case ro ti
Diederik van Arkel's avatar
Diederik van Arkel committed
364
		# (default_expr, ti)					= possiblyFoldOuterCase True default_expr outer_case ro ti
Diederik van Arkel's avatar
Diederik van Arkel committed
365
366
367
368
		= (Yes default_expr, ti)
	lift_default No _ _ ti
		= (No, ti)

Diederik van Arkel's avatar
Diederik van Arkel committed
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
	possiblyFoldOuterCase final guard_expr outer_case ro ti
		| SwitchAutoFoldCaseInCase (isFoldExpression guard_expr) False // otherwise GOTO next alternative
			= transformApplication { app_symb = folder, app_args = folder_args, app_info_ptr = nilPtr } [] ro ti
	where
		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`]
		f_a_before	= takeWhile (\e -> not (isMember e aci.aci_params)) ro.ro_fun_args
		f_a_help	= dropWhile (\e -> not (isMember e aci.aci_params)) ro.ro_fun_args
		f_a_after	= dropWhile (\e -> isMember e aci.aci_params) f_a_help
		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

	possiblyFoldOuterCase final guard_expr outer_case ro ti
		| 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
413
414
415
416
417
418
419
420
421
422
423
424
	= 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
425
426
427
428
429
					-> (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
430
431
432
433
434
435
436
437
		// 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
Diederik van Arkel's avatar
Diederik van Arkel committed
438
								-> possiblyFoldOuterCase this_case ro ti
Diederik van Arkel's avatar
Diederik van Arkel committed
439
440
441
442
443
444
445
446
447
							# 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 })
448
												-!-> ("Recursion","RootCaseOfZombie",ti_next_fun_nr,ti.ti_recursion_introduced)
Diederik van Arkel's avatar
Diederik van Arkel committed
449
450
										RootCase
											-> (ti_next_fun_nr, ro.ro_fun_root)
451
452
453
454
455
456
												-!-> ("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
457
458
459
460
461
							  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
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
	possiblyFoldOuterCase outer_case ro ti
		| SwitchAutoFoldAppInCase True False
			= transformApplication { app_symb = folder, app_args = folder_args, app_info_ptr = nilPtr } [] ro ti
		= skip_over this_case ro ti
	where
		folder		= ro.ro_fun_orig
		folder_args = f_a_before` ++ [case_expr:f_a_after`]
		f_a_before	= takeWhile (\e -> not (isMember e aci.aci_params)) ro.ro_fun_args
		f_a_help	= dropWhile (\e -> not (isMember e aci.aci_params)) ro.ro_fun_args
		f_a_after	= dropWhile (\e -> isMember e aci.aci_params) f_a_help
		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
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
	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
520
			  (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
521
522
			  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 }
523
			  ui= {ui_handle_aci_free_vars = LeaveThem }
Diederik van Arkel's avatar
Diederik van Arkel committed
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
			  (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
543
544
545
546
547
			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
548
549
550
551
	= transform (hd may_be_match_pattern).bp_expr { ro & ro_root_case_mode = NotRootCase } ti
where
	getBasicPatterns (BasicPatterns _ basicPatterns)
		= basicPatterns
552

Diederik van Arkel's avatar
Diederik van Arkel committed
553
554
555
556
557
558
559
560
561
562
563
564
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
	
565
566
567
568
569
570
571
572
573
574
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
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
	  ) 

601
possibly_generate_case_function :: !Case !ActiveCaseInfo !ReadOnlyTI !*TransformInfo -> *(!Expression, !*TransformInfo)
602
possibly_generate_case_function kees=:{case_info_ptr} aci=:{aci_free_vars} ro ti=:{ti_recursion_introduced=old_ti_recursion_introduced}
603
604
//	| 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
605
606
	| not aci.aci_safe
		= skip_over kees ro ti
607
	// determine free variables
608
609
610
611
612
613
614
	# 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
615
616
617
618
619
	// 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
620
621
							TransformedBody {tb_args} 	-> tb_args
							Expanding args				-> args
622
623
624
625
626
627
628
629
630
631
	  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}
632
							\\ {var_name, var_info_ptr} <- free_vars | not (isMember var_info_ptr outer_info_ptrs)]
633
634
	  all_args
	  		= lifted_arguments++arguments_from_outer_fun
Diederik van Arkel's avatar
Diederik van Arkel committed
635
636
637
638
639
640
	| 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 }
		  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
	# (fun_info_ptr, ti_fun_heap)
641
642
643
644
	  		= newPtr FI_Empty ti_fun_heap
	  fun_ident
	  		= { id_name = ro.ro_fun_root.symb_name.id_name+++"_case", id_info = nilPtr }
	  fun_symb
645
	  		= { symb_name = fun_ident, symb_kind=SK_GeneratedFunction fun_info_ptr undeff }
646
	  			<-!- ("<<<transformCaseFunction",fun_ident)
647
648
649
650
651
652
653
654
	  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
655
	  			<-!- ("transformCaseFunction>>>",fun_ident)
656
	  ti	= { ti & ti_recursion_introduced = old_ti_recursion_introduced }
657
658
	= case ti_recursion_introduced of
		Yes fun_index
659
			-> generate_case_function fun_index case_info_ptr new_expr outer_fun_def outer_cons_args used_mask new_ro ti
660
		No	-> (new_expr, ti)
661

662
663
664
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
665
//	| False -!-> ("generate_case_function",ro_fun.symb_name)		= undef
666
	# fun_arity								= length ro_fun_args
Diederik van Arkel's avatar
Diederik van Arkel committed
667
	# ti = arity_warning "generate_case_function" ro_fun.symb_name fun_index fun_arity ti
668
	  (Yes {st_vars,st_args,st_attr_env})	= outer_fun_def.fun_type
669
670
671
672
673
674
675
676
	  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

677
678
	# 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
679
680

	  // unfold...
681
682
683
	  us =		{ us_var_heap				= ti.ti_var_heap
	  			, us_symbol_heap			= ti.ti_symbol_heap
	  			, us_opt_type_heaps			= Yes ti.ti_type_heaps
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
	  			, 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		= []
709
// Sjaak: 							,	fi_is_macro_fun = outer_fun_def.fun_info.fi_is_macro_fun
710
711
712
713
714
715
716
								,	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
717
	  			, cc_args			= repeatn nr_of_lifted_vars CPassive ++ cc_args_from_outer_fun
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
	  			, 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}
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
	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)
766

767
768
removeNeverMatchingSubcases :: Expression !.ReadOnlyTI -> Expression
removeNeverMatchingSubcases keesExpr=:(Case kees) ro
Martin Wierich's avatar
Martin Wierich committed
769
770
771
772
773
774
775
	// 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
776
			| not (any (is_never_matching_case o get_alg_rhs) alg_patterns) && not (is_never_matching_default case_default)
777
				-> keesExpr // frequent case: all subexpressions can't fail
Martin Wierich's avatar
Martin Wierich committed
778
779
			# 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
780
				-> neverMatchingCase never_ident <-!- ("removeNeverMatchingSubcases:AlgebraicPatterns:neverMatchingCase",never_ident)
Martin Wierich's avatar
Martin Wierich committed
781
782
783
784
			| 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
785
			| not (any (is_never_matching_case o get_basic_rhs) basic_patterns) && not (is_never_matching_default case_default)
786
				-> keesExpr // frequent case: all subexpressions can't fail
Martin Wierich's avatar
Martin Wierich committed
787
788
			# 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
789
				-> neverMatchingCase never_ident <-!- ("removeNeverMatchingSubcases:BasicPatterns:neverMatchingCase",never_ident)
Martin Wierich's avatar
Martin Wierich committed
790
791
792
			| is_default_only filtered_default filtered_case_guards
				-> fromYes case_default
			-> Case {kees & case_guards = BasicPatterns bt filtered_case_guards, case_default = filtered_default }
793
794
795
796
797
		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
798
				-> neverMatchingCase never_ident <-!- ("removeNeverMatchingSubcases:OverloadedListPatterns:neverMatchingCase",never_ident)
799
800
801
			| 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
802
		_	-> abort "removeNeverMatchingSubcases does not match"
803
where
Martin Wierich's avatar
Martin Wierich committed
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
	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
820
821
822
823
	is_never_matching_default No
		= False
	is_never_matching_default (Yes expr)
		= is_never_matching_case expr
824
825
826
827
	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
828
829
830
	= expr

	
831
instance transform LetBind
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
832
where
833
834
835
	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
836
837
838

instance transform BasicPattern
where
839
840
	transform pattern=:{bp_expr} ro ti
		# (bp_expr, ti) = transform bp_expr ro ti
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
841
842
843
844
		= ({ pattern & bp_expr = bp_expr }, ti)

instance transform AlgebraicPattern
where
845
846
	transform pattern=:{ap_expr} ro ti
		# (ap_expr, ti) = transform ap_expr ro ti
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
847
848
849
850
		= ({ pattern & ap_expr = ap_expr }, ti)

instance transform CasePatterns
where
851
852
	transform (AlgebraicPatterns type patterns) ro ti
		# (patterns, ti) = transform patterns ro ti
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
853
		= (AlgebraicPatterns type patterns, ti)
854
855
	transform (BasicPatterns type patterns) ro ti
		# (patterns, ti) = transform patterns ro ti
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
856
		= (BasicPatterns type patterns, ti)
857
858
859
860
861
862
863
864
	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
865
866
867
868
	transform NoPattern ro ti
		= (NoPattern, ti)
	transform _ ro ti
		= abort "transform CasePatterns does not match"
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
869

870
instance transform (Optional a) | transform a
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
871
where
872
873
	transform (Yes x) ro ti
		# (x, ti) = transform x ro ti
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
874
		= (Yes x, ti)
875
	transform no ro ti
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
876
877
878
879
		= (no, ti)

instance transform [a] | transform a
where
880
881
882
	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
883
		= ([x : xs], ti)
884
	transform [] ro ti
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
885
886
		= ([], ti)

887
888
889
890
891
//@ tryToFindInstance: 

cIsANewFunction		:== True
cIsNotANewFunction	:== False

892
tryToFindInstance :: !{! Producer} !InstanceInfo !*(Heap FunctionInfo) -> *(!Bool, !FunctionInfoPtr, !InstanceInfo, !.FunctionHeap)
893
894
895
896
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
897
898
899
900
901
902
	| 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)
903
904
905
906
907
908
909
910
911
	# 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
912
913
914
915
916
917
918
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
919
920
921
922
		# 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
923
924
925
926
927
928
929
930
931
932

instance =< Producer
where
	(=<) pr1 pr2
		| equal_constructor pr1 pr2
			= compare_constructor_arguments  pr1 pr2
		| less_constructor pr1 pr2
			= Smaller
			= Greater
	where
933
		compare_constructor_arguments (PR_Function _ _ index1) (PR_Function _ _ index2)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
934
			= index1 =< index2
935
		compare_constructor_arguments (PR_GeneratedFunction _ _ index1) (PR_GeneratedFunction _ _ index2)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
936
			= index1 =< index2
Martin Wierich's avatar
Martin Wierich committed
937
938
		compare_constructor_arguments 	(PR_Class app1 lifted_vars_with_types1 t1) 
										(PR_Class app2 lifted_vars_with_types2 t2) 
939
//			= app1.app_args =< app2.app_args
Martin Wierich's avatar
Martin Wierich committed
940
941
942
943
			# cmp = smallerOrEqual t1 t2
			| cmp<>Equal
				= cmp
			= compare_types lifted_vars_with_types1 lifted_vars_with_types2
944
		compare_constructor_arguments (PR_Curried symb_ident1 _) (PR_Curried symb_ident2 _)
945
946
			= symb_ident1 =< symb_ident2
		compare_constructor_arguments PR_Empty PR_Empty
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
947
			= Equal
948
949
		compare_constructor_arguments PR_Unused PR_Unused
			= Equal
950
		compare_constructor_arguments (PR_Constructor symb_ident1 _ _) (PR_Constructor symb_ident2 _ _)
951
			= symb_ident1 =< symb_ident2
Martin Wierich's avatar
Martin Wierich committed
952
953
954
955
956
957
958
959
960
961
			
		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
		
962
963
964
/*
 *	UNIQUENESS STUFF...
 */
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
965

966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
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)
990

991
992
993
994
995
996
997
998
999
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

1000
substitute_attr_inequality {ai_offered, ai_demanded} th_attrs
For faster browsing, not all history is shown. View entire blame