refmark.icl 41.6 KB
Newer Older
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
1
2
3
implementation module refmark

import StdEnv
4
import syntax, Heap, typesupport, check, overloading, unitype, utilities //, RWSDebug
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
5

6
7
(===>) infix 1
(===>) a b :== a // --->  b
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
8
9
10

NotASelector :== -1

11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
::	RMState =
	{	rms_var_heap	:: !.VarHeap
	,	rms_let_vars	:: ![FreeVar]
	}

class refMark expr ::  ![[FreeVar]] !Int !(Optional [CountedFreeVar]) !expr !*RMState -> *RMState

// fullRefMark :: ![[FreeVar]] !Int !(Optional [CountedFreeVar]) !expr !*VarHeap -> RMState | refMark expr
fullRefMark free_vars sel def expr var_heap
	# {rms_let_vars,rms_var_heap} = refMark free_vars sel def expr { rms_var_heap = var_heap, rms_let_vars = [] }
	  rms_var_heap = openLetVars rms_let_vars rms_var_heap
	= addParRefMarksOfLets "fullRefMark" rms_let_vars ([], { rms_var_heap = rms_var_heap, rms_let_vars = [] })


partialRefMark :: ![[FreeVar]] !expr !*VarHeap -> (!RefMarkResult, *VarHeap) | refMark expr
partialRefMark free_vars  expr var_heap
	# var_heap = saveOccurrences free_vars var_heap
	  {rms_var_heap,rms_let_vars}  = refMark free_vars NotASelector No expr { rms_var_heap = var_heap, rms_let_vars = [] }
	  rms_var_heap = openLetVars rms_let_vars rms_var_heap
	  (occurrences, rms_var_heap) = restoreOccurrences "partialRefMark" free_vars rms_var_heap
	= ((occurrences, rms_let_vars), rms_var_heap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
32
33
34

instance refMark [a] | refMark a
where
35
36
	refMark free_vars sel _ list rms 
		= foldSt (refMark free_vars sel No) list rms 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
37
38
39
40
41
42

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

43
44
contains x []		= False
contains x [y:ys]	= x == y || contains x ys
45

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
46
47
		
saveOccurrences free_vars var_heap
48
	= foldSt (foldSt save_occurrence)  free_vars var_heap // (free_vars ===> ("saveOccurrences", free_vars)) var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
49
50
51
52
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] } )
53
54
55
56
 			===> ("save_occurrence", fv_name, fv_info_ptr, occ_ref_count, length occ_previous)

restoreOccurrences wher free_vars var_heap
	= foldSt (foldSt (restore_occurrence wher)) (free_vars ===> ("restoreOccurrences", wher, free_vars)) ([], var_heap)
57
where
58
59
60
61
62
63
64
	restore_occurrence wher fv=:{fv_name,fv_info_ptr} (occurrences, var_heap)
		# (VI_Occurrence old_occ=:{occ_ref_count,occ_previous,occ_bind}, var_heap) = readPtr fv_info_ptr var_heap
		  (prev_ref_count, occ_previous) = case occ_previous of
		  										[x : xs]
		  											-> (x, xs)
		  										_
		  											-> abort ("restoreOccurrences" ---> (fv_name, fv_info_ptr, wher))
65
		  var_heap = var_heap <:= (fv_info_ptr, VI_Occurrence {old_occ & occ_ref_count = prev_ref_count, occ_previous = occ_previous })
66
		= case occ_ref_count ===> ("restore_occurrence", fv_name, fv_info_ptr, (occ_ref_count, prev_ref_count, occ_previous)) of
67
68
69
			RC_Unused
				-> (occurrences, var_heap)
			_
70
71
72
73
74
75
				-> case occ_bind of
					OB_OpenLet _ _
						-> ([{cfv_var = fv, cfv_count = occ_ref_count, cfv_is_let = True} : occurrences ], var_heap)
					_
						-> ([{cfv_var = fv, cfv_count = occ_ref_count, cfv_is_let = False} : occurrences ], var_heap)

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
76

77
78
markPatternVariables sel list_of_used_pattern_vars var_heap
	= foldSt (mark_pattern_variables sel) list_of_used_pattern_vars var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
79
where
80
81
82
83
84
85
	mark_pattern_variables sel used_pattern_vars var_heap
		| sel == NotASelector
			= foldSt mark_variable used_pattern_vars var_heap
			= mark_selected_variable sel used_pattern_vars var_heap

	mark_selected_variable sel [] var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
86
		= var_heap
87
88
89
90
	mark_selected_variable sel [pv=:{pv_var, pv_arg_nr} : pvs ] var_heap
		| sel == pv_arg_nr
			= mark_variable pv var_heap
			= mark_selected_variable sel pvs var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
91
		
92
	mark_variable {pv_var={fv_name,fv_info_ptr}} var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
93
		# (VI_Occurrence old_occ=:{occ_ref_count}, var_heap) = readPtr fv_info_ptr var_heap
94
		= case occ_ref_count ===> ("mark_variable", fv_name) of
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
95
			RC_Unused
96
				# occ_ref_count = RC_Used {rcu_multiply = [], rcu_selectively = [], rcu_uniquely = [nilPtr]}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
97
98
99
100
101
102
				-> 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 } )

103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145

refMarkOfVariable free_vars sel (VI_Occurrence var_occ) var=:{var_name, var_info_ptr, var_expr_ptr} rms=:{rms_var_heap}
	# occ_ref_count = adjust_ref_count sel var_occ.occ_ref_count var_expr_ptr
	  rms_var_heap = markPatternVariables sel var_occ.occ_pattern_vars rms_var_heap
	= ref_count_of_bindings free_vars var_name var_info_ptr occ_ref_count var_occ { rms & rms_var_heap = rms_var_heap }
		===> ("refMarkOfVariable", var_name, var_occ.occ_ref_count, occ_ref_count)
where
	adjust_ref_count 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 = [] }
	adjust_ref_count sel use=:(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 = add_selection var_expr_ptr sel rcu_selectively
			  rcu_multiply = rcu_uniquely ++ rcu_multiply
			= RC_Used {rcu_multiply = rcu_multiply, rcu_uniquely = [], rcu_selectively = rcu_selectively }

	add_selection var_expr_ptr sel []
		= [ { su_field = sel, su_multiply = [], su_uniquely = [var_expr_ptr]  } ]
	add_selection var_expr_ptr sel sels=:[selection=:{ su_field,su_multiply,su_uniquely } : selections]
		| sel == su_field
			= [ { selection & su_multiply = su_multiply ++ [var_expr_ptr : su_uniquely], su_uniquely = [] } : selections ]
		| sel < su_field
			= [ { su_field = sel, su_multiply = [], su_uniquely = [var_expr_ptr]  } : sels ]
			= [ selection : add_selection var_expr_ptr sel selections ]


	ref_count_of_bindings free_vars var_name var_info_ptr occ_ref_count var_occ=:{occ_bind = OB_OpenLet fv let_info} rms=:{rms_var_heap,rms_let_vars}
		# rms_var_heap = rms_var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_ref_count = occ_ref_count, occ_bind = OB_LockedLet var_occ.occ_bind })
		= { rms & rms_var_heap = rms_var_heap, rms_let_vars = [ fv : rms_let_vars ]}
//				===> ("ref_count_of_bindings (OB_OpenLet)", var_name)
	ref_count_of_bindings free_vars var_name var_info_ptr occ_ref_count var_occ=:{occ_bind = OB_LockedLet _} rms=:{rms_var_heap} 
		= { rms & rms_var_heap = rms_var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_ref_count = occ_ref_count })}
//				===> ("ref_count_of_bindings (OB_LockedLet)", var_name)
	ref_count_of_bindings free_vars var_name var_info_ptr occ_ref_count var_occ rms=:{rms_var_heap}
		= { rms & rms_var_heap = rms_var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_ref_count = occ_ref_count })}

addParRefMarksOfLets call let_vars closed_vars_end_rms
	= foldSt ref_mark_of_let let_vars closed_vars_end_rms
146
where
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
	ref_mark_of_let fv=:{fv_name,fv_info_ptr} (closed_let_vars, rms=:{rms_var_heap})
		# (VI_Occurrence var_occ, rms_var_heap) = readPtr fv_info_ptr rms_var_heap
		  rms = { rms & rms_var_heap = rms_var_heap }
		= case var_occ.occ_bind of
			OB_OpenLet _ (Yes (ref_counts, let_vars))
				# rms_var_heap = rms.rms_var_heap <:= (fv_info_ptr, VI_Occurrence {var_occ & occ_bind = OB_LockedLet var_occ.occ_bind})
				  rms_var_heap = addParRefCounts call ref_counts rms_var_heap
				-> addParRefMarksOfLets call let_vars ([fv : closed_let_vars], {rms & rms_var_heap = rms_var_heap})
//						 ===> ("addParRefMarksOfLets (OB_OpenLet Yes)", fv_name) 
			OB_OpenLet _ No
				# rms_var_heap = rms.rms_var_heap <:= (fv_info_ptr, VI_Occurrence {var_occ & occ_bind = OB_LockedLet var_occ.occ_bind})
				-> (closed_let_vars, { rms  & rms_var_heap = rms_var_heap, rms_let_vars = [fv : rms.rms_let_vars]})
//						 ===> ("addParRefMarksOfLets (OB_OpenLet No)", fv_name) 
			OB_LockedLet _
				-> (closed_let_vars, rms)
//						 ===> ("addParRefMarksOfLets (OB_LockedLet)", fv_name) 
163
		
164
165
addParRefCounts call ref_counts var_heap
	= foldSt (set_occurrence call) ref_counts var_heap
166
where
167
	set_occurrence call {cfv_var = {fv_name,fv_info_ptr}, cfv_count} var_heap
168
169
170
		# (VI_Occurrence occ=:{occ_ref_count}, var_heap) = readPtr fv_info_ptr var_heap
		  comb_ref_count = parCombineRefCount occ_ref_count cfv_count
		= var_heap <:= (fv_info_ptr, VI_Occurrence { occ & occ_ref_count = comb_ref_count})
171
			===>  ("addParRefCounts", call, fv_name, fv_info_ptr, (cfv_count, occ_ref_count, comb_ref_count))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
172

173
174
175
176
177
178
179
180
addSeqRefCounts ref_counts var_heap
	= foldSt set_occurrence ref_counts var_heap
where
	set_occurrence {cfv_var = {fv_name,fv_info_ptr}, cfv_count} var_heap
		# (VI_Occurrence occ=:{occ_ref_count}, var_heap) = readPtr fv_info_ptr var_heap
		  comb_ref_count = seqCombineRefCount occ_ref_count cfv_count
		= var_heap <:= (fv_info_ptr, VI_Occurrence { occ & occ_ref_count = comb_ref_count})
			===>  ("addSeqRefCounts", fv_name, cfv_count, occ_ref_count, comb_ref_count)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
181
182
instance refMark BoundVar
where
183
184
185
186
	refMark free_vars sel _ var rms=:{rms_var_heap}
		# (var_occ, rms_var_heap) = readPtr var.var_info_ptr rms_var_heap
		= refMarkOfVariable free_vars sel var_occ var { rms & rms_var_heap = rms_var_heap }

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
187
188
instance refMark Expression
where
189
190
191
192
193
194
195
196
	refMark free_vars sel _ (Var var) rms 
		= refMark free_vars sel No var rms 
	refMark free_vars sel _ (App {app_args}) rms 
		= refMark free_vars NotASelector No app_args rms 
	refMark free_vars sel _ (fun @ args) rms 
		= refMark free_vars NotASelector No args (refMark free_vars NotASelector No fun rms)

	refMark free_vars sel def (Let {let_strict_binds,let_lazy_binds,let_expr}) rms=:{rms_var_heap} 
Sjaak Smetsers's avatar
Sjaak Smetsers committed
197
		| isEmpty let_lazy_binds
198
			# new_free_vars = [ [ lb_dst \\ {lb_dst} <- let_strict_binds ] : free_vars]
199
			# (observing, rms_var_heap) = binds_are_observing let_strict_binds rms_var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
200
			| observing
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
				# rms_var_heap = saveOccurrences free_vars rms_var_heap
				  rms  = refMark new_free_vars NotASelector No let_strict_binds { rms & rms_var_heap = rms_var_heap }
				  rms_var_heap = saveOccurrences new_free_vars rms.rms_var_heap
				  (_, {rms_var_heap,rms_let_vars})  = fullRefMark new_free_vars sel def let_expr rms_var_heap
//				  rms  = refMark new_free_vars sel def let_expr { rms & rms_var_heap = rms_var_heap }
				= { rms & rms_var_heap = let_combine free_vars rms_var_heap, rms_let_vars = rms_let_vars ++ rms.rms_let_vars }
					===> ("refMark (Let (observing))", hd new_free_vars)
				= refMark new_free_vars sel def let_expr (refMark new_free_vars NotASelector No let_strict_binds { rms & rms_var_heap = rms_var_heap } )
			# all_binds								= let_strict_binds ++ let_lazy_binds
			  local_let_vars						= [ lb_dst \\ {lb_dst} <- all_binds ]
			  new_free_vars							= [ local_let_vars : free_vars]
			  rms_var_heap							= init_let_binds all_binds rms_var_heap
			  rms_var_heap							= ref_mark_of_lets new_free_vars all_binds rms_var_heap
			  (_, {rms_var_heap,rms_let_vars})		= fullRefMark new_free_vars sel def let_expr rms_var_heap
			= { rms & rms_var_heap = rms_var_heap, rms_let_vars = rms_let_vars ++ rms.rms_let_vars }
//			= refMark new_free_vars sel def let_expr { rms & rms_var_heap = rms_var_heap }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
217
218
219

		where
		    binds_are_observing binds var_heap
220
		    	= foldSt bind_is_observing binds (True, var_heap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
221
			where
222
				bind_is_observing {lb_dst={fv_info_ptr}} (observe, var_heap) 
223
					# (VI_Occurrence {occ_observing}, var_heap) = readPtr fv_info_ptr var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
224
225
226
227
228
					= (occ_observing && observe, var_heap)
			
			let_combine free_vars var_heap
				= foldSt (foldSt let_combine_ref_count) free_vars var_heap
			where
229
				let_combine_ref_count {fv_name,fv_info_ptr} var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
230
231
					# (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
232
233
234
235
					  seq_comb_ref_count = seqCombineRefCount occ_ref_count prev_ref_count
					  comb_ref_count = parCombineRefCount seq_comb_ref_count pre_pref_recount
					= (var_heap <:= (fv_info_ptr, VI_Occurrence { old_occ & occ_ref_count = comb_ref_count, occ_previous = occ_previouses }))
						===> ("let_combine_ref_count", fv_name, (pre_pref_recount, prev_ref_count, occ_ref_count, seq_comb_ref_count, comb_ref_count))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
236

237
238
239
			init_let_binds let_binds var_heap
				= foldSt bind_variable let_binds var_heap
			where
240
				bind_variable let_bind=:{lb_dst=fv=:{fv_info_ptr}} var_heap
241
					# (VI_Occurrence occ, var_heap) = readPtr fv_info_ptr var_heap
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
					= var_heap <:= (fv_info_ptr, VI_Occurrence { occ & occ_ref_count = RC_Unused, occ_bind = OB_OpenLet fv No })

			ref_mark_of_lets free_vars let_binds rms_var_heap 
				= foldSt (ref_mark_of_let free_vars) let_binds rms_var_heap

			ref_mark_of_let free_vars let_bind=:{lb_src, lb_dst=fv=:{fv_info_ptr}} rms_var_heap
				# (VI_Occurrence occ, rms_var_heap) = readPtr fv_info_ptr rms_var_heap
				  rms_var_heap = rms_var_heap <:= (fv_info_ptr, VI_Occurrence { occ & occ_bind = OB_LockedLet occ.occ_bind })
				  (res, rms_var_heap) = partialRefMark free_vars lb_src rms_var_heap
				  rms_var_heap = rms_var_heap <:= (fv_info_ptr, VI_Occurrence { occ & occ_bind = OB_OpenLet fv (Yes res)})
				= rms_var_heap ===>  ("ref_mark_of_let", fv, res)

	refMark free_vars sel def (Case ca) rms
		= refMarkOfCase free_vars sel def ca rms 
	refMark free_vars sel _ (Selection _ expr selectors) rms 
		= refMark free_vars (field_number selectors) No expr rms 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
258
259
260
261
262
	where
		field_number [ RecordSelection _ field_nr : _ ]
			= field_nr	
		field_number _
			= NotASelector	
263
264
265
266
267
268
	refMark free_vars sel _ (Update expr1 selectors expr2) rms 
		# rms  = refMark free_vars NotASelector No expr1 rms 
		  rms  = refMark free_vars NotASelector No selectors rms 
		= refMark free_vars NotASelector No expr2 rms 
	refMark free_vars sel _ (RecordUpdate cons_symbol expression expressions) rms 
		= ref_mark_of_record_expression free_vars expression expressions rms 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
269
	where
270
271
272
273
274
		ref_mark_of_record_expression free_vars (Var var) fields rms 
			= ref_mark_of_fields 0 free_vars fields var rms 
		ref_mark_of_record_expression free_vars expression fields rms 
			# rms  = refMark free_vars NotASelector No expression rms 
			= foldSt (ref_mark_of_field free_vars) fields rms 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
275
	
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
		ref_mark_of_fields field_nr free_vars [] var rms 
			= rms 
		ref_mark_of_fields field_nr free_vars [{bind_src = NoBind expr_ptr} : fields] var=:{var_info_ptr} rms=:{rms_var_heap}
			# (var_occ, rms_var_heap) = readPtr var_info_ptr rms_var_heap
			  rms  = refMarkOfVariable free_vars field_nr var_occ { var & var_expr_ptr = expr_ptr } { rms & rms_var_heap = rms_var_heap }
			= ref_mark_of_fields (inc field_nr) free_vars fields var rms 
		ref_mark_of_fields field_nr free_vars [{bind_src} : fields] var rms 
			# rms  = refMark free_vars NotASelector No bind_src rms 
			= ref_mark_of_fields (inc field_nr) free_vars fields var rms 

		ref_mark_of_field free_vars {bind_src} rms 
			= refMark free_vars NotASelector No bind_src rms 

	refMark free_vars sel _ (TupleSelect _ arg_nr expr) rms 
		= refMark free_vars arg_nr No expr rms 
	refMark free_vars sel _ (MatchExpr _ expr) rms 
		= refMark free_vars sel No expr rms 
	refMark free_vars sel _ EE rms 
		= rms 
	refMark _ _ _ _ rms 
		= rms 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
297
298
299
300
301


isUsed RC_Unused	= False				
isUsed _			= True				

302
303
instance refMark LetBind
where
304
305
	refMark free_vars sel _ {lb_src} rms 
		= refMark free_vars NotASelector No lb_src rms 
306

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
307
308
309

instance refMark Selection
where
310
311
312
313
	refMark free_vars _ _ (ArraySelection _ _ index_expr) rms 
		= refMark free_vars NotASelector No index_expr rms 
	refMark free_vars _ _ _ rms 
		= rms 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
314
315
316
317
318
319
320


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
321
			= collect_used_vars pattern_vars (inc arg_nr) [ {pv_var = fv, pv_arg_nr = arg_nr} : collected_vars ]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
322
323
324
325
			= collect_used_vars pattern_vars (inc arg_nr) collected_vars
	collect_used_vars [] arg_nr collected_vars
		= collected_vars

326
327
openLetVars let_vars var_heap
	= foldSt open_let_vars let_vars var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
328
where
329
	open_let_vars {fv_name,fv_info_ptr} var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
330
331
		# (VI_Occurrence var_occ, var_heap) = readPtr fv_info_ptr var_heap
		= case var_occ.occ_bind of
332
333
334
			OB_LockedLet occ_bind
				-> var_heap <:= (fv_info_ptr, VI_Occurrence { var_occ & occ_bind = occ_bind })
//					 ===> ("openLetVars (OB_LockedLet)", fv_name)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
335
			_
336
337
				-> abort "open_let_vars (refmark.icl))"
	
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
338
setUsedLetVars used_vars var_heap
339
	= foldSt (foldSt set_used_let_var) used_vars var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
340
where
341
	set_used_let_var {fv_info_ptr} var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
342
343
		# (VI_Occurrence var_occ, var_heap) = readPtr fv_info_ptr var_heap
		= case var_occ.occ_bind of
344
345
			OB_OpenLet _ _
				-> var_heap <:= (fv_info_ptr, VI_Occurrence { var_occ & occ_bind = OB_LockedLet var_occ.occ_bind })
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
346
347
348
			_
				-> var_heap

349
350
351
352
353
354
355
356
357
358
refMarkOfCase free_vars sel def {case_expr, case_guards=AlgebraicPatterns type patterns, case_explicit, case_default} rms 
	= refMarkOfAlgebraicOrOverloadedListCase free_vars sel def case_expr patterns case_explicit case_default rms 

refMarkOfCase free_vars sel def {case_expr, case_guards=BasicPatterns type patterns,case_default,case_explicit} rms=:{rms_var_heap}
	# (def, all_closed_let_vars, rms) = refMarkOfDefault case_explicit free_vars sel def case_expr case_default [] { rms & rms_var_heap = rms_var_heap }
	  (pattern_depth, all_closed_let_vars, rms) = foldSt (ref_mark_of_basic_pattern free_vars sel def case_expr) patterns (0, all_closed_let_vars, rms)
	  (let_vars_in_default, rms_var_heap) = addRefMarkOfDefault pattern_depth free_vars def rms.rms_var_heap
	  rms_var_heap = setUsedLetVars [let_vars_in_default : all_closed_let_vars] rms_var_heap
	  rms_var_heap = parCombine free_vars rms_var_heap
	= { rms & rms_var_heap = rms_var_heap }
359
where
360
361
362
	ref_mark_of_basic_pattern free_vars sel def case_expr {bp_expr} (pattern_depth, all_closed_let_vars, rms)
		# (all_closed_let_vars, rms) = refMarkOfAlternative free_vars [] sel def case_expr bp_expr all_closed_let_vars rms
		= (inc pattern_depth, all_closed_let_vars, rms)
363

364
365
366
367
refMarkOfCase free_vars sel def {case_expr, case_guards=OverloadedListPatterns type _ patterns, case_explicit, case_default} rms 
	= refMarkOfAlgebraicOrOverloadedListCase free_vars sel def case_expr patterns case_explicit case_default rms 

refMarkOfCase free_vars sel def {case_expr, case_guards=DynamicPatterns patterns,case_default,case_explicit} rms=:{rms_var_heap}
368
369
370
371
372
	# (def, all_closed_let_vars, rms) = refMarkOfDefault case_explicit free_vars sel def case_expr case_default [] { rms & rms_var_heap = rms_var_heap }
	  (pattern_depth, used_lets, rms) = foldSt (ref_mark_of_dynamic_pattern free_vars sel def case_expr) patterns (0, all_closed_let_vars, rms)
	  (let_vars_in_default, rms_var_heap) = addRefMarkOfDefault pattern_depth free_vars def rms.rms_var_heap
	  rms_var_heap = setUsedLetVars [let_vars_in_default : all_closed_let_vars] rms_var_heap
	  rms_var_heap = parCombine free_vars rms_var_heap
373
	= { rms & rms_var_heap = rms_var_heap }
374
where
375
376
377
378
379
	ref_mark_of_dynamic_pattern free_vars sel def case_expr {dp_var, dp_rhs} (pattern_depth, all_closed_let_vars, rms=:{rms_var_heap})
		# used_pattern_vars = collectPatternsVariables [dp_var]
		  new_free_vars = [ pv_var \\ {pv_var} <- used_pattern_vars ]
		  (all_closed_let_vars, rms) = refMarkOfAlternative free_vars new_free_vars sel def case_expr dp_rhs all_closed_let_vars rms
		= (inc pattern_depth, all_closed_let_vars, rms)	
380

381
382
383
384
385
386
387
refMarkOfAlgebraicOrOverloadedListCase free_vars sel def (Var var=:{var_name,var_info_ptr,var_expr_ptr}) alternatives case_explicit case_default rms
	# (def, all_closed_let_vars, rms) = ref_mark_of_default case_explicit free_vars sel def var case_default [] rms
	  (pattern_depth, all_closed_let_vars, rms) = foldSt (ref_mark_of_algebraic_pattern free_vars sel var def) alternatives (0, all_closed_let_vars, rms)		
	  (let_vars_in_default, rms_var_heap) = addRefMarkOfDefault pattern_depth free_vars def rms.rms_var_heap
	  rms_var_heap = setUsedLetVars [let_vars_in_default : all_closed_let_vars] rms_var_heap
	  rms_var_heap = parCombine free_vars rms_var_heap
	= { rms & rms_var_heap = rms_var_heap }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
388
where
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
	ref_mark_of_default case_explicit free_vars sel def var (Yes expr) all_closed_let_vars rms=:{rms_var_heap, rms_let_vars}
		# rms_var_heap = saveOccurrences free_vars rms_var_heap
		  (closed_lets, rms) = fullRefMark free_vars sel No expr rms_var_heap 
		  (closed_lets, rms) = ref_mark_of_variable_pattern True var (closed_lets, rms)
		  rms_var_heap = openLetVars closed_lets rms.rms_var_heap
		  (occurrences, rms_var_heap) = restoreOccurrences "ref_mark_of_default" free_vars rms_var_heap
		= (Yes occurrences, [closed_lets:all_closed_let_vars], { rms & rms_var_heap = rms_var_heap, rms_let_vars = rms.rms_let_vars ++ rms_let_vars })
			===>  ("ref_mark_of_default", occurrences, closed_lets)
	ref_mark_of_default case_explicit free_vars sel def var No all_closed_let_vars rms
		| case_explicit
			= (No,	all_closed_let_vars, rms)
			= (def, all_closed_let_vars, rms)

	ref_mark_of_algebraic_pattern free_vars sel var def {ap_vars,ap_expr} (pattern_depth, all_closed_let_vars, rms=:{rms_var_heap}) 
		# rms_var_heap = saveOccurrences free_vars rms_var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
404
		  used_pattern_vars = collectPatternsVariables ap_vars
405
406
407
408
409
410
411
412
413
		  rms_var_heap = bind_pattern_variable var used_pattern_vars rms_var_heap
		  free_vars = [ [ pv_var \\ {pv_var} <- used_pattern_vars ] : free_vars ]
		  (closed_let_vars, rms) = fullRefMark free_vars sel def ap_expr rms_var_heap
		  rms_var_heap = restore_binding_of_pattern_variable var used_pattern_vars rms.rms_var_heap
		  (closed_let_vars, rms) = ref_mark_of_variable_pattern (isEmpty used_pattern_vars) var (closed_let_vars, { rms & rms_var_heap = rms_var_heap })
		  rms_var_heap = openLetVars closed_let_vars rms.rms_var_heap
		= (inc pattern_depth, [closed_let_vars:all_closed_let_vars], { rms & rms_var_heap = rms_var_heap })

	bind_pattern_variable _ [] var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
414
		= var_heap
415
	bind_pattern_variable {var_info_ptr} used_pattern_vars var_heap
416
417
		# (VI_Occurrence var_occ, var_heap) = readPtr var_info_ptr var_heap
		= var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_pattern_vars = [ used_pattern_vars : var_occ.occ_pattern_vars ] })
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
418

Sjaak Smetsers's avatar
bug fix    
Sjaak Smetsers committed
419
	restore_binding_of_pattern_variable _ [] var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
420
		= var_heap
421
	restore_binding_of_pattern_variable {var_info_ptr} used_pattern_vars var_heap
422
423
		# (VI_Occurrence var_occ, var_heap) = readPtr var_info_ptr var_heap
		= var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_pattern_vars = tl var_occ.occ_pattern_vars })
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
470
471
472
	ref_mark_of_variable_pattern do_seq_combine {var_name,var_info_ptr,var_expr_ptr} (closed_lets, rms=:{rms_var_heap})
		# (VI_Occurrence var_occ_in_alts, rms_var_heap) = readPtr var_info_ptr rms_var_heap
		  (var_occ_in_alts, rms_var_heap) = adjust_ref_count_of_variable_pattern var_occ_in_alts var_info_ptr var_expr_ptr rms_var_heap
		= add_let_variable do_seq_combine var_info_ptr var_occ_in_alts (closed_lets, { rms & rms_var_heap = rms_var_heap })
	where
		adjust_ref_count_of_variable_pattern var_occ_in_alts=:{occ_ref_count = RC_Unused} var_info_ptr var_expr_ptr var_heap
			# var_occ_in_alts = { var_occ_in_alts & occ_ref_count = RC_Used { rcu_multiply = [], rcu_uniquely = [var_expr_ptr], rcu_selectively = []}}
			= (var_occ_in_alts, var_heap <:= (var_info_ptr, VI_Occurrence var_occ_in_alts))
		adjust_ref_count_of_variable_pattern var_occ_in_alts=:{occ_ref_count = RC_Used rcu} var_info_ptr var_expr_ptr var_heap
			# var_occ_in_alts = { var_occ_in_alts & occ_ref_count = RC_Used { rcu & rcu_uniquely = [var_expr_ptr : rcu.rcu_uniquely] }}
			= (var_occ_in_alts, var_heap <:= (var_info_ptr, VI_Occurrence var_occ_in_alts))
		
		add_let_variable do_seq_combine var_info_ptr var_occ=:{occ_bind = ob =: OB_OpenLet fv (Yes (ref_counts,let_vars))} (closed_lets, rms=:{rms_var_heap})
			# rms_var_heap = rms_var_heap <:= (var_info_ptr, VI_Occurrence {var_occ & occ_bind = OB_LockedLet ob}) 
			| do_seq_combine
				# rms_var_heap = addSeqRefCounts ref_counts rms_var_heap
				= addSeqRefMarksOfLets  let_vars ([fv : closed_lets], { rms & rms_var_heap = rms_var_heap })
				# rms_var_heap = addParRefCounts "add_let_variable 1" ref_counts rms_var_heap
				= addParRefMarksOfLets "add_let_variable 2" let_vars ([fv : closed_lets], { rms & rms_var_heap = rms_var_heap })
		add_let_variable do_seq_combine var_info_ptr var_occ=:{occ_bind = ob =: OB_OpenLet fv No} (closed_lets, rms=:{rms_var_heap,rms_let_vars})
			# rms_var_heap = rms_var_heap <:= (var_info_ptr, VI_Occurrence {var_occ & occ_bind = OB_LockedLet ob}) 
			= (closed_lets, {rms_var_heap = rms_var_heap, rms_let_vars = [fv : rms_let_vars]})
		add_let_variable do_seq_combine var_info_ptr v_ closed_lets_and_rms
			= closed_lets_and_rms
		

refMarkOfAlgebraicOrOverloadedListCase free_vars sel def case_expr alternatives case_explicit case_default rms=:{rms_var_heap}
//	# (case_expr_res, rms_var_heap) = partialRefMark free_vars case_expr rms_var_heap
	# (def, all_closed_let_vars, rms) = refMarkOfDefault case_explicit free_vars sel def case_expr case_default [] { rms & rms_var_heap = rms_var_heap }
	  (pattern_depth, all_closed_let_vars, rms) = foldSt (ref_mark_of_algebraic_pattern free_vars sel def case_expr) alternatives (0, all_closed_let_vars, rms)
	  (let_vars_in_default, rms_var_heap) = addRefMarkOfDefault pattern_depth free_vars def rms.rms_var_heap
	  rms_var_heap = setUsedLetVars [let_vars_in_default : all_closed_let_vars] rms_var_heap
	  rms_var_heap = parCombine free_vars rms_var_heap
	= { rms & rms_var_heap = rms_var_heap }
where
	ref_mark_of_algebraic_pattern free_vars sel def case_expr {ap_vars,ap_expr} (pattern_depth, all_closed_let_vars, rms) 
		# used_pattern_vars = collectPatternsVariables ap_vars
		  new_free_vars = [ pv_var \\ {pv_var} <- used_pattern_vars ]
		  (all_closed_let_vars, rms) = refMarkOfAlternative free_vars new_free_vars sel def case_expr ap_expr all_closed_let_vars rms
		= (inc pattern_depth, all_closed_let_vars, rms)	

refMarkOfDefault case_explicit free_vars sel def case_expr (Yes expr) all_closed_let_vars rms
	# (all_closed_let_vars, rms) = refMarkOfAlternative free_vars [] sel def case_expr expr all_closed_let_vars rms
	  (occurrences, rms_var_heap) = restoreOccurrences "refMarkOfDefault" free_vars rms.rms_var_heap
	= (Yes occurrences, all_closed_let_vars, { rms & rms_var_heap = rms_var_heap })
		===>  ("refMarkOfDefault", occurrences)

refMarkOfDefault case_explicit free_vars sel def case_expr No all_closed_let_vars rms 
473
	| case_explicit
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
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
		= (No,	all_closed_let_vars, rms)
		= (def, all_closed_let_vars, rms)


refMarkOfAlternative free_vars pattern_vars sel def case_expr alt_expr all_closed_let_vars rms=:{rms_var_heap,rms_let_vars}
	# rms_var_heap = saveOccurrences [pattern_vars : free_vars] rms_var_heap
	  (closed_let_vars_in_alt, alt_rms)		= fullRefMark [pattern_vars : free_vars] sel def alt_expr rms_var_heap
	  rms_var_heap = saveOccurrences free_vars alt_rms.rms_var_heap
	  (closed_let_vars_in_expr, case_rms)	= fullRefMark free_vars sel def case_expr rms_var_heap
	  rms_var_heap = combine_pattern_and_alternative free_vars pattern_vars case_rms.rms_var_heap
	  rms_var_heap = openLetVars closed_let_vars_in_alt rms_var_heap
	  rms_var_heap = openLetVars closed_let_vars_in_expr rms_var_heap
	= ([ closed_let_vars_in_alt , closed_let_vars_in_expr : all_closed_let_vars ],
			{ case_rms & rms_var_heap = rms_var_heap, rms_let_vars = case_rms.rms_let_vars ++ alt_rms.rms_let_vars ++ rms_let_vars })
where	
	combine_pattern_and_alternative free_vars [] var_heap
		= seqCombine free_vars var_heap
	combine_pattern_and_alternative free_vars _ var_heap
		= parCombine free_vars var_heap

addSeqRefMarksOfLets let_vars closed_vars_end_rms
	= foldSt ref_mark_of_let let_vars closed_vars_end_rms
where		
	ref_mark_of_let fv=:{fv_name,fv_info_ptr} (closed_let_vars, rms=:{rms_var_heap})
		# (VI_Occurrence var_occ, rms_var_heap) = readPtr fv_info_ptr rms_var_heap
		  rms = { rms & rms_var_heap = rms_var_heap }
		= case var_occ.occ_bind of
			OB_OpenLet _ (Yes (ref_counts, let_vars))
				# rms_var_heap = rms.rms_var_heap <:= (fv_info_ptr, VI_Occurrence {var_occ & occ_bind = OB_LockedLet var_occ.occ_bind})
				  rms_var_heap = addSeqRefCounts ref_counts rms_var_heap
				-> addSeqRefMarksOfLets let_vars ([fv : closed_let_vars], {rms & rms_var_heap = rms_var_heap})
//					  ===> ("addSeqRefMarksOfLets (OB_OpenLet Yes)", fv_name) 
			OB_OpenLet fv No
				# rms_var_heap = rms.rms_var_heap <:= (fv_info_ptr, VI_Occurrence {var_occ & occ_bind = OB_LockedLet var_occ.occ_bind})
				-> (closed_let_vars, { rms  & rms_var_heap = rms_var_heap, rms_let_vars = [fv : rms.rms_let_vars]})
//					  ===> ("addSeqRefMarksOfLets (OB_OpenLet No)", fv_name) 
			OB_LockedLet _
				-> (closed_let_vars, rms)
//					  ===> ("addSeqRefMarksOfLets (OB_LockedLet)", fv_name) 


addRefMarkOfDefault :: !Int ![[FreeVar]] !(Optional [CountedFreeVar]) !*VarHeap -> *(![FreeVar], !*VarHeap)
addRefMarkOfDefault pattern_depth free_vars (Yes occurrences) var_heap
	# var_heap = saveOccurrences free_vars var_heap
	# (open_let_vars, var_heap)  = foldSt set_occurrence occurrences ([], var_heap)
	= (open_let_vars, altCombine (inc pattern_depth) free_vars var_heap)
520
where
521
	set_occurrence {cfv_var=fv=:{fv_name,fv_info_ptr}, cfv_count, cfv_is_let} (open_let_vars, var_heap)
522
		# (VI_Occurrence old_occ, var_heap) = readPtr fv_info_ptr var_heap
523
524
525
526
527
528
529
530
531
532
		= (cond_add cfv_is_let fv open_let_vars, var_heap <:= (fv_info_ptr, VI_Occurrence {old_occ & occ_ref_count = cfv_count } ))
			===>  ("set_occurrence", fv_name, cfv_count)
	where
		cond_add cond var vars
			| cond
				= [ var : vars]
				= vars 
	
addRefMarkOfDefault pattern_depth free_vars No var_heap
	= ([], altCombine pattern_depth free_vars var_heap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
533
534

parCombine free_vars var_heap
535
	= foldSt (foldSt par_combine) free_vars (var_heap===> ("parCombine", free_vars))
536
where
537
	par_combine {fv_name,fv_info_ptr} var_heap
538
		# (VI_Occurrence old_occ, var_heap) = readPtr fv_info_ptr var_heap
539
540
541
		= case old_occ.occ_previous of
			[glob_ref_count : occ_previous]
				# comb_ref_count = parCombineRefCount old_occ.occ_ref_count glob_ref_count
542
				-> var_heap <:= (fv_info_ptr, VI_Occurrence { old_occ & occ_ref_count = comb_ref_count , occ_previous = occ_previous })
543
						===> ("par_combine", fv_name, old_occ.occ_ref_count, glob_ref_count, comb_ref_count) 
544
			_
545
				-> abort ("inconsistent reference count administration" ===> fv_name)
546

547
548
549
550
551
552
553
554
555
556
557
558
seqCombine free_vars var_heap
	= foldSt (foldSt seq_combine) free_vars (var_heap===> ("seqCombine", free_vars))
where
	seq_combine {fv_name,fv_info_ptr} var_heap
		# (VI_Occurrence pattern_occ, var_heap) = readPtr fv_info_ptr var_heap
		= case pattern_occ.occ_previous of
			[alt_ref_count : occ_previous]
				# comb_ref_count = seqCombineRefCount alt_ref_count pattern_occ.occ_ref_count
				-> var_heap <:= (fv_info_ptr, VI_Occurrence { pattern_occ & occ_ref_count = comb_ref_count , occ_previous = occ_previous })
						===> ("seq_combine", fv_name, pattern_occ.occ_ref_count, alt_ref_count, comb_ref_count) 
			_
				-> abort ("inconsistent reference count administration" ===> fv_name)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
559

560
altCombine depth free_vars var_heap
561
	= foldSt (foldSt (alt_combine depth)) free_vars (var_heap ===> ("altCombine", free_vars))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
562
where
563
	alt_combine depth {fv_name,fv_info_ptr} var_heap
564
		# (VI_Occurrence old_occ=:{occ_ref_count,occ_previous}, var_heap) = readPtr fv_info_ptr var_heap
565
		  (occ_ref_count, occ_previous) = alt_combine_ref_counts occ_ref_count occ_previous ((dec depth) ===> ("alt_combine", fv_name, occ_ref_count, length occ_previous, depth))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
566
		= var_heap <:= (fv_info_ptr, VI_Occurrence { old_occ & occ_ref_count = occ_ref_count , occ_previous = occ_previous })
567
568
569
570
571
572
				
	alt_combine_ref_counts comb_ref_count ref_counts 0
		= (comb_ref_count, ref_counts)
	alt_combine_ref_counts comb_ref_count [occ_ref_count:occ_previous] depth
		# new_comb_ref_count = alt_combine_ref_count comb_ref_count occ_ref_count
		= alt_combine_ref_counts new_comb_ref_count occ_previous (dec depth)
573
				===> ("alt_combine_ref_count", comb_ref_count, occ_ref_count, new_comb_ref_count)
574
575

	alt_combine_ref_count RC_Unused ref_count
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
576
		= ref_count
577
	alt_combine_ref_count ref_count RC_Unused
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
578
		= ref_count
579
	alt_combine_ref_count (RC_Used {rcu_multiply,rcu_selectively,rcu_uniquely}) (RC_Used ref_count2)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
580
		= RC_Used { rcu_uniquely = rcu_uniquely ++ ref_count2.rcu_uniquely, rcu_multiply = rcu_multiply ++ ref_count2.rcu_multiply,
581
					rcu_selectively = alt_combine_of_selections rcu_selectively ref_count2.rcu_selectively}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
582
	where
583
		alt_combine_of_selections [] sels
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
584
			= sels
585
		alt_combine_of_selections sels []
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
586
			= sels
587
		alt_combine_of_selections sl1=:[sel1=:{ su_field, su_multiply, su_uniquely } : sels1] sl2=:[sel2 : sels2]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
588
589
			| su_field == sel2.su_field
				# sel1 = { sel1 & su_multiply = sel2.su_multiply ++ su_multiply, su_uniquely =  sel2.su_uniquely ++ su_uniquely }
590
				= [ sel1 : alt_combine_of_selections sels1 sels2 ]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
591
			| su_field < sel2.su_field
592
593
				= [sel1 : alt_combine_of_selections sels1 sl2 ]
				= [sel2 : alt_combine_of_selections sl1 sels2 ]
594
595
	
		
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
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

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 []
			= []
651

652

653
654
655
656
657
658
659
660
661
662
663
emptyOccurrence observing =
		{	occ_ref_count		= RC_Unused
		,	occ_previous		= []
		,	occ_observing		= observing
		,	occ_bind			= OB_Empty
		, 	occ_pattern_vars	= []
		}

emptyObservingOccurrence	=: VI_Occurrence (emptyOccurrence True)
emptyNonObservingOccurrence =: VI_Occurrence (emptyOccurrence False)
																	
664
665
666
667
668
669
670
671
672
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
673
674
where
	make_shared_references_of_funcion_non_unique {fun_symb, fun_pos, fun_body = TransformedBody {tb_args,tb_rhs},fun_info={fi_local_vars}}
675
			coercion_env subst type_def_infos var_heap expr_heap error
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
676
	# variables = tb_args ++ fi_local_vars
677
	  (subst, type_def_infos, var_heap, expr_heap) = clear_occurrences variables subst type_def_infos var_heap expr_heap
678
	  (_, {rms_var_heap}) = fullRefMark [tb_args] NotASelector No /* tb_rhs var_heap */ (tb_rhs ===> ("makeSharedReferencesNonUnique", fun_symb, tb_rhs)) var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
679
	  position = newPosition fun_symb fun_pos
680
	  (coercion_env, var_heap, expr_heap, error) = make_shared_vars_non_unique variables coercion_env rms_var_heap expr_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
681
	  		(setErrorAdmin position error)
682
	= (coercion_env, subst, type_def_infos, var_heap, expr_heap, error)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
683
684
	
	where
685
686
		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
687
		where
688
			initial_occurrence {fv_name,fv_info_ptr} (subst, type_def_infos, var_heap, expr_heap) 
689
				# (var_info, var_heap) = readPtr fv_info_ptr var_heap
690
691
692
				| has_observing_base_type var_info type_def_infos subst
					= (subst, type_def_infos, var_heap <:= (fv_info_ptr, emptyObservingOccurrence), expr_heap)
					= (subst, type_def_infos, var_heap <:= (fv_info_ptr, emptyNonObservingOccurrence), expr_heap)
693
694
695
				
		has_observing_base_type (VI_Type {at_type} _) type_def_infos subst
			= has_observing_type at_type type_def_infos subst
696
		has_observing_base_type (VI_FAType _ {at_type} _) type_def_infos subst
697
698
699
			= has_observing_type at_type type_def_infos subst
		has_observing_base_type _ type_def_infos subst
			= abort "has_observing_base_type (refmark.icl)"
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
700
701
702
703
704

		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}
705
			# (VI_Occurrence occ, var_heap) = readPtr fv_info_ptr var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
706
707
708
			= 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)
709
					  (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
710
711
712
					-> (coercion_env, var_heap, expr_heap, error)
				_
					-> (coercion_env, var_heap, expr_heap, error)
713
//						===> ("make_shared_var_non_unique", fv_name)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
714
715
716
717
718
719
720

		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)
721
722
723
724
725
				# (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
726
								 ===> ("make_shared_occurrence_non_unique", free_var, var_expr_ptr, sa_attr_nr)
727
							-> (coercion_env, expr_heap, error)
Martin Wierich's avatar
Martin Wierich committed
728
							-> (coercion_env, expr_heap, uniquenessError (CP_Expression (FreeVar free_var)) " demanded attribute cannot be offered by shared object" error)
729
					_
730
						-> abort ("make_shared_occurrence_non_unique" ===> ((free_var, var_expr_ptr) )) // <<- expr_info))
731

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
732
733
734
		make_selection_non_unique fv {su_multiply} cee
			= make_shared_occurrences_non_unique fv su_multiply cee

735
/*
736
737
	has_observing_type type_def_infos TE
		= True
738
739
	has_observing_type type_def_infos (TB basic_type)
		= True
740
741
*/
	has_observing_type (TB basic_type) type_def_infos subst
742
		= True
743
744
745
746
747
748
749
	has_observing_type (TempV var_number) type_def_infos subst
		= case subst.[var_number] of
			TE
				-> True
			subst_type
				-> 	has_observing_type subst_type type_def_infos subst
	has_observing_type (TA {type_index = {glob_object,glob_module}} type_args) type_def_infos subst
750
		# {tdi_properties} = type_def_infos.[glob_module].[glob_object]
751
752
		= foldSt (\ {at_type} ok -> ok && has_observing_type at_type type_def_infos subst) type_args (tdi_properties bitand cIsHyperStrict <> 0)
	has_observing_type type type_def_infos subst
753
		= False
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
754
755
756
757
758
759
760
761
762
763
764
					
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


765
instance <<< (Ptr v)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
766
767
768
769
where
	(<<<) file ptr = file <<< '[' <<< ptrToInt ptr <<< ']'


770
771
772
773
774
instance <<< CountedFreeVar
where
	(<<<) file {cfv_var,cfv_count} = file <<< cfv_var <<< ':' <<< cfv_count