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

import StdEnv

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

31
32
//import RWSDebug

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_vars				:: ![FreeVar]		// strict variables
153
	,	ro_fun_geni				:: !(!Int,!Int)
154
	,	ro_fun_orig				:: !SymbIdent		// original consumer
155
156
157
158
159

	,	ro_main_dcl_module_n 	:: !Int

	,	ro_transform_fusion		:: !Bool			// fusion switch

160
	,	ro_stdStrictLists_module_n :: !Int
161
162
	}

163
164
::	RootCaseMode = NotRootCase | RootCase | RootCaseOfZombie

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

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

217
218
	transform (Case kees) ro ti
		# ti = store_type_info_of_patterns_in_heap kees ti
219
220
		# (res,ti) = transformCase kees ro ti
		= (res,ti) // ---> ("transform (Case kees)",Case kees,res)
221
222
223
224
	  where
		store_type_info_of_patterns_in_heap {case_guards,case_info_ptr} ti
			= case case_guards of
				AlgebraicPatterns _ patterns
Diederik van Arkel's avatar
Diederik van Arkel committed
225
226
					# (EI_CaseType {ct_cons_types},ti_symbol_heap)
										= readExprInfo case_info_ptr ti.ti_symbol_heap
227
228
229
230
					  ti_var_heap = foldSt store_type_info_of_alg_pattern (zip2 ct_cons_types patterns) ti.ti_var_heap
					-> { ti & ti_symbol_heap = ti_symbol_heap, ti_var_heap = ti_var_heap }
				BasicPatterns _ _
					-> ti // no variables occur
231
				OverloadedListPatterns _ _ patterns
Diederik van Arkel's avatar
Diederik van Arkel committed
232
233
					# (EI_CaseType {ct_cons_types},ti_symbol_heap)
										= readExprInfo case_info_ptr ti.ti_symbol_heap
234
235
					  ti_var_heap = foldSt store_type_info_of_alg_pattern (zip2 ct_cons_types patterns) ti.ti_var_heap
					-> { ti & ti_symbol_heap = ti_symbol_heap, ti_var_heap = ti_var_heap }
236
237
238
				NoPattern
					-> ti
		store_type_info_of_alg_pattern (var_types,{ap_vars}) var_heap
Diederik van Arkel's avatar
Diederik van Arkel committed
239
240
241
242
			= foldSt store_type_info_of_pattern_var (zip2 var_types ap_vars) var_heap
		store_type_info_of_pattern_var (var_type, {fv_info_ptr}) var_heap
			= setExtendedVarInfo fv_info_ptr (EVI_VarType var_type) var_heap

243
244
	transform (Selection opt_type expr selectors) ro ti
		# (expr, ti) = transform expr ro ti
245
		= transformSelection opt_type selectors expr ro ti
246
247
	transform (Update expr1 selectors expr2) ro ti
		# (expr1,ti) = transform expr1 ro ti
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
		# (selectors,ti) = transform_expressions_in_selectors selectors ti
			with
				transform_expressions_in_selectors [selection=:RecordSelection _ _ : selections] ti
					# (selections,ti) = transform_expressions_in_selectors selections ti
					= ([selection:selections],ti)
				transform_expressions_in_selectors [ArraySelection ds ep expr : selections] ti
					# (expr,ti) = transform expr ro ti
					# (selections,ti) = transform_expressions_in_selectors selections ti
					= ([ArraySelection ds ep expr:selections],ti)
				transform_expressions_in_selectors [DictionarySelection bv dictionary_selections ep expr : selections] ti
					# (expr,ti) = transform expr ro ti
					# (dictionary_selections,ti) = transform_expressions_in_selectors dictionary_selections ti
					# (selections,ti) = transform_expressions_in_selectors selections ti
					= ([DictionarySelection bv dictionary_selections ep expr:selections],ti)
				transform_expressions_in_selectors [] ti
					= ([],ti)
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
		# (expr2,ti) = transform expr2 ro ti
		= (Update expr1 selectors expr2,ti)
	transform (RecordUpdate cons_symbol expr exprs) ro ti
		# (expr,ti) = transform expr ro ti
		# (exprs,ti) = transform_fields exprs ro ti
		=(RecordUpdate cons_symbol expr exprs,ti)
	where	
		transform_fields [] ro ti
			= ([],ti)
		transform_fields [bind=:{bind_src} : fields] ro ti
			# (bind_src,ti) = transform bind_src ro ti
			# (fields,ti) = transform_fields fields ro ti
			= ([{bind & bind_src=bind_src} : fields],ti)
	transform (TupleSelect a1 arg_nr expr) ro ti
		# (expr,ti) = transform expr ro ti
		= (TupleSelect a1 arg_nr expr,ti)
280
	transform (MatchExpr a1 expr) ro ti
281
		# (expr,ti) = transform expr ro ti
282
		= (MatchExpr a1 expr,ti)
283
284
	transform (DynamicExpr dynamic_expr) ro ti
		# (dynamic_expr, ti) = transform dynamic_expr ro ti
285
		= (DynamicExpr dynamic_expr, ti)	
286
	transform expr ro ti
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
287
288
289
		= (expr, ti)

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

294
transformCase this_case=:{case_expr,case_guards,case_default,case_ident,case_info_ptr} ro ti
Diederik van Arkel's avatar
Diederik van Arkel committed
295
296
297
	| SwitchCaseFusion (not ro.ro_transform_fusion) True
		= skip_over this_case ro ti
	| isNilPtr case_info_ptr			// encountered neverMatchingCase?!
298
		= skip_over this_case ro ti
299
300
301
302
303
304
305
306
307
308
309
	# (case_info, ti_symbol_heap) = readPtr case_info_ptr ti.ti_symbol_heap
	  ti = { ti & ti_symbol_heap=ti_symbol_heap }
	  (result_expr, ti)	= case case_info of
							EI_Extended (EEI_ActiveCase aci) _
								| is_variable case_expr
									-> skip_over this_case ro ti
								-> case ro.ro_root_case_mode of
									NotRootCase	-> possibly_generate_case_function this_case aci ro ti
									_			-> transCase True (Yes aci) this_case ro ti
							_	-> transCase False No this_case ro ti
	  ti = { ti & ti_symbol_heap = remove_aci_free_vars_info case_info_ptr ti.ti_symbol_heap }
310
311
	# final_expr = removeNeverMatchingSubcases result_expr ro
	= (final_expr, ti) // ---> ("transformCase",result_expr,final_expr)
Diederik van Arkel's avatar
Diederik van Arkel committed
312
where
313
314
315
	is_variable (Var _) = True
	is_variable _ 		= False

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

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

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

//			= transformApplication { app_symb = folder, app_args = folder_args, app_info_ptr = nilPtr } [] ro ti
//	where
397
		isFoldExpression (App app)	ti_fun_defs ti_cons_args = isFoldSymbol app.app_symb.symb_kind
398
399
400
401
402
403
			where
				isFoldSymbol (SK_Function {glob_module,glob_object})
					| glob_module==ro.ro_stdStrictLists_module_n
						# 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
404
405
406
407
408
409
							= 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						
410
411
412
413
						= True
				isFoldSymbol (SK_LocalMacroFunction _)	= True
				isFoldSymbol (SK_GeneratedFunction _ _)	= True
				isFoldSymbol _							= False
414
415
416
		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
Diederik van Arkel's avatar
Diederik van Arkel committed
417
418
419
		
		folder		= ro.ro_fun_orig
		folder_args = f_a_before` ++ [guard_expr:f_a_after`]
420
421
422
		old_f_a_before	= takeWhile (\e -> not (isMember e aci.aci_params)) ro.ro_fun_args
		old_f_a_help	= dropWhile (\e -> not (isMember e aci.aci_params)) ro.ro_fun_args
		old_f_a_after	= dropWhile (\e -> isMember e aci.aci_params) old_f_a_help
423
424
		f_a_before`	= [Var {var_ident = fv_ident, var_info_ptr = fv_info_ptr, var_expr_ptr = nilPtr} \\ {fv_ident,fv_info_ptr} <- f_a_before]
		f_a_after`	= [Var {var_ident = fv_ident, var_info_ptr = fv_info_ptr, var_expr_ptr = nilPtr} \\ {fv_ident,fv_info_ptr} <- f_a_after]
Diederik van Arkel's avatar
Diederik van Arkel committed
425
426
427
428
429
		(Yes aci)	= opt_aci

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

430
	possiblyFoldOuterCase` final guard_expr outer_case ro ti
Diederik van Arkel's avatar
Diederik van Arkel committed
431
		| final
432
433
			# new_case = {outer_case & case_expr = guard_expr}
			= transformCase new_case ro ti // ---> ("possiblyFoldOuterCase`",Case new_case)
Diederik van Arkel's avatar
Diederik van Arkel committed
434
435
436
437
438
439
440
441
442
443
444
445
		# 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 }
446
		= transformCase new_case ro ti // ---> ("possiblyFoldOuterCase`",Case new_case)
Diederik van Arkel's avatar
Diederik van Arkel committed
447
	
448
transCase is_active opt_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
449
450
451
452
	= 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)
453
454
455
456
457
458
459
460
461
462
			# aci_linearity_of_patterns = case opt_aci of
			  			Yes aci -> aci.aci_linearity_of_patterns
			  (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}
			| glob_module==ro.ro_stdStrictLists_module_n && is_active &&
				(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
463
464
465
466
467
468
469
				-> trans_case_of_overloaded_nil_or_cons type ti
			| glob_module==ro.ro_main_dcl_module_n && glob_object>=size ti.ti_cons_args &&
				(ti.ti_fun_defs.[glob_object].fun_info.fi_properties bitand FI_IsUnboxedListOfRecordsConsOrNil)<>0 && is_active &&
				(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
470
471
472
473
		// otherwise it's a function application
		_	-> case opt_aci of
				Yes aci=:{ aci_params, aci_opt_unfolder }
					-> case aci_opt_unfolder of
474
						No	-> skip_over this_case ro ti									-!-> ("transCase","No opt unfolder")
Diederik van Arkel's avatar
Diederik van Arkel committed
475
476
477
						Yes unfolder
							| not (equal app_symb.symb_kind unfolder.symb_kind)
								// in this case a third function could be fused in
478
								-> possiblyFoldOuterCase this_case ro ti					-!-> ("transCase","Diff opt unfolder",unfolder,app_symb)
479
480
							# variables = [ Var {var_ident=fv_ident, var_info_ptr=fv_info_ptr, var_expr_ptr=nilPtr}
											\\ {fv_ident, fv_info_ptr} <- ro.ro_fun_args ]
481
							  (ti_next_fun_nr, ti) = ti!ti_next_fun_nr						-!-> ("transCase","Yes opt unfolder",unfolder)
Diederik van Arkel's avatar
Diederik van Arkel committed
482
483
484
485
486
487
							  (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 })
488
												-!-> ("Recursion","RootCaseOfZombie",ti_next_fun_nr,ti.ti_recursion_introduced)
Diederik van Arkel's avatar
Diederik van Arkel committed
489
490
										RootCase
											-> (ti_next_fun_nr, ro.ro_fun_root)
491
492
493
494
495
496
												-!-> ("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
497
498
499
500
501
							  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
502
503
	possiblyFoldOuterCase outer_case ro ti
		| SwitchAutoFoldAppInCase True False
504
505
			| False -!-> ("possiblyFoldOuterCase","App",bef < 0 || act < 0,ro.ro_fun_args,aci.aci_params) = undef
			| bef < 0 || act < 0	= skip_over this_case ro ti	//abort "possiblyFoldOuterCase: unexpected!\n"
Diederik van Arkel's avatar
Diederik van Arkel committed
506
507
508
			= transformApplication { app_symb = folder, app_args = folder_args, app_info_ptr = nilPtr } [] ro ti
		= skip_over this_case ro ti
	where
509
510
511
512
513
514
515
		(bef,act)	= ro.ro_fun_geni
		new_f_a_before	= take bef ro.ro_fun_args
		new_f_a_after	= drop (bef+act) ro.ro_fun_args
		
		f_a_before	= new_f_a_before
		f_a_after	= new_f_a_after

Diederik van Arkel's avatar
Diederik van Arkel committed
516
517
		folder		= ro.ro_fun_orig
		folder_args = f_a_before` ++ [case_expr:f_a_after`]
518
519
520
		old_f_a_before	= takeWhile (\e -> not (isMember e aci.aci_params)) ro.ro_fun_args
		old_f_a_help	= dropWhile (\e -> not (isMember e aci.aci_params)) ro.ro_fun_args
		old_f_a_after	= dropWhile (\e -> isMember e aci.aci_params) old_f_a_help
521
522
		f_a_before`	= [Var {var_ident = fv_ident, var_info_ptr = fv_info_ptr, var_expr_ptr = nilPtr} \\ {fv_ident,fv_info_ptr} <- f_a_before]
		f_a_after`	= [Var {var_ident = fv_ident, var_info_ptr = fv_info_ptr, var_expr_ptr = nilPtr} \\ {fv_ident,fv_info_ptr} <- f_a_after]
Diederik van Arkel's avatar
Diederik van Arkel committed
523
524
525
526
527
		(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
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
	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

553
554
555
	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
556
557
			match_and_instantiate_algebraic_type [linearity:linearities] cons_index app_args
												 [{ap_symbol={glob_module,glob_object={ds_index}}, ap_vars, ap_expr} : guards] case_default ro ti
558
559
				| 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]
560
					= instantiate linearity app_args ap_vars ap_expr cons_type.st_args_strictness cons_type.st_args ti
561
562
563
564
565
566
				= 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
567
			match_and_instantiate_overloaded_list [linearity:linearities] cons_index=:{glob_module=cons_glob_module,glob_object=cons_ds_index} app_args 
568
569
									[{ap_symbol={glob_module,glob_object={ds_index}}, ap_vars, ap_expr} : guards] 
									case_default ro ti
570
571
572
				| 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
573
574
					= match_and_instantiate_overloaded_list linearities cons_index app_args guards case_default ro ti
					where
575
						equal_list_contructor glob_module ds_index cons_glob_module cons_ds_index
576
577
578
579
							| glob_module==cPredefinedModuleIndex && cons_glob_module==cPredefinedModuleIndex
								# index=ds_index+FirstConstructorPredefinedSymbolIndex
								# cons_index=cons_ds_index+FirstConstructorPredefinedSymbolIndex
								| index==PD_OverloadedConsSymbol
580
									= cons_index==PD_ConsSymbol || cons_index==PD_StrictConsSymbol || cons_index==PD_TailStrictConsSymbol || cons_index==PD_StrictTailStrictConsSymbol
581
								| index==PD_OverloadedNilSymbol
582
									= cons_index==PD_NilSymbol || cons_index==PD_StrictNilSymbol || cons_index==PD_TailStrictNilSymbol || cons_index==PD_StrictTailStrictNilSymbol
583
584
585
									= 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
586

587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
	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
			# aci_linearity_of_patterns = case opt_aci of
			  			Yes aci -> aci.aci_linearity_of_patterns
			  (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
				match_and_instantiate_overloaded_cons_boxed_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_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
				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
							= 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
		*/
665
666

	instantiate linearity app_args ap_vars ap_expr cons_type_args_strictness cons_type_args ti
667
		# zipped = zip2 ap_vars app_args
668
669
670
671
672
673
674
675
// XXX
//		  unfoldables = [ ((not (arg_is_strict i cons_type_args_strictness)) && linear) || in_normal_form app_arg \\ linear <- linearity & app_arg <- app_args & i <- [0..]]
// YYY
		  (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}
//		  		---> ("body_strictness",[if (arg_is_strict i body_strictness) '!' '.' \\ i <- [0..] & a <- ap_vars],ap_vars,ap_expr)
		  unfoldables = [ (arg_is_strict i body_strictness || ((not (arg_is_strict i cons_type_args_strictness))) && linear) || in_normal_form app_arg \\ linear <- linearity & app_arg <- app_args & i <- [0..]]
// ZZZ
676
677
678
679
		  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
680
681
//		  (new_expr, ti_symbol_heap) = possibly_add_let non_unfoldable_args ap_expr not_unfoldable cons_type_args ro ti.ti_symbol_heap
		  (new_expr, ti_symbol_heap) = possibly_add_let zipped ap_expr not_unfoldable cons_type_args ro ti.ti_symbol_heap cons_type_args_strictness
682
683
684
685
686
687
688
		  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 }
		  ui= {ui_handle_aci_free_vars = LeaveThem }
		  (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 }
689
//		| False ---> ("instantiate",app_args,ap_vars,ap_expr,final_expr,unfoldables) = undef
690
		= (Yes final_expr, ti)
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
	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)
		
		
728
729
730
731
732
733
734
	expr_or_never_matching_case (Yes match_expr) case_ident ti
		= (match_expr, ti)
	expr_or_never_matching_case No case_ident ti
		= (neverMatchingCase never_ident, ti) <-!- ("transCase:App:neverMatchingCase",never_ident)
		where
			never_ident = case ro.ro_root_case_mode of
							NotRootCase -> case_ident
735
							_ -> Yes ro.ro_fun_case.symb_ident
736

Diederik van Arkel's avatar
Diederik van Arkel committed
737
738
739
740
741
742
743
744
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
745
746
747
748
			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
749
							_ -> Yes ro.ro_fun_case.symb_ident
Diederik van Arkel's avatar
Diederik van Arkel committed
750
751
752
753
	= transform (hd may_be_match_pattern).bp_expr { ro & ro_root_case_mode = NotRootCase } ti
where
	getBasicPatterns (BasicPatterns _ basicPatterns)
		= basicPatterns
754

Diederik van Arkel's avatar
Diederik van Arkel committed
755
756
757
758
759
760
761
762
763
764
765
766
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
	
767
768
769
770
771
772
773
774
775
776
777
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 _ _
	= []

778
possibly_add_let [] ap_expr _ _ _ ti_symbol_heap cons_type_args_strictness
779
	= (ap_expr, ti_symbol_heap)
780
possibly_add_let non_unfoldable_args ap_expr not_unfoldable cons_type_args ro ti_symbol_heap cons_type_args_strictness
781
	# let_type = filterWith not_unfoldable cons_type_args
782
	  (new_info_ptr, ti_symbol_heap) = newPtr (EI_LetType let_type) ti_symbol_heap
783
784
785
	= SwitchStrictPossiblyAddLet
		( Let
			{	let_strict_binds	= [ {lb_src=lb_src, lb_dst=lb_dst, lb_position = NoPos}
786
										\\ (lb_dst,lb_src)<-non_unfoldable_args
787
788
789
										& n <- not_unfoldable
										& i <- [0..]
										| n && arg_is_strict i cons_type_args_strictness
790
791
792
										]
			,	let_lazy_binds		= [ {lb_src=lb_src, lb_dst=lb_dst, lb_position = NoPos}
										\\ (lb_dst,lb_src)<-non_unfoldable_args
793
794
795
										& n <- not_unfoldable
										& i <- [0..]
										| n && not (arg_is_strict i cons_type_args_strictness)
796
										]
797
798
799
800
801
802
803
			,	let_expr			= ap_expr
			,	let_info_ptr		= new_info_ptr
			,	let_expr_position	= NoPos
			}
	  , ti_symbol_heap
	  ) 
	  ( Let	{	let_strict_binds	= []
804
			,	let_lazy_binds		= [ {lb_src=lb_src, lb_dst=lb_dst, lb_position = NoPos}
805
806
807
808
										\\ (lb_dst,lb_src)<-non_unfoldable_args
										& n <- not_unfoldable
										| n
										]
809
810
811
812
813
814
			,	let_expr			= ap_expr
			,	let_info_ptr		= new_info_ptr
			,	let_expr_position	= NoPos
			}
	  , ti_symbol_heap
	  ) 
815
possibly_generate_case_function :: !Case !ActiveCaseInfo !ReadOnlyTI !*TransformInfo -> *(!Expression, !*TransformInfo)
816
possibly_generate_case_function kees=:{case_info_ptr} aci=:{aci_free_vars} ro ti=:{ti_recursion_introduced=old_ti_recursion_introduced}
817
//	| False -!-> ("possibly_generate_case_function",ro.ro_fun_root.symb_ident.id_name,ro.ro_fun_case.symb_ident.id_name,ro.ro_root_case_mode)
818
//		= undef
819
820
	| not aci.aci_safe
		= skip_over kees ro ti
821
	// determine free variables
822
823
824
825
826
827
828
	# 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
829
830
831
832
833
	// 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
834
835
							TransformedBody {tb_args} 	-> tb_args
							Expanding args				-> args
836
837
838
839
840
841
842
843
844
	  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
845
846
	  		= [ { 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)]
847
848
	  all_args
	  		= lifted_arguments++arguments_from_outer_fun
Diederik van Arkel's avatar
Diederik van Arkel committed
849
850
851
	| 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 }
852
		| ro.ro_transform_fusion
853
			#  ti	= { ti & ti_error_file = ti.ti_error_file <<< "Possibly missed fusion oppurtunity: Case Arity > 32 " <<< ro.ro_fun_root.symb_ident.id_name <<< "\n"}
854
			= skip_over kees ro ti
Diederik van Arkel's avatar
Diederik van Arkel committed
855
856
		= skip_over kees ro ti
	# (fun_info_ptr, ti_fun_heap)
857
858
	  		= newPtr FI_Empty ti_fun_heap
	  fun_ident
859
860
861
	  		= { id_name = ro.ro_fun_root.symb_ident.id_name+++"_case", id_info = nilPtr }
	  fun_ident
	  		= { symb_ident = fun_ident, symb_kind=SK_GeneratedFunction fun_info_ptr undeff }
862
	  			<-!- ("<<<transformCaseFunction",fun_ident)
863
864
865
866
867
868
869
870
	| SwitchAlwaysIntroduceCaseFunction True False
		# ti
	  		= { ti & ti_cons_args = ti_cons_args, ti_fun_defs = ti_fun_defs, ti_fun_heap = ti_fun_heap }
	  	# fun_index
	  		= ti.ti_next_fun_nr
	  	# ti
	  		= { ti & ti_next_fun_nr = fun_index + 1 }
		# new_ro
871
	  		= { ro & ro_root_case_mode = RootCaseOfZombie , ro_fun_case = fun_ident, ro_fun_args = all_args }
872
873
	  	= generate_case_function fun_index case_info_ptr (Case kees) outer_fun_def outer_cons_args used_mask new_ro ti
	# new_ro
874
	  		= { ro & ro_root_case_mode = RootCaseOfZombie , ro_fun_case = fun_ident, ro_fun_args = all_args, ro_fun_geni = (-1,-1) }
875
876
877
	  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)
878
	  		= transformCase kees new_ro ti //---> ("possibly_generate_case_function",Case kees)
879
880
	  (ti_recursion_introduced, ti)
	  		= ti!ti_recursion_introduced
881
	  			<-!- ("transformCaseFunction>>>",fun_ident)
882
	  ti	= { ti & ti_recursion_introduced = old_ti_recursion_introduced }
883
884
	= case ti_recursion_introduced of
		Yes fun_index
885
			-> generate_case_function fun_index case_info_ptr new_expr outer_fun_def outer_cons_args used_mask new_ro ti
886
		No	-> (new_expr, ti)
887

888
889
890
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
891
//	| False -!-> ("generate_case_function",ro_fun.symb_ident)		= undef
892
	# fun_arity								= length ro_fun_args
893
	# ti = arity_warning "generate_case_function" ro_fun.symb_ident fun_index fun_arity ti
894
	  (Yes {st_vars,st_args,st_attr_env})	= outer_fun_def.fun_type
895
896
897
898
899
900
901
902
	  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

903
904
	# 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
905
906

	  // unfold...
907
908
909
	  us =		{ us_var_heap				= ti.ti_var_heap
	  			, us_symbol_heap			= ti.ti_symbol_heap
	  			, us_opt_type_heaps			= Yes ti.ti_type_heaps
910
911
912
913
914
915
916
917
918
919
920
	  			, 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...
921
	  fun_def =	{ fun_ident					= ro_fun.symb_ident
922
923
924
925
926
927
928
929
930
931
932
933
934
				, 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		= []
935
// Sjaak: 							,	fi_is_macro_fun = outer_fun_def.fun_info.fi_is_macro_fun
936
937
938
939
940
941
942
								,	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
943
	  			, cc_args			= repeatn nr_of_lifted_vars CPassive ++ cc_args_from_outer_fun
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
	  			, 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)
970
971
	free_var_to_bound_var {fv_ident, fv_info_ptr}
		= Var { var_ident = fv_ident, var_info_ptr = fv_info_ptr, var_expr_ptr = nilPtr}
972
973
974
975
976
977
	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 }
978
979
		  (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
980
981
982
983
984
985
986
987
988
989
990
991
		  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)
992

993
994
removeNeverMatchingSubcases :: Expression !.ReadOnlyTI -> Expression
removeNeverMatchingSubcases keesExpr=:(Case kees) ro
Martin Wierich's avatar
Martin Wierich committed
995
996
997
998
999
1000
	// 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
For faster browsing, not all history is shown. View entire blame