partition.icl 42.3 KB
Newer Older
1
2
implementation module partition

3
4
import syntax, checksupport, utilities
from transform import ::PredefSymbolsForTransform{..}
5

6
//	PARTITIONING
7

8
::	PartitioningInfo =
9
10
11
	{	pi_marks :: 		!.{# Int}
	,	pi_next_num ::		!Int
	,	pi_next_group ::	!Int
12
	,	pi_groups ::		![ComponentMembers]
13
14
15
16
17
	,	pi_deps ::			![Int]
	}

NotChecked :== -1	

18
partitionateFunctions :: !*{# FunDef} ![IndexRange] -> (!*{!Component}, !*{# FunDef})
19
20
21
22
23
partitionateFunctions fun_defs ranges
	#! max_fun_nr = size fun_defs
	# partitioning_info = { pi_marks = createArray max_fun_nr NotChecked, pi_deps = [], pi_next_num = 0, pi_next_group = 0, pi_groups = [] }
	  (fun_defs, {pi_groups,pi_next_group}) = 
	  		foldSt (partitionate_functions max_fun_nr) ranges (fun_defs, partitioning_info)
24
	  groups = { {component_members = group} \\ group <- reverse pi_groups }
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
	= (groups, fun_defs)
where
	partitionate_functions :: !Index !IndexRange !(!*{# FunDef}, !*PartitioningInfo) -> (!*{# FunDef}, !*PartitioningInfo)
	partitionate_functions max_fun_nr ir=:{ir_from,ir_to} (fun_defs, pi=:{pi_marks})
		| ir_from == ir_to
			= (fun_defs, pi)
		| pi_marks.[ir_from] == NotChecked
			# (_, fun_defs, pi) = partitionate_function ir_from max_fun_nr fun_defs pi
			= partitionate_functions max_fun_nr { ir & ir_from = inc ir_from } (fun_defs, pi)
			= partitionate_functions max_fun_nr { ir & ir_from = inc ir_from } (fun_defs, pi)

	partitionate_function :: !Int !Int !*{# FunDef} !*PartitioningInfo -> *(!Int, !*{# FunDef}, !*PartitioningInfo)
	partitionate_function fun_index max_fun_nr fun_defs pi=:{pi_next_num}
		# (fd, fun_defs) = fun_defs![fun_index]
		# {fi_calls} = fd.fun_info
		  (min_dep, fun_defs, pi) = visit_functions fi_calls max_fun_nr max_fun_nr fun_defs (push_on_dep_stack fun_index pi)
			with
				visit_functions :: ![FunCall] !Int !Int !*{# FunDef} !*PartitioningInfo -> *(!Int, !*{# FunDef}, !*PartitioningInfo)
				visit_functions [FunCall fc_index _:funs] min_dep max_fun_nr fun_defs pi=:{pi_marks} 
					#! mark = pi_marks.[fc_index]
					| mark == NotChecked
						# (mark, fun_defs, pi) = partitionate_function fc_index max_fun_nr fun_defs  pi
						= visit_functions funs (min min_dep mark) max_fun_nr fun_defs pi
						= visit_functions funs (min min_dep mark) max_fun_nr fun_defs pi
49
50
				visit_functions [DclFunCall module_index fc_index:funs] min_dep max_fun_nr fun_defs pi
					= visit_functions funs min_dep max_fun_nr fun_defs pi
51
52
53
54
55
56
57
58
59
60
61
62
				visit_functions [] min_dep max_fun_nr fun_defs pi
					= (min_dep, fun_defs, pi)
		= try_to_close_group fun_index pi_next_num min_dep max_fun_nr fun_defs pi

	push_on_dep_stack :: !Int !*PartitioningInfo -> *PartitioningInfo;
	push_on_dep_stack fun_index pi=:{pi_deps,pi_marks,pi_next_num}
		= { pi & pi_deps = [fun_index : pi_deps], pi_marks = { pi_marks & [fun_index] = pi_next_num}, pi_next_num = inc pi_next_num}

	try_to_close_group :: !Int !Int !Int !Int !*{# FunDef} !*PartitioningInfo -> *(!Int, !*{# FunDef}, !*PartitioningInfo)
	try_to_close_group fun_index fun_nr min_dep max_fun_nr fun_defs pi=:{pi_marks, pi_deps, pi_groups, pi_next_group}
		| fun_nr <= min_dep
			# (pi_deps, pi_marks, group, fun_defs)
63
				= close_group False False fun_index pi_deps pi_marks NoComponentMembers max_fun_nr pi_next_group fun_defs
64
65
66
67
			  pi = { pi & pi_deps = pi_deps, pi_marks = pi_marks, pi_next_group = inc pi_next_group,  pi_groups = [group : pi_groups] }
			= (max_fun_nr, fun_defs, pi)
			= (min_dep, fun_defs, pi)
	where
68
		close_group :: !Bool !Bool !Int ![Int] !*{# Int} !ComponentMembers !Int !Int !*{# FunDef} -> (![Int], !*{# Int}, !ComponentMembers, !*{# FunDef})
69
		close_group n_r_known non_recursive fun_index [d:ds] marks group max_fun_nr group_number fun_defs
70
71
			# marks = { marks & [d] = max_fun_nr }
			# (fd,fun_defs) = fun_defs![d]
72
73
74
75
76
77
78
			# non_recursive = case n_r_known of
								True	-> non_recursive
								_		-> case fun_index == d of
									True	-> isEmpty [fc \\ fc <- fd.fun_info.fi_calls | case fc of FunCall idx _ -> idx == d; _ -> False]
									_		-> False
			# fd = { fd & fun_info.fi_group_index = group_number, fun_info.fi_properties = set_rec_prop non_recursive fd.fun_info.fi_properties}
			# fun_defs = { fun_defs & [d] = fd}
79
			| d == fun_index
80
81
				= (ds, marks, ComponentMember d group, fun_defs)
				= close_group True non_recursive fun_index ds marks (ComponentMember d group) max_fun_nr group_number fun_defs
Diederik van Arkel's avatar
Diederik van Arkel committed
82
83
84
85
86

::	PartitioningInfo` = 
	{	pi_marks` :: 		!.{# Int}
	,	pi_next_num` ::		!Int
	,	pi_next_group` ::	!Int
87
	,	pi_groups` ::		![ComponentMembers]
Diederik van Arkel's avatar
Diederik van Arkel committed
88
89
90
91
92
93
94
95
96
97
	,	pi_deps` ::			![Int]
	,	pi_collect` ::		!.CollectState
	}

stripStrictLets :: !*{# FunDef} !*PredefinedSymbols !*VarHeap !*ExpressionHeap !*ErrorAdmin -> (!*{# FunDef}, !*PredefinedSymbols, !*VarHeap, !*ExpressionHeap, !*ErrorAdmin)
stripStrictLets fun_defs predef_symbols var_heap sym_heap error_admin
	# (cs_predef,predef_symbols) = get_predef_symbols_for_transform predef_symbols
	# collect_state =
		{ cos_predef_symbols_for_transform	= cs_predef
		, cos_var_heap						= var_heap
98
		, cos_expression_heap				= sym_heap
Diederik van Arkel's avatar
Diederik van Arkel committed
99
100
		, cos_error							= error_admin
		}
101
	# (fun_defs,collect_state) = aMapSt determine_ref_counts fun_defs collect_state
102
	= (fun_defs,predef_symbols,collect_state.cos_var_heap, collect_state.cos_expression_heap, collect_state.cos_error)
Diederik van Arkel's avatar
Diederik van Arkel committed
103
104
105
106
107
where
	aMapSt f a s
		# (l,s)	= mapSt f [e \\ e <-: a] s
		= ({e \\ e <- l},s)

108
partitionateFunctions` :: !*{# FunDef} ![IndexRange] !Index !Int !Int !*PredefinedSymbols !*VarHeap !*ExpressionHeap !*ErrorAdmin -> (!*{!Component}, !*{# FunDef}, !*PredefinedSymbols, !*VarHeap, !*ExpressionHeap, !*ErrorAdmin)
Diederik van Arkel's avatar
Diederik van Arkel committed
109
110
111
112
113
114
partitionateFunctions` fun_defs ranges main_dcl_module_n def_min def_max predef_symbols var_heap sym_heap error_admin
	#! max_fun_nr = size fun_defs
	# (cs_predef,predef_symbols) = get_predef_symbols_for_transform predef_symbols
	# collect_state =
		{ cos_predef_symbols_for_transform	= cs_predef
		, cos_var_heap						= var_heap
115
		, cos_expression_heap				= sym_heap
Diederik van Arkel's avatar
Diederik van Arkel committed
116
117
118
119
120
121
122
123
124
125
126
127
		, cos_error							= error_admin
		}
	# partitioning_info =
		{ pi_collect` = collect_state
		, pi_marks` = createArray max_fun_nr NotChecked
		, pi_deps` = []
		, pi_next_num` = 0
		, pi_next_group` = 0
		, pi_groups` = [] 
		}
	  (fun_defs, {pi_groups`,pi_next_group`,pi_collect`}) = 
	  		foldSt (partitionate_functions max_fun_nr) ranges (fun_defs, partitioning_info)
128
	  groups = { {component_members = group} \\ group <- reverse pi_groups` }
129
	= (groups, fun_defs, predef_symbols, pi_collect`.cos_var_heap, pi_collect`.cos_expression_heap, pi_collect`.cos_error)
Diederik van Arkel's avatar
Diederik van Arkel committed
130
131
132
133
134
135
136
137
138
139
140
141
142
where
	partitionate_functions :: !Index !IndexRange !(!*{# FunDef}, !*PartitioningInfo`) -> (!*{# FunDef}, !*PartitioningInfo`)
	partitionate_functions max_fun_nr ir=:{ir_from,ir_to} (fun_defs, pi=:{pi_marks`})
		| ir_from == ir_to
			= (fun_defs, pi)
		| pi_marks`.[ir_from] == NotChecked
			# (_, fun_defs, pi) = partitionate_function ir_from max_fun_nr fun_defs pi
			= partitionate_functions max_fun_nr { ir & ir_from = inc ir_from } (fun_defs, pi)
			= partitionate_functions max_fun_nr { ir & ir_from = inc ir_from } (fun_defs, pi)

	partitionate_function :: !Int !Int !*{# FunDef} !*PartitioningInfo` -> *(!Int, !*{# FunDef}, !*PartitioningInfo`)
	partitionate_function fun_index max_fun_nr fun_defs pi=:{pi_next_num`,pi_collect`}
		# (fd, fun_defs) = fun_defs![fun_index]
143
		# (fd,pi_collect`) = determine_ref_counts fd pi_collect`
Diederik van Arkel's avatar
Diederik van Arkel committed
144
145
146
147
148
149
150
151
		# pi = {pi & pi_collect` = pi_collect`}
		# fc_state = find_calls
						{ main_dcl_module_n=main_dcl_module_n
						, def_min=def_min
						, def_max=def_max
						, fun_index=fun_index
						} fd.fun_body {fun_calls = []}
		  fi_calls = fc_state.fun_calls
152
		  fd = {fd & fun_info.fi_calls = fi_calls}
Diederik van Arkel's avatar
Diederik van Arkel committed
153
154
155
156
157
158
159
160
161
		# fun_defs = {fun_defs & [fun_index] = fd}

		  pi = push_on_dep_stack fun_index pi
		  (min_dep, fun_defs, pi) = visit_functions fi_calls max_fun_nr max_fun_nr fun_defs pi
			with
				visit_functions :: ![FunCall] !Int !Int !*{# FunDef} !*PartitioningInfo` -> *(!Int, !*{# FunDef}, !*PartitioningInfo`)
				visit_functions [FunCall fc_index _:funs] min_dep max_fun_nr fun_defs pi=:{pi_marks`} 
					#! mark = pi_marks`.[fc_index]
					| mark == NotChecked
162
						# (mark, fun_defs, pi) = partitionate_function fc_index max_fun_nr fun_defs pi
Diederik van Arkel's avatar
Diederik van Arkel committed
163
164
						= visit_functions funs (min min_dep mark) max_fun_nr fun_defs pi
						= visit_functions funs (min min_dep mark) max_fun_nr fun_defs pi
165
166
167
168
169
170
				visit_functions [GeneratedFunCall fc_index _:funs] min_dep max_fun_nr fun_defs pi=:{pi_marks`}
					#! mark = pi_marks`.[fc_index]
					| mark == NotChecked
						# (mark, fun_defs, pi) = partitionate_function fc_index max_fun_nr fun_defs pi
						= visit_functions funs (min min_dep mark) max_fun_nr fun_defs pi
						= visit_functions funs (min min_dep mark) max_fun_nr fun_defs pi
171
172
				visit_functions [DclFunCall module_index fc_index:funs] min_dep max_fun_nr fun_defs pi
					= visit_functions funs min_dep max_fun_nr fun_defs pi
Diederik van Arkel's avatar
Diederik van Arkel committed
173
174
175
176
177
178
179
180
181
182
183
184
				visit_functions [] min_dep max_fun_nr fun_defs pi
					= (min_dep, fun_defs, pi)
		= try_to_close_group fun_index pi_next_num` min_dep max_fun_nr fun_defs pi

	push_on_dep_stack :: !Int !*PartitioningInfo` -> *PartitioningInfo`;
	push_on_dep_stack fun_index pi=:{pi_deps`,pi_marks`,pi_next_num`}
		= { pi & pi_deps` = [fun_index : pi_deps`], pi_marks` = { pi_marks` & [fun_index] = pi_next_num`}, pi_next_num` = inc pi_next_num`}

	try_to_close_group :: !Int !Int !Int !Int !*{# FunDef} !*PartitioningInfo` -> *(!Int, !*{# FunDef}, !*PartitioningInfo`)
	try_to_close_group fun_index fun_nr min_dep max_fun_nr fun_defs pi=:{pi_marks`, pi_deps`, pi_groups`, pi_next_group`}
		| fun_nr <= min_dep
			# (pi_deps`, pi_marks`, group, fun_defs)
185
				= close_group False False fun_index pi_deps` pi_marks` NoComponentMembers max_fun_nr pi_next_group` fun_defs
Diederik van Arkel's avatar
Diederik van Arkel committed
186
187
188
189
			  pi = { pi & pi_deps` = pi_deps`, pi_marks` = pi_marks`, pi_next_group` = inc pi_next_group`,  pi_groups` = [group : pi_groups`] }
			= (max_fun_nr, fun_defs, pi)
			= (min_dep, fun_defs, pi)
	where
190
		close_group :: !Bool !Bool !Int ![Int] !*{# Int} !ComponentMembers !Int !Int !*{# FunDef} -> (![Int], !*{# Int}, !ComponentMembers, !*{# FunDef})
191
		close_group n_r_known non_recursive fun_index [d:ds] marks group max_fun_nr group_number fun_defs
Diederik van Arkel's avatar
Diederik van Arkel committed
192
193
			# marks = { marks & [d] = max_fun_nr }
			# (fd,fun_defs) = fun_defs![d]
194
195
196
197
198
199
200
			# non_recursive = case n_r_known of
								True	-> non_recursive
								_		-> case fun_index == d of
									True	-> isEmpty [fc \\ fc <- fd.fun_info.fi_calls | case fc of FunCall idx _ -> idx == d; _ -> False]
									_		-> False
			# fd = { fd & fun_info.fi_group_index = group_number, fun_info.fi_properties = set_rec_prop non_recursive fd.fun_info.fi_properties}
			# fun_defs = { fun_defs & [d] = fd}
Diederik van Arkel's avatar
Diederik van Arkel committed
201
			| d == fun_index
202
203
				= (ds, marks, ComponentMember d group, fun_defs)
				= close_group True non_recursive fun_index ds marks (ComponentMember d group) max_fun_nr group_number fun_defs
Diederik van Arkel's avatar
Diederik van Arkel committed
204
205
206
207
208

::	PartitioningInfo`` = 
	{ pi_marks``			:: !.Marks
	, pi_next_num``			:: !Int
	, pi_next_group``		:: !Int
209
210
	, pi_groups``			:: ![ComponentMembers]
	, pi_deps``				:: !ComponentMembers
211
	, pi_collect``			:: !.CollectState
Diederik van Arkel's avatar
Diederik van Arkel committed
212
213
214
215
216
217
	}

:: Marks	:== {# Mark}
:: Mark		= { m_fun :: !Int, m_mark :: !Int}

create_marks max_fun_nr functions
218
219
220
221
222
223
224
225
226
	= {{m_fun = fun, m_mark = NotChecked} \\ fun <- component_members_to_list functions}

component_members_to_list (ComponentMember member members)
	= [member : component_members_to_list members]
component_members_to_list (GeneratedComponentMember member _ members)
	= [member : component_members_to_list members]
component_members_to_list NoComponentMembers
	= []

Diederik van Arkel's avatar
Diederik van Arkel committed
227
get_mark max_fun_nr marks fun
228
229
230
231
232
233
234
235
236
237
	:== get_mark 0 marks fun max_fun_nr
where
	get_mark :: !Int !{#Mark} !Int !Int -> Int
	get_mark i marks fun max_fun_nr
		| i<size marks
			| marks.[i].m_fun<>fun
				= get_mark (i+1) marks fun max_fun_nr
				= marks.[i].m_mark
			= max_fun_nr

Diederik van Arkel's avatar
Diederik van Arkel committed
238
set_mark marks fun val
239
240
241
242
243
244
245
246
	:== set_mark 0 marks fun val
where
	set_mark :: !Int !*{#Mark} !Int !Int -> *{#Mark}
	set_mark i marks fun val
//		| i<size marks
		| marks.[i].m_fun<>fun
			= set_mark (i+1) marks fun val
			= {marks & [i].m_mark=val}
247
248
249
250

partitionateFunctions`` :: !Int !Int !*{#FunDef} !ComponentMembers !Index !Int !Int !*FunctionHeap !*PredefinedSymbols !*VarHeap !*ExpressionHeap !*ErrorAdmin
	-> (!Int, ![Component], !*{#FunDef}, !*FunctionHeap, !*PredefinedSymbols, !*VarHeap, !*ExpressionHeap, !*ErrorAdmin)
partitionateFunctions`` max_fun_nr next_group fun_defs functions main_dcl_module_n def_min def_max fun_heap predef_symbols var_heap sym_heap error_admin
Diederik van Arkel's avatar
Diederik van Arkel committed
251
	# marks					= create_marks max_fun_nr functions
252
253
254
255
	# (cs_predef,predef_symbols) = get_predef_symbols_for_transform predef_symbols
	# collect_state =
		{ cos_predef_symbols_for_transform	= cs_predef
		, cos_var_heap						= var_heap
256
		, cos_expression_heap				= sym_heap
257
258
		, cos_error							= error_admin
		}
Diederik van Arkel's avatar
Diederik van Arkel committed
259
260
	# partitioning_info =
		{ pi_marks``		= marks
261
		, pi_deps``			= NoComponentMembers
Diederik van Arkel's avatar
Diederik van Arkel committed
262
263
264
		, pi_next_num``		= 0
		, pi_next_group``	= next_group
		, pi_groups``		= [] 
265
		, pi_collect``		= collect_state
Diederik van Arkel's avatar
Diederik van Arkel committed
266
		}
267
268
269
	  (fun_defs, fun_heap, {pi_groups``,pi_next_group``,pi_collect``})
	  	= partitionate_component functions max_fun_nr (fun_defs, fun_heap, partitioning_info)
	  groups = [ {component_members = group} \\ group <- reverse pi_groups`` ]
270
	= (pi_next_group``,groups, fun_defs, fun_heap, predef_symbols, pi_collect``.cos_var_heap, pi_collect``.cos_expression_heap, pi_collect``.cos_error)
Diederik van Arkel's avatar
Diederik van Arkel committed
271
where
272
273
274
275
276
277
278
279
280
281
282
283
284
	partitionate_component :: !ComponentMembers !Index !(!*{# FunDef}, !*FunctionHeap, !*PartitioningInfo``) -> (!*{# FunDef}, !*FunctionHeap, !*PartitioningInfo``)
	partitionate_component (ComponentMember member members) max_fun_nr (fun_defs, fun_heap, pi=:{pi_marks``})
		| get_mark max_fun_nr pi_marks`` member == NotChecked
			# (_, fun_defs, fun_heap, pi) = partitionate_function member max_fun_nr fun_defs fun_heap pi
		 	= partitionate_component members max_fun_nr (fun_defs, fun_heap, pi)
		 	= partitionate_component members max_fun_nr (fun_defs, fun_heap, pi)
	partitionate_component (GeneratedComponentMember member fun_ptr members) max_fun_nr (fun_defs, fun_heap, pi=:{pi_marks``})
		| get_mark max_fun_nr pi_marks`` member == NotChecked
			# (_, fun_defs, fun_heap, pi) = partitionate_generated_function member fun_ptr max_fun_nr fun_defs fun_heap pi
			= partitionate_component members max_fun_nr (fun_defs, fun_heap, pi)
			= partitionate_component members max_fun_nr (fun_defs, fun_heap, pi)
	partitionate_component NoComponentMembers max_fun_nr (fun_defs, fun_heap, pi)
		= (fun_defs, fun_heap, pi)
Diederik van Arkel's avatar
Diederik van Arkel committed
285
286

	partitionate_function :: !Int !Int !*{# FunDef} !*FunctionHeap !*PartitioningInfo`` -> *(!Int, !*{# FunDef}, !*FunctionHeap, !*PartitioningInfo``)
287
	partitionate_function fun_index max_fun_nr fun_defs fun_heap pi=:{pi_next_num``,pi_collect``}
288
289
290
291
		# (fd,fun_defs) = fun_defs![fun_index]
		  (fd,pi_collect``) = determine_ref_counts fd pi_collect``
		  pi = {pi & pi_collect`` = pi_collect``}
		  fc_state = find_calls {main_dcl_module_n=main_dcl_module_n, def_min=def_min, def_max=def_max, fun_index=fun_index} fd.fun_body {fun_calls = []}
Diederik van Arkel's avatar
Diederik van Arkel committed
292
		  fi_calls = fc_state.fun_calls
293
294
		  fd = {fd & fun_info.fi_calls = fi_calls}	
		  fun_defs = {fun_defs & [fun_index] = fd}
Diederik van Arkel's avatar
Diederik van Arkel committed
295
		  pi = push_on_dep_stack fun_index pi
296
297
298
299
300
301
302
303
304
305
306
307
308
		= visit_functions_and_try_to_close_group fi_calls fun_index pi_next_num`` max_fun_nr fun_defs fun_heap pi

	partitionate_generated_function :: !Int !FunctionInfoPtr !Int !*{# FunDef} !*FunctionHeap !*PartitioningInfo`` -> *(!Int, !*{# FunDef}, !*FunctionHeap, !*PartitioningInfo``)
	partitionate_generated_function fun_index fun_ptr max_fun_nr fun_defs fun_heap pi=:{pi_next_num``,pi_collect``}
		# (FI_Function gf=:{gf_fun_def=fd}, fun_heap) = readPtr fun_ptr fun_heap
		  (fd,pi_collect``) = determine_ref_counts fd pi_collect``
		  pi = {pi & pi_collect`` = pi_collect``}
		  fc_state = find_calls {main_dcl_module_n=main_dcl_module_n, def_min=def_min, def_max=def_max, fun_index=fun_index} fd.fun_body {fun_calls = []}
		  fi_calls = fc_state.fun_calls
		  fd = {fd & fun_info.fi_calls = fi_calls}
		  fun_heap = writePtr fun_ptr (FI_Function {gf & gf_fun_def = fd}) fun_heap
		  pi = push_generated_function_on_dep_stack fun_index fun_ptr pi
		= visit_functions_and_try_to_close_group fi_calls fun_index pi_next_num`` max_fun_nr fun_defs fun_heap pi
309

310
311
312
	visit_functions_and_try_to_close_group :: ![FunCall] !Int !Int !Int !*{#FunDef} !*FunctionHeap !*PartitioningInfo`` -> *(!Int,!*{#FunDef},!*FunctionHeap,!*PartitioningInfo``)
	visit_functions_and_try_to_close_group fi_calls fun_index pi_next_num`` max_fun_nr fun_defs fun_heap pi
		# (min_dep, fun_defs, fun_heap, pi) = visit_functions fi_calls max_fun_nr max_fun_nr fun_defs fun_heap pi
Diederik van Arkel's avatar
Diederik van Arkel committed
313
314
		= try_to_close_group fun_index pi_next_num`` min_dep max_fun_nr fun_defs fun_heap pi

315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
	visit_functions :: ![FunCall] !Int !Int !*{# FunDef} !*FunctionHeap !*PartitioningInfo`` -> *(!Int, !*{# FunDef}, !*FunctionHeap, !*PartitioningInfo``)
	visit_functions [FunCall fc_index _:funs] min_dep max_fun_nr fun_defs fun_heap pi=:{pi_marks``} 
		#! mark = get_mark max_fun_nr pi_marks`` fc_index
		| mark == NotChecked
			# (mark, fun_defs, fun_heap, pi) = partitionate_function fc_index max_fun_nr fun_defs fun_heap pi
			= visit_functions funs (min min_dep mark) max_fun_nr fun_defs fun_heap pi
			= visit_functions funs (min min_dep mark) max_fun_nr fun_defs fun_heap pi
	visit_functions [GeneratedFunCall fc_index fun_ptr:funs] min_dep max_fun_nr fun_defs fun_heap pi=:{pi_marks``} 
		#! mark = get_mark max_fun_nr pi_marks`` fc_index
		| mark == NotChecked
			# (mark, fun_defs, fun_heap, pi) = partitionate_generated_function fc_index fun_ptr max_fun_nr fun_defs fun_heap pi
			= visit_functions funs (min min_dep mark) max_fun_nr fun_defs fun_heap pi
			= visit_functions funs (min min_dep mark) max_fun_nr fun_defs fun_heap pi
	visit_functions [DclFunCall module_index fc_index:funs] min_dep max_fun_nr fun_defs fun_heap pi
		= visit_functions funs min_dep max_fun_nr fun_defs fun_heap pi
	visit_functions [] min_dep max_fun_nr fun_defs fun_heap pi
		= (min_dep, fun_defs, fun_heap, pi)

Diederik van Arkel's avatar
Diederik van Arkel committed
333
	push_on_dep_stack :: !Int !*PartitioningInfo`` -> *PartitioningInfo``;
334
335
336
337
	push_on_dep_stack fun_index pi=:{pi_deps``,pi_marks``,pi_next_num``}
		= {pi & pi_deps`` = ComponentMember fun_index pi_deps``
			  , pi_marks`` = set_mark pi_marks`` fun_index pi_next_num``
			  , pi_next_num`` = inc pi_next_num`` }
Diederik van Arkel's avatar
Diederik van Arkel committed
338

339
340
341
342
343
	push_generated_function_on_dep_stack :: !Int !FunctionInfoPtr !*PartitioningInfo`` -> *PartitioningInfo``;
	push_generated_function_on_dep_stack fun_index fun_ptr pi=:{pi_deps``,pi_marks``,pi_next_num``}
		= {pi & pi_deps`` = GeneratedComponentMember fun_index fun_ptr pi_deps``
			  , pi_marks`` = set_mark pi_marks`` fun_index pi_next_num``
			  , pi_next_num`` = inc pi_next_num`` }
Diederik van Arkel's avatar
Diederik van Arkel committed
344
345
346
347
348

	try_to_close_group :: !Int !Int !Int !Int !*{# FunDef} !*FunctionHeap !*PartitioningInfo`` -> *(!Int, !*{# FunDef}, !*FunctionHeap, !*PartitioningInfo``)
	try_to_close_group fun_index fun_nr min_dep max_fun_nr fun_defs fun_heap pi=:{pi_marks``, pi_deps``, pi_groups``, pi_next_group``}
		| fun_nr <= min_dep
			# (pi_deps``, pi_marks``, group, fun_defs, fun_heap)
349
				= close_group False False fun_index pi_deps`` pi_marks`` NoComponentMembers max_fun_nr pi_next_group`` fun_defs fun_heap
Diederik van Arkel's avatar
Diederik van Arkel committed
350
351
352
353
			  pi = { pi & pi_deps`` = pi_deps``, pi_marks`` = pi_marks``, pi_next_group`` = inc pi_next_group``,  pi_groups`` = [group : pi_groups``] }
			= (max_fun_nr, fun_defs, fun_heap, pi)
			= (min_dep, fun_defs, fun_heap, pi)
	where
354
355
		close_group :: !Bool !Bool !Int !ComponentMembers !*Marks !ComponentMembers !Int !Int !*{# FunDef} !*FunctionHeap -> (!ComponentMembers, !*Marks, !ComponentMembers, !*{# FunDef}, !*FunctionHeap)
		close_group n_r_known non_recursive fun_index (ComponentMember d ds) marks group max_fun_nr group_number fun_defs fun_heap
Diederik van Arkel's avatar
Diederik van Arkel committed
356
			# marks = set_mark marks d max_fun_nr
357
358
359
360
			  (fun_info,fun_defs) = fun_defs![d].fun_info
			  non_recursive = determine_if_function_non_recursive n_r_known fun_index d fun_info.fi_calls non_recursive
			  fun_info = {fun_info & fi_group_index = group_number, fi_properties = set_rec_prop non_recursive fun_info.fi_properties}
			  fun_defs = {fun_defs & [d].fun_info = fun_info}
Diederik van Arkel's avatar
Diederik van Arkel committed
361
			| d == fun_index
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
				= (ds, marks, ComponentMember d group, fun_defs, fun_heap)
				= close_group True non_recursive fun_index ds marks (ComponentMember d group) max_fun_nr group_number fun_defs fun_heap
		close_group n_r_known non_recursive fun_index (GeneratedComponentMember d fun_ptr ds) marks group max_fun_nr group_number fun_defs fun_heap
			# marks = set_mark marks d max_fun_nr
			  (FI_Function gf=:{gf_fun_def={fun_info}}, fun_heap) = readPtr fun_ptr fun_heap
			  non_recursive = determine_if_function_non_recursive n_r_known fun_index d fun_info.fi_calls non_recursive
			  fun_info = {fun_info & fi_group_index = group_number, fi_properties = set_rec_prop non_recursive fun_info.fi_properties}
			  fun_heap = writePtr fun_ptr (FI_Function {gf & gf_fun_def.fun_info=fun_info}) fun_heap
			| d == fun_index
				= (ds, marks, GeneratedComponentMember d fun_ptr group, fun_defs, fun_heap)
				= close_group True non_recursive fun_index ds marks (GeneratedComponentMember d fun_ptr group) max_fun_nr group_number fun_defs fun_heap

		determine_if_function_non_recursive :: !Bool !Index !Index ![FunCall] !Bool -> Bool
		determine_if_function_non_recursive n_r_known fun_index d fi_calls non_recursive
			| n_r_known
				= non_recursive
				| fun_index == d
					= isEmpty [fc \\ fc <- fi_calls
									| case fc of FunCall idx _ -> idx == d; GeneratedFunCall idx _ -> idx == d; _ -> False]
					= False
Diederik van Arkel's avatar
Diederik van Arkel committed
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440

:: FindCallsInfo =
	{ main_dcl_module_n	:: !Index
	, def_min			:: !Int
	, def_max			:: !Int
	, fun_index			:: !Int
	}

:: FindCallsState =
	{ fun_calls			:: ![FunCall]
	}

class find_calls a :: !FindCallsInfo !a !FindCallsState -> FindCallsState

instance find_calls [a] | find_calls a
where
	find_calls fc_info els fc_state = foldSt (find_calls fc_info) els fc_state

instance find_calls (Optional a) | find_calls a
where
	find_calls fc_info (Yes e) fc_state = find_calls fc_info e fc_state
	find_calls fc_info No fc_state = fc_state

instance find_calls FunctionBody
where
	find_calls fc_info (TransformedBody tb) fc_state
		= find_calls fc_info tb fc_state
//	find_calls fc_info NoBody fc_state = fc_state
	find_calls fc_info _ fc_state = abort ("Undefined pattern in FunctionBody: "+++toString fc_info.fun_index+++ "?" +++ toString fc_info.def_min+++ "?" +++ toString fc_info.def_max +++ "\n")

instance find_calls TransformedBody
where
	find_calls fc_info {tb_rhs} fc_state = find_calls fc_info tb_rhs fc_state

instance find_calls Expression
where
	find_calls fc_info (Var _)					fc_state = fc_state
	find_calls fc_info (App app)				fc_state = find_calls fc_info app fc_state
	find_calls fc_info (exp @ exps)				fc_state = find_calls fc_info exps (find_calls fc_info exp fc_state)
	find_calls fc_info (Let lete)				fc_state = find_calls fc_info lete fc_state
	find_calls fc_info (Case kees)				fc_state = find_calls fc_info kees fc_state
	find_calls fc_info (Selection _ exp sells)	fc_state = find_calls fc_info sells (find_calls fc_info exp fc_state)
	find_calls fc_info (Update e1 sl e2)		fc_state
		#! fc_state	= find_calls fc_info e1 fc_state
		   fc_state	= find_calls fc_info sl fc_state
		= find_calls fc_info e2 fc_state
	find_calls fc_info (RecordUpdate _ expr bexps) fc_state
		#! fc_state	= find_calls fc_info expr fc_state
		= find_calls fc_info (map (\{bind_src} -> bind_src) bexps) fc_state
	find_calls fc_info (TupleSelect _ _ expr) fc_state
		= find_calls fc_info expr fc_state
	find_calls fc_info (BasicExpr _) fc_state
		= fc_state
	find_calls fc_info (AnyCodeExpr _ _ _) fc_state
		= fc_state
	find_calls fc_info (ABCCodeExpr _ _) fc_state
		= fc_state
	find_calls fc_info (MatchExpr _ expr) fc_state
		= find_calls fc_info expr fc_state
441
442
	find_calls fc_info (IsConstructor expr _ _ _ _ _) fc_state
		= find_calls fc_info expr fc_state
443
444
	find_calls fc_info EE fc_state
		= fc_state
Diederik van Arkel's avatar
Diederik van Arkel committed
445
446
	find_calls fc_info (NoBind _) fc_state
		= fc_state
447
448
	find_calls fc_info (FailExpr _) fc_state
		= fc_state
449
450
	find_calls fc_info (DictionariesFunction dictionaries expr expr_type) fc_state
		= find_calls fc_info expr fc_state
451
452
	find_calls fc_info ExprToBeRemoved fc_state
		= fc_state
Diederik van Arkel's avatar
Diederik van Arkel committed
453
454
455
456
457
458
459
460
461
462

instance find_calls App
where
	find_calls fc_info {app_symb,app_args} fc_state
		#! fc_state = get_index app_symb.symb_kind fc_state
		= find_calls fc_info app_args fc_state
	where
		get_index (SK_Function {glob_object,glob_module}) fc_state
			| fc_info.main_dcl_module_n == glob_module && (glob_object < fc_info.def_max || glob_object >= fc_info.def_min)
				= {fc_state & fun_calls = [FunCall glob_object 0: fc_state.fun_calls]}
463
				= {fc_state & fun_calls = [DclFunCall glob_module glob_object: fc_state.fun_calls]}
Diederik van Arkel's avatar
Diederik van Arkel committed
464
		get_index (SK_Constructor idx) fc_state
465
			= fc_state
Diederik van Arkel's avatar
Diederik van Arkel committed
466
		get_index (SK_LocalMacroFunction idx) fc_state
467
468
469
			= {fc_state & fun_calls = [FunCall idx 0: fc_state.fun_calls]}
		get_index (SK_GeneratedFunction fun_ptr idx) fc_state
			= {fc_state & fun_calls = [GeneratedFunCall idx fun_ptr : fc_state.fun_calls]}
Diederik van Arkel's avatar
Diederik van Arkel committed
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503

instance find_calls Let
where
	find_calls fc_info {let_strict_binds,let_lazy_binds,let_expr} fc_state
		= find_calls fc_info (let_strict_binds++let_lazy_binds) (find_calls fc_info let_expr fc_state)

instance find_calls Case
where
	find_calls fc_info {case_expr,case_guards,case_default} fc_state
		#! fc_state	= find_calls fc_info case_expr fc_state
		   fc_state	= find_calls fc_info case_default fc_state
		= find_calls fc_info case_guards fc_state

instance find_calls Selection
where
	find_calls fc_info (RecordSelection _ _) fc_state
		= fc_state
	find_calls fc_info (ArraySelection _ _ expr) fc_state
		= find_calls fc_info expr fc_state
	find_calls fc_info (DictionarySelection _ sells _ expr) fc_state
		= find_calls fc_info expr (find_calls fc_info sells fc_state)
	find_calls _ u _ = abort "Undefined pattern in Selection\n"

instance find_calls LetBind
where
	find_calls fc_info {lb_src} fc_state
		= find_calls fc_info lb_src fc_state

instance find_calls CasePatterns
where
	find_calls fc_info (AlgebraicPatterns _ pats) fc_state
		= find_calls fc_info pats fc_state
	find_calls fc_info (BasicPatterns _ pats) fc_state
		= find_calls fc_info pats fc_state
504
	find_calls fc_info (OverloadedPatterns _ expr pats) fc_state
Diederik van Arkel's avatar
Diederik van Arkel committed
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
		= find_calls fc_info pats (find_calls fc_info expr fc_state)
	find_calls fc_info (NoPattern) fc_state
		= fc_state
	find_calls _ u _ = abort "Undefined pattern in CasePatterns\n"

instance find_calls AlgebraicPattern
where
	find_calls fc_info {ap_expr} fc_state
		= find_calls fc_info ap_expr fc_state

instance find_calls BasicPattern
where
	find_calls fc_info {bp_expr} fc_state
		= find_calls fc_info bp_expr fc_state

520
determine_ref_counts fd=:{fun_body=TransformedBody {tb_args,tb_rhs}} pi_collect
521
	# (new_rhs, new_args, pi_collect) = determineVariablesAndRefCounts tb_args tb_rhs pi_collect
Diederik van Arkel's avatar
Diederik van Arkel committed
522
523
	# fd = {fd & fun_body=TransformedBody {tb_args=new_args,tb_rhs=new_rhs}}
	= (fd,pi_collect)
524
determine_ref_counts fd pi_collect
Diederik van Arkel's avatar
Diederik van Arkel committed
525
526
527
528
529
530
531
532
533
	= (fd, pi_collect)

get_predef_symbols_for_transform :: *PredefinedSymbols -> (!PredefSymbolsForTransform,!.PredefinedSymbols)
get_predef_symbols_for_transform cs_predef_symbols
	# (predef_alias_dummy,cs_predef_symbols) = cs_predef_symbols![PD_DummyForStrictAliasFun]
	# (predef_and,cs_predef_symbols) = cs_predef_symbols![PD_AndOp]
	# (predef_or,cs_predef_symbols) = cs_predef_symbols![PD_OrOp]
	= ({predef_alias_dummy=predef_alias_dummy,predef_and=predef_and,predef_or=predef_or},cs_predef_symbols)

534
set_rec_prop non_recursive fi_properties
535
536
537
	| non_recursive
		= fi_properties bitor FI_IsNonRecursive
		= fi_properties bitand (bitnot FI_IsNonRecursive)
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
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
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
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
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
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
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
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
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872

::	CollectState =
	{	cos_var_heap		:: !.VarHeap
	,	cos_expression_heap :: !.ExpressionHeap
	,	cos_error			:: !.ErrorAdmin
	,	cos_predef_symbols_for_transform :: !PredefSymbolsForTransform
	}

determineVariablesAndRefCounts :: ![FreeVar] !Expression !*CollectState -> (!Expression , ![FreeVar], !*CollectState)
determineVariablesAndRefCounts free_vars expr cos=:{cos_var_heap}
	# cos = {cos & cos_var_heap = clearCount free_vars cIsAGlobalVar cos_var_heap}
	  (expr, cos) = collectVariables expr cos
	  (free_vars, cos_var_heap) = retrieveRefCounts free_vars cos.cos_var_heap
	= (expr, free_vars, { cos & cos_var_heap = cos_var_heap })

retrieveRefCounts free_vars var_heap
	= mapSt retrieveRefCount free_vars var_heap

retrieveRefCount :: FreeVar *VarHeap -> (!FreeVar,!.VarHeap)
retrieveRefCount fv=:{fv_info_ptr} var_heap
	# (VI_Count count _, var_heap) = readPtr fv_info_ptr var_heap
	= ({ fv & fv_count = count }, var_heap)

class clearCount a :: !a !Bool !*VarHeap -> *VarHeap

instance clearCount [a] | clearCount a
where
	clearCount [x:xs] locality var_heap
		= clearCount x locality (clearCount xs locality var_heap)
	clearCount [] locality var_heap
		= var_heap

instance clearCount LetBind
where
	clearCount bind=:{lb_dst} locality var_heap
		= clearCount lb_dst locality var_heap

instance clearCount FreeVar
where
	clearCount {fv_info_ptr} locality var_heap
		= var_heap <:= (fv_info_ptr, VI_Count 0 locality)

instance clearCount (FreeVar,a)
where
	clearCount ({fv_info_ptr},_) locality var_heap
		= var_heap <:= (fv_info_ptr, VI_Count 0 locality)

//	In 'collectVariables' the reference counts of the local as well as of the global variables are determined.
//	Aliases and unreachable bindings introduced in a 'let' are removed.

class collectVariables a :: !a !*CollectState -> (!a, !*CollectState)

cContainsACycle		:== True
cContainsNoCycle	:== False

instance collectVariables Expression
where
	collectVariables (Var var) cos
		# (var, cos) = collectVariables var cos
		= (Var var, cos)
	collectVariables (App app=:{app_args}) cos
		# (app_args, cos) = collectVariables app_args cos
		= (App { app & app_args = app_args}, cos)
	collectVariables (expr @ exprs) cos
		# ((expr, exprs), cos) = collectVariables (expr, exprs) cos
		= (expr @ exprs, cos)
	collectVariables (Let lad=:{let_strict_binds, let_lazy_binds, let_expr, let_info_ptr}) cos=:{cos_var_heap}
		# cos_var_heap = determine_aliases let_strict_binds cos.cos_var_heap
		  cos_var_heap = determine_aliases let_lazy_binds cos_var_heap

		  (let_info,cos_expression_heap)	= readPtr let_info_ptr cos.cos_expression_heap
		  let_types = case let_info of
						EI_LetType let_types	-> let_types
						_						-> repeat undef
		  cos & cos_var_heap=cos_var_heap, cos_expression_heap = cos_expression_heap

		  (let_strict_binds, let_types)	= combine let_strict_binds let_types
				with
					combine [] let_types
						= ([],let_types)
					combine [lb:let_binds] [tp:let_types]
						# (let_binds,let_types)	= combine let_binds let_types
						= ([(tp, lb) : let_binds], let_types)
		  let_lazy_binds = zip2 let_types let_lazy_binds

		  (is_cyclic_s, let_strict_binds, cos)
				= detect_cycles_and_handle_alias_binds True let_strict_binds cos
		  (is_cyclic_l, let_lazy_binds, cos)
				= detect_cycles_and_handle_alias_binds False let_lazy_binds cos
		| is_cyclic_s || is_cyclic_l
			# (let_strict_bind_types,let_strict_binds) = unzip let_strict_binds
			  (let_lazy_bind_types,let_lazy_binds) = unzip let_lazy_binds
			  let_info = case let_info of
				EI_LetType _	-> EI_LetType (let_strict_bind_types ++ let_lazy_bind_types)
				_				-> let_info
			  cos & cos_expression_heap = writePtr let_info_ptr let_info cos.cos_expression_heap
			= (Let {lad & let_strict_binds = let_strict_binds, let_lazy_binds = let_lazy_binds },
					{ cos & cos_error = checkError "" "cyclic let definition" cos.cos_error})
//		| otherwise
			# (let_expr, cos) = collectVariables let_expr cos
			  (collected_strict_binds, collected_lazy_binds, cos)
				= collect_variables_in_binds let_strict_binds let_lazy_binds [] [] cos
			| collected_strict_binds=:[] && collected_lazy_binds=:[]
				= (let_expr, cos)
				# (let_strict_bind_types,let_strict_binds) = unzip collected_strict_binds
				  (let_lazy_bind_types,let_lazy_binds) = unzip collected_lazy_binds
				  let_info = case let_info of
					EI_LetType _	-> EI_LetType (let_strict_bind_types ++ let_lazy_bind_types)
					_				-> let_info
				  cos & cos_expression_heap = writePtr let_info_ptr let_info cos.cos_expression_heap
				= (Let {lad & let_expr = let_expr, let_strict_binds = let_strict_binds, let_lazy_binds = let_lazy_binds}, cos)
		where
		/*	Set the 'var_info_field' of each  bound variable to either 'VI_Alias var' (if
			this variable is an alias for 'var') or to 'VI_Count 0 cIsALocalVar' to initialise
			the reference count info.
		*/
			determine_aliases [{lb_dst={fv_info_ptr}, lb_src = Var var} : binds] var_heap
				= determine_aliases binds (writePtr fv_info_ptr (VI_Alias var) var_heap)
			determine_aliases [bind : binds] var_heap
				= determine_aliases binds (clearCount bind cIsALocalVar var_heap)
			determine_aliases [] var_heap
				= var_heap

		/*	Remove all aliases from the list of lazy 'let'-binds. Add a _dummyForStrictAlias
			function call for the strict aliases. Be careful with cycles! */

			detect_cycles_and_handle_alias_binds :: !.Bool !u:[v:(.a,w:LetBind)] !*CollectState -> (!.Bool,!x:[y:(.a,z:LetBind)],!.CollectState), [u <= x,v <= y,w <= z]
			detect_cycles_and_handle_alias_binds is_strict [] cos
				= (cContainsNoCycle, [], cos)
//			detect_cycles_and_handle_alias_binds is_strict [bind=:{bind_dst={fv_info_ptr}} : binds] cos
			detect_cycles_and_handle_alias_binds is_strict [(type,bind=:{lb_dst={fv_info_ptr}}) : binds] cos
				# (var_info, cos_var_heap) = readPtr fv_info_ptr cos.cos_var_heap
				  cos = { cos & cos_var_heap = cos_var_heap }
				= case var_info of
					VI_Alias {var_info_ptr}
						| is_cyclic fv_info_ptr var_info_ptr cos.cos_var_heap
							-> (cContainsACycle, binds, cos)
						| is_strict
							# cos_var_heap = writePtr fv_info_ptr (VI_Count 0 cIsALocalVar) cos.cos_var_heap
							  (new_bind_src, cos) = add_dummy_id_for_strict_alias bind.lb_src
															{ cos & cos_var_heap = cos_var_heap }
							  (is_cyclic, binds, cos)
									= detect_cycles_and_handle_alias_binds is_strict binds cos
							-> (is_cyclic, [(type,{ bind & lb_src = new_bind_src }) : binds], cos)
						-> detect_cycles_and_handle_alias_binds is_strict binds cos
					_
						# (is_cyclic, binds, cos) = detect_cycles_and_handle_alias_binds is_strict binds cos
						-> (is_cyclic, [(type,bind) : binds], cos)
			where
				is_cyclic :: !.(Ptr VarInfo) !(Ptr VarInfo) !VarHeap -> .Bool
				is_cyclic orig_info_ptr info_ptr var_heap
					| orig_info_ptr == info_ptr
						= True
						#! var_info = sreadPtr info_ptr var_heap
						= case var_info of
							VI_Alias {var_info_ptr}
								-> is_cyclic orig_info_ptr var_info_ptr var_heap
							_
								-> False

				add_dummy_id_for_strict_alias :: !.Expression !*CollectState -> (!.Expression,!.CollectState)
				add_dummy_id_for_strict_alias bind_src cos=:{cos_expression_heap, cos_predef_symbols_for_transform}
					# (new_app_info_ptr, cos_expression_heap) = newPtr EI_Empty cos_expression_heap
					  {pds_module, pds_def} = cos_predef_symbols_for_transform.predef_alias_dummy
					  pds_ident = predefined_idents.[PD_DummyForStrictAliasFun]
					  app_symb = { symb_ident = pds_ident, symb_kind = SK_Function {glob_module = pds_module, glob_object = pds_def} }
					= (App { app_symb = app_symb, app_args = [bind_src], app_info_ptr = new_app_info_ptr },
						{ cos & cos_expression_heap = cos_expression_heap } )

		/*	Apply 'collectVariables' to the bound expressions (the 'bind_src' field of 'let'-bind) if
		    the corresponding bound variable (the 'bind_dst' field) has been used. This can be determined
		    by examining the reference count.
		*/
			collect_variables_in_binds :: ![(t,LetBind)] ![(t,LetBind)] ![(t,LetBind)] ![(t,LetBind)] !*CollectState
																	-> (![(t,LetBind)],![(t,LetBind)],!*CollectState)
			collect_variables_in_binds strict_binds lazy_binds collected_strict_binds collected_lazy_binds cos
				# (bind_fond, lazy_binds, collected_lazy_binds, cos)
					= examine_reachable_binds False lazy_binds collected_lazy_binds cos
				# (bind_fond, strict_binds, collected_strict_binds, cos)
					= examine_reachable_binds bind_fond strict_binds collected_strict_binds cos
				| bind_fond
					= collect_variables_in_binds strict_binds lazy_binds collected_strict_binds collected_lazy_binds cos
					# cos & cos_error=report_unused_strict_binds strict_binds cos.cos_error
					= (collected_strict_binds, collected_lazy_binds, cos)

			examine_reachable_binds :: !Bool ![(t,LetBind)] ![(t,LetBind)] !*CollectState -> *(!Bool,![(t,LetBind)],![(t,LetBind)],!*CollectState)
			examine_reachable_binds bind_found [bind=:(type, letb=:{lb_dst=fv=:{fv_info_ptr},lb_src}) : binds] collected_binds cos
				# (bind_found, binds, collected_binds, cos) = examine_reachable_binds bind_found binds collected_binds cos
				# (info, cos_var_heap) = readPtr fv_info_ptr cos.cos_var_heap
				# cos = { cos & cos_var_heap = cos_var_heap }
				= case info of
					VI_Count count _
						| count > 0
							#  (lb_src, cos) = collectVariables lb_src cos
							-> (True, binds, [ (type, { letb & lb_dst = { fv & fv_count = count }, lb_src = lb_src }) : collected_binds ], cos)
							-> (bind_found, [bind : binds], collected_binds, cos)
			examine_reachable_binds bind_found [] collected_binds cos
				= (bind_found, [], collected_binds, cos)

			report_unused_strict_binds [(type,{lb_dst={fv_ident},lb_position}):binds] errors
				= report_unused_strict_binds binds (checkWarningWithPosition fv_ident lb_position "not used, ! ignored" errors)
			report_unused_strict_binds [] errors
				= errors

	collectVariables (Case case_expr) cos
		# (case_expr, cos) = collectVariables case_expr cos
		= (Case case_expr, cos)
	collectVariables (Selection is_unique expr selectors) cos
		# ((expr, selectors), cos) = collectVariables (expr, selectors) cos
		= (Selection is_unique expr selectors, cos)
	collectVariables (Update expr1 selectors expr2) cos
		# (((expr1, expr2), selectors), cos) = collectVariables ((expr1, expr2), selectors) cos
		= (Update expr1 selectors expr2, cos)
	collectVariables (RecordUpdate cons_symbol expression expressions) cos
		# ((expression, expressions), cos) = collectVariables (expression, expressions) cos
		= (RecordUpdate cons_symbol expression expressions, cos)
	collectVariables (TupleSelect symbol argn_nr expr) cos
		# (expr, cos) = collectVariables expr cos
		= (TupleSelect symbol argn_nr expr, cos)
	collectVariables (MatchExpr cons_ident expr) cos
		# (expr, cos) = collectVariables expr cos
		= (MatchExpr cons_ident expr, cos)
	collectVariables (IsConstructor expr cons_symbol cons_arity global_type_index case_ident position) cos
		# (expr, cos) = collectVariables expr cos
		= (IsConstructor expr cons_symbol cons_arity global_type_index case_ident position, cos)
	collectVariables (DynamicExpr dynamic_expr) cos
		= abort "collectVariables DynamicExpr"
	collectVariables (TypeSignature type_function expr) cos
		# (expr, cos) = collectVariables expr cos
		= (TypeSignature type_function expr, cos);
	collectVariables (DictionariesFunction dictionaries expr expr_type) cos
		# cos = {cos & cos_var_heap = clearCount dictionaries cIsALocalVar cos.cos_var_heap}
		  (expr, cos) = collectVariables expr cos
		  (dictionaries, var_heap) = mapSt retrieve_ref_count dictionaries cos.cos_var_heap
		  cos = {cos & cos_var_heap = var_heap}
		= (DictionariesFunction dictionaries expr expr_type, cos)
	where
		retrieve_ref_count (fv,a_type) var_heap
			# (fv,var_heap) = retrieveRefCount fv var_heap
			= ((fv,a_type),var_heap)
	collectVariables expr cos
		= (expr, cos)

instance collectVariables Selection
where
	collectVariables (ArraySelection array_select expr_ptr index_expr) cos
		# (index_expr, cos) = collectVariables index_expr cos
		= (ArraySelection array_select expr_ptr index_expr, cos)
	collectVariables (DictionarySelection dictionary_select selectors expr_ptr index_expr) cos
		# ((index_expr,selectors), cos) = collectVariables (index_expr,selectors) cos
		= (DictionarySelection dictionary_select selectors expr_ptr index_expr, cos)
	collectVariables record_selection cos
		= (record_selection, cos)

instance collectVariables [a] | collectVariables a
where
	collectVariables [x:xs] cos
		# (x, cos) = collectVariables x cos
		# (xs, cos) = collectVariables xs cos
		= ([x:xs], cos)
	collectVariables [] cos
		= ([], cos)

instance collectVariables (!a,!b) | collectVariables a & collectVariables b
where
	collectVariables (x,y) cos
		# (x, cos) = collectVariables x cos
		# (y, cos) = collectVariables y cos
		= ((x,y), cos)

instance collectVariables (Optional a) | collectVariables a
where
	collectVariables (Yes x) cos
		# (x, cos) = collectVariables x cos
		= (Yes x, cos)
	collectVariables no cos
		= (no, cos)

instance collectVariables (Bind a b) | collectVariables a where
	collectVariables bind=:{bind_src} cos
		# (bind_src, cos) = collectVariables bind_src cos
		= ({bind & bind_src = bind_src}, cos)

instance collectVariables Case
where
	collectVariables kees=:{ case_expr, case_guards, case_default } cos
		# (case_expr, cos) = collectVariables case_expr cos
		# (case_guards, cos) = collectVariables case_guards cos
		# (case_default, cos) = collectVariables case_default cos
		=  ({ kees & case_expr = case_expr, case_guards = case_guards, case_default = case_default }, cos)

instance collectVariables CasePatterns
where
	collectVariables (AlgebraicPatterns type patterns) cos
		# (patterns, cos) = collectVariables patterns cos
		= (AlgebraicPatterns type patterns, cos)
	collectVariables (BasicPatterns type patterns) cos
		# (patterns, cos) = collectVariables patterns cos
		= (BasicPatterns type patterns, cos)
	collectVariables (OverloadedPatterns type decons_expr patterns) cos
		# (patterns, cos) = collectVariables patterns cos
		= (OverloadedPatterns type decons_expr patterns, cos)
	collectVariables (NewTypePatterns type patterns) cos
		# (patterns, cos) = collectVariables patterns cos
		= (NewTypePatterns type patterns, cos)
	collectVariables NoPattern cos
		= (NoPattern, cos)

instance collectVariables AlgebraicPattern
where
	collectVariables pattern=:{ap_vars,ap_expr} cos
		# cos = {cos & cos_var_heap = clearCount ap_vars cIsALocalVar cos.cos_var_heap}
		  (ap_expr, cos) = collectVariables ap_expr cos
		  (ap_vars, cos_var_heap) = retrieveRefCounts ap_vars cos.cos_var_heap
		= ({ pattern & ap_expr = ap_expr, ap_vars = ap_vars }, { cos & cos_var_heap = cos_var_heap })

instance collectVariables BasicPattern
where
	collectVariables pattern=:{bp_expr} cos
		# (bp_expr, cos) = collectVariables bp_expr cos
		= ({ pattern & bp_expr = bp_expr }, cos)

instance collectVariables BoundVar
where
	collectVariables var=:{var_ident,var_info_ptr,var_expr_ptr} cos=:{cos_var_heap}
		# (var_info, cos_var_heap) = readPtr var_info_ptr cos_var_heap
		  cos = { cos & cos_var_heap = cos_var_heap }
		= case var_info of
			VI_Count count is_global
				| count > 0 || is_global
					-> (var, { cos & cos_var_heap = writePtr var_info_ptr (VI_Count (inc count) is_global) cos.cos_var_heap })
					-> (var, { cos & cos_var_heap = writePtr var_info_ptr (VI_Count 1 is_global) cos.cos_var_heap })
			VI_Alias alias
				#  (original, cos) = collectVariables alias cos
				-> ({ original & var_expr_ptr = var_expr_ptr }, cos)