trans.icl 267 KB
Newer Older
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
1
2
implementation module trans

3
import StdEnv, StdStrictLists
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
4

5
import syntax, transform, checksupport, compare_types, utilities, expand_types, unitype, type
6
import classify, partition
7
from StdOverloadedList import RepeatnM,TakeM,++$
8

9
SwitchCaseFusion			fuse dont_fuse :== fuse
10
11
SwitchGeneratedFusion		fuse dont_fuse :== fuse
SwitchFunctionFusion		fuse dont_fuse :== fuse
12
SwitchConstructorFusion		fuse fuse_generics dont_fuse :== fuse_generics
13
SwitchRnfConstructorFusion  rnf  linear	   :== rnf
14
SwitchCurriedFusion			fuse xtra dont_fuse :== fuse 
15
SwitchExtraCurriedFusion	fuse macro	   :== fuse//(fuse && macro)//fuse
16
SwitchTrivialFusion			fuse dont_fuse :== fuse
17
SwitchUnusedFusion			fuse dont_fuse :== fuse
18
SwitchTransformConstants	tran dont_tran :== tran
19
SwitchSpecialFusion			fuse dont_fuse :== fuse
20
21
22
SwitchArityChecks			check dont_check :== check
SwitchAutoFoldCaseInCase	fold dont	   :== fold
SwitchAutoFoldAppInCase		fold dont	   :== fold
23
SwitchAlwaysIntroduceCaseFunction yes no   :== no
24
25
26
SwitchNonRecFusion			fuse dont_fuse :== dont_fuse
SwitchHOFusion				fuse dont_fuse :== fuse
SwitchHOFusion`				fuse dont_fuse :== fuse
27
SwitchStrictPossiblyAddLet  strict lazy    :== lazy//strict
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
28

29
/*
30
(-!->) infix
31
32
33
(-!->) a b :== a  // ---> b
(<-!-) infix
(<-!-) a b :== a  // <--- b
34
*/
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53

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)
54
55
get_producer_symbol (PR_CurriedFunction symbol arity _)
	= (symbol,arity)
56
57

// 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)
71
		_							-> abort "Error in compiler: '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
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

122
//	TRANSFORM
123

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

141
142
:: RI = { ri_fun_index :: !Int, ri_fun_ptr :: !FunctionInfoPtr}

143
144
::	ReadOnlyTI = 
	{	ro_imported_funs	:: !{# {# FunType} }
145
	,	ro_common_defs		:: !{# CommonDefs }
146
147
// the following four are used when possibly generating functions for cases...
	,	ro_root_case_mode		:: !RootCaseMode
148
	,	ro_tfi					:: !TransformFunctionInfo
149
150
	,	ro_main_dcl_module_n 	:: !Int
	,	ro_transform_fusion		:: !Bool			// fusion switch
151
152
	,	ro_StdStrictLists_module_n :: !Int
	,	ro_StdGeneric_module_n	:: !Int
153
154
	}

155
156
157
158
159
160
::	TransformFunctionInfo =
	{	tfi_root				:: !SymbIdent		// original function
	,	tfi_case				:: !SymbIdent		// original function or possibly generated case
	,	tfi_args				:: ![FreeVar]		// args of above
	,	tfi_vars				:: ![FreeVar]		// strict variables
	,	tfi_orig				:: !SymbIdent		// original consumer
161
162
	,	tfi_n_args_before_producer :: !Int
	,	tfi_n_producer_args		:: !Int
163
164
	}

165
166
::	RootCaseMode = NotRootCase | RootCase | RootCaseOfZombie

167
168
169
170
::	CopyState = {
		cs_var_heap				:: !.VarHeap,
		cs_symbol_heap			:: !.ExpressionHeap,
		cs_opt_type_heaps		:: !.Optional .TypeHeaps,
171
172
173
		cs_cleanup_info			:: ![ExprInfoPtr]
	}

174
::	CopyInfo = { ci_handle_aci_free_vars	:: !AciFreeVarsHandleMode }
175
176
177

:: AciFreeVarsHandleMode = LeaveAciFreeVars | RemoveAciFreeVars | SubstituteAciFreeVars

178
179
180
neverMatchingCase (Yes ident)
	= FailExpr ident
neverMatchingCase _ 
181
	# ident = {id_name = "neverMatchingCase", id_info = nilPtr}
182
	= FailExpr ident
183

184
185
186
187
188
189
190
191
192
store_type_info_of_alg_pattern_in_pattern_variables ct_cons_types patterns var_heap
	= fold2St store_type_info_of_alg_pattern ct_cons_types patterns var_heap
	where
		store_type_info_of_alg_pattern var_types {ap_vars} var_heap
			= fold2St store_type_info_of_pattern_var 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

193
class transform a :: !a !ReadOnlyTI !*TransformInfo -> (!a, !*TransformInfo)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
194
195
196

instance transform Expression
where
197
	transform (App app=:{app_args}) ro ti
198
		# (app_args, ti) = transform app_args ro ti
199
		= transformApplication {app & app_args = app_args} [] ro ti
200
201
202
	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
203
204
		= case expr of
			App app
205
				-> transformApplication app exprs ro ti
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
206
207
			_
				-> (expr @ exprs, ti)
Sjaak Smetsers's avatar
Sjaak Smetsers committed
208
	transform (Let lad=:{let_strict_binds, let_lazy_binds, let_expr}) ro ti
209
		# ti = store_type_info_of_bindings_in_heap lad ti
Sjaak Smetsers's avatar
Sjaak Smetsers committed
210
211
		  (let_strict_binds, ti) = transform let_strict_binds ro ti
		  (let_lazy_binds, ti) = transform let_lazy_binds ro ti
212
		  (let_expr, ti) = transform let_expr ro ti
213
214
		  lad = { lad & let_lazy_binds = let_lazy_binds, let_strict_binds = let_strict_binds, let_expr = let_expr}
		= (Let lad, ti)
215
	  where
Sjaak Smetsers's avatar
Sjaak Smetsers committed
216
217
		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
218
			  (EI_LetType var_types, ti_symbol_heap) = readExprInfo let_info_ptr ti.ti_symbol_heap
219
			  ti_var_heap = foldSt store_type_info_let_bind (zip2 var_types let_binds) ti.ti_var_heap
220
			= {ti & ti_symbol_heap = ti_symbol_heap, ti_var_heap = ti_var_heap}
Diederik van Arkel's avatar
Diederik van Arkel committed
221
222
		store_type_info_let_bind (var_type, {lb_dst={fv_info_ptr}}) var_heap
			= setExtendedVarInfo fv_info_ptr (EVI_VarType var_type) var_heap
223

224
225
	transform (Case kees) ro ti
		# ti = store_type_info_of_patterns_in_heap kees ti
226
		= transformCase kees ro ti
227
228
229
230
	  where
		store_type_info_of_patterns_in_heap {case_guards,case_info_ptr} ti
			= case case_guards of
				AlgebraicPatterns _ patterns
231
232
					# (EI_CaseType {ct_cons_types},ti_symbol_heap) = readExprInfo case_info_ptr ti.ti_symbol_heap
					  ti_var_heap = store_type_info_of_alg_pattern_in_pattern_variables ct_cons_types patterns ti.ti_var_heap
233
234
235
					-> { ti & ti_symbol_heap = ti_symbol_heap, ti_var_heap = ti_var_heap }
				BasicPatterns _ _
					-> ti // no variables occur
236
				OverloadedListPatterns _ _ patterns
237
238
					# (EI_CaseType {ct_cons_types},ti_symbol_heap) = readExprInfo case_info_ptr ti.ti_symbol_heap
					  ti_var_heap = store_type_info_of_alg_pattern_in_pattern_variables ct_cons_types patterns ti.ti_var_heap
239
					-> { ti & ti_symbol_heap = ti_symbol_heap, ti_var_heap = ti_var_heap }
240
241
				NoPattern
					-> ti
Diederik van Arkel's avatar
Diederik van Arkel committed
242

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
285
	transform (IsConstructor expr cons_symbol cons_arity global_type_index case_ident position) ro ti
		# (expr,ti) = transform expr ro ti
		= (IsConstructor expr cons_symbol cons_arity global_type_index case_ident position, ti)
286
287
	transform (DynamicExpr dynamic_expr) ro ti
		# (dynamic_expr, ti) = transform dynamic_expr ro ti
288
		= (DynamicExpr dynamic_expr, ti)
289
290
291
	transform (DictionariesFunction dictionaries expr expr_type) ro ti
		# (expr,ti) = transform expr ro ti
		= (DictionariesFunction dictionaries expr expr_type,ti)
292
	transform expr ro ti
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
293
294
295
		= (expr, ti)

instance transform DynamicExpr where
296
297
	transform dyn=:{dyn_expr} ro ti
		# (dyn_expr, ti) = transform dyn_expr ro ti
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
298
299
		= ({dyn & dyn_expr = dyn_expr}, ti)

300
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
301
302
303
	| SwitchCaseFusion (not ro.ro_transform_fusion) True
		= skip_over this_case ro ti
	| isNilPtr case_info_ptr			// encountered neverMatchingCase?!
304
		= skip_over this_case ro ti
305
306
307
308
309
310
311
	# (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
312
313
314
315
316
317
									NotRootCase
										-> transform_active_non_root_case this_case aci ro ti
									_
										-> transform_active_root_case aci this_case ro ti
							_
								-> skip_over this_case ro ti
318
	  ti = { ti & ti_symbol_heap = remove_aci_free_vars_info case_info_ptr ti.ti_symbol_heap }
319
320
	# final_expr = removeNeverMatchingSubcases result_expr ro
	= (final_expr, ti) // ---> ("transformCase",result_expr,final_expr)
Diederik van Arkel's avatar
Diederik van Arkel committed
321
where
322
323
324
	is_variable (Var _) = True
	is_variable _ 		= False

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
skip_over this_case=:{case_expr=case_expr=:BasicExpr basic_value,case_guards=case_guards=:BasicPatterns basic_type basicPatterns,case_default} ro ti
	// currently only active cases are matched at runtime (multimatch problem)
	# matching_patterns = [pattern \\ pattern=:{bp_value}<-basicPatterns | bp_value==basic_value]
	= case matching_patterns of
		[]
			-> case case_default of
				Yes default_expr
					-> transform default_expr {ro & ro_root_case_mode = NotRootCase} ti
				No
					# ro_lost_root = {ro & ro_root_case_mode = NotRootCase}
					# (new_case_expr, ti) = transform case_expr ro_lost_root ti
					-> (Case {this_case & case_expr=new_case_expr, case_guards=BasicPatterns basic_type []}, ti)
/*
					// The following does not work, because a FailExpr may only occur as else of an if in the backend */
					# never_ident = case ro.ro_root_case_mode of
										NotRootCase -> this_case.case_ident
										_ -> Yes ro.ro_tfi.tfi_case.symb_ident
					-> (neverMatchingCase never_ident, ti)
*/
		[{bp_expr}]
			| case_alt_matches_always bp_expr ro
				-> transform bp_expr {ro & ro_root_case_mode = NotRootCase} 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)
Diederik van Arkel's avatar
Diederik van Arkel committed
353
354
355
356
357
358
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)
359

360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
case_alt_matches_always (Case {case_default,case_explicit,case_guards}) ro
	| case_explicit
		= True
		= case case_default of
			Yes _
				-> True
			_
				-> case case_guards of
					AlgebraicPatterns {gi_module,gi_index} algebraic_patterns
						-> case ro.ro_common_defs.[gi_module].com_type_defs.[gi_index].td_rhs of
							AlgType constructors
								| same_length constructors algebraic_patterns
									-> algebraic_patterns_match_always algebraic_patterns ro
							RecordType _
								-> algebraic_patterns_match_always algebraic_patterns ro
							_
								-> False
					_
						-> False
case_alt_matches_always (Let {let_expr}) ro
	= case_alt_matches_always let_expr ro
case_alt_matches_always _ ro
	= True

algebraic_patterns_match_always [{ap_expr}:algebraic_patterns] ro
	= case_alt_matches_always ap_expr ro && algebraic_patterns_match_always algebraic_patterns ro
algebraic_patterns_match_always [] ro
	= True

389
390
391
392
393
free_vars_to_bound_vars free_vars
	= [Var {var_ident = fv_ident, var_info_ptr = fv_info_ptr, var_expr_ptr = nilPtr} \\ {fv_ident,fv_info_ptr} <- free_vars]

transform_active_root_case aci this_case=:{case_expr = Case case_in_case} ro ti
	= lift_case case_in_case this_case ro ti
Diederik van Arkel's avatar
Diederik van Arkel committed
394
395
396
397
398
399
400
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
401
		  (case_guards, ti) = lift_patterns default_exists case_guards nested_case.case_info_ptr outer_case ro ti
Diederik van Arkel's avatar
Diederik van Arkel committed
402
403
404
405
406
407
408
409
410
411
412
413
414
		  (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

415
	lift_patterns default_exists (AlgebraicPatterns type case_guards) case_info_ptr outer_case ro ti
Diederik van Arkel's avatar
Diederik van Arkel committed
416
		# guard_exprs	= [ ap_expr \\ {ap_expr} <- case_guards ]
417
		  (EI_CaseType {ct_cons_types},symbol_heap) = readExprInfo case_info_ptr ti.ti_symbol_heap
418
419
420
		  var_heap = store_type_info_of_alg_pattern_in_pattern_variables ct_cons_types case_guards ti.ti_var_heap
		  ti = {ti & ti_symbol_heap=symbol_heap,ti_var_heap=var_heap}
		  (guard_exprs_with_case, ti) = lift_patterns_2 default_exists guard_exprs outer_case ro ti
Diederik van Arkel's avatar
Diederik van Arkel committed
421
		= (AlgebraicPatterns type [ { case_guard & ap_expr=guard_expr } \\ case_guard<-case_guards & guard_expr<-guard_exprs_with_case], ti)
422
	lift_patterns default_exists (BasicPatterns basic_type case_guards) case_info_ptr outer_case ro ti
Diederik van Arkel's avatar
Diederik van Arkel committed
423
		# guard_exprs	= [ bp_expr \\ {bp_expr} <- case_guards ]
424
		  (guard_exprs_with_case, ti) = lift_patterns_2 default_exists guard_exprs outer_case ro ti
Diederik van Arkel's avatar
Diederik van Arkel committed
425
		= (BasicPatterns basic_type [ { case_guard & bp_expr=guard_expr } \\ case_guard<-case_guards & guard_expr<-guard_exprs_with_case], ti)
426
	lift_patterns default_exists (OverloadedListPatterns type decons_expr case_guards) case_info_ptr outer_case ro ti
Diederik van Arkel's avatar
Diederik van Arkel committed
427
		# guard_exprs	= [ ap_expr \\ {ap_expr} <- case_guards ]
428
429
430
431
		  (EI_CaseType {ct_cons_types},symbol_heap) = readExprInfo case_info_ptr ti.ti_symbol_heap
		  var_heap = store_type_info_of_alg_pattern_in_pattern_variables ct_cons_types case_guards ti.ti_var_heap
		  ti = {ti & ti_symbol_heap=symbol_heap,ti_var_heap=var_heap}
		  (guard_exprs_with_case, ti) = lift_patterns_2 default_exists guard_exprs outer_case ro ti
Diederik van Arkel's avatar
Diederik van Arkel committed
432
433
434
435
		= (OverloadedListPatterns type decons_expr [ { case_guard & ap_expr=guard_expr } \\ case_guard<-case_guards & guard_expr<-guard_exprs_with_case], ti)

	lift_patterns_2 False [guard_expr] outer_case ro ti
		// if no default pattern exists, then the outer case expression does not have to be copied for the last pattern
Diederik van Arkel's avatar
Diederik van Arkel committed
436
		# (guard_expr, ti)						= possiblyFoldOuterCase True guard_expr outer_case ro ti
Diederik van Arkel's avatar
Diederik van Arkel committed
437
438
		= ([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
439
		# (guard_expr, ti)						= possiblyFoldOuterCase False guard_expr outer_case ro ti
Diederik van Arkel's avatar
Diederik van Arkel committed
440
441
442
443
		  (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
444
		
Diederik van Arkel's avatar
Diederik van Arkel committed
445
	lift_default (Yes default_expr) outer_case ro ti
Diederik van Arkel's avatar
Diederik van Arkel committed
446
		# (default_expr, ti)					= possiblyFoldOuterCase True default_expr outer_case ro ti
Diederik van Arkel's avatar
Diederik van Arkel committed
447
448
449
450
		= (Yes default_expr, ti)
	lift_default No _ _ ti
		= (No, ti)

451
	possiblyFoldOuterCase final guard_expr outer_case ro=:{ro_tfi} ti
452
		| SwitchAutoFoldCaseInCase (isFoldExpression guard_expr ti.ti_fun_defs ti.ti_cons_args) False // otherwise GOTO next alternative
453
			| ro_tfi.tfi_n_args_before_producer < 0 || ro_tfi.tfi_n_producer_args < 0
454
				= possiblyFoldOuterCase` final guard_expr outer_case ro ti	//abort "possiblyFoldOuterCase: unexpected!\n"
455
456
457
458
459
			= case aci.aci_opt_unfolder of
				No
					-> possiblyFoldOuterCase` final guard_expr outer_case ro ti
				Yes _
					-> transformApplication (make_consumer_application ro_tfi guard_expr) [] ro ti
460
		= possiblyFoldOuterCase` final guard_expr outer_case ro ti
Diederik van Arkel's avatar
Diederik van Arkel committed
461
	where
462
		isFoldExpression (App app)	ti_fun_defs ti_cons_args = isFoldSymbol app.app_symb.symb_kind
463
464
			where
				isFoldSymbol (SK_Function {glob_module,glob_object})
465
					| glob_module==ro.ro_StdStrictLists_module_n
466
467
468
						# type_arity = ro.ro_imported_funs.[glob_module].[glob_object].ft_type.st_arity
						| type_arity==0 || (type_arity==2 && case app.app_args of [_:_] -> True; _ -> False)
							= False
469
470
471
472
473
474
							= True
					| glob_module==ro.ro_main_dcl_module_n && glob_object>=size ti_cons_args &&
						(ti_fun_defs.[glob_object].fun_info.fi_properties bitand FI_IsUnboxedListOfRecordsConsOrNil<>0) &&
							(case ti_fun_defs.[glob_object].fun_type of
								Yes type ->(type.st_arity==0 || (type.st_arity==2 && case app.app_args of [_:_] -> True; _ -> False)))
							= False						
475
476
477
478
						= True
				isFoldSymbol (SK_LocalMacroFunction _)	= True
				isFoldSymbol (SK_GeneratedFunction _ _)	= True
				isFoldSymbol _							= False
479
480
481
		isFoldExpression (Var _)	ti_fun_defs ti_cons_args = True
//		isFoldExpression (Case _)	ti_fun_defs ti_cons_args = True
		isFoldExpression _			ti_fun_defs ti_cons_args = False
482

483
	possiblyFoldOuterCase` final guard_expr outer_case ro ti
Diederik van Arkel's avatar
Diederik van Arkel committed
484
		| final
485
486
			# new_case = {outer_case & case_expr = guard_expr}
			= transformCase new_case ro ti // ---> ("possiblyFoldOuterCase`",Case new_case)
487
		# cs = {cs_var_heap = ti.ti_var_heap, cs_symbol_heap = ti.ti_symbol_heap, cs_opt_type_heaps = No, cs_cleanup_info=ti.ti_cleanup_info}
488
		  (outer_guards, cs=:{cs_cleanup_info})	= copyCasePatterns outer_case.case_guards No {ci_handle_aci_free_vars = LeaveAciFreeVars} cs
489
		  (expr_info, ti_symbol_heap)			= readPtr outer_case.case_info_ptr cs.cs_symbol_heap
Diederik van Arkel's avatar
Diederik van Arkel committed
490
		  (new_info_ptr, ti_symbol_heap)		= newPtr expr_info ti_symbol_heap
491
		  new_cleanup_info 						= case expr_info of
Diederik van Arkel's avatar
Diederik van Arkel committed
492
		  		EI_Extended _ _
493
494
495
		  			-> [new_info_ptr:cs_cleanup_info]
		  		_ 	-> cs_cleanup_info
		  ti = { ti & ti_var_heap = cs.cs_var_heap, ti_symbol_heap = ti_symbol_heap, ti_cleanup_info=new_cleanup_info }
Diederik van Arkel's avatar
Diederik van Arkel committed
496
		  new_case								= { outer_case & case_expr = guard_expr, case_guards=outer_guards, case_info_ptr=new_info_ptr }
497
		= transformCase new_case ro ti // ---> ("possiblyFoldOuterCase`",Case new_case)
498

499
transform_active_root_case aci this_case=:{case_expr = case_expr=:(App app=:{app_symb,app_args}),case_guards,case_default,case_explicit,case_ident} ro ti
Diederik van Arkel's avatar
Diederik van Arkel committed
500
501
	= case app_symb.symb_kind of
		SK_Constructor cons_index
502
503
			// currently only active cases are matched at runtime (multimatch problem)
			# aci_linearity_of_patterns = aci.aci_linearity_of_patterns
504
505
506
			  (may_be_match_expr, ti) = match_and_instantiate aci_linearity_of_patterns cons_index app_args case_guards case_default ro ti
			-> expr_or_never_matching_case may_be_match_expr case_ident ti
		SK_Function {glob_module,glob_object}
507
			| glob_module==ro.ro_StdStrictLists_module_n &&
508
509
510
				(let type = ro.ro_imported_funs.[glob_module].[glob_object].ft_type
				 in (type.st_arity==0 || (type.st_arity==2 && case app_args of [_:_] -> True; _ -> False)))
				# type = ro.ro_imported_funs.[glob_module].[glob_object].ft_type
511
512
				-> trans_case_of_overloaded_nil_or_cons type ti
			| glob_module==ro.ro_main_dcl_module_n && glob_object>=size ti.ti_cons_args &&
513
				(ti.ti_fun_defs.[glob_object].fun_info.fi_properties bitand FI_IsUnboxedListOfRecordsConsOrNil)<>0 &&
514
515
516
517
				(case ti.ti_fun_defs.[glob_object].fun_type of
					Yes type ->(type.st_arity==0 || (type.st_arity==2 && case app_args of [_:_] -> True; _ -> False)))
				# (Yes type,ti) = ti!ti_fun_defs.[glob_object].fun_type
				-> trans_case_of_overloaded_nil_or_cons type ti
Diederik van Arkel's avatar
Diederik van Arkel committed
518
		// otherwise it's a function application
519
520
521
522
		_
			# {aci_params,aci_opt_unfolder} = aci
			-> case aci_opt_unfolder of
				No
523
					-> skip_over this_case ro ti									// -!-> ("transform_active_root_case","No opt unfolder")
524
525
526
				Yes unfolder
					| not (equal app_symb.symb_kind unfolder.symb_kind)
						// in this case a third function could be fused in
527
						-> possiblyFoldOuterCase this_case ro ti					// -!-> ("transform_active_root_case","Diff opt unfolder",unfolder,app_symb)
528
					# variables = [ Var {var_ident=fv_ident, var_info_ptr=fv_info_ptr, var_expr_ptr=nilPtr}
529
									\\ {fv_ident, fv_info_ptr} <- ro.ro_tfi.tfi_args ]
530
					  (app_symb, ti)
531
						= case ro.ro_root_case_mode /* -!-> ("transform_active_root_case","Yes opt unfolder",unfolder) */ of
532
533
							RootCaseOfZombie
								# (recursion_introduced,ti) = ti!ti_recursion_introduced
534
								  (ro_fun=:{symb_kind=SK_GeneratedFunction fun_info_ptr _}) = ro.ro_tfi.tfi_case
535
536
537
538
								-> case recursion_introduced of
									No
										# (ti_next_fun_nr, ti) = ti!ti_next_fun_nr
										  ri = {ri_fun_index=ti_next_fun_nr, ri_fun_ptr=fun_info_ptr}
539
540
541
										  ti & ti_next_fun_nr = inc ti_next_fun_nr, ti_recursion_introduced = Yes ri,
										  	   ti_new_functions = [fun_info_ptr:ti.ti_new_functions]
										-> ({ro_fun & symb_kind=SK_GeneratedFunction fun_info_ptr ti_next_fun_nr}, ti)
542
//											-!-> ("Recursion","RootCaseOfZombie",ti_next_fun_nr,recursion_introduced)
543
544
545
546
									Yes {ri_fun_index,ri_fun_ptr}
										| ri_fun_ptr==fun_info_ptr
											-> ({ro_fun & symb_kind=SK_GeneratedFunction fun_info_ptr ri_fun_index},ti)
							RootCase
547
								-> (ro.ro_tfi.tfi_root,{ti & ti_recursion_introduced = No})
548
//									-!-> ("Recursion","RootCase",ro.ro_tfi.tfi_root)
549
550
551
					  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)
Diederik van Arkel's avatar
Diederik van Arkel committed
552
where
553
	possiblyFoldOuterCase this_case ro=:{ro_tfi} ti
Diederik van Arkel's avatar
Diederik van Arkel committed
554
		| SwitchAutoFoldAppInCase True False
555
			| ro_tfi.tfi_n_args_before_producer < 0 || ro_tfi.tfi_n_producer_args < 0
556
				= skip_over this_case ro ti	//abort "possiblyFoldOuterCase: unexpected!\n"
557
			= transformApplication (make_consumer_application ro_tfi case_expr) [] ro ti
Diederik van Arkel's avatar
Diederik van Arkel committed
558
559
		= skip_over this_case ro ti

Diederik van Arkel's avatar
Diederik van Arkel committed
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
	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

585
586
587
	match_and_instantiate linearities cons_index app_args (AlgebraicPatterns _ algebraicPatterns) case_default ro ti
		= match_and_instantiate_algebraic_type linearities cons_index app_args algebraicPatterns case_default ro ti
		where
588
			match_and_instantiate_algebraic_type [!linearity:linearities!] cons_index app_args
589
												 [{ap_symbol={glob_module,glob_object={ds_index}}, ap_vars, ap_expr} : guards] case_default ro ti
590
591
				| cons_index.glob_module == glob_module && cons_index.glob_object == ds_index
					# {cons_type} = ro.ro_common_defs.[glob_module].com_cons_defs.[ds_index]
592
					= instantiate linearity app_args ap_vars ap_expr cons_type.st_args_strictness cons_type.st_args ti
593
594
595
596
597
598
				= match_and_instantiate_algebraic_type linearities cons_index app_args guards case_default ro ti
			match_and_instantiate_algebraic_type _ cons_index app_args [] case_default ro ti
				= transform case_default { ro & ro_root_case_mode = NotRootCase } ti
	match_and_instantiate linearities cons_index app_args (OverloadedListPatterns (OverloadedList _ _ _ _) _ algebraicPatterns) case_default ro ti
		= match_and_instantiate_overloaded_list linearities cons_index app_args algebraicPatterns case_default ro ti
		where
599
			match_and_instantiate_overloaded_list [!linearity:linearities!] cons_index=:{glob_module=cons_glob_module,glob_object=cons_ds_index} app_args 
600
601
									[{ap_symbol={glob_module,glob_object={ds_index}}, ap_vars, ap_expr} : guards] 
									case_default ro ti
602
603
604
				| equal_list_contructor glob_module ds_index cons_glob_module cons_ds_index
					# {cons_type} = ro.ro_common_defs.[cons_glob_module].com_cons_defs.[cons_ds_index]
					= instantiate linearity app_args ap_vars ap_expr cons_type.st_args_strictness cons_type.st_args ti
605
606
					= match_and_instantiate_overloaded_list linearities cons_index app_args guards case_default ro ti
					where
607
						equal_list_contructor glob_module ds_index cons_glob_module cons_ds_index
608
609
610
611
							| glob_module==cPredefinedModuleIndex && cons_glob_module==cPredefinedModuleIndex
								# index=ds_index+FirstConstructorPredefinedSymbolIndex
								# cons_index=cons_ds_index+FirstConstructorPredefinedSymbolIndex
								| index==PD_OverloadedConsSymbol
612
									= cons_index==PD_ConsSymbol || cons_index==PD_StrictConsSymbol || cons_index==PD_TailStrictConsSymbol || cons_index==PD_StrictTailStrictConsSymbol
613
								| index==PD_OverloadedNilSymbol
614
									= cons_index==PD_NilSymbol || cons_index==PD_StrictNilSymbol || cons_index==PD_TailStrictNilSymbol || cons_index==PD_StrictTailStrictNilSymbol
615
616
617
									= abort "equal_list_contructor"
			match_and_instantiate_overloaded_list _ cons_index app_args [] case_default ro ti
				= transform case_default { ro & ro_root_case_mode = NotRootCase } ti
618

619
620
621
622
	trans_case_of_overloaded_nil_or_cons type ti
		| type.st_arity==0
			# (may_be_match_expr, ti) = match_and_instantiate_overloaded_nil case_guards case_default ro ti
			= expr_or_never_matching_case may_be_match_expr case_ident ti
623
			# aci_linearity_of_patterns = aci.aci_linearity_of_patterns
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
			  (may_be_match_expr, ti) = match_and_instantiate_overloaded_cons type aci_linearity_of_patterns app_args case_guards case_default ro ti
			= expr_or_never_matching_case may_be_match_expr case_ident ti
	where
		match_and_instantiate_overloaded_nil (OverloadedListPatterns _ _ algebraicPatterns) case_default ro ti
			= match_and_instantiate_nil algebraicPatterns case_default ro ti
		match_and_instantiate_overloaded_nil (AlgebraicPatterns _ algebraicPatterns) case_default ro ti
			= match_and_instantiate_nil algebraicPatterns case_default ro ti
	
		match_and_instantiate_nil [{ap_symbol={glob_module,glob_object={ds_index}},ap_expr} : guards] case_default ro ti
			| glob_module==cPredefinedModuleIndex
				# index=ds_index+FirstConstructorPredefinedSymbolIndex
				| index==PD_NilSymbol || index==PD_StrictNilSymbol || index==PD_TailStrictNilSymbol || index==PD_StrictTailStrictNilSymbol ||
				  index==PD_OverloadedNilSymbol || index==PD_UnboxedNilSymbol || index==PD_UnboxedTailStrictNilSymbol
					= instantiate [] [] [] ap_expr NotStrict [] ti
					= match_and_instantiate_nil guards case_default ro ti
		match_and_instantiate_nil [] case_default ro ti
			= transform case_default { ro & ro_root_case_mode = NotRootCase } ti
	
		match_and_instantiate_overloaded_cons cons_function_type linearities app_args (AlgebraicPatterns _ algebraicPatterns) case_default ro ti
			= match_and_instantiate_overloaded_cons_boxed_match linearities app_args algebraicPatterns case_default ro ti
			where
645
				match_and_instantiate_overloaded_cons_boxed_match [!linearity:linearities!] app_args
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
										[{ap_symbol={glob_module,glob_object={ds_index}}, ap_vars, ap_expr} : guards] 
										case_default ro ti
					| glob_module==cPredefinedModuleIndex
						# index=ds_index+FirstConstructorPredefinedSymbolIndex
						| index==PD_ConsSymbol || index==PD_StrictConsSymbol || index==PD_TailStrictConsSymbol || index==PD_StrictTailStrictConsSymbol
							# {cons_type} = ro.ro_common_defs.[glob_module].com_cons_defs.[ds_index]
							= instantiate linearity app_args ap_vars ap_expr cons_type.st_args_strictness cons_type.st_args ti
		//				| index==PD_NilSymbol || index==PD_StrictNilSymbol || index==PD_TailStrictNilSymbol || index==PD_StrictTailStrictNilSymbol
							= match_and_instantiate_overloaded_cons_boxed_match linearities app_args guards case_default ro ti
		//					= abort "match_and_instantiate_overloaded_cons_boxed_match"
				match_and_instantiate_overloaded_cons_boxed_match _ app_args [] case_default ro ti
					= transform case_default { ro & ro_root_case_mode = NotRootCase } ti
		match_and_instantiate_overloaded_cons cons_function_type linearities app_args (OverloadedListPatterns _ _ algebraicPatterns) case_default ro ti
			= match_and_instantiate_overloaded_cons_overloaded_match linearities app_args algebraicPatterns case_default ro ti
			where
661
				match_and_instantiate_overloaded_cons_overloaded_match [!linearity:linearities!] app_args
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
										[{ap_symbol={glob_module,glob_object={ds_index}}, ap_vars, ap_expr} : guards] 
										case_default ro ti
					| glob_module==cPredefinedModuleIndex
						# index=ds_index+FirstConstructorPredefinedSymbolIndex
						| index==PD_UnboxedConsSymbol || index==PD_UnboxedTailStrictConsSymbol || index==PD_OverloadedConsSymbol
							= instantiate linearity app_args ap_vars ap_expr cons_function_type.st_args_strictness cons_function_type.st_args ti
		//				| index==PD_UnboxedNilSymbol || index==PD_UnboxedTailStrictNilSymbol || index==PD_OverloadedNilSymbol
							= match_and_instantiate_overloaded_cons_overloaded_match linearities app_args guards case_default ro ti
		//					= abort "match_and_instantiate_overloaded_cons_overloaded_match"
				match_and_instantiate_overloaded_cons_overloaded_match _ app_args [] case_default ro ti
					= transform case_default { ro & ro_root_case_mode = NotRootCase } ti
	
		/*
		match_and_instantiate_overloaded_cons linearities app_args (OverloadedListPatterns _ (App {app_args=[],app_symb={symb_kind=SK_Function {glob_module=decons_module,glob_object=deconsindex}}}) algebraicPatterns) case_default ro ti
			= match_and_instantiate_overloaded_cons_overloaded_match linearities app_args algebraicPatterns case_default ro ti
			where
				match_and_instantiate_overloaded_cons_overloaded_match [linearity:linearities] app_args 
										[{ap_symbol={glob_module,glob_object={ds_index}}, ap_vars, ap_expr} : guards] 
										case_default ro ti
					| glob_module==cPredefinedModuleIndex
						# index=ds_index+FirstConstructorPredefinedSymbolIndex
						| index==PD_UnboxedConsSymbol || index==PD_UnboxedTailStrictConsSymbol || index==PD_OverloadedConsSymbol
							# (argument_types,strictness) = case ro.ro_imported_funs.[decons_module].[deconsindex].ft_type.st_result.at_type of
													TA _ args=:[arg1,arg2] -> (args,NotStrict)
													TAS _ args=:[arg1,arg2] strictness -> (args,strictness)
							= instantiate linearity app_args ap_vars ap_expr strictness argument_types ti
						| index==PD_UnboxedNilSymbol || index==PD_UnboxedTailStrictNilSymbol || index==PD_OverloadedNilSymbol
							= match_and_instantiate_overloaded_cons_overloaded_match linearities app_args guards case_default ro ti
							= abort "match_and_instantiate_overloaded_cons_overloaded_match"
				match_and_instantiate_overloaded_cons_overloaded_match [linearity:linearities] app_args [guard : guards] case_default ro ti
					= match_and_instantiate_overloaded_cons_overloaded_match linearities app_args guards case_default ro ti
				match_and_instantiate_overloaded_cons_overloaded_match _ app_args [] case_default ro ti
					= transform case_default { ro & ro_root_case_mode = NotRootCase } ti
		*/
696
697

	instantiate linearity app_args ap_vars ap_expr cons_type_args_strictness cons_type_args ti
698
		# zipped_ap_vars_and_args = zip2 ap_vars app_args
699
700
		  (body_strictness,ti_fun_defs,ti_fun_heap) = body_strict ap_expr ap_vars ro ti.ti_fun_defs ti.ti_fun_heap
		  ti = {ti & ti_fun_defs = ti_fun_defs, ti_fun_heap = ti_fun_heap}
701
		  unfoldables = [ (arg_is_strict i body_strictness || ((not (arg_is_strict i cons_type_args_strictness))) && linear) || in_normal_form app_arg
702
		  				 \\ linear <|- linearity & app_arg <- app_args & i <- [0..]]
703
		  unfoldable_args = filterWith unfoldables zipped_ap_vars_and_args
704
705
		  not_unfoldable = map not unfoldables
		  ti_var_heap = foldSt (\({fv_info_ptr}, arg) -> writeVarInfo fv_info_ptr (VI_Expression arg)) unfoldable_args ti.ti_var_heap
706
		  (new_expr, ti_symbol_heap) = possibly_add_let zipped_ap_vars_and_args ap_expr not_unfoldable cons_type_args ro ti.ti_symbol_heap cons_type_args_strictness
707
		  copy_state = { cs_var_heap = ti_var_heap, cs_symbol_heap = ti_symbol_heap, cs_opt_type_heaps = No,cs_cleanup_info=ti.ti_cleanup_info }
708
		  (unfolded_expr, copy_state) = copy new_expr {ci_handle_aci_free_vars = LeaveAciFreeVars} copy_state
709
		  ti_var_heap = foldSt (\({fv_info_ptr}, arg) -> writeVarInfo fv_info_ptr VI_Empty) unfoldable_args copy_state.cs_var_heap
710
		  ti & ti_var_heap = ti_var_heap,ti_symbol_heap = copy_state.cs_symbol_heap,ti_cleanup_info=copy_state.cs_cleanup_info
711
		  (final_expr, ti) = transform unfolded_expr { ro & ro_root_case_mode = NotRootCase } ti
712
//		| False ---> ("instantiate",app_args,ap_vars,ap_expr,final_expr,unfoldables) = undef
713
		= (Yes final_expr, ti)
714
715
716
717
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
746
747
748
749
	where
		body_strict (Var v) ap_vars ro fun_defs fun_heap
			# lazy_args = insert_n_lazy_values_at_beginning (length app_args) NotStrict
			# is = [i \\ i <- [0..] & var <- ap_vars | v.var_info_ptr == var.fv_info_ptr]
			= case is of
				[]		-> (lazy_args,fun_defs,fun_heap)
				[i:_]	-> (add_strictness i lazy_args,fun_defs,fun_heap)
		body_strict (App app) ap_vars ro fun_defs fun_heap
			# (is,fun_defs,fun_heap) = app_indices app ro fun_defs fun_heap
			# lazy_args = insert_n_lazy_values_at_beginning (length app_args) NotStrict
			= (seq (map add_strictness is) lazy_args, fun_defs,fun_heap)
		body_strict _ _ ro fun_defs fun_heap
			# lazy_args = insert_n_lazy_values_at_beginning (length app_args) NotStrict
			= (lazy_args,fun_defs,fun_heap)
		
		app_indices {app_symb,app_args} ro fun_defs fun_heap
			# ({st_args_strictness,st_arity},fun_defs,fun_heap)	= get_producer_type app_symb ro fun_defs fun_heap
			| length app_args == st_arity
				= find_indices st_args_strictness 0 app_args ro fun_defs fun_heap
				= ([],fun_defs,fun_heap)
		where
			find_indices st_args_strictness i [] ro fun_defs fun_heap
				= ([],fun_defs,fun_heap)
			find_indices st_args_strictness i [e:es] ro fun_defs fun_heap
				# (is,fun_defs,fun_heap)	= find_index st_args_strictness i e ro fun_defs fun_heap
				# (iss,fun_defs,fun_heap)	= find_indices st_args_strictness (i+1) es ro fun_defs fun_heap
				= (is++iss,fun_defs,fun_heap)

			find_index st_args_strictness i e ro fun_defs fun_heap
				| arg_is_strict i st_args_strictness
					= case e of
						Var v	-> ([i \\ i <- [0..] & var <- ap_vars | v.var_info_ptr == var.fv_info_ptr],fun_defs,fun_heap)
						App	a	-> app_indices a ro fun_defs fun_heap
						_		-> ([],fun_defs,fun_heap)
				= ([],fun_defs,fun_heap)
		
750
751
752
	expr_or_never_matching_case (Yes match_expr) case_ident ti
		= (match_expr, ti)
	expr_or_never_matching_case No case_ident ti
753
		= (neverMatchingCase never_ident, ti) // <-!- ("transform_active_root_case:App:neverMatchingCase",never_ident)
754
755
756
		where
			never_ident = case ro.ro_root_case_mode of
							NotRootCase -> case_ident
757
							_ -> Yes ro.ro_tfi.tfi_case.symb_ident
758

759
transform_active_root_case aci this_case=:{case_expr=case_expr=:BasicExpr basic_value,case_guards=case_guards=:BasicPatterns _ basicPatterns,case_default} ro ti
760
	// currently only active cases are matched at runtime (multimatch problem)
761
762
763
764
765
766
767
768
	# matching_patterns = [pattern \\ pattern=:{bp_value}<-basicPatterns | bp_value==basic_value]
	= case matching_patterns of
		[]
			-> case case_default of
				Yes default_expr
					-> transform default_expr { ro & ro_root_case_mode = NotRootCase } ti
				No
					-> (neverMatchingCase never_ident, ti)
769
770
771
					with
						never_ident = case ro.ro_root_case_mode of
							NotRootCase -> this_case.case_ident
772
							_ -> Yes ro.ro_tfi.tfi_case.symb_ident
773
774
		[{bp_expr}:_]
			-> transform bp_expr {ro & ro_root_case_mode = NotRootCase} ti
775

776
transform_active_root_case aci this_case=:{case_expr = (Let lad)} ro ti
Diederik van Arkel's avatar
Diederik van Arkel committed
777
778
779
780
781
782
	# 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)

783
transform_active_root_case aci this_case ro ti
Diederik van Arkel's avatar
Diederik van Arkel committed
784
	= skip_over this_case ro ti
785
786
787
788
789

make_consumer_application {tfi_orig,tfi_args,tfi_n_args_before_producer=bef,tfi_n_producer_args=act} arg_expr
	# args = free_vars_to_bound_vars (take bef tfi_args) ++ [arg_expr : free_vars_to_bound_vars (drop (bef+act) tfi_args)]
	= {app_symb = tfi_orig, app_args = args, app_info_ptr = nilPtr}

790
791
792
793
794
795
796
797
798
799
800
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 _ _
	= []

801
possibly_add_let [] ap_expr _ _ _ ti_symbol_heap cons_type_args_strictness
802
	= (ap_expr, ti_symbol_heap)
803
possibly_add_let zipped_ap_vars_and_args ap_expr not_unfoldable cons_type_args ro ti_symbol_heap cons_type_args_strictness
804
	# let_type = filterWith not_unfoldable cons_type_args
805
	  (new_info_ptr, ti_symbol_heap) = newPtr (EI_LetType let_type) ti_symbol_heap
806
	= SwitchStrictPossiblyAddLet
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
		(let
			strict_binds	= [ {lb_src=lb_src, lb_dst=lb_dst, lb_position = NoPos}
									\\ (lb_dst,lb_src)<-zipped_ap_vars_and_args
									& n <- not_unfoldable
									& i <- [0..]
									| n && arg_is_strict i cons_type_args_strictness
									]
			lazy_binds		= [ {lb_src=lb_src, lb_dst=lb_dst, lb_position = NoPos}
									\\ (lb_dst,lb_src)<-zipped_ap_vars_and_args
									& n <- not_unfoldable
									& i <- [0..]
									| n && not (arg_is_strict i cons_type_args_strictness)
									]
		 in
		 	case (strict_binds,lazy_binds) of
		 		([],[])
		 			->	ap_expr
		 		_
		 			->	Let
						{	let_strict_binds	= strict_binds
						,	let_lazy_binds		= lazy_binds
						,	let_expr			= ap_expr
						,	let_info_ptr		= new_info_ptr
						,	let_expr_position	= NoPos
						}
832
833
	  , ti_symbol_heap
	  ) 
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
	  (let
			lazy_binds		= [ {lb_src=lb_src, lb_dst=lb_dst, lb_position = NoPos}
									\\ (lb_dst,lb_src)<-zipped_ap_vars_and_args
									& n <- not_unfoldable
									| n
									]
	   in
			case lazy_binds of
				[]
					-> ap_expr
				_
					-> Let
		  			 	{	let_strict_binds	= []
						,	let_lazy_binds		= lazy_binds
						,	let_expr			= ap_expr
						,	let_info_ptr		= new_info_ptr
						,	let_expr_position	= NoPos
						}
852
	  , ti_symbol_heap
853
854
	  )

855
856
857
858
859
860
861
free_variables_of_expression expr ti
	# ti_var_heap = clearVariables expr 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 expr fvi
	  ti = {ti & ti_var_heap = fvi_var_heap, ti_symbol_heap = fvi_expr_heap, ti_cleanup_info = fvi_expr_ptrs}
	 = (fvi_variables,ti)

862
transform_active_non_root_case :: !Case !ActiveCaseInfo !ReadOnlyTI !*TransformInfo -> *(!Expression, !*TransformInfo)
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
transform_active_non_root_case kees=:{case_info_ptr,case_expr = App {app_symb}} aci=:{aci_free_vars} ro ti=:{ti_recursion_introduced=old_ti_recursion_introduced}
	| not aci.aci_safe
		= skip_over kees ro ti
	| is_safe_producer app_symb.symb_kind ro ti.ti_fun_heap ti.ti_cons_args
		// determine free variables	
		# (free_vars,ti) = free_variables_of_expression (Case {kees & case_expr=EE}) ti	
		// 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_tfi.tfi_root.symb_kind ti.ti_cons_args ti.ti_fun_defs ti.ti_fun_heap
		  outer_arguments
		  		= case outer_fun_def.fun_body of
								TransformedBody {tb_args} 	-> tb_args
								Expanding args				-> args
		  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_ident = var_ident, fv_info_ptr = var_info_ptr, fv_count = undeff}
								\\ {var_ident, var_info_ptr} <- free_vars | not (isMember var_info_ptr outer_info_ptrs)]
		  all_args = lifted_arguments++arguments_from_outer_fun
		| SwitchArityChecks (1+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 }
			| ro.ro_transform_fusion
				# ti = { ti & ti_error_file = ti.ti_error_file <<< "Possibly missed fusion oppurtunity: Case Arity > 32 " <<< ro.ro_tfi.tfi_root.symb_ident.id_name <<< "\n"}
				= skip_over kees ro ti
			= skip_over kees ro ti
		# (fun_info_ptr, ti_fun_heap) = newPtr FI_Empty ti_fun_heap
		  fun_ident = { id_name = ro.ro_tfi.tfi_root.symb_ident.id_name+++"_case", id_info = nilPtr }
892
		  fun_symb = { symb_ident = fun_ident, symb_kind=SK_GeneratedFunction fun_info_ptr undeff }
893
894
895
896
897
898
		# ti = { ti & ti_cons_args = ti_cons_args, ti_fun_defs = ti_fun_defs, ti_fun_heap = ti_fun_heap }
//				---> ("lifted arguments",[fv_ident\\{fv_ident}<-lifted_arguments],outer_arguments,
//					'\n',kees.case_expr,kees.case_guards,kees.case_default)
	  	# fun_index = ti.ti_next_fun_nr
	  	# ti = { ti & ti_next_fun_nr = fun_index + 1 }
		// JvG: why are dictionaries not the first arguments ?
899
900
		# new_ro = { ro & ro_root_case_mode = RootCaseOfZombie, ro_tfi.tfi_case = fun_symb, ro_tfi.tfi_args = all_args }
		= generate_case_function_with_pattern_argument fun_index case_info_ptr (Case kees) outer_fun_def outer_cons_args used_mask fun_symb all_args ti
901

902
transform_active_non_root_case kees=:{case_info_ptr} aci=:{aci_free_vars} ro ti=:{ti_recursion_introduced=old_ti_recursion_introduced}
903
904
	| not aci.aci_safe
		= skip_over kees ro ti
905
	// determine free variables
906
	# (free_vars,ti) = free_variables_of_expression (Case kees) ti	
907
908
	// search function definition and consumer arguments
	  (outer_fun_def, outer_cons_args, ti_cons_args, ti_fun_defs, ti_fun_heap)
909
			= get_fun_def_and_cons_args ro.ro_tfi.tfi_root.symb_kind ti.ti_cons_args ti.ti_fun_defs ti.ti_fun_heap
910
911
	  outer_arguments
	  		= case outer_fun_def.fun_body of
912
913
							TransformedBody {tb_args} 	-> tb_args
							Expanding args				-> args
914
915
916
917
	  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 ]
918
	  lifted_arguments
919
920
	  		= [ { fv_def_level = undeff, fv_ident = var_ident, fv_info_ptr = var_info_ptr, fv_count = undeff}
							\\ {var_ident, var_info_ptr} <- free_vars | not (isMember var_info_ptr outer_info_ptrs)]
921
	  all_args = lifted_arguments++arguments_from_outer_fun
Diederik van Arkel's avatar
Diederik van Arkel committed
922
	| SwitchArityChecks (length all_args > 32) False
923
		# ti = { ti & ti_cons_args = ti_cons_args, ti_fun_defs = ti_fun_defs, ti_fun_heap = ti_fun_heap, ti_recursion_introduced = No }
924
		| ro.ro_transform_fusion
925
			#  ti	= { ti & ti_error_file = ti.ti_error_file <<< "Possibly missed fusion oppurtunity: Case Arity > 32 " <<< ro.ro_tfi.tfi_root.symb_ident.id_name <<< "\n"}
926
			= skip_over kees ro ti
Diederik van Arkel's avatar
Diederik van Arkel committed
927
		= skip_over kees ro ti
928
	# (fun_info_ptr, ti_fun_heap) = newPtr FI_Empty ti_fun_heap
929
	  fun_ident = { id_name = ro.ro_tfi.tfi_root.symb_ident.id_name+++"_case", id_info = nilPtr }
930
931
	  fun_symb = { symb_ident = fun_ident, symb_kind=SK_GeneratedFunction fun_info_ptr undeff }
//					<-!- ("<<<transformCaseFunction",fun_symb)
932