From 98d14c13887046648073ab8d387505ae023370d2 Mon Sep 17 00:00:00 2001
From: johnvg
Date: Fri, 15 Jun 2012 11:44:09 +0000
Subject: in substitute use original type (instead of copy) if possible, to
 reduce memory usage of the compiler

git-svn-id: https://svn.cs.ru.nl/repos/clean-compiler/trunk@2094 1f8540f1-abd5-4d5b-9d24-4c5ce8603e2d
---
 frontend/check.icl        |  15 ++--
 frontend/expand_types.dcl |   5 +-
 frontend/expand_types.icl | 208 ++++++++++++++++++++++++++++------------------
 frontend/overloading.icl  |  12 +--
 frontend/trans.icl        |  52 ++++++------
 frontend/typesupport.icl  |  16 ++--
 6 files changed, 179 insertions(+), 129 deletions(-)

diff --git a/frontend/check.icl b/frontend/check.icl
index a17ad19..6ebb935 100644
--- a/frontend/check.icl
+++ b/frontend/check.icl
@@ -338,15 +338,14 @@ instantiateTypes old_type_vars old_attr_vars types type_contexts attr_env {ss_en
 	  (new_attr_vars, th_attrs) = foldSt build_attr_var_subst ss_attrs ([], th_attrs)
 
 	  type_heaps = foldSt build_type_subst ss_environ { type_heaps & th_vars = th_vars, th_attrs = th_attrs }
-	  (new_ss_context, type_heaps) = substitute ss_context type_heaps
+	  (_, new_ss_context, type_heaps) = substitute ss_context type_heaps
 
 	  (inst_vars, th_vars)			= foldSt determine_free_var old_type_vars (new_type_vars, type_heaps.th_vars) 
 	  (inst_attr_vars, th_attrs)	= foldSt build_attr_var_subst old_attr_vars (new_attr_vars, type_heaps.th_attrs)
 
 	  (inst_types, (ok2, type_heaps))	= mapSt substitue_arg_type types (True, { type_heaps & th_vars = th_vars, th_attrs = th_attrs })
-//	  (ok2, inst_types, type_heaps)		= substitute types { type_heaps & th_vars = th_vars, th_attrs = th_attrs }
-	  (inst_contexts, type_heaps)	= substitute type_contexts type_heaps
-	  (inst_attr_env, type_heaps)	= substitute attr_env type_heaps
+	  (_, inst_contexts, type_heaps)	= substitute type_contexts type_heaps
+	  (_, inst_attr_env, type_heaps)	= substitute attr_env type_heaps
 	  (special_subst_list, th_vars) 	= mapSt adjust_special_subst special_subst_list type_heaps.th_vars
 	= (inst_vars, inst_attr_vars, inst_types, new_ss_context ++ inst_contexts, inst_attr_env, special_subst_list, { type_heaps & th_vars = th_vars }, error)
 where
@@ -361,7 +360,7 @@ where
 				-> (free_vars, type_var_heap)
 
 	build_type_subst {bind_src,bind_dst} type_heaps
-		# (bind_src, type_heaps) = substitute bind_src type_heaps
+		# (_, bind_src, type_heaps) = substitute bind_src type_heaps
 // RWS ...
 /*
 	FIXME: this is a patch for the following incorrect function type (in a dcl module)
@@ -382,10 +381,10 @@ where
 
 	substitue_arg_type at=:{at_type = TFA type_vars type} (was_ok, type_heaps)
 		# (fresh_type_vars, type_heaps) = foldSt build_avar_subst type_vars ([], type_heaps)
-		  (new_at, type_heaps) = substitute {at & at_type = type} type_heaps
+		  (_, new_at, type_heaps) = substitute {at & at_type = type} type_heaps
 		= ({ new_at & at_type = TFA fresh_type_vars new_at.at_type}, (was_ok, type_heaps))
 	substitue_arg_type type (was_ok, type_heaps)
-		# (type, type_heaps) = substitute type type_heaps
+		# (_, type, type_heaps) = substitute type type_heaps
 		= (type, (was_ok, type_heaps))
 		
 	build_var_subst var (free_vars, type_var_heap)
@@ -2267,7 +2266,7 @@ check_module2 mod_ident mod_modification_time mod_imported_objects mod_imports m
 
 	  (instance_types, icl_common, dcl_modules, hp_var_heap, hp_type_heaps, cs)
 	  		= checkIclInstances main_dcl_module_n icl_common dcl_modules hp_var_heap hp_type_heaps cs
-	  		  	
+
 	  heaps = { heaps & hp_type_heaps = hp_type_heaps, hp_var_heap = hp_var_heap }
 
 	  e_info = { ef_type_defs = icl_common.com_type_defs, ef_selector_defs = icl_common.com_selector_defs, ef_class_defs = icl_common.com_class_defs, 
diff --git a/frontend/expand_types.dcl b/frontend/expand_types.dcl
index ae7ac5e..fca50e8 100644
--- a/frontend/expand_types.dcl
+++ b/frontend/expand_types.dcl
@@ -33,11 +33,10 @@ class expandSynTypes a :: !Int !{#CommonDefs} !a !*ExpandTypeState -> (!Bool,!a,
 
 instance expandSynTypes (a,b) | expandSynTypes a & expandSynTypes b special a=[AType],b=AType
 
-class substitute a :: !a !*TypeHeaps -> (!a, !*TypeHeaps)
+class substitute a :: !a !*TypeHeaps -> (!Bool, !a, !*TypeHeaps)
 
 instance substitute Type,AType,TypeContext,AttrInequality,CaseType
-instance substitute [a] | substitute a special a=AType; a=AttrInequality; a=TypeContext
-instance substitute (a,b) | substitute a & substitute b special a=[AType],b=AType
+instance substitute [a] | substitute a special a=AType; a=TypeContext; a=AttrInequality
 
 class removeAnnotations a :: !a  -> (!Bool, !a)
 
diff --git a/frontend/expand_types.icl b/frontend/expand_types.icl
index a8e4cc4..f9591ec 100644
--- a/frontend/expand_types.icl
+++ b/frontend/expand_types.icl
@@ -261,10 +261,12 @@ where
 				= type_heaps
 	
 			substitute_rhs rem_annots rhs_type type_heaps
-				| (rem_annots bitand RemoveAnnotationsMask)<>0
+				| rem_annots bitand RemoveAnnotationsMask<>0
 					# (_, rhs_type) = removeAnnotations rhs_type
-				  	= substitute rhs_type type_heaps
-				  	= substitute rhs_type type_heaps
+				  	# (_,type,heaps) = substitute rhs_type type_heaps
+				  	= (type,heaps)
+				  	# (_,type,heaps) = substitute rhs_type type_heaps
+				  	= (type,heaps)
 
 	collect_imported_constructors :: !{#.CommonDefs} !.Int !.TypeRhs !*ExpandTypeState -> .ExpandTypeState
 	collect_imported_constructors common_defs mod_index (RecordType {rt_constructor}) ets=:{ets_collected_conses,ets_var_heap}
@@ -290,119 +292,167 @@ where
 		has_been_collected (VI_ExpandedType _)	= True
 		has_been_collected _					= False
 
-class substitute a :: !a !*TypeHeaps -> (!a, !*TypeHeaps)
+class substitute a :: !a !*TypeHeaps -> (!Bool, !a, !*TypeHeaps)
 
 instance substitute AType
 where
 	substitute atype=:{at_attribute,at_type} heaps
-		# ((at_attribute,at_type), heaps)  = substitute (at_attribute,at_type) heaps
-		= ({ atype & at_attribute = at_attribute, at_type = at_type }, heaps)
+		# (changed_attribute, at_attribute_r, heaps) = substitute at_attribute heaps
+		# (changed_type, at_type_r, heaps) = substitute at_type heaps
+		| changed_attribute
+			| changed_type
+				= (True, {at_attribute = at_attribute_r, at_type = at_type_r}, heaps)
+				= (True, {atype & at_attribute = at_attribute_r}, heaps)
+			| changed_type
+				= (True, {atype & at_type = at_type_r}, heaps)
+				= (False, atype, heaps)
 
 instance substitute TypeAttribute
 where
-	substitute (TA_Var {av_ident, av_info_ptr}) heaps=:{th_attrs}
-		#! av_info = sreadPtr av_info_ptr th_attrs
-		= case av_info of
+	substitute (TA_Var {av_info_ptr}) heaps=:{th_attrs}
+		= case sreadPtr av_info_ptr th_attrs of
 			AVI_Attr attr
-				-> (attr, heaps)
+				-> (True, attr, heaps)
 			_
-				-> (TA_Multi, heaps)
+				-> (True, TA_Multi, heaps)
 	substitute (TA_RootVar {av_info_ptr}) heaps=:{th_attrs}
-		#! av_info = sreadPtr av_info_ptr th_attrs
-		= case av_info of
+		= case sreadPtr av_info_ptr th_attrs of
 			AVI_Attr attr
-				-> (attr, heaps)
+				-> (True, attr, heaps)
 			_
-				-> (TA_Multi, heaps)
+				-> (True, TA_Multi, heaps)
 	substitute TA_None heaps
-		= (TA_Multi, heaps)
+		= (True, TA_Multi, heaps)
 	substitute attr heaps
-		= (attr, heaps)
-
-instance substitute (a,b) | substitute a & substitute b
-where
-	substitute (x,y) heaps
-		# (x, heaps) = substitute x heaps
-		  (y, heaps) = substitute y heaps
-		= ((x,y), heaps)
-	
-instance substitute [a] | substitute a
-where
-	substitute [] heaps
-		= ( [], heaps)
-	substitute [t:ts] heaps
-		# (t, heaps) = substitute t heaps
-		  ( ts, heaps) = substitute ts heaps
-		= ([t:ts], heaps)
-
-instance substitute TypeContext
-where
-	substitute tc=:{tc_types} heaps
-		# (tc_types, heaps) = substitute tc_types heaps
-		= ({ tc & tc_types = tc_types }, heaps)
+		= (False, attr, heaps)
 
 instance substitute Type
 where
 	substitute tv=:(TV {tv_info_ptr}) heaps=:{th_vars}
 		# (tv_info, th_vars) = readPtr tv_info_ptr th_vars
-		  heaps = {heaps & th_vars = th_vars}
+		  heaps & th_vars = th_vars
 		= case tv_info of
 			TVI_Type type
-				-> (type, heaps)
+				-> (True, type, heaps)
 			_
-				-> (tv, heaps)
-	substitute (arg_type --> res_type) heaps
-		# ((arg_type, res_type), heaps) = substitute (arg_type, res_type) heaps
-		= (arg_type --> res_type, heaps)
-	substitute (TArrow1 arg_type) heaps
-		# (arg_type, heaps) = substitute arg_type heaps
-		= (TArrow1 arg_type, heaps)
-	substitute (TA cons_id cons_args) heaps
-		# (cons_args, heaps) = substitute cons_args heaps
-		= (TA cons_id cons_args,  heaps)
-	substitute (TAS cons_id cons_args strictness) heaps
-		# (cons_args, heaps) = substitute cons_args heaps
-		= (TAS cons_id cons_args strictness,  heaps)
-	substitute (CV type_var :@: types) heaps=:{th_vars}
+				-> (False, tv, heaps)
+	substitute type=:(arg_type --> res_type) heaps
+		# (changed_arg_type, arg_type_r, heaps) = substitute arg_type heaps
+		# (changed_res_type, res_type_r, heaps) = substitute res_type heaps
+		| changed_arg_type
+			| changed_res_type
+				= (True, arg_type_r --> res_type_r, heaps)
+				= (True, arg_type_r --> res_type, heaps)
+			| changed_res_type
+				= (True, arg_type --> res_type_r, heaps)
+				= (False, type, heaps)
+	substitute type=:(TA cons_id cons_args) heaps
+		# (changed, cons_args_r, heaps) = substitute cons_args heaps
+		| changed
+			= (True, TA cons_id cons_args_r, heaps)
+			= (False, type, heaps)
+	substitute type=:(TAS cons_id cons_args strictness) heaps
+		# (changed, cons_args_r, heaps) = substitute cons_args heaps
+		| changed
+			= (True, TAS cons_id cons_args_r strictness, heaps)
+			= (False, type, heaps)
+	substitute type=:(CV type_var :@: types) heaps=:{th_vars}
 		# (tv_info, th_vars) = readPtr type_var.tv_info_ptr th_vars
-		  heaps = {heaps & th_vars = th_vars}
-		  (types, heaps) = substitute types heaps
-		= case tv_info of
-			TVI_Type type
-				#  (ok, simplified_type) = simplifyAndCheckTypeApplication type types
-				| ok
-					-> (simplified_type, heaps)
-				// otherwise
-					// this will lead to a kind check error later on
-					-> 	(CV type_var :@: types, heaps)
-			-> 	(CV type_var :@: types, heaps)
+		  heaps & th_vars = th_vars
+		  (changed, types_r, heaps) = substitute types heaps
+		| changed
+			= case tv_info of
+				TVI_Type s_type
+					# (ok, simplified_type) = simplifyAndCheckTypeApplication s_type types_r
+					| ok
+						-> (True, simplified_type, heaps)
+						// this will lead to a kind check error later on
+						-> 	(True, CV type_var :@: types_r, heaps)
+				_
+					-> 	(True, CV type_var :@: types_r, heaps)
+			= case tv_info of
+				TVI_Type s_type
+					# (ok, simplified_type) = simplifyAndCheckTypeApplication s_type types
+					| ok
+						-> (True, simplified_type, heaps)
+						// this will lead to a kind check error later on
+						-> 	(False, type, heaps)
+				_
+					-> 	(False, type, heaps)
+	substitute type=:(TArrow1 arg_type) heaps
+		# (changed, arg_type_r, heaps) = substitute arg_type heaps
+		| changed
+			= (True, TArrow1 arg_type_r, heaps)
+			= (False, type, heaps)
 	substitute type heaps
-		= (type, heaps)
+		= (False, type, heaps)
+
+instance substitute [a] | substitute a
+where
+	substitute lt=:[t:ts] heaps
+		# (changed_t, t_r, heaps) = substitute t heaps
+		  (changed_ts, ts_r, heaps) = substitute ts heaps
+		| changed_t
+			| changed_ts
+				= (True, [t_r:ts_r], heaps)
+				= (True, [t_r:ts], heaps)
+			| changed_ts
+				= (True, [t:ts_r], heaps)
+				= (False, lt, heaps)
+	substitute [] heaps
+		= (False, [], heaps)
+
+instance substitute TypeContext
+where
+	substitute tc=:{tc_types} heaps
+		# (changed_tc_types, tc_types_r, heaps) = substitute tc_types heaps
+		| changed_tc_types
+			= (True, {tc & tc_types = tc_types_r}, heaps)
+			= (False, tc, heaps)
 
 instance substitute AttributeVar
 where
 	substitute av=:{av_info_ptr} heaps=:{th_attrs}
-		#! av_info = sreadPtr av_info_ptr th_attrs
-		= case av_info of
+		= case sreadPtr av_info_ptr th_attrs of
 			AVI_Attr (TA_Var attr_var)
-				-> (attr_var, heaps)
+				-> (True, attr_var, heaps)
 			_
-				-> (av, heaps)
+				-> (False, av, heaps)
 
 instance substitute AttrInequality
 where
 	substitute {ai_demanded,ai_offered} heaps
-		# ((ai_demanded, ai_offered), heaps) = substitute (ai_demanded, ai_offered) heaps
-		= ({ai_demanded = ai_demanded, ai_offered = ai_offered}, heaps)
+		# (changed_ai_demanded, ai_demanded_r, heaps) = substitute ai_demanded heaps
+		  (changed_ai_offered, ai_offered_r, heaps) = substitute ai_offered heaps
+		| changed_ai_demanded
+			| changed_ai_offered
+				= (True, {ai_demanded = ai_demanded_r, ai_offered = ai_offered_r}, heaps)
+				= (True, {ai_demanded = ai_demanded_r, ai_offered = ai_offered}, heaps)
+			| changed_ai_offered
+				= (True, {ai_demanded = ai_demanded, ai_offered = ai_offered_r}, heaps)
+				= (False, {ai_demanded = ai_demanded, ai_offered = ai_offered}, heaps)
 
 instance substitute CaseType
 where
-	substitute {ct_pattern_type, ct_result_type, ct_cons_types} heaps 
-		# (ct_pattern_type, heaps) = substitute ct_pattern_type heaps
-		  (ct_result_type, heaps) = substitute ct_result_type heaps
-		  (ct_cons_types, heaps) = substitute ct_cons_types heaps
-		= ({ct_pattern_type = ct_pattern_type, ct_result_type = ct_result_type, 
-								ct_cons_types = ct_cons_types}, heaps)
+	substitute {ct_pattern_type, ct_result_type, ct_cons_types} heaps
+		# (changed_pattern_type, pattern_type_r, heaps) = substitute ct_pattern_type heaps
+		  (changed_result_type, result_type_r, heaps) = substitute ct_result_type heaps
+		  (changed_cons_types, cons_types_r, heaps) = substitute ct_cons_types heaps
+		| changed_pattern_type
+			| changed_result_type
+				| changed_cons_types
+					= (True, {ct_pattern_type=pattern_type_r, ct_result_type=result_type_r, ct_cons_types=cons_types_r}, heaps)
+					= (True, {ct_pattern_type=pattern_type_r, ct_result_type=result_type_r, ct_cons_types=ct_cons_types}, heaps)
+				| changed_cons_types
+					= (True, {ct_pattern_type=pattern_type_r, ct_result_type=ct_result_type, ct_cons_types=cons_types_r}, heaps)
+					= (True, {ct_pattern_type=pattern_type_r, ct_result_type=ct_result_type, ct_cons_types=ct_cons_types}, heaps)
+			| changed_result_type
+				| changed_cons_types
+					= (True, {ct_pattern_type=ct_pattern_type, ct_result_type=result_type_r, ct_cons_types=cons_types_r}, heaps)
+					= (True, {ct_pattern_type=ct_pattern_type, ct_result_type=result_type_r, ct_cons_types=ct_cons_types}, heaps)
+				| changed_cons_types
+					= (True, {ct_pattern_type=ct_pattern_type, ct_result_type=ct_result_type, ct_cons_types=cons_types_r}, heaps)
+					= (False, {ct_pattern_type=ct_pattern_type, ct_result_type=ct_result_type, ct_cons_types=ct_cons_types}, heaps)
 
 class removeAnnotations a :: !a  -> (!Bool, !a)
 
diff --git a/frontend/overloading.icl b/frontend/overloading.icl
index 07b13ca..ed3e286 100644
--- a/frontend/overloading.icl
+++ b/frontend/overloading.icl
@@ -328,10 +328,10 @@ where
 	where
 		fresh_context :: !TypeContext !*TypeHeaps -> (TypeContext,*TypeHeaps)
 		fresh_context tc=:{tc_types} type_heaps
-			# (tc_types, type_heaps) = substitute tc_types type_heaps
-//			  (tc_var, var_heap) = newPtr VI_Empty var_heap
-//			= ({ tc & tc_types = tc_types, tc_var = tc_var }, (var_heap, type_heaps))
-			= ({ tc & tc_types = tc_types }, type_heaps)
+			# (changed_tc_types, tc_types, type_heaps) = substitute tc_types type_heaps
+			| changed_tc_types
+				= ({tc & tc_types = tc_types}, type_heaps)
+				= (tc, type_heaps)
 
 	is_unboxed_array:: [Type] PredefinedSymbols -> Bool
 	is_unboxed_array [TA {type_index={glob_module,glob_object},type_arity} _ : _] predef_symbols
@@ -851,7 +851,7 @@ where
 			= type_var_heap <:= (tv_info_ptr, TVI_Type type)
 		  
 		subst_context_and_generate_super_classes class_context (super_classes, type_heaps)
-			# (super_class, type_heaps) = substitute class_context type_heaps
+			# (_, super_class, type_heaps) = substitute class_context type_heaps
 			| containsContext super_class super_classes
 				= (super_classes, type_heaps)
 				= generate_super_classes super_class ([super_class : super_classes], type_heaps) 
@@ -1090,7 +1090,7 @@ where
 			# {tc_class=TCClass {glob_object={ds_index},glob_module}} = tc2
 			  {class_args,class_members,class_context,class_dictionary} = defs.[glob_module].com_class_defs.[ds_index]
 			  th_vars = foldr2 (\{tv_info_ptr} type -> writePtr tv_info_ptr (TVI_Type type)) th_vars class_args tc2.tc_types
-			  (super_instances, type_heaps) = substitute class_context { type_heaps & th_vars = th_vars } 
+			  (_, super_instances, type_heaps) = substitute class_context {type_heaps & th_vars = th_vars} 
 			= find_super_instance tc1 super_instances (size class_members) address glob_module class_dictionary.ds_index defs type_heaps
 	where
 		find_super_instance :: !TypeContext ![TypeContext] !Index ![(Int, Global DefinedSymbol)] !Index !Index !{#CommonDefs} !*TypeHeaps
diff --git a/frontend/trans.icl b/frontend/trans.icl
index e2ad3b8..ea098b9 100644
--- a/frontend/trans.icl
+++ b/frontend/trans.icl
@@ -997,7 +997,6 @@ generate_case_function fun_index case_info_ptr new_expr outer_fun_def outer_cons
 	  app_args = free_vars_to_bound_vars tfi_args
 	= ( App {app_symb = app_symb, app_args = app_args, app_info_ptr = nilPtr}, ti)
 
-
 generate_case_function_with_pattern_argument :: !Int !ExprInfoPtr !Expression FunDef .ConsClasses [.Bool] !SymbIdent ![FreeVar] !*TransformInfo
 	-> (!Expression,!*TransformInfo)
 generate_case_function_with_pattern_argument fun_index case_info_ptr 
@@ -1051,7 +1050,7 @@ generate_case_function_with_pattern_argument fun_index case_info_ptr
 								,	fi_local_vars	= []
 								,	fi_dynamics		= []
 								,	fi_properties	= outer_fun_def.fun_info.fi_properties
-								}	
+								}
 				}
 	# cc_args_from_outer_fun		= [ cons_arg \\ cons_arg <- outer_cons_args.cc_args & used <- used_mask | used ]
 	  cc_linear_bits_from_outer_fun	= [ cons_arg \\ cons_arg <- outer_cons_args.cc_linear_bits & used <- used_mask | used ]
@@ -1089,8 +1088,8 @@ determine_case_function_type fun_arity ct_result_type arg_types st_attr_env ti=:
 	# (type_variables, th_vars)				= getTypeVars [ct_result_type:arg_types] ti_type_heaps.th_vars
 	  (fresh_type_vars, th_vars)			= mapSt bind_to_fresh_type_variable type_variables th_vars
 	  ti_type_heaps							= { ti_type_heaps & th_vars = th_vars }
-	  (fresh_arg_types, ti_type_heaps)		= substitute arg_types ti_type_heaps
-	  (fresh_result_type, ti_type_heaps)	= substitute ct_result_type ti_type_heaps
+	  (_, fresh_arg_types, ti_type_heaps)	= substitute arg_types ti_type_heaps
+	  (_, fresh_result_type, ti_type_heaps)	= substitute ct_result_type ti_type_heaps
 	  fun_type =
 	  			{ st_vars					= fresh_type_vars
 	  			, st_args					= fresh_arg_types
@@ -1467,8 +1466,8 @@ generateFunction app_symb fd=:{fun_body = TransformedBody {tb_args,tb_rhs},fun_i
 	  das_AVI_Attr_TA_TempVar_info_ptrs = [st_attr_vars]
 	  ti_type_heaps = {ti_type_heaps & th_attrs = th_attrs, th_vars = th_vars}
 //	| False-!->("before substitute", st_args, "->", st_result)		= undef
-	# ((st_args,st_result), ti_type_heaps)
-	  		= substitute (st_args,st_result) ti_type_heaps
+	# (_, st_args, ti_type_heaps) = substitute st_args ti_type_heaps
+	# (_, st_result, ti_type_heaps) = substitute st_result ti_type_heaps
 //	| False-!->("after substitute", st_args, "->", st_result)		= undef
 // determine args...
 	# das = { das_vars						= []
@@ -1791,9 +1790,9 @@ where
 				= mapSt bind_to_fresh_type_variable st_vars th_vars
 		  (fresh_st_attr_vars, th_attrs)
 				= mapSt bind_to_fresh_attr_variable st_attr_vars th_attrs
-		  ([fresh_st_result:fresh_st_args], ti_type_heaps)
+		  (_, [fresh_st_result:fresh_st_args], ti_type_heaps)
 		  		= substitute [st_result:st_args] { ti_type_heaps & th_vars = th_vars, th_attrs = th_attrs }
-		  (fresh_st_attr_env, ti_type_heaps)
+		  (_, fresh_st_attr_env, ti_type_heaps)
 		  		= substitute st_attr_env ti_type_heaps
 		= (Yes { symbol_type & st_vars = fresh_st_vars, st_attr_vars = fresh_st_attr_vars, st_args = fresh_st_args,
 				st_result = fresh_st_result, st_attr_env = fresh_st_attr_env}, ti_type_heaps)
@@ -1981,7 +1980,7 @@ determine_arg (PR_Class class_app free_vars_and_types class_type) _ {fv_info_ptr
 			  das=:{das_arg_types, das_subst, das_type_heaps, das_predef}
 	# (ws_arg_type, das_arg_types) = das_arg_types![prod_index]
 	# {ats_types=[arg_type:_]} = ws_arg_type
-	  (int_class_type, das_type_heaps)
+	  (_, int_class_type, das_type_heaps)
 	  		= substitute class_type das_type_heaps
 	  class_atype = { empty_atype & at_type = int_class_type }
 	  type_input
@@ -2014,9 +2013,9 @@ determine_arg (PR_Class class_app free_vars_and_types class_type) _ {fv_info_ptr
 		= abort ("sanity check nr 93 in module trans failed\n"--->(class_atype,"\n", arg_type))
 	# (free_vars_and_types,das_type_heaps) = mapSt subFVT free_vars_and_types das_type_heaps
 		with
-			subFVT (fv,ty) th
-				# (ty`,th`)		= substitute ty th
-				= ((fv,ty`),th`)
+			subFVT (fv,ty) type_heaps
+				# (_, ty`,type_heaps) = substitute ty type_heaps
+				= ((fv,ty`),type_heaps)
 
 	# ws_ats_types = [ { empty_atype & at_type = at_type } \\ (_, at_type) <- free_vars_and_types]
 	# ws_arg_type` = {ats_types= ws_ats_types, ats_strictness = first_n_strict (length free_vars_and_types) }
@@ -2057,8 +2056,8 @@ determine_arg producer (Yes {st_args, st_args_strictness, st_result, st_attr_var
 	  // because types in Cases and Lets should not use TA_TempVar's
 	  das_AVI_Attr_TA_TempVar_info_ptrs = [st_attr_vars:das_AVI_Attr_TA_TempVar_info_ptrs]
 	  		// prepare for substitute calls
-	  ((st_args, st_result), das_type_heaps)
-	  		= substitute (st_args, st_result) { das_type_heaps & th_vars = th_vars, th_attrs = th_attrs }
+	  (_, st_args, das_type_heaps) = substitute st_args {das_type_heaps & th_vars = th_vars, th_attrs = th_attrs}
+	  (_, st_result, das_type_heaps) = substitute st_result das_type_heaps
 	  nr_of_applied_args = symbol_arity
 	  (application_type, attr_env, das_next_attr_nr)
 	  		= build_application_type st_arity (length st_context) st_result st_args nr_of_applied_args [] das_next_attr_nr
@@ -4169,11 +4168,6 @@ get_fun_def_and_cons_args (SK_GeneratedFunction fun_info_ptr fun_index) cons_arg
 	= (gf_fun_def, gf_cons_args, cons_args, fun_defs, fun_heap)
 
 //@ <<<
-/*
-instance <<< Group where
-	(<<<) file {group_members}
-	 = file <<< "Group: " <<< group_members
-*/
 
 instance <<< RootCaseMode where
 	(<<<) file mode = case mode of NotRootCase -> file <<< "NotRootCase"; RootCase -> file <<< "RootCase"; RootCaseOfZombie -> file <<< "RootCaseOfZombie";
@@ -4459,7 +4453,7 @@ copy_dictionary_variable app_symb app_args class_type ci cs
 	substitute_class_types class_types No
 		= (class_types, No)
 	substitute_class_types class_types (Yes type_heaps)
-		# (new_class_types, type_heaps) = substitute class_types type_heaps
+		# (_, new_class_types, type_heaps) = substitute class_types type_heaps
 		= (new_class_types, Yes type_heaps)
 
 instance copy DynamicExpr
@@ -4536,7 +4530,7 @@ where
 			= ({ app & app_args = app_args, app_info_ptr = new_info_ptr}, cs) 
 
 		substitute_EI_DictionaryType (EI_DictionaryType class_type) (Yes type_heaps)
-			# (new_class_type, type_heaps) = substitute class_type type_heaps
+			# (_, new_class_type, type_heaps) = substitute class_type type_heaps
 			= (EI_DictionaryType new_class_type, Yes type_heaps)
 		substitute_EI_DictionaryType x opt_type_heaps
 			= (x, opt_type_heaps)
@@ -4684,12 +4678,16 @@ substitute_let_or_case_type	expr_info No
 substitute_let_or_case_type	(EI_Extended extensions expr_info) yes_type_heaps
 	# (new_expr_info, yes_type_heaps) = substitute_let_or_case_type expr_info yes_type_heaps
 	= (EI_Extended extensions new_expr_info, yes_type_heaps)
-substitute_let_or_case_type	(EI_CaseType case_type) (Yes type_heaps)
-	# (new_case_type, type_heaps) = substitute case_type type_heaps
-	= (EI_CaseType new_case_type, Yes type_heaps)
-substitute_let_or_case_type	(EI_LetType let_type) (Yes type_heaps)
-	# (new_let_type, type_heaps) = substitute let_type type_heaps
-	= (EI_LetType new_let_type, Yes type_heaps)
+substitute_let_or_case_type	expr_info=:(EI_CaseType case_type) (Yes type_heaps)
+	# (changed, new_case_type, type_heaps) = substitute case_type type_heaps
+	| changed
+		= (EI_CaseType new_case_type, Yes type_heaps)
+		= (expr_info, Yes type_heaps)
+substitute_let_or_case_type	expr_info=:(EI_LetType let_type) (Yes type_heaps)
+	# (changed, new_let_type, type_heaps) = substitute let_type type_heaps
+	| changed
+		= (EI_LetType new_let_type, Yes type_heaps)
+		= (expr_info, Yes type_heaps)
 
 instance copy CasePatterns
 where
diff --git a/frontend/typesupport.icl b/frontend/typesupport.icl
index 04c6f8d..b25149b 100644
--- a/frontend/typesupport.icl
+++ b/frontend/typesupport.icl
@@ -584,13 +584,17 @@ where
 		# (info, expr_heap) = readPtr expr_ptr expr_heap
 		= case info of
 			EI_CaseType case_type
-				# (case_type, type_heaps) = substitute case_type type_heaps
-				-> (type_heaps, expr_heap <:= (expr_ptr, EI_CaseType case_type))
+				# (changed, case_type_r, type_heaps) = substitute case_type type_heaps
+				| changed
+					-> (type_heaps, expr_heap <:= (expr_ptr, EI_CaseType case_type_r))
+					-> (type_heaps, expr_heap)
 			EI_LetType let_type
-				# (let_type, type_heaps) = substitute let_type type_heaps
-				-> (type_heaps, expr_heap <:= (expr_ptr, EI_LetType let_type))
+				# (changed, let_type_r, type_heaps) = substitute let_type type_heaps
+				| changed
+					-> (type_heaps, expr_heap <:= (expr_ptr, EI_LetType let_type_r))
+					-> (type_heaps, expr_heap)
 			EI_DictionaryType dict_type
-				# (dict_type, type_heaps) = substitute dict_type type_heaps
+				# (_, dict_type, type_heaps) = substitute dict_type type_heaps
 				-> (type_heaps, expr_heap <:= (expr_ptr, EI_DictionaryType dict_type))
 
 class bindInstances a :: !a !a !*TypeVarHeap -> *TypeVarHeap
@@ -640,7 +644,7 @@ instance bindInstances AType
 substituteType :: !TypeAttribute !TypeAttribute ![ATypeVar] ![AType] !Type !*TypeHeaps -> (!Type, !*TypeHeaps)
 substituteType form_root_attribute act_root_attribute form_type_args act_type_args orig_type type_heaps
 	# type_heaps = bindTypeVarsAndAttributes form_root_attribute act_root_attribute form_type_args act_type_args type_heaps
-	  (expanded_type, type_heaps) = substitute orig_type type_heaps
+	  (_, expanded_type, type_heaps) = substitute orig_type type_heaps
 	= (expanded_type, clearBindingsOfTypeVarsAndAttributes form_root_attribute form_type_args type_heaps)
 
 bindTypeVarsAndAttributes :: !TypeAttribute !TypeAttribute ![ATypeVar] ![AType] !*TypeHeaps -> *TypeHeaps
-- 
cgit v1.2.3