Initial import

git-svn-id: https://svn.cs.ru.nl/repos/clean-compiler/trunk@2 1f8540f1-abd5-4d5b-9d24-4c5ce8603e2d

1 files changed, 591 insertions, 0 deletions

diff --git a/frontend/refmark.icl b/frontend/refmark.icl
new file mode 100644
index 0000000..9b54103
--- /dev/null
+++ b/frontend/refmark.icl
@@ -0,0 +1,591 @@
+implementation module refmark
+
+import StdEnv
+import syntax, Heap, typesupport, check, overloading, unitype, utilities, RWSDebug
+
+
+NotASelector :== -1
+
+class refMark expr ::  ![[FreeVar]] !Int !expr !*VarHeap -> *VarHeap
+
+
+instance refMark [a] | refMark a
+where
+	refMark free_vars sel list var_heap
+		= foldSt (refMark free_vars sel) list var_heap
+
+collectAllSelections [] cum_sels
+	= cum_sels
+collectAllSelections [{su_multiply,su_uniquely} : sels ] cum_sels
+	= collectAllSelections sels (su_uniquely ++ su_multiply ++ cum_sels)
+
+addSelection var_expr_ptr sel []
+	= [ { su_field = sel, su_multiply = [], su_uniquely = [var_expr_ptr]  } ]
+addSelection var_expr_ptr sel sels=:[selection=:{ su_field,su_multiply,su_uniquely } : selections]
+	| sel == su_field
+		= [ { selection & su_multiply = su_multiply ++ [var_expr_ptr : su_multiply], su_uniquely = [] } : selections ]
+	| sel < su_field
+		= [ { su_field = sel, su_multiply = [], su_uniquely = [var_expr_ptr]  } : sels ]
+		= [ selection : addSelection var_expr_ptr sel selections ]
+		
+saveOccurrences free_vars var_heap
+	= foldSt (foldSt save_occurrence) free_vars var_heap
+where
+	save_occurrence {fv_name,fv_info_ptr} var_heap
+		# (VI_Occurrence old_occ=:{occ_ref_count,occ_previous}, var_heap) = readPtr fv_info_ptr var_heap
+		= var_heap <:= (fv_info_ptr, VI_Occurrence {old_occ & occ_ref_count = RC_Unused, occ_previous = [occ_ref_count : occ_previous] } )
+	
+
+adjustRefCount sel RC_Unused var_expr_ptr
+	| sel == NotASelector
+		= RC_Used {rcu_multiply = [], rcu_selectively = [], rcu_uniquely = [var_expr_ptr] }
+		# sel_ref = { su_field = sel, su_multiply = [], su_uniquely = [var_expr_ptr] }
+		= RC_Used {rcu_multiply = [], rcu_selectively = [{ su_field = sel, su_multiply = [], su_uniquely = [var_expr_ptr] }], rcu_uniquely = [] }
+adjustRefCount sel (RC_Used {rcu_multiply,rcu_uniquely,rcu_selectively}) var_expr_ptr
+	| sel == NotASelector
+		# rcu_multiply = collectAllSelections rcu_selectively (rcu_uniquely ++ [var_expr_ptr : rcu_multiply])
+		= RC_Used {rcu_multiply = rcu_multiply, rcu_uniquely = [], rcu_selectively = [] }
+		# rcu_selectively = addSelection var_expr_ptr sel rcu_selectively
+		  rcu_multiply = rcu_uniquely ++ rcu_multiply
+		= RC_Used {rcu_multiply = rcu_multiply, rcu_uniquely = [], rcu_selectively = rcu_selectively }
+
+markPatternVariables sel used_pattern_vars var_heap
+	| sel == NotASelector
+		= foldSt mark_variable [ fv \\ (fv,_) <- used_pattern_vars ] var_heap
+		= mark_pattern_variable sel used_pattern_vars var_heap
+where
+	mark_pattern_variable sel [] var_heap
+		= var_heap
+	mark_pattern_variable sel [(fv, var_number) : used_pattern_vars ] var_heap
+		| sel == var_number
+			= mark_variable fv var_heap
+			= mark_pattern_variable sel used_pattern_vars var_heap
+		
+	mark_variable {fv_info_ptr} var_heap
+		# (VI_Occurrence old_occ=:{occ_ref_count}, var_heap) = readPtr fv_info_ptr var_heap
+		= case occ_ref_count of
+			RC_Unused
+				# occ_ref_count = RC_Used {rcu_multiply = [], rcu_selectively = [], rcu_uniquely = [nilPtr] }
+				-> var_heap <:= (fv_info_ptr, VI_Occurrence {old_occ & occ_ref_count = occ_ref_count } )
+			RC_Used {rcu_multiply,rcu_uniquely,rcu_selectively}
+				# occ_ref_count = RC_Used { rcu_multiply = collectAllSelections rcu_selectively (rcu_uniquely ++ rcu_multiply),
+							 rcu_selectively = [], rcu_uniquely = [] }
+				-> var_heap <:= (fv_info_ptr, VI_Occurrence {old_occ & occ_ref_count = occ_ref_count } )
+
+
+instance refMark BoundVar
+where
+	refMark free_vars sel {var_name,var_expr_ptr,var_info_ptr} var_heap
+		# (VI_Occurrence var_occ, var_heap) = readPtr var_info_ptr var_heap
+		  occ_ref_count = adjustRefCount sel var_occ.occ_ref_count var_expr_ptr
+		= case var_occ.occ_bind of
+			OB_OpenLet let_expr
+				# var_heap = var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_ref_count = occ_ref_count, occ_bind = OB_LockedLet let_expr })
+				-> refMark free_vars sel let_expr var_heap
+			OB_Pattern used_pattern_vars occ_bind
+				-> markPatternVariables sel used_pattern_vars (var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_ref_count = occ_ref_count }))
+			_
+				-> var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_ref_count = occ_ref_count })
+			
+instance refMark Expression
+where
+	refMark free_vars sel (Var var) var_heap
+		= refMark free_vars sel var var_heap
+	refMark free_vars sel (App {app_args}) var_heap
+		= refMark free_vars NotASelector app_args var_heap
+	refMark free_vars sel (fun @ args) var_heap
+		= refMark free_vars NotASelector args (refMark free_vars NotASelector fun var_heap)
+	refMark free_vars sel (Let {let_strict,let_binds,let_expr}) var_heap
+		# let_vars = [ bind_dst \\ {bind_dst} <- let_binds ]
+		  new_free_vars = [ let_vars : free_vars]
+		| let_strict
+			# (observing, var_heap) = binds_are_observing let_binds var_heap
+			| observing
+				# var_heap = saveOccurrences free_vars var_heap
+				  var_heap = refMark new_free_vars NotASelector let_binds var_heap
+				  var_heap = saveOccurrences new_free_vars var_heap
+				  var_heap = refMark new_free_vars sel let_expr var_heap
+				= let_combine free_vars var_heap
+				= refMark new_free_vars sel let_expr (refMark new_free_vars NotASelector let_binds var_heap)
+			# var_heap = foldSt bind_variable let_binds var_heap
+			= refMark new_free_vars sel let_expr var_heap
+
+		where
+		    binds_are_observing binds var_heap
+		    	= foldr bind_is_observing (True, var_heap) binds
+			where
+				bind_is_observing {bind_dst={fv_info_ptr}} (observe, var_heap) 
+					#! info = sreadPtr fv_info_ptr var_heap
+					# (VI_Occurrence {occ_observing}) = info
+					= (occ_observing && observe, var_heap)
+			
+			let_combine free_vars var_heap
+				= foldSt (foldSt let_combine_ref_count) free_vars var_heap
+			where
+				let_combine_ref_count {fv_info_ptr} var_heap
+					# (VI_Occurrence old_occ=:{occ_ref_count,occ_previous=[prev_ref_count, pre_pref_recount:occ_previouses]}, var_heap)
+							= readPtr fv_info_ptr var_heap
+					  comb_ref_count = parCombineRefCount (seqCombineRefCount prev_ref_count occ_ref_count) pre_pref_recount
+					= var_heap <:= (fv_info_ptr, VI_Occurrence { old_occ & occ_ref_count = comb_ref_count, occ_previous = occ_previouses })
+
+			bind_variable {bind_src,bind_dst={fv_info_ptr}} var_heap
+				# (VI_Occurrence occ, var_heap) = readPtr fv_info_ptr var_heap
+				= var_heap <:= (fv_info_ptr, VI_Occurrence { occ & occ_bind = OB_OpenLet bind_src })
+
+	refMark free_vars sel (Case {case_expr,case_guards,case_default}) var_heap
+		= refMarkOfCase free_vars sel case_expr case_guards case_default var_heap
+	refMark free_vars sel (Selection _ expr selectors) var_heap
+		= refMark free_vars (field_number selectors) expr var_heap
+	where
+		field_number [ RecordSelection _ field_nr : _ ]
+			= field_nr	
+		field_number _
+			= NotASelector	
+	refMark free_vars sel (Update expr1 selectors expr2) var_heap
+		= refMark free_vars NotASelector expr2 (refMark free_vars NotASelector expr1 var_heap)
+	refMark free_vars sel (RecordUpdate cons_symbol expression expressions) var_heap
+		= ref_mark_of_record_expression free_vars expression expressions var_heap
+	where
+		ref_mark_of_record_expression free_vars (Var var) fields var_heap
+			= ref_mark_of_fields 0 free_vars fields var var_heap
+		ref_mark_of_record_expression free_vars expression fields var_heap
+			# var_heap = refMark free_vars NotASelector expression var_heap
+			= foldSt (ref_mark_of_field free_vars) fields var_heap
+	
+		ref_mark_of_fields field_nr free_vars [] var var_heap
+			= var_heap
+		ref_mark_of_fields field_nr free_vars [{bind_src = EE} : fields] var var_heap
+			# var_heap = refMark free_vars field_nr var var_heap
+			= ref_mark_of_fields (inc field_nr) free_vars fields var var_heap
+		ref_mark_of_fields field_nr free_vars [{bind_src} : fields] var var_heap
+			# var_heap = refMark free_vars NotASelector bind_src var_heap
+			= ref_mark_of_fields (inc field_nr) free_vars fields var var_heap
+
+		ref_mark_of_field free_vars {bind_src} var_heap
+			= refMark free_vars NotASelector bind_src var_heap
+
+	refMark free_vars sel (TupleSelect _ arg_nr expr) var_heap
+		= refMark free_vars arg_nr expr var_heap
+	refMark free_vars sel (MatchExpr _ _ expr) var_heap
+		= refMark free_vars sel expr var_heap
+	refMark free_vars sel EE var_heap
+		= var_heap
+	refMark _ _ _ var_heap
+		= var_heap
+
+
+isUsed RC_Unused	= False				
+isUsed _			= True				
+
+instance refMark Bind a b | refMark a
+where
+	refMark free_vars sel {bind_src} var_heap
+		= refMark free_vars NotASelector bind_src var_heap
+
+instance refMark Selection
+where
+	refMark free_vars _ (ArraySelection _ _ index_expr) var_heap
+		= refMark free_vars NotASelector index_expr var_heap
+
+collectUsedFreeVariables free_vars var_heap
+	= foldSt collectUsedVariables free_vars ([], var_heap)
+
+collectUsedVariables free_vars (collected_vars, var_heap)
+	= foldSt collect_used_var free_vars (collected_vars, var_heap)
+where
+	collect_used_var fv=:{fv_info_ptr} (collected_vars, var_heap)
+		# (VI_Occurrence occ=:{occ_ref_count}, var_heap) = readPtr fv_info_ptr var_heap
+		| isUsed occ_ref_count
+			= ([ fv : collected_vars ], var_heap)
+			= (collected_vars, var_heap)
+
+collectPatternsVariables pattern_vars
+	= collect_used_vars pattern_vars 0 []
+where
+	collect_used_vars [ fv=:{fv_count} : pattern_vars ] arg_nr collected_vars
+		| fv_count > 0
+			= collect_used_vars pattern_vars (inc arg_nr) [ (fv, arg_nr) : collected_vars ]
+			= collect_used_vars pattern_vars (inc arg_nr) collected_vars
+	collect_used_vars [] arg_nr collected_vars
+		= collected_vars
+
+markVariables variables var_heap
+	= foldSt markVariable variables var_heap
+
+markVariable {fv_name,fv_info_ptr} var_heap
+	# (VI_Occurrence var_occ=:{occ_ref_count}, var_heap) = readPtr fv_info_ptr var_heap
+	= case occ_ref_count of
+		RC_Unused
+			-> var_heap
+		RC_Used {rcu_multiply,rcu_uniquely,rcu_selectively}
+			# rcu_multiply = collectAllSelections rcu_selectively (rcu_uniquely ++ rcu_multiply)
+			-> var_heap <:= (fv_info_ptr, VI_Occurrence { var_occ &
+							occ_ref_count = RC_Used {rcu_multiply = rcu_multiply, rcu_uniquely = [], rcu_selectively = [] }})
+//				---> ("markVariable", fv_name, rcu_multiply)
+
+collectLocalLetVars free_vars var_heap
+	= foldSt (foldSt collect_local_let_var) free_vars ([], var_heap)
+where
+	collect_local_let_var fv=:{fv_info_ptr} (collected_vars, var_heap)
+		# (VI_Occurrence var_occ, var_heap) = readPtr fv_info_ptr var_heap
+		= case var_occ.occ_bind of
+			OB_OpenLet _
+				-> ([ fv_info_ptr : collected_vars], var_heap)
+			_
+				-> (collected_vars, var_heap)
+		
+collectUsedLetVars local_vars (used_vars, var_heap)
+	= foldSt collect_local_let_var local_vars (used_vars, var_heap)
+where
+	collect_local_let_var fv_info_ptr (used_vars, var_heap)
+		# (VI_Occurrence var_occ, var_heap) = readPtr fv_info_ptr var_heap
+		= case var_occ.occ_bind of
+			OB_LockedLet let_expr
+				-> ([ fv_info_ptr : used_vars], var_heap <:= (fv_info_ptr, VI_Occurrence { var_occ & occ_bind = OB_OpenLet let_expr }))
+			_
+				-> (used_vars, var_heap)
+
+setUsedLetVars used_vars var_heap
+	= foldSt set_used_let_var used_vars var_heap
+where
+	set_used_let_var fv_info_ptr var_heap
+		# (VI_Occurrence var_occ, var_heap) = readPtr fv_info_ptr var_heap
+		= case var_occ.occ_bind of
+			OB_OpenLet let_expr
+				-> var_heap <:= (fv_info_ptr, VI_Occurrence { var_occ & occ_bind = OB_LockedLet let_expr })
+			_
+				-> var_heap
+
+refMarkOfCase free_vars sel expr (AlgebraicPatterns type patterns) defaul var_heap
+	= ref_mark_of_algebraic_case free_vars sel expr patterns defaul var_heap
+where
+	ref_mark_of_algebraic_case free_vars sel (Var {var_name,var_info_ptr,var_expr_ptr}) patterns defaul var_heap
+		# (VI_Occurrence var_occ=:{occ_bind,occ_ref_count}, var_heap) = readPtr var_info_ptr var_heap
+		= case occ_bind of
+			OB_Empty
+		  		# (local_lets, var_heap) = collectLocalLetVars free_vars var_heap
+				-> ref_mark_of_algebraic_case_with_variable_pattern var_info_ptr var_expr_ptr var_occ free_vars sel local_lets patterns defaul var_heap
+			_
+				-> ref_mark_of_algebraic_case_with_non_variable_pattern free_vars sel expr patterns defaul var_heap
+	ref_mark_of_algebraic_case free_vars sel expr patterns defaul var_heap
+		= ref_mark_of_algebraic_case_with_non_variable_pattern free_vars sel expr patterns defaul var_heap
+
+	ref_mark_of_algebraic_case_with_variable_pattern var_info_ptr var_expr_ptr {occ_ref_count = RC_Unused}
+					free_vars sel local_lets patterns case_default var_heap
+		# (_, pattern_depth, used_lets, var_heap)
+				= foldSt (ref_mark_of_algebraic_pattern free_vars sel (Yes var_info_ptr) local_lets) patterns (False, 0, [], var_heap)		
+		  var_heap = refMarkOfDefault False pattern_depth free_vars sel case_default used_lets var_heap
+		  (VI_Occurrence var_occ, var_heap) = readPtr var_info_ptr var_heap
+		= case var_occ.occ_ref_count of
+				RC_Unused
+					-> var_heap <:= (var_info_ptr, VI_Occurrence { var_occ &
+								occ_ref_count = RC_Used {	rcu_multiply = [], rcu_uniquely = [var_expr_ptr], rcu_selectively = [] }})
+				RC_Used rcu
+					-> var_heap <:= (var_info_ptr, VI_Occurrence { var_occ &
+								occ_ref_count = RC_Used { rcu & rcu_uniquely = [var_expr_ptr : rcu.rcu_uniquely] }})					
+	ref_mark_of_algebraic_case_with_variable_pattern var_info_ptr var_expr_ptr var_occ=:{occ_ref_count = RC_Used {rcu_multiply,rcu_uniquely,rcu_selectively}}
+					free_vars sel local_lets patterns case_default var_heap
+		# var_occ = { var_occ & occ_ref_count = RC_Used { rcu_multiply = collectAllSelections rcu_selectively (rcu_uniquely ++ [var_expr_ptr : rcu_multiply]),
+														  rcu_uniquely = [], rcu_selectively = [] }}
+		  var_heap = var_heap <:= (var_info_ptr, VI_Occurrence var_occ )
+		  (with_pattern_bindings, pattern_depth, used_lets, var_heap)
+			= foldSt (ref_mark_of_algebraic_pattern free_vars sel (Yes var_info_ptr) local_lets) patterns (False, 0, [], var_heap)		
+		= refMarkOfDefault False pattern_depth free_vars sel case_default used_lets var_heap
+
+	ref_mark_of_algebraic_case_with_non_variable_pattern free_vars sel expr patterns case_default var_heap
+		# var_heap = refMark free_vars NotASelector expr var_heap
+		  (local_lets, var_heap) = collectLocalLetVars free_vars var_heap
+		  (with_pattern_bindings, pattern_depth, used_lets, var_heap)
+			= foldSt (ref_mark_of_algebraic_pattern free_vars sel No local_lets) patterns (False, 0, [], var_heap)		
+		= refMarkOfDefault with_pattern_bindings pattern_depth free_vars sel case_default used_lets var_heap
+
+	ref_mark_of_algebraic_pattern free_vars sel opt_pattern_var local_lets {ap_vars,ap_expr}
+					(with_pattern_bindings, pattern_depth, used_lets, var_heap) 
+		# pattern_depth = inc pattern_depth
+		  var_heap = saveOccurrences free_vars var_heap
+		  used_pattern_vars = collectPatternsVariables ap_vars
+		  var_heap = bind_optional_pattern_variable opt_pattern_var used_pattern_vars var_heap
+		  var_heap = refMark [ [ fv \\ (fv,_) <- used_pattern_vars ] : free_vars ] sel ap_expr var_heap
+		  var_heap = restore_bindinding_of_pattern_variable opt_pattern_var used_pattern_vars var_heap
+		  (used_lets, var_heap) = collectUsedLetVars local_lets (used_lets, var_heap)
+		= (with_pattern_bindings || not (isEmpty used_pattern_vars), pattern_depth, used_lets, var_heap)
+	
+	bind_optional_pattern_variable _ [] var_heap
+		= var_heap
+	bind_optional_pattern_variable (Yes var_info_ptr) used_pattern_vars var_heap
+		# (VI_Occurrence var_occ=:{occ_bind}, var_heap) = readPtr var_info_ptr var_heap
+		= var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_bind = OB_Pattern used_pattern_vars occ_bind })
+	bind_optional_pattern_variable _ used_pattern_vars var_heap
+		= var_heap
+
+	restore_bindinding_of_pattern_variable _ [] var_heap
+		= var_heap
+	restore_bindinding_of_pattern_variable (Yes var_info_ptr) used_pattern_vars var_heap
+		# (VI_Occurrence var_occ=:{occ_bind=OB_Pattern used_pattern_vars occ_bind}, var_heap) = readPtr var_info_ptr var_heap
+		= var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_bind = occ_bind})
+	restore_bindinding_of_pattern_variable _ used_pattern_vars var_heap
+		= var_heap
+	
+refMarkOfCase free_vars sel expr (BasicPatterns type patterns) defaul var_heap
+	# var_heap = refMark free_vars NotASelector expr var_heap
+	  (local_lets, var_heap) = collectLocalLetVars free_vars var_heap
+	  (pattern_depth, used_lets, var_heap) = foldSt (ref_mark_of_basic_pattern free_vars sel local_lets) patterns (0, [], var_heap)
+	= refMarkOfDefault False pattern_depth free_vars sel defaul used_lets var_heap
+where
+	ref_mark_of_basic_pattern free_vars sel local_lets {bp_expr} (pattern_depth, used_lets, var_heap)
+		# pattern_depth = inc pattern_depth
+		  var_heap = saveOccurrences free_vars var_heap
+		  var_heap = refMark free_vars sel bp_expr var_heap
+		  (used_lets, var_heap) = collectUsedLetVars local_lets (used_lets, var_heap)
+		= (pattern_depth, used_lets, var_heap)
+
+refMarkOfCase free_vars sel expr (DynamicPatterns patterns) defaul var_heap
+	# var_heap = saveOccurrences free_vars var_heap
+	  var_heap = refMark free_vars NotASelector expr var_heap
+	  (used_free_vars, var_heap) = collectUsedFreeVariables free_vars var_heap
+	  var_heap = parCombine free_vars var_heap
+	  (local_lets, var_heap) = collectLocalLetVars free_vars var_heap
+	  (pattern_depth, used_lets, var_heap) = foldSt (ref_mark_of_dynamic_pattern free_vars sel local_lets) patterns (0, [], var_heap)
+	= refMarkOfDefault True pattern_depth free_vars sel defaul used_lets var_heap
+where
+	ref_mark_of_dynamic_pattern free_vars sel local_lets {dp_var, dp_rhs} (pattern_depth, used_lets, var_heap)
+		# pattern_depth = inc pattern_depth
+		  var_heap = saveOccurrences free_vars var_heap
+		  used_pattern_vars = collectPatternsVariables [dp_var]
+		  var_heap = refMark [ [ fv \\ (fv,_) <- used_pattern_vars ] : free_vars ] sel dp_rhs var_heap
+		  (used_lets, var_heap) = collectUsedLetVars local_lets (used_lets, var_heap)
+		= (pattern_depth, used_lets, var_heap)
+
+refMarkOfDefault do_par_combine pattern_depth free_vars sel (Yes expr) used_lets var_heap
+	# pattern_depth = inc pattern_depth
+	  var_heap = saveOccurrences free_vars var_heap
+	  var_heap = refMark free_vars sel expr var_heap
+	  var_heap = setUsedLetVars used_lets var_heap
+	= caseCombine do_par_combine free_vars var_heap pattern_depth
+refMarkOfDefault do_par_combine pattern_depth free_vars sel No used_lets var_heap
+	# var_heap = setUsedLetVars used_lets var_heap
+	= caseCombine do_par_combine free_vars var_heap pattern_depth
+
+parCombine free_vars var_heap
+	= foldSt (foldSt (par_combine)) free_vars var_heap
+where
+	par_combine {fv_info_ptr} var_heap
+		#! old_info = sreadPtr fv_info_ptr var_heap
+		# (VI_Occurrence old_occ=:{occ_ref_count,occ_previous=[prev_ref_count:prev_counts]}) = old_info
+		= var_heap <:= (fv_info_ptr, VI_Occurrence { old_occ &
+				occ_ref_count = parCombineRefCount occ_ref_count prev_ref_count , occ_previous = prev_counts })
+
+
+caseCombine do_par_combine free_vars var_heap depth
+	= foldSt (foldSt (case_combine do_par_combine depth)) free_vars var_heap
+where
+	case_combine do_par_combine depth {fv_name,fv_info_ptr} var_heap
+		#! old_info = sreadPtr fv_info_ptr var_heap
+		# (VI_Occurrence old_occ=:{occ_ref_count,occ_previous}) = old_info
+		  (occ_ref_count, occ_previous) = case_combine_ref_counts do_par_combine occ_ref_count occ_previous (dec depth)
+		= var_heap <:= (fv_info_ptr, VI_Occurrence { old_occ & occ_ref_count = occ_ref_count , occ_previous = occ_previous })
+//				---> ("case_combine", fv_name, occ_ref_count)
+
+	case_combine_ref_counts do_par_combine comb_ref_count [occ_ref_count:occ_previous] 0
+		| do_par_combine
+			# new_comb_ref_count = parCombineRefCount comb_ref_count occ_ref_count
+			= (new_comb_ref_count, occ_previous)
+	//				---> ("parCombineRefCount", comb_ref_count, occ_ref_count, new_comb_ref_count)
+			# new_comb_ref_count = seqCombineRefCount comb_ref_count occ_ref_count
+			= (new_comb_ref_count, occ_previous)
+	//				---> ("seqCombineRefCount", comb_ref_count, occ_ref_count, new_comb_ref_count)
+	case_combine_ref_counts do_par_combine comb_ref_count [occ_ref_count:occ_previous] depth
+		# new_comb_ref_count = case_combine_ref_count comb_ref_count occ_ref_count
+		= case_combine_ref_counts do_par_combine new_comb_ref_count occ_previous (dec depth)
+//				---> ("case_combine_ref_count", comb_ref_count, occ_ref_count, new_comb_ref_count)
+
+	case_combine_ref_count RC_Unused ref_count
+		= ref_count
+	case_combine_ref_count ref_count RC_Unused
+		= ref_count
+	case_combine_ref_count (RC_Used {rcu_multiply,rcu_selectively,rcu_uniquely}) (RC_Used ref_count2)
+		= RC_Used { rcu_uniquely = rcu_uniquely ++ ref_count2.rcu_uniquely, rcu_multiply = rcu_multiply ++ ref_count2.rcu_multiply,
+					rcu_selectively = case_combine_of_selections rcu_selectively ref_count2.rcu_selectively }
+	where
+		case_combine_of_selections [] sels
+			= sels
+		case_combine_of_selections sels []
+			= sels
+		case_combine_of_selections sl1=:[sel1=:{ su_field, su_multiply, su_uniquely } : sels1] sl2=:[sel2 : sels2]
+			| su_field == sel2.su_field
+				# sel1 = { sel1 & su_multiply = sel2.su_multiply ++ su_multiply, su_uniquely =  sel2.su_uniquely ++ su_uniquely }
+				= [ sel1 : case_combine_of_selections sels1 sels2 ]
+			| su_field < sel2.su_field
+				= [sel1 : case_combine_of_selections sels1 sl2 ]
+				= [sel2 : case_combine_of_selections sl1 sels2 ]
+
+parCombineRefCount RC_Unused ref_count
+	= ref_count
+parCombineRefCount ref_count RC_Unused
+	= ref_count
+parCombineRefCount (RC_Used {rcu_multiply,rcu_selectively,rcu_uniquely}) (RC_Used ref_count2)
+	# rcu_multiply = ref_count2.rcu_uniquely ++ ref_count2.rcu_multiply ++ rcu_uniquely ++ rcu_multiply
+	| isEmpty rcu_multiply
+		=  RC_Used { rcu_multiply = [], rcu_uniquely = [], rcu_selectively = par_combine_selections rcu_selectively ref_count2.rcu_selectively }
+		# rcu_multiply = collectAllSelections ref_count2.rcu_selectively (collectAllSelections rcu_selectively rcu_multiply)
+		= RC_Used { rcu_multiply = rcu_multiply, rcu_uniquely = [], rcu_selectively = [] }
+where	
+	par_combine_selections [] sels
+		= sels
+	par_combine_selections sels []
+		= sels
+	par_combine_selections sl1=:[sel1=:{ su_field, su_multiply, su_uniquely } : sels1] sl2=:[sel2 : sels2]
+		| su_field == sel2.su_field
+			# sel1 = { sel1 & su_multiply = sel2.su_multiply ++ su_multiply ++ sel2.su_uniquely ++ su_uniquely, su_uniquely = [] }
+			= [ sel1 : par_combine_selections sels1 sels2 ]
+		| su_field < sel2.su_field
+			= [sel1 : par_combine_selections sels1 sl2 ]
+			= [sel2 : par_combine_selections sl1 sels2 ]
+
+seqCombineRefCount RC_Unused ref_count
+	= ref_count
+seqCombineRefCount ref_count RC_Unused
+	= ref_count
+seqCombineRefCount (RC_Used sec_ref) (RC_Used prim_ref)
+	# rcu_multiply = prim_ref.rcu_uniquely ++ prim_ref.rcu_multiply ++ sec_ref.rcu_multiply
+	| isEmpty rcu_multiply
+		| isEmpty sec_ref.rcu_uniquely /* so sec_ref contains selections only */
+			# rcu_selectively = seq_combine_selections sec_ref.rcu_selectively prim_ref.rcu_selectively /* rcu_selectively can't be empty */
+			= RC_Used { rcu_uniquely = [], rcu_multiply = [], rcu_selectively = rcu_selectively }
+			# prim_selections = make_primary_selections_on_unique prim_ref.rcu_selectively
+			  rcu_selectively = seq_combine_selections sec_ref.rcu_selectively prim_selections
+			= RC_Used { sec_ref & rcu_selectively = rcu_selectively }
+		= RC_Used { sec_ref & rcu_multiply = collectAllSelections prim_ref.rcu_selectively rcu_multiply }
+	where	
+		seq_combine_selections [] sels
+			= sels
+		seq_combine_selections sels []
+			= sels
+		seq_combine_selections sl1=:[sel1=:{ su_field, su_multiply, su_uniquely } : sels1] sl2=:[sel2 : sels2]
+			| su_field == sel2.su_field
+				# sel1 = { sel1 & su_multiply = sel2.su_multiply ++ sel2.su_uniquely ++ su_multiply }
+				= [ sel1 : seq_combine_selections sels1 sels2 ]
+			| su_field < sel2.su_field
+				= [sel1 : seq_combine_selections sels1 sl2 ]
+				= [sel2 : seq_combine_selections sl1 sels2 ]
+
+		make_primary_selections_on_unique [sel=:{su_multiply, su_uniquely } : sels]
+			= [ { sel & su_multiply = su_uniquely ++ su_multiply, su_uniquely = [] } : make_primary_selections_on_unique sels ]
+		make_primary_selections_on_unique []
+			= []
+
+makeSharedReferencesNonUnique :: ![Int] !u:{# FunDef} !*Coercions !w:{! Type} !{# CommonDefs } !*VarHeap !*ExpressionHeap !*ErrorAdmin
+	-> (!u:{# FunDef}, !*Coercions, !w:{! Type}, !*VarHeap, !*ExpressionHeap, !*ErrorAdmin)
+makeSharedReferencesNonUnique [] fun_defs coercion_env subst defs var_heap expr_heap  error
+	= (fun_defs, coercion_env, subst, var_heap, expr_heap, error)
+makeSharedReferencesNonUnique [fun : funs] fun_defs coercion_env subst defs var_heap expr_heap error
+	#! fun_def = fun_defs.[fun] 
+	# (coercion_env, subst, var_heap, expr_heap, error)
+		= make_shared_references_of_funcion_non_unique fun_def coercion_env subst defs var_heap expr_heap error
+	= makeSharedReferencesNonUnique funs fun_defs coercion_env subst defs var_heap expr_heap error
+where
+	make_shared_references_of_funcion_non_unique {fun_symb, fun_pos, fun_body = TransformedBody {tb_args,tb_rhs},fun_info={fi_local_vars}}
+			coercion_env subst defs var_heap expr_heap error
+	# variables = tb_args ++ fi_local_vars
+	  (subst, var_heap, expr_heap) = clear_occurrences variables subst defs var_heap expr_heap
+	  var_heap = refMark [tb_args] NotASelector tb_rhs var_heap
+	  position = newPosition fun_symb fun_pos
+	  (coercion_env, var_heap, expr_heap, error) = make_shared_vars_non_unique variables coercion_env var_heap expr_heap
+	  		(setErrorAdmin position error)
+	= (coercion_env, subst, var_heap, expr_heap, error)
+	
+	where
+		clear_occurrences vars subst defs var_heap expr_heap
+			= foldSt (initial_occurrence defs) vars (subst, var_heap, expr_heap)
+		where
+			initial_occurrence defs {fv_name,fv_info_ptr} (subst, var_heap, expr_heap) 
+				# (VI_Type {at_type,at_attribute}, var_heap) = readPtr fv_info_ptr var_heap
+				= case at_type of
+					TempV tv_number
+						#! is_oberving = hasObservingType subst.[tv_number] defs
+						-> (subst, var_heap <:= (fv_info_ptr,
+								VI_Occurrence { occ_ref_count = RC_Unused, occ_previous = [],
+									occ_observing = is_oberving, occ_bind = OB_Empty }), expr_heap)
+					_
+						-> (subst, var_heap <:= (fv_info_ptr,
+								VI_Occurrence { occ_ref_count = RC_Unused, occ_previous = [],
+									occ_observing = False,  occ_bind = OB_Empty }), expr_heap)
+					
+
+		make_shared_vars_non_unique vars coercion_env var_heap expr_heap error
+			= foldl make_shared_var_non_unique (coercion_env, var_heap, expr_heap, error) vars
+
+		make_shared_var_non_unique (coercion_env, var_heap, expr_heap, error)  fv=:{fv_name,fv_info_ptr}
+			#! var_info = sreadPtr fv_info_ptr var_heap
+			# (VI_Occurrence occ) = var_info
+			= 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)
+//					  (coercion_env, expr_heap, error) = foldSt (make_selection_non_unique fv) rcu_selectively (coercion_env, expr_heap, error)  
+					-> (coercion_env, var_heap, expr_heap, error)
+				_
+					-> (coercion_env, var_heap, expr_heap, error)
+
+		make_shared_occurrences_non_unique fv multiply (coercion_env, expr_heap, error)
+			= foldSt (make_shared_occurrence_non_unique fv) multiply (coercion_env, expr_heap, error) 
+		
+		make_shared_occurrence_non_unique free_var var_expr_ptr (coercion_env, expr_heap, error) 
+			| isNilPtr var_expr_ptr
+				= (coercion_env, expr_heap, error)
+				#! expr_info = sreadPtr var_expr_ptr expr_heap
+				# (EI_Attribute sa_attr_nr) = expr_info
+				# (succ, coercion_env) = tryToMakeNonUnique sa_attr_nr coercion_env
+				| succ
+//						 ---> ("make_shared_occurrence_non_unique", free_var)
+					= (coercion_env, expr_heap, error)
+					= (coercion_env, expr_heap, uniquenessError { cp_expression = FreeVar free_var} " demanded attribute cannot be offered by shared object" error)
+
+		make_selection_non_unique fv {su_multiply} cee
+			= make_shared_occurrences_non_unique fv su_multiply cee
+
+hasObservingType TE defs
+	= True
+hasObservingType (TB basic_type) defs
+	= True
+hasObservingType (TempV var_number) defs 
+	= True
+hasObservingType (TA {type_index = {glob_object,glob_module}} type_args) defs
+	# {td_properties} = defs.[glob_module].com_type_defs.[glob_object]
+	= True
+//	= foldSt (\ {at_type} ok -> ok && hasObservingType at_type defs) type_args (td_properties bitand cIsHyperStrict <> 0)
+hasObservingType type defs
+	= False
+
+					
+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
+
+
+
+instance <<< Ptr v
+where
+	(<<<) file ptr = file <<< '[' <<< ptrToInt ptr <<< ']'
+
+
+instance <<< FreeVar
+where
+	(<<<) file {fv_name,fv_info_ptr} = file <<< fv_name <<< fv_info_ptr
+
+
+import Debug
+
+show
+	=	debugShowWithOptions [DebugMaxChars 80, DebugMaxDepth 5]
+
+instance <<< VarInfo
+where
+	(<<<) file vi
+		 = file <<< show vi
+
+