refmark.icl 46.9 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
::	RMState =
12
13
14
	{	rms_var_heap :: !.VarHeap
	,	rms_let_vars :: ![FreeVar]
	,	rms_counted_let_vars :: ![FreeVar]
15
16
	}

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

19
20
21
22
fullRefMarkOfRootOrLetExpr :: ![[FreeVar]] !Int !(Optional [CountedFreeVar]) !Expression [FreeVar] !*VarHeap -> *RMState
fullRefMarkOfRootOrLetExpr free_vars sel def expr rms_counted_let_vars var_heap
	# {rms_let_vars,rms_counted_let_vars,rms_var_heap}
		= refMark free_vars sel def expr {rms_var_heap=var_heap, rms_let_vars=[], rms_counted_let_vars=rms_counted_let_vars}
23
	  rms_var_heap = openLetVars rms_let_vars rms_var_heap
24
	  (closed_let_vars,rms) = addParRefMarksOfLets rms_let_vars ([],{rms_let_vars=[],rms_counted_let_vars=rms_counted_let_vars,rms_var_heap=rms_var_heap})
25
	= {rms & rms_counted_let_vars=closed_let_vars++rms.rms_counted_let_vars}
26

27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
fullRefMarkOfAlternative :: ![[FreeVar]] !Int !(Optional [CountedFreeVar]) !expr !*VarHeap -> (!*[FreeVar],!*RMState) | refMark expr
fullRefMarkOfAlternative free_vars sel def expr var_heap
	# {rms_let_vars,rms_counted_let_vars,rms_var_heap}
		= refMark free_vars sel def expr {rms_var_heap=var_heap, rms_let_vars=[], rms_counted_let_vars=[]}
	  rms_var_heap = openLetVars rms_let_vars rms_var_heap
	= addParRefMarksOfLets rms_let_vars ([], {rms_let_vars=[], rms_counted_let_vars=rms_counted_let_vars, rms_var_heap=rms_var_heap})

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

ref_mark_of_lets free_vars let_binds rms_counted_let_vars rms_var_heap
	= foldSt (ref_mark_of_let free_vars) let_binds (rms_counted_let_vars,rms_var_heap)
43
where
44
	ref_mark_of_let free_vars let_bind=:{lb_src, lb_dst=fv=:{fv_info_ptr}} (rms_counted_let_vars,rms_var_heap)
45
		# (VI_Occurrence occ, rms_var_heap) = readPtr fv_info_ptr rms_var_heap
46
47
48
49
		  rms_var_heap = rms_var_heap <:= (fv_info_ptr, VI_Occurrence {occ & occ_bind = OB_LockedLet occ.occ_bind})
		  (res,rms_counted_let_vars,rms_var_heap) = partialRefMark free_vars lb_src rms_counted_let_vars rms_var_heap
		#! rms_var_heap = rms_var_heap <:= (fv_info_ptr, VI_Occurrence {occ & occ_bind = OB_OpenLet fv (Yes res)})
		= (rms_counted_let_vars,rms_var_heap) ===> ("ref_mark_of_let", fv, res)
50

51
52
	partialRefMark :: ![[FreeVar]] !Expression [FreeVar] !*VarHeap -> (!([CountedFreeVar],[FreeVar]),![FreeVar],!*VarHeap)
	partialRefMark free_vars expr rms_counted_let_vars var_heap
53
		# var_heap = saveOccurrences free_vars var_heap
54
55
		  {rms_var_heap,rms_counted_let_vars,rms_let_vars}
		  	= refMark free_vars NotASelector No expr {rms_var_heap=var_heap, rms_let_vars=[], rms_counted_let_vars=rms_counted_let_vars}
56
57
		  rms_var_heap = openLetVars rms_let_vars rms_var_heap
		  (occurrences, rms_var_heap) = restoreOccurrences free_vars rms_var_heap
58
		= ((occurrences, rms_let_vars),rms_counted_let_vars,rms_var_heap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
59

60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
remove_local_let_vars_from_counted_let_vars :: ![FreeVar] ![FreeVar] !*VarHeap -> (![FreeVar],!*VarHeap)
remove_local_let_vars_from_counted_let_vars local_let_vars counted_let_vars var_heap
	# var_heap = foldSt (\ {fv_info_ptr} -> mark_bind fv_info_ptr) local_let_vars var_heap
	  (counted_let_vars,var_heap) = remove_marked_local_let_vars counted_let_vars var_heap
	  var_heap = foldSt (\ {fv_info_ptr} -> unmark_bind fv_info_ptr) local_let_vars var_heap
	= (counted_let_vars,var_heap)
where
	mark_bind fv_info_ptr var_heap
		# (VI_Occurrence occ,var_heap) = readPtr fv_info_ptr var_heap
		= writePtr fv_info_ptr (VI_Occurrence {occ & occ_bind=OB_MarkedLet occ.occ_bind}) var_heap

	remove_marked_local_let_vars [closed_let_var:closed_let_vars] var_heap
		# (VI_Occurrence occ) = sreadPtr closed_let_var.fv_info_ptr var_heap
		= case occ.occ_bind of
			OB_MarkedLet _
				-> remove_marked_local_let_vars closed_let_vars var_heap
			_
				# (closed_let_vars,var_heap) = remove_marked_local_let_vars closed_let_vars var_heap
				-> ([closed_let_var:closed_let_vars],var_heap)
	remove_marked_local_let_vars [] var_heap
		= ([],var_heap)

	unmark_bind fv_info_ptr var_heap
		# (VI_Occurrence occ=:{occ_bind=OB_MarkedLet occ_bind},var_heap) = readPtr fv_info_ptr var_heap
		= writePtr fv_info_ptr (VI_Occurrence {occ & occ_bind=occ_bind}) var_heap

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
86
87
instance refMark [a] | refMark a
where
88
89
	refMark free_vars sel _ list rms 
		= foldSt (refMark free_vars sel No) list rms 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
90
91
92
93
94
95
96

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

saveOccurrences free_vars var_heap
97
	= foldSt (foldSt save_occurrence) free_vars var_heap // (free_vars ===> ("saveOccurrences", free_vars)) var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
98
where
99
	save_occurrence {fv_ident,fv_info_ptr} var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
100
101
		# (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] } )
102
 			===> ("save_occurrence", fv_ident, fv_info_ptr, occ_ref_count, length occ_previous)
103

104
105
restoreOccurrences free_vars var_heap
	= foldSt (foldSt restore_occurrence) (free_vars ===> ("restoreOccurrences", free_vars)) ([], var_heap)
106
where
107
	restore_occurrence fv=:{fv_ident,fv_info_ptr} (occurrences, var_heap)
108
109
110
111
112
		# (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)
		  										_
113
		  											-> abort ("restoreOccurrences" /* ---> (fv_ident, fv_info_ptr) */)
114
		  var_heap = var_heap <:= (fv_info_ptr, VI_Occurrence {old_occ & occ_ref_count = prev_ref_count, occ_previous = occ_previous })
115
		= case occ_ref_count ===> ("restore_occurrence", fv_ident, fv_info_ptr, (occ_ref_count, prev_ref_count, occ_previous)) of
116
117
118
			RC_Unused
				-> (occurrences, var_heap)
			_
119
120
121
122
123
124
				-> 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)

125
markPatternVariables sel list_of_used_pattern_vars var_heap
126
127
128
	| sel == NotASelector
		= markPatternVariables list_of_used_pattern_vars var_heap
		= foldSt (mark_selected_variable sel) list_of_used_pattern_vars var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
129
where
130
131
132
133
134
	markPatternVariables list_of_used_pattern_vars var_heap
		= foldSt mark_pattern_variables list_of_used_pattern_vars var_heap

	mark_pattern_variables used_pattern_vars var_heap
		= foldSt mark_variable used_pattern_vars var_heap
135
136

	mark_selected_variable sel [] var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
137
		= var_heap
138
139
140
141
	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
142

143
	mark_variable {pv_var={fv_ident,fv_info_ptr}} var_heap
144
		# (VI_Occurrence old_occ=:{occ_ref_count,occ_observing = (_, expr_ptr),occ_pattern_vars}, var_heap) = readPtr fv_info_ptr var_heap
145
		= case occ_ref_count ===> ("mark_variable", fv_ident) of
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
146
			RC_Unused
147
				# occ_ref_count = RC_Used {rcu_multiply = [], rcu_selectively = [], rcu_uniquely = [expr_ptr]}
148
149
				# var_heap= var_heap <:= (fv_info_ptr, VI_Occurrence {old_occ & occ_ref_count = occ_ref_count } )
				-> markPatternVariables occ_pattern_vars var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
150
			RC_Used {rcu_multiply,rcu_uniquely,rcu_selectively}
151
				# occ_ref_count = RC_Used { rcu_multiply = collectAllSelections rcu_selectively (rcu_uniquely ++ [expr_ptr : rcu_multiply]),
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
152
							 rcu_selectively = [], rcu_uniquely = [] }
153
154
				# var_heap = var_heap <:= (fv_info_ptr, VI_Occurrence {old_occ & occ_ref_count = occ_ref_count } )
				-> markPatternVariables occ_pattern_vars var_heap
155

156
refMarkOfVariable sel (VI_Occurrence var_occ) var=:{var_ident, var_info_ptr, var_expr_ptr} rms=:{rms_var_heap}
157
158
	# 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
159
	= ref_count_of_bindings var_occ var_ident var_info_ptr occ_ref_count { rms & rms_var_heap = rms_var_heap }
160
		===> ("refMarkOfVariable", var_ident, var_occ.occ_ref_count, occ_ref_count, var_occ.occ_pattern_vars)
161
162
163
where
	adjust_ref_count sel RC_Unused var_expr_ptr
		| sel == NotASelector
164
165
166
			= RC_Used {rcu_multiply = [], rcu_uniquely = [var_expr_ptr], rcu_selectively = []}
			= RC_Used {rcu_multiply = [], rcu_uniquely = [],
					   rcu_selectively = [{ su_field = sel, su_multiply = [], su_uniquely = [var_expr_ptr] }]}
167
168
169
170
	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 = []}
171
172
173
174
175
176
			# rcu_multiply = rcu_uniquely ++ rcu_multiply
			| isEmpty rcu_multiply
				# rcu_selectively = add_selection var_expr_ptr sel rcu_selectively
				= RC_Used {rcu_multiply = [], rcu_uniquely = [], rcu_selectively = rcu_selectively}
				# rcu_multiply = collectAllSelections rcu_selectively [var_expr_ptr : rcu_multiply]
				= RC_Used {rcu_multiply = rcu_multiply, rcu_uniquely = [], rcu_selectively = []}
177
178
179
180
181
182
183
184
185
186

	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 ]

187
	ref_count_of_bindings var_occ=:{occ_bind = OB_OpenLet fv _} var_ident var_info_ptr occ_ref_count rms=:{rms_var_heap,rms_let_vars}
188
189
		# 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 ]}
190
				===> ("ref_count_of_bindings (OB_OpenLet)", var_ident)
191
	ref_count_of_bindings var_occ=:{occ_bind = OB_LockedLet _} var_ident var_info_ptr occ_ref_count rms=:{rms_var_heap} 
192
		= { rms & rms_var_heap = rms_var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_ref_count = occ_ref_count })}
193
//				===> ("ref_count_of_bindings (OB_LockedLet)", var_ident)
194
	ref_count_of_bindings var_occ var_ident var_info_ptr occ_ref_count rms=:{rms_var_heap}
195
196
		= { rms & rms_var_heap = rms_var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_ref_count = occ_ref_count })}

197
198
addParRefMarksOfLets let_vars closed_vars_and_rms
	= foldSt ref_mark_of_let let_vars closed_vars_and_rms
199
where
200
	ref_mark_of_let fv=:{fv_ident,fv_info_ptr} (closed_let_vars, rms=:{rms_var_heap})
201
		# (VI_Occurrence var_occ, rms_var_heap) = readPtr fv_info_ptr rms_var_heap
202
		  rms = {rms & rms_var_heap = rms_var_heap}
203
204
205
		= 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})
206
207
				  rms_var_heap = addParRefCounts ref_counts rms_var_heap
				-> addParRefMarksOfLets let_vars ([fv : closed_let_vars], {rms & rms_var_heap = rms_var_heap})
208
						 ===> ("addParRefMarksOfLets (OB_OpenLet Yes)", fv_ident) 
209
210
211
			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]})
212
						 ===> ("addParRefMarksOfLets (OB_OpenLet No)", fv_ident) 
213
214
			OB_LockedLet _
				-> (closed_let_vars, rms)
215
						 ===> ("addParRefMarksOfLets (OB_LockedLet)", fv_ident) 
216
217
218

addParRefCounts ref_counts var_heap
	= foldSt set_occurrence ref_counts var_heap
219
where
220
	set_occurrence {cfv_var = {fv_ident,fv_info_ptr}, cfv_count} var_heap
221
222
223
		# (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})
224
			===>  ("addParRefCounts", fv_ident, fv_info_ptr, (cfv_count, occ_ref_count, comb_ref_count))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
225

226
227
228
addSeqRefCounts ref_counts var_heap
	= foldSt set_occurrence ref_counts var_heap
where
229
	set_occurrence {cfv_var = {fv_ident,fv_info_ptr}, cfv_count} var_heap
230
231
232
		# (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})
233
			===>  ("addSeqRefCounts", fv_ident, cfv_count, occ_ref_count, comb_ref_count)
234

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
235
236
instance refMark BoundVar
where
237
238
	refMark free_vars sel _ var rms=:{rms_var_heap}
		# (var_occ, rms_var_heap) = readPtr var.var_info_ptr rms_var_heap
239
		= refMarkOfVariable sel var_occ var { rms & rms_var_heap = rms_var_heap }
240

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
241
242
instance refMark Expression
where
243
244
245
246
247
248
249
	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)

250
	refMark free_vars sel def (Let {let_strict_binds,let_lazy_binds,let_expr}) rms=:{rms_counted_let_vars,rms_var_heap}
Sjaak Smetsers's avatar
Sjaak Smetsers committed
251
		| isEmpty let_lazy_binds
252
253
			# local_let_vars = [lb_dst \\ {lb_dst} <- let_strict_binds]
			# new_free_vars = [local_let_vars : free_vars]
254
			| binds_are_observing let_strict_binds rms_var_heap
255
				# rms_var_heap = saveOccurrences free_vars rms_var_heap
256
				  rms = refMark new_free_vars NotASelector No let_strict_binds {rms & rms_var_heap = rms_var_heap}
257
				  rms_var_heap = saveOccurrences new_free_vars rms.rms_var_heap
258
259
260
				  {rms_var_heap,rms_let_vars,rms_counted_let_vars}
					= fullRefMarkOfRootOrLetExpr new_free_vars sel def let_expr rms_counted_let_vars rms_var_heap
				  rms_var_heap = let_combine free_vars rms_var_heap
261
				  (rms_counted_let_vars,rms_var_heap) = remove_local_let_vars_from_counted_let_vars local_let_vars rms_counted_let_vars rms_var_heap
262
				= {rms_var_heap=rms_var_heap, rms_let_vars=rms_let_vars ++ rms.rms_let_vars, rms_counted_let_vars=rms_counted_let_vars}
263
					===> ("refMark (Let (observing))", hd new_free_vars)
264
				= refMark new_free_vars sel def let_expr (refMark new_free_vars NotASelector No let_strict_binds {rms & rms_var_heap = rms_var_heap})
265
			# all_binds								= let_strict_binds ++ let_lazy_binds
266
267
268
269
270
271
			  local_let_vars						= [lb_dst \\ {lb_dst} <- all_binds]
			  new_free_vars							= [local_let_vars : free_vars]
			  rms_var_heap							= init_let_binds local_let_vars rms_var_heap
			  (rms_counted_let_vars,rms_var_heap)	= ref_mark_of_lets new_free_vars all_binds rms_counted_let_vars rms_var_heap
			  {rms_var_heap,rms_let_vars,rms_counted_let_vars}
				= fullRefMarkOfRootOrLetExpr new_free_vars sel def let_expr rms_counted_let_vars rms_var_heap
272
			  (rms_counted_let_vars,rms_var_heap) = remove_local_let_vars_from_counted_let_vars local_let_vars rms_counted_let_vars rms_var_heap
273
			= {rms_var_heap=rms_var_heap, rms_let_vars=rms_let_vars ++ rms.rms_let_vars, rms_counted_let_vars=rms_counted_let_vars}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
274
		where
275
276
277
278
279
			binds_are_observing [{lb_dst={fv_info_ptr}}:binds] var_heap
				# (VI_Occurrence {occ_observing=(is_observing,_)}) = sreadPtr fv_info_ptr var_heap
				= is_observing && binds_are_observing binds var_heap
		    binds_are_observing [] var_heap
		    	= True
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
280
281
282
283
			
			let_combine free_vars var_heap
				= foldSt (foldSt let_combine_ref_count) free_vars var_heap
			where
284
				let_combine_ref_count {fv_ident,fv_info_ptr} var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
285
286
					# (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
287
288
289
					  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 }))
290
						===> ("let_combine_ref_count", fv_ident, (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
291

292
293
294
			init_let_binds let_binds var_heap
				= foldSt bind_variable let_binds var_heap
			where
295
				bind_variable fv=:{fv_info_ptr} var_heap
296
					# (VI_Occurrence occ, var_heap) = readPtr fv_info_ptr var_heap
297
298
299
300
					= var_heap <:= (fv_info_ptr, VI_Occurrence { occ & occ_ref_count = RC_Unused, occ_bind = OB_OpenLet fv No })

	refMark free_vars sel def (Case ca) rms
		= refMarkOfCase free_vars sel def ca rms 
301
302
303
304
	refMark free_vars sel _ (Selection selkind expr selectors) rms
		= case selkind of
			UniqueSelector
				-> refMark free_vars NotASelector No expr rms
305
306
307
			UniqueSelectorUniqueElementResult
				-> refMark free_vars NotASelector No expr rms
			_
308
				-> refMark free_vars (field_number selectors) No expr rms 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
309
310
311
312
313
	where
		field_number [ RecordSelection _ field_nr : _ ]
			= field_nr	
		field_number _
			= NotASelector	
314
315
316
317
318
319
	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
320
	where
321
322
323
324
325
		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
326
	
327
328
329
330
		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
331
			  rms  = refMarkOfVariable field_nr var_occ { var & var_expr_ptr = expr_ptr } { rms & rms_var_heap = rms_var_heap }
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
			= 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
348

349
350
instance refMark LetBind
where
351
	refMark free_vars sel _ {lb_src} rms
352
		= refMark free_vars NotASelector No lb_src rms 
353

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
354
355
instance refMark Selection
where
356
357
358
359
	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
360
361
362
363
364
365

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
366
			= 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
367
368
369
370
			= collect_used_vars pattern_vars (inc arg_nr) collected_vars
	collect_used_vars [] arg_nr collected_vars
		= collected_vars

371
372
openLetVars let_vars var_heap
	= foldSt open_let_vars let_vars var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
373
where
374
	open_let_vars {fv_ident,fv_info_ptr} var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
375
376
		# (VI_Occurrence var_occ, var_heap) = readPtr fv_info_ptr var_heap
		= case var_occ.occ_bind of
377
			OB_LockedLet occ_bind
378
				-> var_heap <:= (fv_info_ptr, VI_Occurrence {var_occ & occ_bind = occ_bind})
379
//					 ===> ("openLetVars (OB_LockedLet)", fv_ident)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
380
			_
381
				-> abort "open_let_vars (refmark.icl))"
382

383
384
setUsedLetVars used_vars counted_let_vars var_heap
	= foldSt (foldSt set_used_let_var) used_vars (counted_let_vars,var_heap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
385
where
386
	set_used_let_var fv=:{fv_info_ptr,fv_ident} (counted_let_vars,var_heap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
387
388
		# (VI_Occurrence var_occ, var_heap) = readPtr fv_info_ptr var_heap
		= case var_occ.occ_bind of
389
			OB_OpenLet _ _
390
391
392
				# var_heap = writePtr fv_info_ptr (VI_Occurrence {var_occ & occ_bind = OB_LockedLet var_occ.occ_bind}) var_heap
				  counted_let_vars = [fv:counted_let_vars]
				-> (counted_let_vars,var_heap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
393
			_
394
				-> (counted_let_vars,var_heap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
395

396
397
398
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 

399
400
refMarkOfCase free_vars sel def {case_expr, case_guards=BasicPatterns type patterns,case_default,case_explicit} rms=:{rms_counted_let_vars}
	# (def, all_closed_let_vars, rms) = refMarkOfDefault case_explicit free_vars sel def case_expr case_default [] rms
401
402
	  (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
403
	  (rms_counted_let_vars,rms_var_heap) = setUsedLetVars [let_vars_in_default : all_closed_let_vars] rms_counted_let_vars rms_var_heap
404
	  rms_var_heap = parCombine free_vars rms_var_heap
405
	= {rms & rms_var_heap=rms_var_heap, rms_counted_let_vars=rms_counted_let_vars}
406
where
407
408
409
	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)
410

411
refMarkOfCase free_vars sel def {case_expr, case_guards=OverloadedListPatterns type _ patterns, case_explicit, case_default} rms
412
413
	= refMarkOfAlgebraicOrOverloadedListCase free_vars sel def case_expr patterns case_explicit case_default rms 

John van Groningen's avatar
John van Groningen committed
414
415
416
refMarkOfCase free_vars sel def {case_expr, case_guards=NewTypePatterns type patterns, case_explicit, case_default} rms 
	= refMarkOfAlgebraicOrOverloadedListCase free_vars sel def case_expr patterns case_explicit case_default rms 

417
418
refMarkOfCase free_vars sel def {case_expr, case_guards=DynamicPatterns patterns,case_default,case_explicit} rms=:{rms_counted_let_vars}
	# (def, all_closed_let_vars, rms) = refMarkOfDefault case_explicit free_vars sel def case_expr case_default [] rms
419
	  (pattern_depth, all_closed_let_vars, rms) = foldSt (ref_mark_of_dynamic_pattern free_vars sel def case_expr) patterns (0, all_closed_let_vars, rms)
420
	  (let_vars_in_default, rms_var_heap) = addRefMarkOfDefault pattern_depth free_vars def rms.rms_var_heap
421
	  (rms_counted_let_vars,rms_var_heap) = setUsedLetVars [let_vars_in_default : all_closed_let_vars] rms_counted_let_vars rms_var_heap
422
	  rms_var_heap = parCombine free_vars rms_var_heap
423
	= {rms & rms_var_heap=rms_var_heap, rms_counted_let_vars=rms_counted_let_vars}
424
where
425
426
	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]
427
		  new_free_vars = [pv_var \\ {pv_var} <- used_pattern_vars]
428
429
		  (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)	
430

431
432
refMarkOfAlgebraicOrOverloadedListCase free_vars sel def (Var var) alternatives case_explicit case_default rms=:{rms_counted_let_vars}
	# (def, all_closed_let_vars, rms) = ref_mark_of_default case_explicit free_vars sel def var case_default rms
433
434
	  (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
435
	  (rms_counted_let_vars,rms_var_heap) = setUsedLetVars [let_vars_in_default : all_closed_let_vars] rms_counted_let_vars rms_var_heap
436
	  rms_var_heap = parCombine free_vars rms_var_heap
437
	= {rms & rms_var_heap=rms_var_heap, rms_counted_let_vars=rms_counted_let_vars}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
438
where
439
	ref_mark_of_default case_explicit free_vars sel def var (Yes expr) rms=:{rms_var_heap, rms_let_vars}
440
		# rms_var_heap = saveOccurrences free_vars rms_var_heap
441
		  (closed_lets, rms) = fullRefMarkOfAlternative free_vars sel No expr rms_var_heap 
442
443
		  (closed_lets, rms) = ref_mark_of_variable_pattern True var (closed_lets, rms)
		  rms_var_heap = openLetVars closed_lets rms.rms_var_heap
444
445
		  rms_var_heap = openLetVars rms.rms_counted_let_vars rms_var_heap
		  all_closed_let_vars = [closed_lets,rms.rms_counted_let_vars]
446
		  (occurrences, rms_var_heap) = restoreOccurrences free_vars rms_var_heap
447
		= (Yes occurrences, all_closed_let_vars, {rms & rms_var_heap = rms_var_heap, rms_let_vars = rms.rms_let_vars ++ rms_let_vars})
448
			===>  ("ref_mark_of_default", occurrences, closed_lets)
449
	ref_mark_of_default case_explicit free_vars sel def var No rms
450
		| case_explicit
451
452
			= (No,	[], rms)
			= (def, [], rms)
453

454
	ref_mark_of_algebraic_pattern free_vars sel var def {ap_vars,ap_expr} (pattern_depth, all_closed_let_vars, {rms_var_heap}) 
455
		# rms_var_heap = saveOccurrences free_vars rms_var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
456
		  used_pattern_vars = collectPatternsVariables ap_vars
457
		  rms_var_heap = bind_pattern_variable var used_pattern_vars rms_var_heap
458
459
		  free_vars = [[pv_var \\ {pv_var} <- used_pattern_vars] : free_vars]
		  (closed_let_vars, rms) = fullRefMarkOfAlternative free_vars sel def ap_expr rms_var_heap
460
		  rms_var_heap = restore_binding_of_pattern_variable var used_pattern_vars rms.rms_var_heap
461
		  (closed_let_vars, rms) = ref_mark_of_variable_pattern (isEmpty used_pattern_vars) var (closed_let_vars, {rms & rms_var_heap = rms_var_heap})
462
		  rms_var_heap = openLetVars closed_let_vars rms.rms_var_heap
463
464
465
		  rms_var_heap = openLetVars rms.rms_counted_let_vars rms_var_heap
		  all_closed_let_vars = [rms.rms_counted_let_vars:all_closed_let_vars]
		= (inc pattern_depth, [closed_let_vars:all_closed_let_vars], {rms & rms_var_heap = rms_var_heap})
466
467

	bind_pattern_variable _ [] var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
468
		= var_heap
469
	bind_pattern_variable {var_info_ptr} used_pattern_vars var_heap
470
		# (VI_Occurrence var_occ, var_heap) = readPtr var_info_ptr var_heap
471
		= 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
472

Sjaak Smetsers's avatar
bug fix    
Sjaak Smetsers committed
473
	restore_binding_of_pattern_variable _ [] var_heap
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
474
		= var_heap
475
	restore_binding_of_pattern_variable {var_info_ptr} used_pattern_vars var_heap
476
		# (VI_Occurrence var_occ, var_heap) = readPtr var_info_ptr var_heap
477
		= var_heap <:= (var_info_ptr, VI_Occurrence {var_occ & occ_pattern_vars = tl var_occ.occ_pattern_vars})
478

479
	ref_mark_of_variable_pattern do_seq_combine {var_ident,var_info_ptr,var_expr_ptr} (closed_lets, rms=:{rms_var_heap})
480
481
		# (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
482
		= add_let_variable do_seq_combine var_info_ptr var_occ_in_alts (closed_lets, {rms & rms_var_heap = rms_var_heap})
483
484
485
486
487
488
489
	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))
490

491
492
493
494
		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
495
				= addSeqRefMarksOfLets let_vars ([fv : closed_lets], { rms & rms_var_heap = rms_var_heap })
496
497
				# rms_var_heap = addParRefCounts ref_counts rms_var_heap
				= addParRefMarksOfLets let_vars ([fv : closed_lets], { rms & rms_var_heap = rms_var_heap })
498
499
		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}) 
500
			= (closed_lets, {rms & rms_var_heap = rms_var_heap, rms_let_vars = [fv : rms_let_vars]})
501
502
503
		add_let_variable do_seq_combine var_info_ptr v_ closed_lets_and_rms
			= closed_lets_and_rms

504
505
refMarkOfAlgebraicOrOverloadedListCase free_vars sel def case_expr alternatives case_explicit case_default rms=:{rms_counted_let_vars}
	# (def, all_closed_let_vars, rms) = refMarkOfDefault case_explicit free_vars sel def case_expr case_default [] rms
506
507
	  (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
508
	  (rms_counted_let_vars,rms_var_heap) = setUsedLetVars [let_vars_in_default : all_closed_let_vars] rms_counted_let_vars rms_var_heap
509
	  rms_var_heap = parCombine free_vars rms_var_heap
510
	= {rms & rms_var_heap=rms_var_heap, rms_counted_let_vars=rms_counted_let_vars}
511
512
513
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
514
		  new_free_vars = [pv_var \\ {pv_var} <- used_pattern_vars]
515
516
517
518
519
		  (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
520
	  (occurrences, rms_var_heap) = restoreOccurrences free_vars rms.rms_var_heap
521
522
523
	= (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 
524
	| case_explicit
525
526
527
		= (No,	all_closed_let_vars, rms)
		= (def, all_closed_let_vars, rms)

528
refMarkOfAlternative free_vars [] sel def case_expr alt_expr all_closed_let_vars {rms_let_vars,rms_var_heap}
529
	# rms_var_heap = saveOccurrences free_vars rms_var_heap
530
	  (closed_let_vars_in_alt, alt_rms) = fullRefMarkOfAlternative free_vars sel def alt_expr rms_var_heap
531
	  rms_var_heap = saveOccurrences free_vars alt_rms.rms_var_heap
532
	  (closed_let_vars_in_expr, case_rms) = fullRefMarkOfCaseExpr free_vars sel def case_expr alt_rms.rms_counted_let_vars rms_var_heap
533
534
535
	  rms_var_heap = seqCombine free_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
536
537
538
539
540
	  rms_var_heap = openLetVars case_rms.rms_counted_let_vars rms_var_heap
	  all_closed_let_vars = [case_rms.rms_counted_let_vars:all_closed_let_vars]
	= ([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})
refMarkOfAlternative free_vars pattern_vars sel def case_expr alt_expr all_closed_let_vars {rms_let_vars,rms_var_heap}
541
	# rms_var_heap = saveOccurrences [pattern_vars : free_vars] rms_var_heap
542
	  (closed_let_vars_in_alt_and_expr, alt_and_case_rms) = fullRefMarkOfAlternative [pattern_vars : free_vars] sel def [alt_expr,case_expr] rms_var_heap
543
	  rms_var_heap = openLetVars closed_let_vars_in_alt_and_expr alt_and_case_rms.rms_var_heap
544
545
546
547
	  rms_var_heap = openLetVars alt_and_case_rms.rms_counted_let_vars rms_var_heap
	  all_closed_let_vars = [alt_and_case_rms.rms_counted_let_vars:all_closed_let_vars]
	= ([closed_let_vars_in_alt_and_expr:all_closed_let_vars],
			{alt_and_case_rms & rms_var_heap = rms_var_heap, rms_let_vars = alt_and_case_rms.rms_let_vars ++ rms_let_vars})
548

549
550
551
addSeqRefMarksOfLets let_vars closed_vars_and_rms
	= foldSt ref_mark_of_let let_vars closed_vars_and_rms
where
552
	ref_mark_of_let fv=:{fv_ident,fv_info_ptr} (closed_let_vars, rms=:{rms_var_heap})
553
554
555
556
557
558
559
		# (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})
560
//					  ===> ("addSeqRefMarksOfLets (OB_OpenLet Yes)", fv_ident) 
561
562
563
			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]})
564
//					  ===> ("addSeqRefMarksOfLets (OB_OpenLet No)", fv_ident) 
565
566
			OB_LockedLet _
				-> (closed_let_vars, rms)
567
//					  ===> ("addSeqRefMarksOfLets (OB_LockedLet)", fv_ident) 
568
569
570
571
572
573

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)
574
where
575
	set_occurrence {cfv_var=fv=:{fv_ident,fv_info_ptr}, cfv_count, cfv_is_let} (open_let_vars, var_heap)
576
		# (VI_Occurrence old_occ, var_heap) = readPtr fv_info_ptr var_heap
577
		= (cond_add cfv_is_let fv open_let_vars, var_heap <:= (fv_info_ptr, VI_Occurrence {old_occ & occ_ref_count = cfv_count}))
578
			===>  ("set_occurrence", fv_ident, cfv_count)
579
580
581
	where
		cond_add cond var vars
			| cond
582
583
				= [var : vars]
				= vars
584
585
addRefMarkOfDefault pattern_depth free_vars No var_heap
	= ([], altCombine pattern_depth free_vars var_heap)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
586
587

parCombine free_vars var_heap
588
	= foldSt (foldSt par_combine) free_vars (var_heap===> ("parCombine", free_vars))
589
where
590
	par_combine {fv_ident,fv_info_ptr} var_heap
591
		# (VI_Occurrence old_occ, var_heap) = readPtr fv_info_ptr var_heap
592
593
594
		= case old_occ.occ_previous of
			[glob_ref_count : occ_previous]
				# comb_ref_count = parCombineRefCount old_occ.occ_ref_count glob_ref_count
595
				-> var_heap <:= (fv_info_ptr, VI_Occurrence { old_occ & occ_ref_count = comb_ref_count , occ_previous = occ_previous })
596
						===> ("par_combine", fv_ident, old_occ.occ_ref_count, glob_ref_count, comb_ref_count) 
597
			_
598
				-> abort ("inconsistent reference count administration" ===> fv_ident)
599

600
601
602
seqCombine free_vars var_heap
	= foldSt (foldSt seq_combine) free_vars (var_heap===> ("seqCombine", free_vars))
where
603
	seq_combine {fv_ident,fv_info_ptr} var_heap
604
605
606
607
608
		# (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 })
609
						===> ("seq_combine", fv_ident, pattern_occ.occ_ref_count, alt_ref_count, comb_ref_count) 
610
			_
611
				-> abort ("inconsistent reference count administration" ===> fv_ident)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
612

613
altCombine depth free_vars var_heap
614
	= foldSt (foldSt (alt_combine depth)) free_vars (var_heap ===> ("altCombine", free_vars))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
615
where
616
	alt_combine depth {fv_ident,fv_info_ptr} var_heap
617
		# (VI_Occurrence old_occ=:{occ_ref_count,occ_previous}, var_heap) = readPtr fv_info_ptr var_heap
618
		  (occ_ref_count, occ_previous) = alt_combine_ref_counts occ_ref_count occ_previous ((dec depth) ===> ("alt_combine", fv_ident, occ_ref_count, length occ_previous, depth))
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
619
		= var_heap <:= (fv_info_ptr, VI_Occurrence { old_occ & occ_ref_count = occ_ref_count , occ_previous = occ_previous })
620
621
622
623
624
625
				
	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)
626
				===> ("alt_combine_ref_count", comb_ref_count, occ_ref_count, new_comb_ref_count)
627
628

	alt_combine_ref_count RC_Unused ref_count
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
629
		= ref_count
630
	alt_combine_ref_count ref_count RC_Unused
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
631
		= ref_count
632
	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
633
		= RC_Used { rcu_uniquely = rcu_uniquely ++ ref_count2.rcu_uniquely, rcu_multiply = rcu_multiply ++ ref_count2.rcu_multiply,
634
					rcu_selectively = alt_combine_of_selections rcu_selectively ref_count2.rcu_selectively}
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
635
	where
636
		alt_combine_of_selections [] sels
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
637
			= sels
638
		alt_combine_of_selections sels []
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
639
			= sels
640
		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
641
642
			| su_field == sel2.su_field
				# sel1 = { sel1 & su_multiply = sel2.su_multiply ++ su_multiply, su_uniquely =  sel2.su_uniquely ++ su_uniquely }
643
				= [ sel1 : alt_combine_of_selections sels1 sels2 ]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
644
			| su_field < sel2.su_field
645
646
				= [sel1 : alt_combine_of_selections sels1 sl2 ]
				= [sel2 : alt_combine_of_selections sl1 sels2 ]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
647
648
649
650
651
652
653
654

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
655
		= RC_Used { rcu_multiply = [], rcu_uniquely = [], rcu_selectively = par_combine_selections rcu_selectively ref_count2.rcu_selectively }
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
656
657
		# rcu_multiply = collectAllSelections ref_count2.rcu_selectively (collectAllSelections rcu_selectively rcu_multiply)
		= RC_Used { rcu_multiply = rcu_multiply, rcu_uniquely = [], rcu_selectively = [] }
658
where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
659
660
661
662
663
664
665
	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 = [] }
666
			= [sel1 : par_combine_selections sels1 sels2]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
667
		| su_field < sel2.su_field
668
669
			= [sel1 : par_combine_selections sels1 sl2]
			= [sel2 : par_combine_selections sl1 sels2]
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
670
671
672
673
674
675
676
677
678
679
680

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 }
681
			# prim_selections = make_primary_selections_non_unique prim_ref.rcu_selectively
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
682
683
684
			  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 }
685
	where
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
686
687
688
689
690
691
692
693
694
695
696
697
		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 ]

698
699
700
		make_primary_selections_non_unique [sel=:{su_multiply, su_uniquely } : sels]
			= [ { sel & su_multiply = su_uniquely ++ su_multiply, su_uniquely = [] } : make_primary_selections_non_unique sels ]
		make_primary_selections_non_unique []
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
701
			= []
702

703

704
emptyOccurrence type_info =
705
706
		{	occ_ref_count		= RC_Unused
		,	occ_previous		= []
707
		,	occ_observing		= type_info
708
709
710
711
		,	occ_bind			= OB_Empty
		, 	occ_pattern_vars	= []
		}

712
713
714
715
716
717
718
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)
719
		= make_shared_references_of_function_non_unique fun_def coercion_env subst type_def_infos var_heap expr_heap error
720
	= makeSharedReferencesNonUnique funs fun_defs coercion_env subst type_def_infos var_heap expr_heap error
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
721
where
John van Groningen's avatar
John van Groningen committed
722
	make_shared_references_of_function_non_unique {fun_ident, fun_pos, fun_body = fun_body =: TransformedBody {tb_args,tb_rhs},fun_info={fi_local_vars}}
723
			coercion_env subst type_def_infos var_heap expr_heap error
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
724
	# variables = tb_args ++ fi_local_vars
725
	  (subst, type_def_infos, var_heap, expr_heap) = clear_occurrences variables subst type_def_infos var_heap expr_heap
726
	  {rms_var_heap} = fullRefMarkOfRootOrLetExpr [tb_args] NotASelector No (tb_rhs ===> ("makeSharedReferencesNonUnique", fun_ident, tb_rhs)) [] var_heap
727
	  position = newPosition fun_ident fun_pos