refmark.icl 29.1 KB
Newer Older
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
implementation module refmark

import StdEnv
import syntax, Heap, typesupport, check, overloading, unitype, utilities, RWSDebug


NotASelector :== -1

class refMark expr ::  ![[FreeVar]] !Int !expr !*VarHeap -> *VarHeap


instance refMark [a] | refMark a
where
	refMark free_vars sel list var_heap
		= foldSt (refMark free_vars sel) list var_heap

collectAllSelections [] cum_sels
	= cum_sels
collectAllSelections [{su_multiply,su_uniquely} : sels ] cum_sels
	= collectAllSelections sels (su_uniquely ++ su_multiply ++ cum_sels)

addSelection var_expr_ptr sel []
	= [ { su_field = sel, su_multiply = [], su_uniquely = [var_expr_ptr]  } ]
addSelection var_expr_ptr sel sels=:[selection=:{ su_field,su_multiply,su_uniquely } : selections]
	| sel == su_field
26
		= [ { selection & su_multiply = su_multiply ++ [var_expr_ptr : su_uniquely], su_uniquely = [] } : selections ]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
	| sel < su_field
		= [ { su_field = sel, su_multiply = [], su_uniquely = [var_expr_ptr]  } : sels ]
		= [ selection : addSelection var_expr_ptr sel selections ]
		
saveOccurrences free_vars var_heap
	= foldSt (foldSt save_occurrence) free_vars var_heap
where
	save_occurrence {fv_name,fv_info_ptr} var_heap
		# (VI_Occurrence old_occ=:{occ_ref_count,occ_previous}, var_heap) = readPtr fv_info_ptr var_heap
		= var_heap <:= (fv_info_ptr, VI_Occurrence {old_occ & occ_ref_count = RC_Unused, occ_previous = [occ_ref_count : occ_previous] } )
	

adjustRefCount sel RC_Unused var_expr_ptr
	| sel == NotASelector
		= RC_Used {rcu_multiply = [], rcu_selectively = [], rcu_uniquely = [var_expr_ptr] }
		# sel_ref = { su_field = sel, su_multiply = [], su_uniquely = [var_expr_ptr] }
		= RC_Used {rcu_multiply = [], rcu_selectively = [{ su_field = sel, su_multiply = [], su_uniquely = [var_expr_ptr] }], rcu_uniquely = [] }
adjustRefCount sel (RC_Used {rcu_multiply,rcu_uniquely,rcu_selectively}) var_expr_ptr
	| sel == NotASelector
		# rcu_multiply = collectAllSelections rcu_selectively (rcu_uniquely ++ [var_expr_ptr : rcu_multiply])
		= RC_Used {rcu_multiply = rcu_multiply, rcu_uniquely = [], rcu_selectively = [] }
		# rcu_selectively = addSelection var_expr_ptr sel rcu_selectively
		  rcu_multiply = rcu_uniquely ++ rcu_multiply
		= RC_Used {rcu_multiply = rcu_multiply, rcu_uniquely = [], rcu_selectively = rcu_selectively }

markPatternVariables sel used_pattern_vars var_heap
	| sel == NotASelector
		= foldSt mark_variable [ fv \\ (fv,_) <- used_pattern_vars ] var_heap
		= mark_pattern_variable sel used_pattern_vars var_heap
where
	mark_pattern_variable sel [] var_heap
		= var_heap
	mark_pattern_variable sel [(fv, var_number) : used_pattern_vars ] var_heap
		| sel == var_number
			= mark_variable fv var_heap
			= mark_pattern_variable sel used_pattern_vars var_heap
		
	mark_variable {fv_info_ptr} var_heap
		# (VI_Occurrence old_occ=:{occ_ref_count}, var_heap) = readPtr fv_info_ptr var_heap
		= case occ_ref_count of
			RC_Unused
				# occ_ref_count = RC_Used {rcu_multiply = [], rcu_selectively = [], rcu_uniquely = [nilPtr] }
				-> var_heap <:= (fv_info_ptr, VI_Occurrence {old_occ & occ_ref_count = occ_ref_count } )
			RC_Used {rcu_multiply,rcu_uniquely,rcu_selectively}
				# occ_ref_count = RC_Used { rcu_multiply = collectAllSelections rcu_selectively (rcu_uniquely ++ rcu_multiply),
							 rcu_selectively = [], rcu_uniquely = [] }
				-> var_heap <:= (fv_info_ptr, VI_Occurrence {old_occ & occ_ref_count = occ_ref_count } )

75
76
77
78
79
80
81
82
83
84
85
refMarkOfVariable free_vars sel (VI_Occurrence var_occ) var_name var_info_ptr var_expr_ptr var_heap
	# occ_ref_count = adjustRefCount sel var_occ.occ_ref_count var_expr_ptr
	= case var_occ.occ_bind of // ---> (var_name,var_expr_ptr,occ_ref_count,var_occ.occ_ref_count) of
		OB_OpenLet let_expr
			# var_heap = var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_ref_count = occ_ref_count, occ_bind = OB_LockedLet let_expr })
			-> refMark free_vars sel let_expr var_heap
		OB_Pattern used_pattern_vars occ_bind
			-> markPatternVariables sel used_pattern_vars (var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_ref_count = occ_ref_count }))
		_
			-> var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_ref_count = occ_ref_count })

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
86
87
88
89

instance refMark BoundVar
where
	refMark free_vars sel {var_name,var_expr_ptr,var_info_ptr} var_heap
90
91
		# (var_occ, var_heap) = readPtr var_info_ptr var_heap
		= refMarkOfVariable free_vars sel var_occ var_name var_info_ptr var_expr_ptr var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
92
93
94
95
96
97
98
99
100
			
instance refMark Expression
where
	refMark free_vars sel (Var var) var_heap
		= refMark free_vars sel var var_heap
	refMark free_vars sel (App {app_args}) var_heap
		= refMark free_vars NotASelector app_args var_heap
	refMark free_vars sel (fun @ args) var_heap
		= refMark free_vars NotASelector args (refMark free_vars NotASelector fun var_heap)
Sjaak Smetsers's avatar
Sjaak Smetsers committed
101
102
103
104
	refMark free_vars sel (Let {let_strict_binds,let_lazy_binds,let_expr}) var_heap
		| isEmpty let_lazy_binds
			# new_free_vars = [ [ bind_dst \\ {bind_dst} <- let_strict_binds ] : free_vars]
			# (observing, var_heap) = binds_are_observing let_strict_binds var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
105
106
			| observing
				# var_heap = saveOccurrences free_vars var_heap
Sjaak Smetsers's avatar
Sjaak Smetsers committed
107
				  var_heap = refMark new_free_vars NotASelector let_strict_binds var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
108
109
110
				  var_heap = saveOccurrences new_free_vars var_heap
				  var_heap = refMark new_free_vars sel let_expr var_heap
				= let_combine free_vars var_heap
Sjaak Smetsers's avatar
Sjaak Smetsers committed
111
112
113
114
				= refMark new_free_vars sel let_expr (refMark new_free_vars NotASelector let_strict_binds var_heap)
			# new_free_vars = [ [ bind_dst \\ {bind_dst} <- let_strict_binds ++ let_lazy_binds ] : free_vars]
			  var_heap = foldSt bind_variable let_strict_binds var_heap
			  var_heap = foldSt bind_variable let_lazy_binds var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
115
116
117
118
119
120
121
			= refMark new_free_vars sel let_expr var_heap

		where
		    binds_are_observing binds var_heap
		    	= foldr bind_is_observing (True, var_heap) binds
			where
				bind_is_observing {bind_dst={fv_info_ptr}} (observe, var_heap) 
122
					# (VI_Occurrence {occ_observing}, var_heap) = readPtr fv_info_ptr var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
123
124
125
126
127
128
129
130
					= (occ_observing && observe, var_heap)
			
			let_combine free_vars var_heap
				= foldSt (foldSt let_combine_ref_count) free_vars var_heap
			where
				let_combine_ref_count {fv_info_ptr} var_heap
					# (VI_Occurrence old_occ=:{occ_ref_count,occ_previous=[prev_ref_count, pre_pref_recount:occ_previouses]}, var_heap)
							= readPtr fv_info_ptr var_heap
Sjaak Smetsers's avatar
Sjaak Smetsers committed
131
					  comb_ref_count = parCombineRefCount (seqCombineRefCount occ_ref_count prev_ref_count) pre_pref_recount
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
132
133
134
135
					= var_heap <:= (fv_info_ptr, VI_Occurrence { old_occ & occ_ref_count = comb_ref_count, occ_previous = occ_previouses })

			bind_variable {bind_src,bind_dst={fv_info_ptr}} var_heap
				# (VI_Occurrence occ, var_heap) = readPtr fv_info_ptr var_heap
Sjaak Smetsers's avatar
Sjaak Smetsers committed
136
137
//				= var_heap <:= (fv_info_ptr, VI_Occurrence { occ & occ_bind = OB_OpenLet bind_src })
				= var_heap <:= (fv_info_ptr, VI_Occurrence { occ & occ_ref_count = RC_Unused, occ_bind = OB_OpenLet bind_src })
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160

	refMark free_vars sel (Case {case_expr,case_guards,case_default}) var_heap
		= refMarkOfCase free_vars sel case_expr case_guards case_default var_heap
	refMark free_vars sel (Selection _ expr selectors) var_heap
		= refMark free_vars (field_number selectors) expr var_heap
	where
		field_number [ RecordSelection _ field_nr : _ ]
			= field_nr	
		field_number _
			= NotASelector	
	refMark free_vars sel (Update expr1 selectors expr2) var_heap
		= refMark free_vars NotASelector expr2 (refMark free_vars NotASelector expr1 var_heap)
	refMark free_vars sel (RecordUpdate cons_symbol expression expressions) var_heap
		= ref_mark_of_record_expression free_vars expression expressions var_heap
	where
		ref_mark_of_record_expression free_vars (Var var) fields var_heap
			= ref_mark_of_fields 0 free_vars fields var var_heap
		ref_mark_of_record_expression free_vars expression fields var_heap
			# var_heap = refMark free_vars NotASelector expression var_heap
			= foldSt (ref_mark_of_field free_vars) fields var_heap
	
		ref_mark_of_fields field_nr free_vars [] var var_heap
			= var_heap
161
162
163
		ref_mark_of_fields field_nr free_vars [{bind_src = NoBind expr_ptr} : fields] var=:{var_name,var_info_ptr} var_heap
			# (var_occ, var_heap) = readPtr var_info_ptr var_heap
			  var_heap = refMarkOfVariable free_vars field_nr var_occ var_name var_info_ptr expr_ptr var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
			= ref_mark_of_fields (inc field_nr) free_vars fields var var_heap
		ref_mark_of_fields field_nr free_vars [{bind_src} : fields] var var_heap
			# var_heap = refMark free_vars NotASelector bind_src var_heap
			= ref_mark_of_fields (inc field_nr) free_vars fields var var_heap

		ref_mark_of_field free_vars {bind_src} var_heap
			= refMark free_vars NotASelector bind_src var_heap

	refMark free_vars sel (TupleSelect _ arg_nr expr) var_heap
		= refMark free_vars arg_nr expr var_heap
	refMark free_vars sel (MatchExpr _ _ expr) var_heap
		= refMark free_vars sel expr var_heap
	refMark free_vars sel EE var_heap
		= var_heap
	refMark _ _ _ var_heap
		= var_heap


isUsed RC_Unused	= False				
isUsed _			= True				

185
instance refMark (Bind a b) | refMark a
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
where
	refMark free_vars sel {bind_src} var_heap
		= refMark free_vars NotASelector bind_src var_heap

instance refMark Selection
where
	refMark free_vars _ (ArraySelection _ _ index_expr) var_heap
		= refMark free_vars NotASelector index_expr var_heap

collectUsedFreeVariables free_vars var_heap
	= foldSt collectUsedVariables free_vars ([], var_heap)

collectUsedVariables free_vars (collected_vars, var_heap)
	= foldSt collect_used_var free_vars (collected_vars, var_heap)
where
	collect_used_var fv=:{fv_info_ptr} (collected_vars, var_heap)
		# (VI_Occurrence occ=:{occ_ref_count}, var_heap) = readPtr fv_info_ptr var_heap
		| isUsed occ_ref_count
			= ([ fv : collected_vars ], var_heap)
			= (collected_vars, var_heap)

collectPatternsVariables pattern_vars
	= collect_used_vars pattern_vars 0 []
where
	collect_used_vars [ fv=:{fv_count} : pattern_vars ] arg_nr collected_vars
		| fv_count > 0
			= collect_used_vars pattern_vars (inc arg_nr) [ (fv, arg_nr) : collected_vars ]
			= collect_used_vars pattern_vars (inc arg_nr) collected_vars
	collect_used_vars [] arg_nr collected_vars
		= collected_vars

collectLocalLetVars free_vars var_heap
	= foldSt (foldSt collect_local_let_var) free_vars ([], var_heap)
where
	collect_local_let_var fv=:{fv_info_ptr} (collected_vars, var_heap)
		# (VI_Occurrence var_occ, var_heap) = readPtr fv_info_ptr var_heap
		= case var_occ.occ_bind of
			OB_OpenLet _
				-> ([ fv_info_ptr : collected_vars], var_heap)
			_
				-> (collected_vars, var_heap)
		
collectUsedLetVars local_vars (used_vars, var_heap)
	= foldSt collect_local_let_var local_vars (used_vars, var_heap)
where
	collect_local_let_var fv_info_ptr (used_vars, var_heap)
		# (VI_Occurrence var_occ, var_heap) = readPtr fv_info_ptr var_heap
		= case var_occ.occ_bind of
			OB_LockedLet let_expr
				-> ([ fv_info_ptr : used_vars], var_heap <:= (fv_info_ptr, VI_Occurrence { var_occ & occ_bind = OB_OpenLet let_expr }))
			_
				-> (used_vars, var_heap)

setUsedLetVars used_vars var_heap
	= foldSt set_used_let_var used_vars var_heap
where
	set_used_let_var fv_info_ptr var_heap
		# (VI_Occurrence var_occ, var_heap) = readPtr fv_info_ptr var_heap
		= case var_occ.occ_bind of
			OB_OpenLet let_expr
				-> var_heap <:= (fv_info_ptr, VI_Occurrence { var_occ & occ_bind = OB_LockedLet let_expr })
			_
				-> var_heap

refMarkOfCase free_vars sel expr (AlgebraicPatterns type patterns) defaul var_heap
	= ref_mark_of_algebraic_case free_vars sel expr patterns defaul var_heap
where
	ref_mark_of_algebraic_case free_vars sel (Var {var_name,var_info_ptr,var_expr_ptr}) patterns defaul var_heap
		# (VI_Occurrence var_occ=:{occ_bind,occ_ref_count}, var_heap) = readPtr var_info_ptr var_heap
		= case occ_bind of
			OB_Empty
Sjaak Smetsers's avatar
bugfix    
Sjaak Smetsers committed
257
258
259
260
261
262
263
				-> ref_mark_of_algebraic_case_with_variable_pattern False var_info_ptr var_expr_ptr var_occ free_vars sel patterns defaul var_heap
			OB_OpenLet let_expr
				# var_heap = var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_ref_count = occ_ref_count, occ_bind = OB_LockedLet let_expr })
				  var_heap = refMark free_vars sel let_expr var_heap
				-> ref_mark_of_algebraic_case_with_variable_pattern True var_info_ptr var_expr_ptr var_occ free_vars sel patterns defaul var_heap
			OB_LockedLet _
				-> ref_mark_of_algebraic_case_with_variable_pattern True var_info_ptr var_expr_ptr var_occ free_vars sel patterns defaul var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
264
265
266
	ref_mark_of_algebraic_case free_vars sel expr patterns defaul var_heap
		= ref_mark_of_algebraic_case_with_non_variable_pattern free_vars sel expr patterns defaul var_heap

Sjaak Smetsers's avatar
bugfix    
Sjaak Smetsers committed
267
268
269
	ref_mark_of_algebraic_case_with_variable_pattern with_composite_pattern var_info_ptr var_expr_ptr {occ_ref_count = RC_Unused}
					free_vars sel patterns case_default var_heap
		# var_heap = ref_mark_of_patterns with_composite_pattern free_vars sel (Yes var_info_ptr) patterns case_default var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
270
271
272
273
274
275
276
277
		  (VI_Occurrence var_occ, var_heap) = readPtr var_info_ptr var_heap
		= case var_occ.occ_ref_count of
				RC_Unused
					-> var_heap <:= (var_info_ptr, VI_Occurrence { var_occ &
								occ_ref_count = RC_Used {	rcu_multiply = [], rcu_uniquely = [var_expr_ptr], rcu_selectively = [] }})
				RC_Used rcu
					-> var_heap <:= (var_info_ptr, VI_Occurrence { var_occ &
								occ_ref_count = RC_Used { rcu & rcu_uniquely = [var_expr_ptr : rcu.rcu_uniquely] }})					
Sjaak Smetsers's avatar
bugfix    
Sjaak Smetsers committed
278
279
	ref_mark_of_algebraic_case_with_variable_pattern with_composite_pattern var_info_ptr var_expr_ptr
			var_occ=:{occ_ref_count = RC_Used {rcu_multiply,rcu_uniquely,rcu_selectively}} free_vars sel patterns case_default var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
280
281
282
		# var_occ = { var_occ & occ_ref_count = RC_Used { rcu_multiply = collectAllSelections rcu_selectively (rcu_uniquely ++ [var_expr_ptr : rcu_multiply]),
														  rcu_uniquely = [], rcu_selectively = [] }}
		  var_heap = var_heap <:= (var_info_ptr, VI_Occurrence var_occ )
Sjaak Smetsers's avatar
bugfix    
Sjaak Smetsers committed
283
		= ref_mark_of_patterns with_composite_pattern free_vars sel (Yes var_info_ptr) patterns case_default var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
284
285
286

	ref_mark_of_algebraic_case_with_non_variable_pattern free_vars sel expr patterns case_default var_heap
		# var_heap = refMark free_vars NotASelector expr var_heap
Sjaak Smetsers's avatar
bugfix    
Sjaak Smetsers committed
287
288
289
290
		= ref_mark_of_patterns True free_vars sel No patterns case_default var_heap

	ref_mark_of_patterns with_composite_pattern free_vars sel opt_pattern_var patterns case_default var_heap
		# (local_lets, var_heap) = collectLocalLetVars free_vars var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
291
		  (with_pattern_bindings, pattern_depth, used_lets, var_heap)
Sjaak Smetsers's avatar
bug fix    
Sjaak Smetsers committed
292
			= foldSt (ref_mark_of_algebraic_pattern free_vars sel opt_pattern_var local_lets) patterns (False, 0, [], var_heap)		
Sjaak Smetsers's avatar
bugfix    
Sjaak Smetsers committed
293
		= refMarkOfDefault (with_composite_pattern && with_pattern_bindings) pattern_depth free_vars sel case_default used_lets var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
294
295
296
297
298
299
300
301

	ref_mark_of_algebraic_pattern free_vars sel opt_pattern_var local_lets {ap_vars,ap_expr}
					(with_pattern_bindings, pattern_depth, used_lets, var_heap) 
		# pattern_depth = inc pattern_depth
		  var_heap = saveOccurrences free_vars var_heap
		  used_pattern_vars = collectPatternsVariables ap_vars
		  var_heap = bind_optional_pattern_variable opt_pattern_var used_pattern_vars var_heap
		  var_heap = refMark [ [ fv \\ (fv,_) <- used_pattern_vars ] : free_vars ] sel ap_expr var_heap
Sjaak Smetsers's avatar
bug fix    
Sjaak Smetsers committed
302
		  var_heap = restore_binding_of_pattern_variable opt_pattern_var used_pattern_vars var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
303
304
305
306
307
308
309
310
311
312
313
		  (used_lets, var_heap) = collectUsedLetVars local_lets (used_lets, var_heap)
		= (with_pattern_bindings || not (isEmpty used_pattern_vars), pattern_depth, used_lets, var_heap)
	
	bind_optional_pattern_variable _ [] var_heap
		= var_heap
	bind_optional_pattern_variable (Yes var_info_ptr) used_pattern_vars var_heap
		# (VI_Occurrence var_occ=:{occ_bind}, var_heap) = readPtr var_info_ptr var_heap
		= var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_bind = OB_Pattern used_pattern_vars occ_bind })
	bind_optional_pattern_variable _ used_pattern_vars var_heap
		= var_heap

Sjaak Smetsers's avatar
bug fix    
Sjaak Smetsers committed
314
	restore_binding_of_pattern_variable _ [] var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
315
		= var_heap
Sjaak Smetsers's avatar
bug fix    
Sjaak Smetsers committed
316
317
	restore_binding_of_pattern_variable (Yes var_info_ptr) used_pattern_vars var_heap
		# (VI_Occurrence var_occ=:{occ_ref_count, occ_bind=OB_Pattern _ occ_bind}, var_heap) = readPtr var_info_ptr var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
318
		= var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_bind = occ_bind})
Sjaak Smetsers's avatar
bug fix    
Sjaak Smetsers committed
319
320
//			---> ("restore_binding_of_pattern_variable", occ_ref_count)
	restore_binding_of_pattern_variable _ used_pattern_vars var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
321
322
323
324
325
326
327
		= var_heap
	
refMarkOfCase free_vars sel expr (BasicPatterns type patterns) defaul var_heap
	# var_heap = refMark free_vars NotASelector expr var_heap
	  (local_lets, var_heap) = collectLocalLetVars free_vars var_heap
	  (pattern_depth, used_lets, var_heap) = foldSt (ref_mark_of_basic_pattern free_vars sel local_lets) patterns (0, [], var_heap)
	= refMarkOfDefault False pattern_depth free_vars sel defaul used_lets var_heap
Sjaak Smetsers's avatar
Sjaak Smetsers committed
328
//		---> ("refMarkOfCase", expr, [ (bp_value, bp_expr) \\ {bp_value, bp_expr} <- patterns])
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
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
365
366
367
where
	ref_mark_of_basic_pattern free_vars sel local_lets {bp_expr} (pattern_depth, used_lets, var_heap)
		# pattern_depth = inc pattern_depth
		  var_heap = saveOccurrences free_vars var_heap
		  var_heap = refMark free_vars sel bp_expr var_heap
		  (used_lets, var_heap) = collectUsedLetVars local_lets (used_lets, var_heap)
		= (pattern_depth, used_lets, var_heap)

refMarkOfCase free_vars sel expr (DynamicPatterns patterns) defaul var_heap
	# var_heap = saveOccurrences free_vars var_heap
	  var_heap = refMark free_vars NotASelector expr var_heap
	  (used_free_vars, var_heap) = collectUsedFreeVariables free_vars var_heap
	  var_heap = parCombine free_vars var_heap
	  (local_lets, var_heap) = collectLocalLetVars free_vars var_heap
	  (pattern_depth, used_lets, var_heap) = foldSt (ref_mark_of_dynamic_pattern free_vars sel local_lets) patterns (0, [], var_heap)
	= refMarkOfDefault True pattern_depth free_vars sel defaul used_lets var_heap
where
	ref_mark_of_dynamic_pattern free_vars sel local_lets {dp_var, dp_rhs} (pattern_depth, used_lets, var_heap)
		# pattern_depth = inc pattern_depth
		  var_heap = saveOccurrences free_vars var_heap
		  used_pattern_vars = collectPatternsVariables [dp_var]
		  var_heap = refMark [ [ fv \\ (fv,_) <- used_pattern_vars ] : free_vars ] sel dp_rhs var_heap
		  (used_lets, var_heap) = collectUsedLetVars local_lets (used_lets, var_heap)
		= (pattern_depth, used_lets, var_heap)

refMarkOfDefault do_par_combine pattern_depth free_vars sel (Yes expr) used_lets var_heap
	# pattern_depth = inc pattern_depth
	  var_heap = saveOccurrences free_vars var_heap
	  var_heap = refMark free_vars sel expr var_heap
	  var_heap = setUsedLetVars used_lets var_heap
	= caseCombine do_par_combine free_vars var_heap pattern_depth
refMarkOfDefault do_par_combine pattern_depth free_vars sel No used_lets var_heap
	# var_heap = setUsedLetVars used_lets var_heap
	= caseCombine do_par_combine free_vars var_heap pattern_depth

parCombine free_vars var_heap
	= foldSt (foldSt (par_combine)) free_vars var_heap
where
	par_combine {fv_info_ptr} var_heap
368
		# (VI_Occurrence old_occ=:{occ_ref_count,occ_previous=[prev_ref_count:prev_counts]}, var_heap) = readPtr fv_info_ptr var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
369
370
371
372
373
374
375
376
		= var_heap <:= (fv_info_ptr, VI_Occurrence { old_occ &
				occ_ref_count = parCombineRefCount occ_ref_count prev_ref_count , occ_previous = prev_counts })


caseCombine do_par_combine free_vars var_heap depth
	= foldSt (foldSt (case_combine do_par_combine depth)) free_vars var_heap
where
	case_combine do_par_combine depth {fv_name,fv_info_ptr} var_heap
377
		# (VI_Occurrence old_occ=:{occ_ref_count,occ_previous}, var_heap) = readPtr fv_info_ptr var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
378
379
380
381
382
383
384
385
		  (occ_ref_count, occ_previous) = case_combine_ref_counts do_par_combine occ_ref_count occ_previous (dec depth)
		= var_heap <:= (fv_info_ptr, VI_Occurrence { old_occ & occ_ref_count = occ_ref_count , occ_previous = occ_previous })
//				---> ("case_combine", fv_name, occ_ref_count)

	case_combine_ref_counts do_par_combine comb_ref_count [occ_ref_count:occ_previous] 0
		| do_par_combine
			# new_comb_ref_count = parCombineRefCount comb_ref_count occ_ref_count
			= (new_comb_ref_count, occ_previous)
Sjaak Smetsers's avatar
Sjaak Smetsers committed
386
//					---> ("parCombineRefCount", comb_ref_count, occ_ref_count, new_comb_ref_count)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
387
388
			# new_comb_ref_count = seqCombineRefCount comb_ref_count occ_ref_count
			= (new_comb_ref_count, occ_previous)
Sjaak Smetsers's avatar
Sjaak Smetsers committed
389
//					---> ("seqCombineRefCount", comb_ref_count, occ_ref_count, new_comb_ref_count)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
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
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
	case_combine_ref_counts do_par_combine comb_ref_count [occ_ref_count:occ_previous] depth
		# new_comb_ref_count = case_combine_ref_count comb_ref_count occ_ref_count
		= case_combine_ref_counts do_par_combine new_comb_ref_count occ_previous (dec depth)
//				---> ("case_combine_ref_count", comb_ref_count, occ_ref_count, new_comb_ref_count)

	case_combine_ref_count RC_Unused ref_count
		= ref_count
	case_combine_ref_count ref_count RC_Unused
		= ref_count
	case_combine_ref_count (RC_Used {rcu_multiply,rcu_selectively,rcu_uniquely}) (RC_Used ref_count2)
		= RC_Used { rcu_uniquely = rcu_uniquely ++ ref_count2.rcu_uniquely, rcu_multiply = rcu_multiply ++ ref_count2.rcu_multiply,
					rcu_selectively = case_combine_of_selections rcu_selectively ref_count2.rcu_selectively }
	where
		case_combine_of_selections [] sels
			= sels
		case_combine_of_selections sels []
			= sels
		case_combine_of_selections sl1=:[sel1=:{ su_field, su_multiply, su_uniquely } : sels1] sl2=:[sel2 : sels2]
			| su_field == sel2.su_field
				# sel1 = { sel1 & su_multiply = sel2.su_multiply ++ su_multiply, su_uniquely =  sel2.su_uniquely ++ su_uniquely }
				= [ sel1 : case_combine_of_selections sels1 sels2 ]
			| su_field < sel2.su_field
				= [sel1 : case_combine_of_selections sels1 sl2 ]
				= [sel2 : case_combine_of_selections sl1 sels2 ]

parCombineRefCount RC_Unused ref_count
	= ref_count
parCombineRefCount ref_count RC_Unused
	= ref_count
parCombineRefCount (RC_Used {rcu_multiply,rcu_selectively,rcu_uniquely}) (RC_Used ref_count2)
	# rcu_multiply = ref_count2.rcu_uniquely ++ ref_count2.rcu_multiply ++ rcu_uniquely ++ rcu_multiply
	| isEmpty rcu_multiply
		=  RC_Used { rcu_multiply = [], rcu_uniquely = [], rcu_selectively = par_combine_selections rcu_selectively ref_count2.rcu_selectively }
		# rcu_multiply = collectAllSelections ref_count2.rcu_selectively (collectAllSelections rcu_selectively rcu_multiply)
		= RC_Used { rcu_multiply = rcu_multiply, rcu_uniquely = [], rcu_selectively = [] }
where	
	par_combine_selections [] sels
		= sels
	par_combine_selections sels []
		= sels
	par_combine_selections sl1=:[sel1=:{ su_field, su_multiply, su_uniquely } : sels1] sl2=:[sel2 : sels2]
		| su_field == sel2.su_field
			# sel1 = { sel1 & su_multiply = sel2.su_multiply ++ su_multiply ++ sel2.su_uniquely ++ su_uniquely, su_uniquely = [] }
			= [ sel1 : par_combine_selections sels1 sels2 ]
		| su_field < sel2.su_field
			= [sel1 : par_combine_selections sels1 sl2 ]
			= [sel2 : par_combine_selections sl1 sels2 ]

seqCombineRefCount RC_Unused ref_count
	= ref_count
seqCombineRefCount ref_count RC_Unused
	= ref_count
seqCombineRefCount (RC_Used sec_ref) (RC_Used prim_ref)
	# rcu_multiply = prim_ref.rcu_uniquely ++ prim_ref.rcu_multiply ++ sec_ref.rcu_multiply
	| isEmpty rcu_multiply
		| isEmpty sec_ref.rcu_uniquely /* so sec_ref contains selections only */
			# rcu_selectively = seq_combine_selections sec_ref.rcu_selectively prim_ref.rcu_selectively /* rcu_selectively can't be empty */
			= RC_Used { rcu_uniquely = [], rcu_multiply = [], rcu_selectively = rcu_selectively }
			# prim_selections = make_primary_selections_on_unique prim_ref.rcu_selectively
			  rcu_selectively = seq_combine_selections sec_ref.rcu_selectively prim_selections
			= RC_Used { sec_ref & rcu_selectively = rcu_selectively }
		= RC_Used { sec_ref & rcu_multiply = collectAllSelections prim_ref.rcu_selectively rcu_multiply }
	where	
		seq_combine_selections [] sels
			= sels
		seq_combine_selections sels []
			= sels
		seq_combine_selections sl1=:[sel1=:{ su_field, su_multiply, su_uniquely } : sels1] sl2=:[sel2 : sels2]
			| su_field == sel2.su_field
				# sel1 = { sel1 & su_multiply = sel2.su_multiply ++ sel2.su_uniquely ++ su_multiply }
				= [ sel1 : seq_combine_selections sels1 sels2 ]
			| su_field < sel2.su_field
				= [sel1 : seq_combine_selections sels1 sl2 ]
				= [sel2 : seq_combine_selections sl1 sels2 ]

		make_primary_selections_on_unique [sel=:{su_multiply, su_uniquely } : sels]
			= [ { sel & su_multiply = su_uniquely ++ su_multiply, su_uniquely = [] } : make_primary_selections_on_unique sels ]
		make_primary_selections_on_unique []
			= []

470
471
472
473
474
475
476
477
478
makeSharedReferencesNonUnique :: ![Int] !u:{# FunDef} !*Coercions !w:{! Type} !v:TypeDefInfos !*VarHeap !*ExpressionHeap !*ErrorAdmin
	-> (!u:{# FunDef}, !*Coercions, !w:{! Type},  !v:TypeDefInfos, !*VarHeap, !*ExpressionHeap, !*ErrorAdmin)
makeSharedReferencesNonUnique [] fun_defs coercion_env subst type_def_infos var_heap expr_heap  error
	= (fun_defs, coercion_env, subst, type_def_infos, var_heap, expr_heap, error)
makeSharedReferencesNonUnique [fun : funs] fun_defs coercion_env subst type_def_infos var_heap expr_heap error
	# (fun_def, fun_defs) = fun_defs![fun] 
	# (coercion_env, subst, type_def_infos, var_heap, expr_heap, error)
		= make_shared_references_of_funcion_non_unique fun_def coercion_env subst type_def_infos var_heap expr_heap error
	= makeSharedReferencesNonUnique funs fun_defs coercion_env subst type_def_infos var_heap expr_heap error
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
479
480
where
	make_shared_references_of_funcion_non_unique {fun_symb, fun_pos, fun_body = TransformedBody {tb_args,tb_rhs},fun_info={fi_local_vars}}
481
			coercion_env subst type_def_infos var_heap expr_heap error
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
482
	# variables = tb_args ++ fi_local_vars
483
484
485
	  (subst, type_def_infos, var_heap, expr_heap) = clear_occurrences variables subst type_def_infos var_heap expr_heap
	  var_heap = refMark [tb_args] NotASelector tb_rhs var_heap // (tb_rhs ---> ("makeSharedReferencesNonUnique", fun_symb, tb_rhs)) var_heap
	//tb_rhs var_heap //   
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
486
487
488
	  position = newPosition fun_symb fun_pos
	  (coercion_env, var_heap, expr_heap, error) = make_shared_vars_non_unique variables coercion_env var_heap expr_heap
	  		(setErrorAdmin position error)
489
	= (coercion_env, subst, type_def_infos, var_heap, expr_heap, error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
490
491
	
	where
492
493
		clear_occurrences vars subst type_def_infos var_heap expr_heap
			= foldSt initial_occurrence vars (subst, type_def_infos, var_heap, expr_heap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
494
		where
495
			initial_occurrence {fv_name,fv_info_ptr} (subst, type_def_infos, var_heap, expr_heap) 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
496
497
498
				# (VI_Type {at_type,at_attribute}, var_heap) = readPtr fv_info_ptr var_heap
				= case at_type of
					TempV tv_number
499
500
						#! is_oberving = has_observing_type type_def_infos subst.[tv_number]
						-> (subst, type_def_infos, var_heap <:= (fv_info_ptr,
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
501
502
503
								VI_Occurrence { occ_ref_count = RC_Unused, occ_previous = [],
									occ_observing = is_oberving, occ_bind = OB_Empty }), expr_heap)
					_
504
						-> (subst, type_def_infos, var_heap <:= (fv_info_ptr,
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
505
506
507
508
509
510
511
512
								VI_Occurrence { occ_ref_count = RC_Unused, occ_previous = [],
									occ_observing = False,  occ_bind = OB_Empty }), expr_heap)
					

		make_shared_vars_non_unique vars coercion_env var_heap expr_heap error
			= foldl make_shared_var_non_unique (coercion_env, var_heap, expr_heap, error) vars

		make_shared_var_non_unique (coercion_env, var_heap, expr_heap, error)  fv=:{fv_name,fv_info_ptr}
513
			# (VI_Occurrence occ, var_heap) = readPtr fv_info_ptr var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
514
515
516
			= case occ.occ_ref_count of
				RC_Used {rcu_multiply,rcu_selectively}
					# (coercion_env, expr_heap, error) = make_shared_occurrences_non_unique fv rcu_multiply (coercion_env, expr_heap, error)
517
					  (coercion_env, expr_heap, error) = foldSt (make_selection_non_unique fv) rcu_selectively (coercion_env, expr_heap, error)  
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
518
519
520
521
522
523
524
525
526
527
					-> (coercion_env, var_heap, expr_heap, error)
				_
					-> (coercion_env, var_heap, expr_heap, error)

		make_shared_occurrences_non_unique fv multiply (coercion_env, expr_heap, error)
			= foldSt (make_shared_occurrence_non_unique fv) multiply (coercion_env, expr_heap, error) 
		
		make_shared_occurrence_non_unique free_var var_expr_ptr (coercion_env, expr_heap, error) 
			| isNilPtr var_expr_ptr
				= (coercion_env, expr_heap, error)
528
529
530
531
532
				# (expr_info, expr_heap) = readPtr var_expr_ptr expr_heap
				= case expr_info of
					EI_Attribute sa_attr_nr
						# (succ, coercion_env) = tryToMakeNonUnique sa_attr_nr coercion_env
						| succ
clean's avatar
clean committed
533
//								 ---> ("make_shared_occurrence_non_unique", free_var, var_expr_ptr)
534
535
536
537
							-> (coercion_env, expr_heap, error)
							-> (coercion_env, expr_heap, uniquenessError { cp_expression = FreeVar free_var} " demanded attribute cannot be offered by shared object" error)
					_
						-> abort ("make_shared_occurrence_non_unique" ---> ((free_var, var_expr_ptr) <<- expr_info))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
538
539
540
		make_selection_non_unique fv {su_multiply} cee
			= make_shared_occurrences_non_unique fv su_multiply cee

541
542
543
544
545
546
547
548
549
550
551
	has_observing_type type_def_infos TE
		= True
	has_observing_type type_def_infos (TB basic_type)
		= True
	has_observing_type type_def_infos (TempV var_number) 
		= True
	has_observing_type type_def_infos (TA {type_index = {glob_object,glob_module}} type_args)
		# {tdi_properties} = type_def_infos.[glob_module].[glob_object]
		= foldSt (\ {at_type} ok -> ok && has_observing_type type_def_infos at_type) type_args (tdi_properties bitand cIsHyperStrict <> 0)
	has_observing_type type_def_infos type
		= False
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
552
553
554
555
556
557
558
559
560
561
562
563
564

					
instance <<< ReferenceCount
where
	(<<<) file RC_Unused = file
	(<<<) file (RC_Used {rcu_multiply,rcu_uniquely,rcu_selectively}) = file <<< '\n' <<< "M:" <<< rcu_multiply <<< " U:" <<< rcu_uniquely <<< " S:" <<< rcu_selectively

instance <<< SelectiveUse
where
	(<<<) file {su_field,su_multiply,su_uniquely} = file <<< su_field <<< " M:" <<< su_multiply <<< " U:" <<< su_uniquely



565
instance <<< (Ptr v)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
566
567
568
569
where
	(<<<) file ptr = file <<< '[' <<< ptrToInt ptr <<< ']'