optimize adapters for generic functions using algebraic types which have

constructors with only type variable arguments occurring at most once,
these types can be optimized if they occur as an argument or result,
or as an argument of such a type, of a generic function (and a generic
variable is used by the type)


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

2 files changed, 408 insertions, 184 deletions

diff --git a/frontend/generics1.icl b/frontend/generics1.icl
index 0c97b31..399a7e9 100644
--- a/frontend/generics1.icl
+++ b/frontend/generics1.icl
@@ -337,13 +337,13 @@ where
 				# (expanded_type, th) = expandSynonymType type_def attr args heaps.hp_type_heaps 
 				-> convert {at_type = expanded_type, at_attribute = attr} 
 					(modules, td_infos, {heaps & hp_type_heaps = th}, error) 
-			_ 	
+			_
 				#! {pds_module, pds_def} = predefs.[PD_UnboxedArrayType]
 				| 	type_index.glob_module == pds_module
 					&& type_index.glob_object == pds_def
 					&& (case args of [{at_type=TB _}] -> True; _ -> False)
 					-> (GTSAppCons KindConst [], (modules, td_infos, heaps, error))
-				| otherwise	
+				| otherwise
 					#! ({tdi_kinds}, td_infos) = td_infos ! [type_index.glob_module,type_index.glob_object]
 					#! kind = if (isEmpty tdi_kinds) KindConst (KindArrow tdi_kinds)
 					#! (args, st) = mapSt  convert args (modules, td_infos, heaps, error)
@@ -373,29 +373,79 @@ where
 		# error = reportError predefined_idents.[PD_GenericBimap] pos ("can not build generic representation for this type", type) error
 		= (GTSE, (modules, td_infos, heaps, error))
 
-	convert_type_app {type_index} attr args (modules, td_infos, heaps, error)	
-		# (type_def, modules) = modules![type_index.glob_module].com_type_defs.[type_index.glob_object]
+	convert_type_app {type_index=type_index=:{glob_module,glob_object},type_arity} attr args (modules, td_infos, heaps, error)
+		# (type_def, modules) = modules![glob_module].com_type_defs.[glob_object]
 		= case type_def.td_rhs of 
 			SynType atype
-				# (expanded_type, th) = expandSynonymType type_def attr args heaps.hp_type_heaps 
+				# (expanded_type, th) = expandSynonymType type_def attr args heaps.hp_type_heaps
 				-> convert {at_type = expanded_type, at_attribute = attr} 
 					(modules, td_infos, {heaps & hp_type_heaps = th}, error) 
-			_ 	
+			AbstractType _
 				#! {pds_module, pds_def} = predefs.[PD_UnboxedArrayType]
-				| type_index.glob_module == pds_module && type_index.glob_object == pds_def
+				| glob_module == pds_module && glob_object == pds_def
 					&& (case args of [{at_type=TB _}] -> True; _ -> False)
 					-> (GTSAppCons KindConst [], (modules, td_infos, heaps, error))
+			RecordType _
 				# {pds_module, pds_def} = predefs.[PD_TypeBimap]
-				| type_index.glob_module == pds_module && type_index.glob_object == pds_def
+				| glob_module == pds_module && glob_object == pds_def
 					&& case args of [_,_] -> True; _ -> False
-					#! ({tdi_kinds}, td_infos) = td_infos ! [type_index.glob_module,type_index.glob_object]
+					#! (tdi_kinds,td_infos) = td_infos![glob_module,glob_object].tdi_kinds
 					#! kind = if (isEmpty tdi_kinds) KindConst (KindArrow tdi_kinds)
-					#! (args, st) = mapSt  convert args (modules, td_infos, heaps, error)
+					#! (args, st) = convert_args args (modules, td_infos, heaps, error)
 					-> (GTSAppBimap kind args, st)
-					#! ({tdi_kinds}, td_infos) = td_infos ! [type_index.glob_module,type_index.glob_object]
-					#! kind = if (isEmpty tdi_kinds) KindConst (KindArrow tdi_kinds)
-					#! (args, st) = mapSt  convert args (modules, td_infos, heaps, error)
-					-> (GTSAppCons kind args, st)
+			AlgType alts
+				# n_args = length args
+				| n_args>0 && type_arity==n_args
+					# (can_generate_bimap_to_or_from,modules,heaps)
+						= can_generate_bimap_to_or_from_for_this_type type_def glob_module alts modules heaps
+					| can_generate_bimap_to_or_from
+						#! (tdi_kinds,td_infos) = td_infos![glob_module,glob_object].tdi_kinds			
+						#! (args, st) = convert_args args (modules, td_infos, heaps, error)
+						-> (GTSAppConsSimpleType type_index (KindArrow tdi_kinds) args, st)
+						-> 	convert_type_app_to_GTSAppCons glob_module glob_object args modules td_infos heaps error
+			_
+				-> 	convert_type_app_to_GTSAppCons glob_module glob_object args modules td_infos heaps error
+	where
+		convert_type_app_to_GTSAppCons glob_module glob_object args modules td_infos heaps error
+			#! (tdi_kinds,td_infos) = td_infos![glob_module,glob_object].tdi_kinds
+			#! kind = if (isEmpty tdi_kinds) KindConst (KindArrow tdi_kinds)
+			#! (args, st) = convert_args args (modules, td_infos, heaps, error)
+			= (GTSAppCons kind args, st)
+
+	can_generate_bimap_to_or_from_for_this_type :: !CheckedTypeDef !Index ![DefinedSymbol] !*Modules !*Heaps -> (!Bool,!*Modules,!*Heaps)
+	can_generate_bimap_to_or_from_for_this_type type_def=:{td_args} type_def_module_n alts modules heaps=:{hp_type_heaps}
+		# th_vars = number_type_arguments td_args 0 hp_type_heaps.th_vars
+		#! ok = check_constructors alts type_def_module_n modules th_vars
+		# th_vars = remove_type_argument_numbers td_args th_vars
+		# heaps = {heaps & hp_type_heaps={hp_type_heaps & th_vars=th_vars}}
+		= (ok,modules,heaps)
+	where
+		check_constructors :: ![DefinedSymbol] !Index !Modules !TypeVarHeap -> Bool
+		check_constructors [{ds_index}:constructors] type_def_module_n modules th_vars
+			# {cons_type,cons_exi_vars} = modules.[type_def_module_n].com_cons_defs.[ds_index]
+			= isEmpty cons_exi_vars &&
+			  isEmpty cons_type.st_context &&
+			  check_constructor cons_type.st_args 0 th_vars &&
+			  check_constructors constructors type_def_module_n modules th_vars
+		check_constructors [] type_def_module_n modules th_vars
+			= True
+
+		check_constructor :: ![AType] !Int !TypeVarHeap -> Bool
+		check_constructor [{at_type=TV {tv_info_ptr}}:atypes] used_type_vars th_vars
+			= case sreadPtr tv_info_ptr th_vars of
+				TVI_GenTypeVarNumber arg_n
+					# arg_mask = 1<<arg_n
+					| used_type_vars bitand arg_mask<>0
+						-> False
+						# used_type_vars = used_type_vars bitor arg_mask
+						-> check_constructor atypes used_type_vars th_vars
+		check_constructor [_:_] used_type_vars th_vars
+			= False
+		check_constructor [] used_type_vars th_vars
+			= True
+
+	convert_args args st
+		= mapSt convert args st
 
 // the structure type of a generic type can often be simplified
 // because bimaps for types not containing generic variables are indentity bimaps
@@ -416,6 +466,12 @@ where
 			= (GTSAppConsBimapKindConst, st)
 			# (args, st) = mapSt simplify args st
 			= (GTSAppCons kind args, st)
+	simplify (GTSAppConsSimpleType type_symbol_n kind args) st
+		# contains_gen_vars = occurs_list args st
+		| not contains_gen_vars
+			= (GTSAppConsBimapKindConst, st)
+			# (args, st) = mapSt simplify args st
+			= (GTSAppConsSimpleType type_symbol_n kind args, st)
 	simplify t=:(GTSAppBimap KindConst [])  st
 		= (t, st)
 	simplify (GTSAppBimap kind=:(KindArrow kinds) args) st
@@ -457,8 +513,9 @@ where
 		= (GTSObject type_info_ds x, st)
 		
 	occurs (GTSAppCons _ args) st 	= occurs_list args st
+	occurs (GTSAppConsSimpleType _ _ args) st 	= occurs_list args st
 	occurs (GTSAppBimap _ args) st 	= occurs_list args st
-	occurs (GTSAppVar tv args) st 	= occurs (GTSVar tv) st || occurs_list args st		
+	occurs (GTSAppVar tv args) st 	= type_var_occurs tv st || occurs_list args st		
 	occurs (GTSVar tv) st			= type_var_occurs tv st
 	occurs (GTSArrow x y) st 		= occurs2 x y st
 	occurs (GTSPair x y) st			= occurs2 x y st
@@ -486,7 +543,6 @@ where
 		= case tv_info of
 			TVI_Empty = writePtr tv_info_ptr TVI_Used th_vars 
 			_ = abort "type var is not empty"
-				--->  ("type var is not empty", tv, tv_info)
 
 	clear_type_var {tv_info_ptr} th_vars
 		= writePtr tv_info_ptr TVI_Empty th_vars 
@@ -503,7 +559,6 @@ buildStructType ::
 buildStructType {gi_module,gi_index} type_info cons_infos predefs (modules, td_infos, heaps, error)
 	# (type_def=:{td_ident}, modules) = modules![gi_module].com_type_defs.[gi_index]	
 	= build_type type_def type_info cons_infos (modules, td_infos, heaps, error)	
-		//---> ("buildStructureType", td_ident, atype)	
 where
 	build_type {td_rhs=AlgType alts, td_ident, td_pos} type_info cons_infos st
 		# (cons_args, st) = zipWithSt (build_alt td_ident td_pos) alts cons_infos st
@@ -634,7 +689,7 @@ buildTypeDefInfo1 td_module {td_ident, td_pos, td_arity} alts fields main_module
 	# (type_def_dsc_fun, heaps) = build_type_def_dsc group_index cons_dsc_dss type_def_dsc_ds heaps	
 	
 	# (cons_dsc_funs, (modules, heaps)) = zipWithSt (build_cons_dsc group_index type_def_dsc_ds field_dsc_dss) cons_dsc_dss alts (modules, heaps)
-	
+
 	# (field_dsc_funs, (modules, heaps)) = zipWithSt (build_field_dsc group_index (hd cons_dsc_dss)) field_dsc_dss fields (modules, heaps)
 	 
 	// NOTE: reverse order (new functions are added at the head) 
@@ -658,7 +713,7 @@ buildTypeDefInfo1 td_module {td_ident, td_pos, td_arity} alts fields main_module
 
 	= (type_info_ds, cons_infos, funs_and_groups, modules, heaps, error)
 where
-	build_type_def_dsc group_index cons_info_dss {ds_ident}  heaps	
+	build_type_def_dsc group_index cons_info_dss {ds_ident} heaps
 		# td_name_expr = makeStringExpr td_ident.id_name
 		# td_arity_expr = makeIntExpr td_arity
 		# num_conses_expr = makeIntExpr (length alts)
@@ -869,7 +924,7 @@ buildConversionIso type_def=:{td_ident, td_pos} from_fun to_fun
 
 build_bimap_record to_expr from_expr predefs heaps 
 	= buildPredefConsApp PD_ConsBimap [to_expr, from_expr] predefs heaps	
-		
+
 // conversion from type to generic
 buildConversionTo ::
 		!Index				// type def module
@@ -891,11 +946,9 @@ buildConversionTo
 		# (def_sym, funs_and_groups) 
 			= (buildFunAndGroup fun_name [] EE No main_module_index td_pos funs_and_groups)
 		= (def_sym, funs_and_groups, heaps, error)	
-			//---> ("buildConversionTo failed", td_ident)
 		# (def_sym, funs_and_groups) 
 			= (buildFunAndGroup fun_name [arg_var] body_expr No main_module_index td_pos funs_and_groups)
 		= (def_sym, funs_and_groups, heaps, error)
-			//---> ("buildConversionTo", td_ident, let (_,_,fs,_) = funs_and_groups in hd fs)
 where
 	// build conversion for type rhs
 	build_expr_for_type_rhs :: 
@@ -907,8 +960,7 @@ where
 			!*ErrorAdmin
 		-> 	( !Expression		// generated expression
 			, !*Heaps	// state
-			, !*ErrorAdmin
-			)
+			, !*ErrorAdmin)
  	build_expr_for_type_rhs type_def_mod type_def_index (AlgType def_symbols) arg_expr heaps error
 		= build_expr_for_conses False type_def_mod type_def_index def_symbols arg_expr heaps error
 	build_expr_for_type_rhs type_def_mod type_def_index (RecordType {rt_constructor}) arg_expr heaps error		
@@ -919,25 +971,25 @@ where
 	build_expr_for_type_rhs type_def_mod type_def_index (SynType _) arg_expr  heaps error
 		#! error = checkErrorWithIdentPos (newPosition td_ident td_pos) "cannot build isomorphisms for a synonym type" error
 		= (EE, heaps, error)
-	
+
 	// build conversion for constructors of a type def 	
 	build_expr_for_conses is_record type_def_mod type_def_index cons_def_syms arg_expr heaps error
-		# (case_alts, heaps, error) = 
-			build_exprs_for_conses is_record 0 (length cons_def_syms) type_def_mod cons_def_syms  heaps error
+		# (case_alts, heaps, error)
+			= build_exprs_for_conses is_record 0 (length cons_def_syms) type_def_mod cons_def_syms  heaps error
 		# case_patterns = AlgebraicPatterns {glob_module = type_def_mod, glob_object = type_def_index} case_alts
 		# (case_expr, heaps) = buildCaseExpr arg_expr case_patterns heaps
 		= (case_expr, heaps, error)	
-			//---> (free_vars, case_expr)		
-	
+
 	// build conversions for constructors 	
 	build_exprs_for_conses :: !Bool !Int !Int !Int ![DefinedSymbol] !*Heaps !*ErrorAdmin
 		-> ([AlgebraicPattern], !*Heaps, !*ErrorAdmin)
-	build_exprs_for_conses is_record i n type_def_mod [] heaps error = ([], heaps, error) 	
+	build_exprs_for_conses is_record i n type_def_mod [] heaps error
+		= ([], heaps, error)
 	build_exprs_for_conses is_record i n type_def_mod [cons_def_sym:cons_def_syms] heaps error
 		#! (alt, heaps, error) = build_expr_for_cons is_record i n type_def_mod cons_def_sym heaps error
 		#! (alts, heaps, error) =  build_exprs_for_conses is_record (i+1) n type_def_mod cons_def_syms heaps error 		
 		= ([alt:alts], heaps, error)
-					
+		
 	// build conversion for a constructor	
 	build_expr_for_cons :: !Bool !Int !Int !Int !DefinedSymbol !*Heaps !*ErrorAdmin 
 		-> (AlgebraicPattern, !*Heaps, !*ErrorAdmin)
@@ -1006,23 +1058,18 @@ buildConversionFrom
 		# (def_sym, funs_and_groups) 
 			= (buildFunAndGroup fun_name [] EE No main_module_index td_pos funs_and_groups)
 		= (def_sym, funs_and_groups, heaps, error)
-			//---> ("buildConversionFrom failed", td_ident)
 		# (def_sym, funs_and_groups) 
 			= (buildFunAndGroup fun_name [arg_var] body_expr No main_module_index td_pos funs_and_groups)
 		= (def_sym, funs_and_groups, heaps, error)
-			//---> ("buildConversionFrom", td_ident, let (_,_,fs,_) = funs_and_groups in hd fs)
 where
 	// build expression for type def rhs
 	build_expr_for_type_rhs :: 
 			!Index				// type def module
 			!TypeRhs			// type rhs
-			!*Heaps
-			!*ErrorAdmin	
+			!*Heaps !*ErrorAdmin	
 		-> 	( !Expression		// body expresssion
 			, !FreeVar
-			, !*Heaps
-			, !*ErrorAdmin
-			)		
+			, !*Heaps, !*ErrorAdmin)
 	build_expr_for_type_rhs type_def_mod (AlgType def_symbols) heaps error
 		#! (expr, var, heaps, error) = build_sum False type_def_mod def_symbols heaps error
 		#! (expr, var, heaps) = build_case_object var expr predefs heaps
@@ -1031,7 +1078,6 @@ where
 		# (expr, var, heaps, error) = build_sum True type_def_mod [rt_constructor] heaps	error
 		#! (expr, var, heaps) = build_case_object var expr predefs heaps
 		= (expr, var, heaps, error)
-		
 	build_expr_for_type_rhs type_def_mod (AbstractType _) heaps error
 		#! error = reportError td_ident td_pos "cannot build isomorphisms for an abstract type" error
 		# dummy_fv = {fv_def_level=(-1), fv_count=0, fv_ident=makeIdent "dummy", fv_info_ptr=nilPtr}
@@ -1961,7 +2007,7 @@ buildGenericCaseBody ::
 		!FunsAndGroups !*TypeDefInfos !*{#CommonDefs} !*Heaps !*ErrorAdmin 
 	-> (!FunctionBody,
 		!FunsAndGroups, !*TypeDefInfos,!*{#CommonDefs},!*Heaps,!*ErrorAdmin)
-buildGenericCaseBody main_module_index gc=:{gc_type_cons=TypeConsSymb {type_ident,type_index},gc_kind,gc_generic} has_generic_info st predefs
+buildGenericCaseBody main_module_index gc=:{gc_type_cons=TypeConsSymb {type_ident,type_index},gc_kind,gc_generic,gc_ident,gc_pos} has_generic_info st predefs
 					funs_and_groups td_infos modules heaps error
 	#! (gen_def, modules) = modules![gc_generic.gi_module].com_generic_defs.[gc_generic.gi_index]
 	#! (td_info=:{tdi_gen_rep}, td_infos) = td_infos![type_index.glob_module,type_index.glob_object]
@@ -1982,13 +2028,12 @@ buildGenericCaseBody main_module_index gc=:{gc_type_cons=TypeConsSymb {type_iden
 			False
 				-> (arg_vars,heaps)
 
-	#! (optional_adaptor_expr, adapted_arg_exprs, original_arg_exprs, funs_and_groups, modules, td_infos, heaps, error)
-		= build_adaptor_expr gc gen_def gen_type_rep original_arg_exprs funs_and_groups modules td_infos heaps error
-
 	#! (specialized_expr, funs_and_groups, td_infos, heaps, error)
-		= build_specialized_expr gc gtr_type td_args generated_arg_exprs gen_def.gen_info_ptr funs_and_groups td_infos heaps error
+		= build_specialized_expr gc_pos gc_ident gc_generic gtr_type td_args generated_arg_exprs gen_def.gen_info_ptr funs_and_groups td_infos heaps error
+
+	#! (body_expr, funs_and_groups, modules, td_infos, heaps, error)
+		= adapt_specialized_expr gc_pos gen_def gen_type_rep original_arg_exprs specialized_expr funs_and_groups modules td_infos heaps error
 
-	# body_expr = build_body_expr optional_adaptor_expr specialized_expr adapted_arg_exprs original_arg_exprs
 	= (TransformedBody {tb_args=arg_vars, tb_rhs=body_expr}, funs_and_groups, td_infos, modules, heaps, error)	
 where
 	build_generic_info_arg heaps=:{hp_var_heap}
@@ -2008,9 +2053,33 @@ where
 				heaps	
 		= (generated_arg_exprs, original_arg_exprs, generated_arg_vars ++ original_arg_vars, heaps)
 
+	// generic function specialized to the generic representation of the type
+	build_specialized_expr gc_pos gc_ident gcf_generic gtr_type td_args generated_arg_exprs gen_info_ptr funs_and_groups td_infos heaps error
+		#! spec_env = [(atv_variable, TVI_Expr expr) \\ {atv_variable} <- td_args & expr <- generated_arg_exprs]
+		# generic_bimap = predefs.[PD_GenericBimap]
+		| gcf_generic.gi_module==generic_bimap.pds_module && gcf_generic.gi_index==generic_bimap.pds_def
+
+			// JvG: can probably make special version of simplify_bimap_GenTypeStruct that doesn't simplify if any var occurs, because all vars are passed
+			# (gtr_type, heaps) = simplify_bimap_GenTypeStruct [atv_variable \\ {atv_variable} <- td_args] gtr_type heaps
+
+			# (expr,funs_and_groups,heaps,error)
+				= specialize_generic_bimap gcf_generic gtr_type spec_env gc_ident gc_pos main_module_index predefs funs_and_groups heaps error
+			= (expr,funs_and_groups,td_infos,heaps,error)
+
+			# ({gen_OBJECT_CONS_FIELD_indices},generic_heap) = readPtr gen_info_ptr heaps.hp_generic_heap
+			  heaps = {heaps & hp_generic_heap=generic_heap}
+
+			# (expr,td_infos,heaps,error)
+				= specializeGeneric gcf_generic gtr_type spec_env gc_ident gc_pos gen_OBJECT_CONS_FIELD_indices main_module_index td_infos heaps error
+			= (expr,funs_and_groups,td_infos,heaps,error)
+
 	// adaptor that converts a function for the generic representation into a 
 	// function for the type itself
-	build_adaptor_expr {gc_pos} {gen_type, gen_vars, gen_info_ptr} {gtr_iso,gtr_to,gtr_from} original_arg_exprs funs_and_groups modules td_infos heaps error
+	adapt_specialized_expr :: Position GenericDef GenericTypeRep [Expression] Expression
+						!FunsAndGroups !*Modules !*TypeDefInfos !*Heaps !*ErrorAdmin
+		-> (!Expression,!FunsAndGroups,!*Modules,!*TypeDefInfos,!*Heaps,!*ErrorAdmin)
+	adapt_specialized_expr gc_pos {gen_type, gen_vars, gen_info_ptr} {gtr_iso,gtr_to,gtr_from} original_arg_exprs specialized_expr
+			funs_and_groups modules td_infos heaps error
 		#! (var_kinds, heaps) = get_var_kinds gen_info_ptr heaps		
 		#! non_gen_var_kinds = drop (length gen_vars) var_kinds  
 		
@@ -2028,11 +2097,11 @@ where
 		#! (struct_gen_type, heaps) = simplify_bimap_GenTypeStruct gen_vars struct_gen_type heaps
 
 		# bimap_gi = {gi_module=bimap_module,gi_index=bimap_index}
-		#! (adaptor_expr, adapted_arg_exprs, original_arg_exprs, funs_and_groups, heaps, error)
-			= specialize_generic_from_bimap bimap_gi struct_gen_type spec_env bimap_ident gc_pos original_arg_exprs main_module_index predefs
-														funs_and_groups heaps error
+		#! (body_expr, funs_and_groups, modules, heaps, error)
+			= adapt_with_specialized_generic_bimap bimap_gi struct_gen_type spec_env bimap_ident gc_pos original_arg_exprs specialized_expr main_module_index predefs 
+						funs_and_groups modules heaps error
 
-		= (adaptor_expr, adapted_arg_exprs, original_arg_exprs, funs_and_groups, modules, td_infos, heaps, error)
+		= (body_expr, funs_and_groups, modules, td_infos, heaps, error)
 	where
 		{pds_module = bimap_module, pds_def=bimap_index} = predefs.[PD_GenericBimap]
 		bimap_ident = predefined_idents.[PD_GenericBimap]
@@ -2065,46 +2134,6 @@ where
 					= buildGenericApp bimap_module bimap_index bimap_ident kind [] heaps		
 				= ((non_gen_var, TVI_Expr expr), funs_and_groups, heaps)
 
-	// generic function specialzied to the generic representation of the type
-	build_specialized_expr :: GenericCaseDef GenTypeStruct [ATypeVar] [Expression] GenericInfoPtr !FunsAndGroups !*TypeDefInfos !*Heaps !*ErrorAdmin
-																				  -> (!Expression,!FunsAndGroups,!*TypeDefInfos,!*Heaps,!*ErrorAdmin)
-	build_specialized_expr {gc_ident, gc_pos, gc_generic} gtr_type td_args generated_arg_exprs gen_info_ptr funs_and_groups td_infos heaps error
-		#! spec_env = [(atv_variable, TVI_Expr expr) \\ {atv_variable} <- td_args & expr <- generated_arg_exprs]
-		# generic_bimap = predefs.[PD_GenericBimap]
-		| gc_generic.gi_module==generic_bimap.pds_module && gc_generic.gi_index==generic_bimap.pds_def
-
-			// can probably make special version of simplify_bimap_GenTypeStruct that doesn't simplify if a var occurs, because all vars are passed
-			# (gtr_type, heaps) = simplify_bimap_GenTypeStruct [atv_variable \\ {atv_variable} <- td_args] gtr_type heaps
-
-			# (expr,funs_and_groups,heaps,error)
-				= specialize_generic_bimap gc_generic gtr_type spec_env gc_ident gc_pos main_module_index predefs funs_and_groups heaps error
-			= (expr,funs_and_groups,td_infos,heaps,error)
-
-			# ({gen_OBJECT_CONS_FIELD_indices},generic_heap) = readPtr gen_info_ptr heaps.hp_generic_heap
-			  heaps = {heaps & hp_generic_heap=generic_heap}
-
-			# (expr,td_infos,heaps,error)
-				= specializeGeneric gc_generic gtr_type spec_env gc_ident gc_pos gen_OBJECT_CONS_FIELD_indices main_module_index td_infos heaps error
-			= (expr,funs_and_groups,td_infos,heaps,error)
-
-	// the body expression
-	build_body_expr No specialized_expr [] []
-		= specialized_expr
-	build_body_expr No specialized_expr [] original_arg_exprs
-		= specialized_expr @ original_arg_exprs
-	build_body_expr No specialized_expr adapted_arg_exprs []
-		= specialized_expr @ adapted_arg_exprs
-	build_body_expr No specialized_expr adapted_arg_exprs original_arg_exprs
-		= specialized_expr @ (adapted_arg_exprs++original_arg_exprs)
-	build_body_expr (Yes adaptor_expr) specialized_expr [] []
-		= adaptor_expr @ [specialized_expr]
-	build_body_expr (Yes adaptor_expr) specialized_expr [] original_arg_exprs
-		= (adaptor_expr @ [specialized_expr]) @ original_arg_exprs
-	build_body_expr (Yes adaptor_expr) specialized_expr adapted_arg_exprs []
-		= adaptor_expr @ [specialized_expr @ adapted_arg_exprs]
-	build_body_expr (Yes adaptor_expr) specialized_expr adapted_arg_exprs original_arg_exprs
-		= (adaptor_expr @ [specialized_expr @ adapted_arg_exprs]) @ original_arg_exprs
-
 buildGenericCaseBody main_module_index {gc_ident,gc_pos} has_generic_info st predefs funs_and_groups td_infos modules heaps error
 	# error = reportError gc_ident gc_pos "cannot specialize to this type" error
 	= (TransformedBody {tb_args=[], tb_rhs=EE}, funs_and_groups, td_infos, modules, heaps, error)
@@ -2466,44 +2495,101 @@ is_bimap_id (GTSAppCons KindConst []) = True
 is_bimap_id GTSAppConsBimapKindConst = True
 is_bimap_id _ = False
 
-specialize_generic_from_bimap ::
+adapt_with_specialized_generic_bimap ::
 		!GlobalIndex			// generic index
 		!GenTypeStruct 			// type to specialize to
 		![(TypeVar, TypeVarInfo)] // specialization environment
 		!Ident					// generic/generic case
 		!Position				// of generic case
 		![Expression]
+		!Expression
 		!Index 					// main_module index
 		!PredefinedSymbols
-		!FunsAndGroups !*Heaps !*ErrorAdmin
-	-> (!Optional Expression, ![Expression], ![Expression],
-		!FunsAndGroups,!*Heaps,!*ErrorAdmin)
-specialize_generic_from_bimap gen_index type spec_env gen_ident gen_pos arg_exprs main_module_index predefs funs_and_groups heaps error
+		!FunsAndGroups !*Modules !*Heaps !*ErrorAdmin
+	-> (!Expression,
+		!FunsAndGroups,!*Modules,!*Heaps,!*ErrorAdmin)
+adapt_with_specialized_generic_bimap gen_index type spec_env gen_ident gen_pos arg_exprs specialized_expr main_module_index predefs
+		funs_and_groups modules heaps error
 	#! heaps = set_tvs spec_env heaps
-	#! (optional_adaptor_expr, adapted_arg_exprs, arg_exprs, (funs_and_groups, heaps, error))
-		= specialize_args_and_result arg_exprs type (funs_and_groups, heaps, error)
+	#! (adapted_arg_exprs, arg_exprs, type, st)
+		= adapt_args arg_exprs type (funs_and_groups, modules, heaps, error)
+	#! (body_expr, (funs_and_groups, modules, heaps, error))
+		= adapt_result arg_exprs type specialized_expr adapted_arg_exprs st
 	# heaps = clear_tvs spec_env heaps
-	= (optional_adaptor_expr, adapted_arg_exprs, arg_exprs, funs_and_groups, heaps, error)
+	= (body_expr, funs_and_groups, modules, heaps, error)
 where
-	specialize_args_and_result [arg_expr:arg_exprs] (GTSArrow arg_type args_type) st
+	adapt_args [arg_expr:arg_exprs] (GTSArrow arg_type args_type) st
 		# (adapted_arg_expr,st)
 		  	= adapt_arg arg_type arg_expr st
-		  (adaptor_expr,adapted_arg_exprs,arg_exprs,st)
-			= specialize_args_and_result arg_exprs args_type st
-		= (adaptor_expr,[adapted_arg_expr:adapted_arg_exprs],arg_exprs,st)
-	specialize_args_and_result arg_exprs type st
-		| is_bimap_id type
-			= (No, [], arg_exprs, st)
-			# (adaptor_expr,st)
-				= specialize_from type st
-			= (Yes adaptor_expr,[],arg_exprs,st)
+		  (adapted_arg_exprs,arg_exprs,args_type,st)
+			= adapt_args arg_exprs args_type st
+		= ([adapted_arg_expr:adapted_arg_exprs],arg_exprs,args_type,st)
+	adapt_args arg_exprs args_type st
+		= ([],arg_exprs,args_type,st)
 
 	adapt_arg arg_type arg_expr st
 		| is_bimap_id arg_type
 			= (arg_expr,st)
-			# (arg_adaptor_expr,st)
-				= specialize_to arg_type st
-			= (arg_adaptor_expr @ [arg_expr],st)
+			= specialize_to_with_arg arg_type arg_expr st
+
+	adapt_result arg_exprs type specialized_expr adapted_arg_exprs st
+		| is_bimap_id type
+			= (build_body_expr specialized_expr adapted_arg_exprs arg_exprs,st)
+			with
+				build_body_expr specialized_expr [] []
+					= specialized_expr
+				build_body_expr specialized_expr [] original_arg_exprs
+					= specialized_expr @ original_arg_exprs
+				build_body_expr specialized_expr adapted_arg_exprs []
+					= specialized_expr @ adapted_arg_exprs
+				build_body_expr specialized_expr adapted_arg_exprs original_arg_exprs
+					= specialized_expr @ (adapted_arg_exprs++original_arg_exprs)
+
+			#! specialized_expr_with_adapted_args
+				= case adapted_arg_exprs of
+					[] -> specialized_expr
+					_  -> specialized_expr @ adapted_arg_exprs
+			= case arg_exprs of
+				[]
+					-> specialize_from_with_arg type specialized_expr_with_adapted_args st
+				_
+					# (adapted_expr,st)
+						= specialize_from_with_arg type specialized_expr_with_adapted_args st
+					-> (adapted_expr @ arg_exprs, st)
+
+	specialize_to_with_arg (GTSVar tv=:{tv_info_ptr}) arg (funs_and_groups, modules, heaps=:{hp_type_heaps=th=:{th_vars}}, error)
+		# (expr, th_vars) = readPtr tv_info_ptr th_vars
+		# heaps = {heaps & hp_type_heaps = {th & th_vars = th_vars}}
+		= case expr of
+			TVI_Expr expr
+				# expr = build_map_to_expr expr predefs @ [arg]
+				-> (expr, (funs_and_groups, modules, heaps, error))
+			TVI_Iso iso_ds to_ds from_ds
+				# (expr,heaps) = buildFunApp main_module_index to_ds [arg] heaps
+				-> (expr, (funs_and_groups, modules, heaps, error))
+	specialize_to_with_arg (GTSAppConsSimpleType type_symbol_n kind arg_types) arg st
+		= bimap_to_simple_type type_symbol_n kind arg_types arg st
+	specialize_to_with_arg type arg st
+		# (adaptor_expr,st)
+			= specialize_to type st
+		= (adaptor_expr @ [arg],st)
+
+	specialize_from_with_arg (GTSVar tv=:{tv_info_ptr}) arg (funs_and_groups, modules, heaps=:{hp_type_heaps=th=:{th_vars}}, error)
+		# (expr, th_vars) = readPtr tv_info_ptr th_vars
+		# heaps = {heaps & hp_type_heaps = {th & th_vars = th_vars}}
+		= case expr of
+			TVI_Expr expr
+				# expr = build_map_from_expr expr predefs @ [arg]
+				-> (expr, (funs_and_groups, modules, heaps, error))
+			TVI_Iso iso_ds to_ds from_ds
+				# (expr,heaps) = buildFunApp main_module_index from_ds [arg] heaps
+				-> (expr, (funs_and_groups, modules, heaps, error))
+	specialize_from_with_arg (GTSAppConsSimpleType type_symbol_n kind arg_types) arg st
+		= bimap_from_simple_type type_symbol_n kind arg_types arg st
+	specialize_from_with_arg type arg st
+		# (adaptor_expr,st)
+			= specialize_from type st
+		= (adaptor_expr @ [arg],st)
 
 	specialize_from (GTSArrow (GTSAppCons KindConst []) y) st
 		= specialize_from_arrow_arg_id y st
@@ -2513,7 +2599,7 @@ where
 		= specialize_from_arrow_res_id x st
 	specialize_from (GTSArrow x GTSAppConsBimapKindConst) st
 		= specialize_from_arrow_res_id x st
-	specialize_from (GTSArrow (GTSVar {tv_info_ptr=xp}) (GTSVar {tv_info_ptr=yp})) (funs_and_groups, heaps=:{hp_type_heaps=th=:{th_vars}}, error)
+	specialize_from (GTSArrow (GTSVar {tv_info_ptr=xp}) (GTSVar {tv_info_ptr=yp})) (funs_and_groups, modules, heaps=:{hp_type_heaps=th=:{th_vars}}, error)
 		# (x_expr, th_vars) = readPtr xp th_vars
 		  (y_expr, th_vars) = readPtr yp th_vars
 		  heaps = {heaps & hp_type_heaps = {th & th_vars = th_vars}}
@@ -2521,115 +2607,123 @@ where
 			# (y,heaps) = build_map_from_tvi_expr y_expr main_module_index predefs heaps
 			  (expr, funs_and_groups, heaps)
 				= bimap_from_arrow_arg_id_expression [y] main_module_index predefs funs_and_groups heaps
-			= (expr, (funs_and_groups, heaps, error))
+			= (expr, (funs_and_groups, modules, heaps, error))
 		| is_bimap_id_expression y_expr main_module_index funs_and_groups
 			# (x,heaps) = build_map_to_tvi_expr x_expr main_module_index predefs heaps
 			  (expr, funs_and_groups, heaps)
 				= bimap_from_arrow_res_id_expression [x] main_module_index predefs funs_and_groups heaps
-			= (expr, (funs_and_groups, heaps, error))
+			= (expr, (funs_and_groups, modules, heaps, error))
 			# (x,heaps) = build_map_to_tvi_expr x_expr main_module_index predefs heaps
 			  (y,heaps) = build_map_from_tvi_expr y_expr main_module_index predefs heaps
 			  (expr, funs_and_groups, heaps)
 				= bimap_from_arrow_expression [x,y] main_module_index predefs funs_and_groups heaps
-			= (expr, (funs_and_groups, heaps, error))
-	specialize_from (GTSArrow (GTSVar {tv_info_ptr}) y) (funs_and_groups, heaps=:{hp_type_heaps=th=:{th_vars}}, error)
+			= (expr, (funs_and_groups, modules, heaps, error))
+	specialize_from (GTSArrow (GTSVar {tv_info_ptr}) y) (funs_and_groups, modules, heaps=:{hp_type_heaps=th=:{th_vars}}, error)
 		#! (expr, th_vars) = readPtr tv_info_ptr th_vars
 		# heaps = {heaps & hp_type_heaps = {th & th_vars = th_vars}}
 		| is_bimap_id_expression expr main_module_index funs_and_groups
-			# st = (funs_and_groups, heaps, error)
+			# st = (funs_and_groups, modules, heaps, error)
 			= specialize_from_arrow_arg_id y st
 			# (x,heaps) = build_map_to_tvi_expr expr main_module_index predefs heaps
-			  (y, (funs_and_groups, heaps, error)) = specialize_from y (funs_and_groups, heaps, error)
+			  (y, (funs_and_groups, modules, heaps, error))
+			  	= specialize_from y (funs_and_groups, modules, heaps, error)
 			  (expr, funs_and_groups, heaps)
 				= bimap_from_arrow_expression [x,y] main_module_index predefs funs_and_groups heaps
-			= (expr, (funs_and_groups, heaps, error))
-	specialize_from (GTSArrow x (GTSVar {tv_info_ptr})) (funs_and_groups, heaps=:{hp_type_heaps=th=:{th_vars}}, error)
+			= (expr, (funs_and_groups, modules, heaps, error))
+	specialize_from (GTSArrow x (GTSVar {tv_info_ptr})) (funs_and_groups, modules, heaps=:{hp_type_heaps=th=:{th_vars}}, error)
 		#! (expr, th_vars) = readPtr tv_info_ptr th_vars
 		# heaps = {heaps & hp_type_heaps = {th & th_vars = th_vars}}
 		| is_bimap_id_expression expr main_module_index funs_and_groups
-			# st = (funs_and_groups, heaps, error)
+			# st = (funs_and_groups, modules, heaps, error)
 			= specialize_from_arrow_res_id x st
 			# (y,heaps) = build_map_from_tvi_expr expr main_module_index predefs heaps
-			  (x, (funs_and_groups, heaps, error)) = specialize_to x (funs_and_groups, heaps, error)
+			  (x, (funs_and_groups, modules, heaps, error))
+			  	= specialize_to x (funs_and_groups, modules, heaps, error)
 			  (expr, funs_and_groups, heaps)
 				= bimap_from_arrow_expression [x,y] main_module_index predefs funs_and_groups heaps
-			= (expr, (funs_and_groups, heaps, error))
+			= (expr, (funs_and_groups, modules, heaps, error))
 	specialize_from (GTSArrow x y) st
 		#! (x, st) = specialize_to x st
 		#! (y, st) = specialize_from y st
-		# (funs_and_groups, heaps, error) = st
+		# (funs_and_groups, modules, heaps, error) = st
 		  (expr, funs_and_groups, heaps)
 			= bimap_from_arrow_expression [x,y] main_module_index predefs funs_and_groups heaps
-		= (expr, (funs_and_groups, heaps, error))
-	specialize_from (GTSVar tv=:{tv_info_ptr}) (funs_and_groups, heaps=:{hp_type_heaps=th=:{th_vars}}, error)
+		= (expr, (funs_and_groups, modules, heaps, error))
+	specialize_from (GTSVar tv=:{tv_info_ptr}) (funs_and_groups, modules, heaps=:{hp_type_heaps=th=:{th_vars}}, error)
 		# (expr, th_vars) = readPtr tv_info_ptr th_vars
 		# heaps = {heaps & hp_type_heaps = {th & th_vars = th_vars}}
 		= case expr of
 			TVI_Expr expr
 				# from_expr = build_map_from_expr expr predefs
-				-> (from_expr, (funs_and_groups, heaps, error))
+				-> (from_expr, (funs_and_groups, modules, heaps, error))
 			TVI_Iso iso_ds to_ds from_ds
 				# (expr,heaps) = buildFunApp main_module_index from_ds [] heaps
-				-> (expr, (funs_and_groups, heaps, error))
+				-> (expr, (funs_and_groups, modules, heaps, error))
 	specialize_from type=:(GTSAppBimap (KindArrow [KindConst,KindConst]) [arg1,arg2]) st
 		# (arg1,st) = specialize arg1 st
 		  (arg2,st) = specialize arg2 st
-		  (funs_and_groups, heaps, error) = st
+		  (funs_and_groups, modules, heaps, error) = st
 		  (expr, funs_and_groups, heaps)
 			= bimap_from_Bimap_expression [arg1,arg2] main_module_index predefs funs_and_groups heaps
-		= (expr, (funs_and_groups, heaps, error))
-	specialize_from type (funs_and_groups, heaps, error)
+		= (expr, (funs_and_groups, modules, heaps, error))
+	specialize_from type (funs_and_groups, modules, heaps, error)
 		#! (bimap_expr, st) 
-			= specialize type (funs_and_groups, heaps, error)
+			= specialize type (funs_and_groups, modules, heaps, error)
 		# adaptor_expr = build_map_from_expr bimap_expr predefs
 		= (adaptor_expr, st)
 
 	specialize_from_arrow_arg_id y st
 		#! (y, st) = specialize_from y st
-		# (funs_and_groups, heaps, error) = st
+		# (funs_and_groups, modules, heaps, error) = st
 		  (expr, funs_and_groups, heaps)
 			= bimap_from_arrow_arg_id_expression [y] main_module_index predefs funs_and_groups heaps
-		= (expr, (funs_and_groups, heaps, error))
+		= (expr, (funs_and_groups, modules, heaps, error))
 
 	specialize_from_arrow_res_id x st
 		#! (x, st) = specialize_to x st
-		# (funs_and_groups, heaps, error) = st
+		# (funs_and_groups, modules, heaps, error) = st
 		  (expr, funs_and_groups, heaps)
 			= bimap_from_arrow_res_id_expression [x] main_module_index predefs funs_and_groups heaps
-		= (expr, (funs_and_groups, heaps, error))
+		= (expr, (funs_and_groups, modules, heaps, error))
 
-	specialize_to (GTSVar tv=:{tv_info_ptr}) (funs_and_groups, heaps=:{hp_type_heaps=th=:{th_vars}}, error)
+	specialize_to (GTSVar tv=:{tv_info_ptr}) (funs_and_groups, modules, heaps=:{hp_type_heaps=th=:{th_vars}}, error)
 		# (expr, th_vars) = readPtr tv_info_ptr th_vars
 		# heaps = {heaps & hp_type_heaps = {th & th_vars = th_vars}}
 		= case expr of
 			TVI_Expr expr
 				# from_expr = build_map_to_expr expr predefs
-				-> (from_expr, (funs_and_groups, heaps, error))
+				-> (from_expr, (funs_and_groups, modules, heaps, error))
 			TVI_Iso iso_ds to_ds from_ds
 				# (expr,heaps) = buildFunApp main_module_index to_ds [] heaps
-				-> (expr, (funs_and_groups, heaps, error))
-	specialize_to type (funs_and_groups, heaps, error)
+				-> (expr, (funs_and_groups, modules, heaps, error))
+	specialize_to type (funs_and_groups, modules, heaps, error)
 		#! (bimap_expr, st) 
-			= specialize type (funs_and_groups, heaps, error)
+			= specialize type (funs_and_groups, modules, heaps, error)
 		# adaptor_expr = build_map_to_expr bimap_expr predefs
 		= (adaptor_expr, st)
 
-	specialize (GTSAppCons KindConst []) (funs_and_groups, heaps, error)
+	specialize (GTSAppCons KindConst []) (funs_and_groups, modules, heaps, error)
 		# (expr, funs_and_groups, heaps)
 			= bimap_id_expression main_module_index predefs funs_and_groups heaps
-		= (expr ,(funs_and_groups, heaps, error))
+		= (expr ,(funs_and_groups, modules, heaps, error))
 	specialize (GTSAppCons kind arg_types) st
 		#! (arg_exprs, st) = mapSt specialize arg_types st
-		# (funs_and_groups, heaps, error) = st
+		# (funs_and_groups, modules, heaps, error) = st
 		  (expr, heaps)
 		  	= build_generic_app kind arg_exprs gen_index gen_ident heaps
-		= (expr, (funs_and_groups, heaps, error))
+		= (expr, (funs_and_groups, modules, heaps, error))
+	specialize (GTSAppConsSimpleType _ kind arg_types) st
+		#! (arg_exprs, st) = mapSt specialize arg_types st
+		# (funs_and_groups, modules, heaps, error) = st
+		  (expr, heaps)
+		  	= build_generic_app kind arg_exprs gen_index gen_ident heaps
+		= (expr, (funs_and_groups, modules, heaps, error))
 	specialize (GTSAppBimap kind arg_types) st
 		#! (arg_exprs, st) = mapSt specialize arg_types st
-		# (funs_and_groups, heaps, error) = st
+		# (funs_and_groups, modules, heaps, error) = st
 		  (expr, heaps)
 		  	= build_generic_app kind arg_exprs gen_index gen_ident heaps
-		= (expr, (funs_and_groups, heaps, error))
+		= (expr, (funs_and_groups, modules, heaps, error))
 	specialize (GTSAppVar tv arg_types) st
 		#! (arg_exprs, st) = mapSt specialize arg_types st
 		#! (expr, st) = specialize_type_var tv st 
@@ -2639,43 +2733,172 @@ where
 	specialize (GTSArrow x y) st
 		| is_bimap_id x
 			#! (y, st) = specialize y st
-			# (funs_and_groups, heaps, error) = st
+			# (funs_and_groups, modules, heaps, error) = st
 			  (expr, funs_and_groups, heaps)
 				= bimap_arrow_arg_id_expression [y] main_module_index predefs funs_and_groups heaps
-			= (expr, (funs_and_groups, heaps, error))
+			= (expr, (funs_and_groups, modules, heaps, error))
 		| is_bimap_id y
 			#! (x, st) = specialize x st
-			# (funs_and_groups, heaps, error) = st
+			# (funs_and_groups, modules, heaps, error) = st
 			  (expr, funs_and_groups, heaps)
 				= bimap_arrow_res_id_expression [x] main_module_index predefs funs_and_groups heaps
-			= (expr, (funs_and_groups, heaps, error))
+			= (expr, (funs_and_groups, modules, heaps, error))
 			#! (x, st) = specialize x st
 			#! (y, st) = specialize y st
-			# (funs_and_groups, heaps, error) = st
+			# (funs_and_groups, modules, heaps, error) = st
 			  (expr, funs_and_groups, heaps)
 				= bimap_arrow_expression [x,y] main_module_index predefs funs_and_groups heaps
-			= (expr, (funs_and_groups, heaps, error))
-	specialize GTSAppConsBimapKindConst (funs_and_groups, heaps, error)
+			= (expr, (funs_and_groups, modules, heaps, error))
+	specialize GTSAppConsBimapKindConst (funs_and_groups, modules, heaps, error)
 		# (expr, funs_and_groups, heaps)
 			= bimap_id_expression main_module_index predefs funs_and_groups heaps
-		= (expr ,(funs_and_groups, heaps, error))
-	specialize type (funs_and_groups, heaps, error)
+		= (expr ,(funs_and_groups, modules, heaps, error))
+	specialize type (funs_and_groups, modules, heaps, error)
 		#! error = reportError gen_ident gen_pos "cannot specialize " error 
-		= (EE, (funs_and_groups, heaps, error))
+		= (EE, (funs_and_groups, modules, heaps, error))
 
-	specialize_type_var tv=:{tv_info_ptr} (funs_and_groups, heaps=:{hp_type_heaps=th=:{th_vars}}, error)		
+	specialize_type_var tv=:{tv_info_ptr} (funs_and_groups, modules, heaps=:{hp_type_heaps=th=:{th_vars}}, error)		
 		# (expr, th_vars) = readPtr tv_info_ptr th_vars
 		# heaps = {heaps & hp_type_heaps = {th & th_vars = th_vars}}
 		= case expr of
 			TVI_Expr expr
-				-> (expr, (funs_and_groups, heaps, error))
+				-> (expr, (funs_and_groups, modules, heaps, error))
 			TVI_Iso iso_ds to_ds from_ds
 				# (expr,heaps) = buildFunApp main_module_index iso_ds [] heaps
-				-> (expr, (funs_and_groups, heaps, error))
+				-> (expr, (funs_and_groups, modules, heaps, error))
 
 	build_generic_app kind arg_exprs gen_index gen_ident heaps
 		= buildGenericApp gen_index.gi_module gen_index.gi_index gen_ident kind arg_exprs heaps 
 
+	bimap_to_simple_type :: !(Global Index) !TypeKind ![GenTypeStruct] !Expression !*(!FunsAndGroups,!*{#CommonDefs},!*Heaps,!*ErrorAdmin)
+																  -> *(!Expression,!*(!FunsAndGroups,!*{#CommonDefs},!*Heaps,!*ErrorAdmin))
+	bimap_to_simple_type global_type_def_index=:{glob_module} (KindArrow kinds) arg_types arg (funs_and_groups,modules,heaps,error)
+		# (alts,constructors_arg_types,modules,heaps)
+			= determine_constructors_arg_types global_type_def_index arg_types modules heaps
+		# (alg_patterns,funs_and_groups,modules,heaps,error)
+			= build_to_alg_patterns alts constructors_arg_types glob_module funs_and_groups modules heaps error
+		= build_bimap_case global_type_def_index arg alg_patterns funs_and_groups modules heaps error
+	where
+		build_to_alg_patterns [cons_ds=:{ds_ident,ds_index,ds_arity}:alts] [constructor_arg_types:constructors_arg_types] type_module_n funs_and_groups modules heaps error
+			# arg_names = ["x" +++ toString k \\ k <- [1..ds_arity]]
+			# (var_exprs, vars, heaps) = buildVarExprs arg_names heaps
+			# (args,(funs_and_groups,modules,heaps,error))
+				= specialize_to_with_args constructor_arg_types var_exprs (funs_and_groups,modules,heaps,error)
+			# (alg_pattern,heaps)
+				= build_alg_pattern cons_ds vars args type_module_n heaps
+			# (alg_patterns,funs_and_groups,modules,heaps,error)
+				= build_to_alg_patterns alts constructors_arg_types type_module_n funs_and_groups modules heaps error
+			= ([alg_pattern:alg_patterns],funs_and_groups,modules,heaps,error)
+		build_to_alg_patterns [] [] type_module_n funs_and_groups modules heaps error
+			= ([],funs_and_groups,modules,heaps,error)
+	
+		specialize_to_with_args [type:types] [arg:args] st
+			| is_bimap_id type
+				# (args,st)
+					= specialize_to_with_args types args st
+				= ([arg:args],st)
+				# (arg,st)
+					= specialize_to_with_arg type arg st
+				# (args,st)
+					= specialize_to_with_args types args st
+				= ([arg:args],st)
+		specialize_to_with_args [] [] st
+			= ([],st)
+
+	bimap_from_simple_type :: !(Global Index) !TypeKind ![GenTypeStruct] !Expression !*(!FunsAndGroups,!*{#CommonDefs},!*Heaps,!*ErrorAdmin)
+																	-> *(!Expression,!*(!FunsAndGroups,!*{#CommonDefs},!*Heaps,!*ErrorAdmin))
+	bimap_from_simple_type global_type_def_index=:{glob_module} (KindArrow kinds) arg_types arg (funs_and_groups,modules,heaps,error)
+		# (alts,constructors_arg_types,modules,heaps)
+			= determine_constructors_arg_types global_type_def_index arg_types modules heaps
+		# (alg_patterns,funs_and_groups,modules,heaps,error)
+			= build_from_alg_patterns alts constructors_arg_types glob_module funs_and_groups modules heaps error
+		= build_bimap_case global_type_def_index arg alg_patterns funs_and_groups modules heaps error
+	where
+		build_from_alg_patterns [cons_ds=:{ds_ident,ds_index,ds_arity}:alts] [constructor_arg_types:constructors_arg_types] type_module_n funs_and_groups modules heaps error
+			# arg_names = ["x" +++ toString k \\ k <- [1..ds_arity]]
+			# (var_exprs, vars, heaps) = buildVarExprs arg_names heaps
+			# (args,(funs_and_groups,modules,heaps,error))
+				= specialize_from_with_args constructor_arg_types var_exprs (funs_and_groups,modules,heaps,error)
+			# (alg_pattern,heaps)
+				= build_alg_pattern cons_ds vars args type_module_n heaps
+			# (alg_patterns,funs_and_groups,modules,heaps,error)
+				= build_from_alg_patterns alts constructors_arg_types type_module_n funs_and_groups modules heaps error
+			= ([alg_pattern:alg_patterns],funs_and_groups,modules,heaps,error)
+		build_from_alg_patterns [] [] type_module_n funs_and_groups modules heaps error
+			= ([],funs_and_groups,modules,heaps,error)
+	
+		specialize_from_with_args [type:types] [arg:args] st
+			| is_bimap_id type
+				# (args,st)
+					= specialize_from_with_args types args st
+				= ([arg:args],st)
+				# (arg,st)
+					= specialize_from_with_arg type arg st
+				# (args,st)
+					= specialize_from_with_args types args st
+				= ([arg:args],st)
+		specialize_from_with_args [] [] st
+			= ([],st)
+
+	determine_constructors_arg_types :: !(Global Index) ![GenTypeStruct] !*Modules !*Heaps
+								 -> (![DefinedSymbol],![[GenTypeStruct]],!*Modules,!*Heaps)
+	determine_constructors_arg_types {glob_module,glob_object} arg_types modules heaps
+		# ({td_args,td_rhs=AlgType alts},modules) = modules![glob_module].com_type_defs.[glob_object]
+
+		# {hp_type_heaps} = heaps
+		# th_vars = number_type_arguments td_args 0 hp_type_heaps.th_vars
+		# arg_types_a = {!arg_type\\arg_type<-arg_types}
+		# (constructors_arg_types,modules,th_vars)
+			= compute_constructors_arg_types alts glob_module arg_types_a modules th_vars
+		# th_vars = remove_type_argument_numbers td_args th_vars
+		# heaps = {heaps & hp_type_heaps={hp_type_heaps & th_vars=th_vars}}
+		= (alts,constructors_arg_types,modules,heaps)
+	where
+		compute_constructors_arg_types :: ![DefinedSymbol] !Int !{!GenTypeStruct} !*Modules !*TypeVarHeap
+														   -> (![[GenTypeStruct]],!*Modules,!*TypeVarHeap)
+		compute_constructors_arg_types [cons_ds=:{ds_ident,ds_index}:alts] type_module_n arg_types_a modules th_vars
+			# ({cons_type={st_args}},modules) = modules![type_module_n].com_cons_defs.[ds_index]
+			# (constructor_arg_numbers,th_vars)
+				= compute_constructor_arg_types st_args arg_types_a th_vars
+			# (constructors_arg_numbers,modules,th_vars)
+				= compute_constructors_arg_types alts type_module_n arg_types_a modules th_vars
+			= ([constructor_arg_numbers:constructors_arg_numbers],modules,th_vars)
+		compute_constructors_arg_types [] type_module_n arg_types_a modules th_vars
+			= ([],modules,th_vars)
+
+		compute_constructor_arg_types :: ![AType] !{!GenTypeStruct} !*TypeVarHeap -> (![GenTypeStruct],!*TypeVarHeap)
+		compute_constructor_arg_types [{at_type=TV {tv_info_ptr}}:atypes] arg_types_a th_vars
+			# (TVI_GenTypeVarNumber constructor_arg_number,th_vars)
+				= readPtr tv_info_ptr th_vars
+			#! constructor_arg_types = arg_types_a.[constructor_arg_number]
+			# (constructors_arg_types,th_vars)
+				= compute_constructor_arg_types atypes arg_types_a th_vars
+			= ([constructor_arg_types:constructors_arg_types],th_vars);
+		compute_constructor_arg_types [] arg_types_a th_vars
+			= ([],th_vars)
+
+	build_bimap_case :: !(Global Index) !.Expression ![AlgebraicPattern] !FunsAndGroups !*Modules !*Heaps !*ErrorAdmin
+													   -> (!Expression,!(!FunsAndGroups,!*Modules,!*Heaps,!*ErrorAdmin))
+	build_bimap_case global_type_def_index arg alg_patterns funs_and_groups modules heaps error
+		# case_patterns = AlgebraicPatterns global_type_def_index alg_patterns
+		# (expr_info_ptr, hp_expression_heap) = newPtr EI_Empty heaps.hp_expression_heap
+		# case_expr = Case {case_expr = arg, case_guards = case_patterns, case_default = No, case_ident = No,
+							case_info_ptr = expr_info_ptr, case_explicit = True, case_default_pos = NoPos}
+		# heaps = {heaps & hp_expression_heap = hp_expression_heap}
+		= (case_expr, (funs_and_groups,modules,heaps,error))
+
+	build_alg_pattern :: !DefinedSymbol ![FreeVar] ![Expression] !Int !*Heaps -> (!AlgebraicPattern,!*Heaps)
+	build_alg_pattern cons_ds=:{ds_ident,ds_index} vars args type_module_n heaps
+		# cons_symbol = {glob_module = type_module_n, glob_object = cons_ds}
+		# cons_symb_ident = {symb_ident = ds_ident, symb_kind = SK_Constructor {glob_module = type_module_n,glob_object = ds_index}}
+
+		# (expr_info_ptr, hp_expression_heap) = newPtr EI_Empty heaps.hp_expression_heap
+		# expr = App {app_symb = cons_symb_ident, app_args = args, app_info_ptr = expr_info_ptr} 
+
+		#! alg_pattern = { ap_symbol = cons_symbol, ap_vars = vars, ap_expr = expr, ap_position = NoPos }
+		# heaps = {heaps & hp_expression_heap = hp_expression_heap}
+		= (alg_pattern,heaps)
+
 is_bimap_id_expression (TVI_Expr (App {app_symb={symb_kind=SK_Function fun_glob},app_args=[]})) main_module_index {fg_bimap_functions={bimap_id_function={fii_index}}}
 	= fii_index>=0 && fun_glob.glob_module==main_module_index && fun_glob.glob_object==fii_index
 is_bimap_id_expression _ main_module_index _
@@ -2693,6 +2916,20 @@ clear_tvs spec_env heaps=:{hp_type_heaps=hp_type_heaps=:{th_vars}}
 				= writePtr tv_info_ptr TVI_Empty th_vars		
 	= {heaps & hp_type_heaps = {hp_type_heaps & th_vars = th_vars }}
 
+number_type_arguments :: ![ATypeVar] !Int !*TypeVarHeap -> *TypeVarHeap
+number_type_arguments [{atv_variable={tv_info_ptr}}:atype_vars] arg_n th_vars
+	# th_vars = writePtr tv_info_ptr (TVI_GenTypeVarNumber arg_n) th_vars
+	= number_type_arguments atype_vars (arg_n+1) th_vars
+number_type_arguments [] arg_n th_vars
+	= th_vars
+
+remove_type_argument_numbers :: ![ATypeVar] !*TypeVarHeap -> *TypeVarHeap
+remove_type_argument_numbers [{atv_variable={tv_info_ptr}}:atype_vars] th_vars
+	# th_vars = writePtr tv_info_ptr TVI_Empty th_vars
+	= remove_type_argument_numbers atype_vars th_vars
+remove_type_argument_numbers [] th_vars
+	= th_vars
+
 build_bimap_with_calls map_id_index map_id_ident to_args from_args main_module_index predefs heaps
 	# (map_to_expr,heaps) = buildFunApp2 main_module_index map_id_index map_id_ident to_args heaps
 	  (map_from_expr,heaps) = buildFunApp2 main_module_index map_id_index map_id_ident from_args heaps
@@ -3088,24 +3325,20 @@ where
 		# fresh_gtvs = take (length gtvs) fresh_st.st_vars		
 		= (fresh_st, fresh_gtvs, th)
 
-	build_symbol_type :: 
+	build_symbol_type ::
 			 !SymbolType 	// generic type, 
-			 ![ATypeVar]		// attributed generic variables
+			 ![ATypeVar]	// attributed generic variables
 			 !TypeKind 		// kind to specialize to 
 			 !Int 			// current order (in the sense of the order of the kind)
-			 !*TypeHeaps
-			 !*ErrorAdmin	
+			 !*TypeHeaps !*ErrorAdmin
 		-> ( !SymbolType	// new generic type
 			, ![ATypeVar]	// fresh copies of generic variables created for the 
 							// generic arguments
-			, !*TypeHeaps
-			, !*ErrorAdmin
-			)
+			, !*TypeHeaps, !*ErrorAdmin)
 	build_symbol_type st gatvs KindConst order th error	
 		= (st, [], th, error)
 	build_symbol_type st gatvs (KindArrow kinds) order th error
 		| order > 2
-				//---> ("build_symbol_type called for", (KindArrow kinds), gatvs, st)
 			# error = reportError ident pos "kinds of order higher then 2 are not supported" error
 			= (st, [], th, error)
 		
@@ -3157,7 +3390,6 @@ where
 			)
 	build_arg st gatvs order kind (arg_num, th, error)		
 		#! th = clearSymbolType st th
-			//---> ("build_arg called for", arg_num, kind, gatvs, st)
 		#! (fresh_gatvs, th) = mapSt subst_gatv gatvs th 
 		#! (new_st, th) = applySubstInSymbolType st th
 		
@@ -3169,7 +3401,6 @@ where
 		#! curry_st = adjust_forall curry_st forall_atvs
 				
 		= ((curry_st, fresh_gatvs), (inc arg_num, th, error))
-			//---> ("build_arg returns", fresh_gatvs, curry_st)		
 	where
 		postfix = toString arg_num
 
@@ -3188,7 +3419,7 @@ where
 		subst_attr (TA_Var {av_ident, av_info_ptr}) th_attrs 
 			# (av, th_attrs) = freshAttrVar (postfixIdent av_ident.id_name postfix) th_attrs
 			= (TA_Var av, writePtr av_info_ptr (AVI_Attr (TA_Var av)) th_attrs)
-				//---> ("(2) writePtr av_info_ptr", ptrToInt av_info_ptr, av)
+
 		subst_attr TA_Multi th = (TA_Multi, th)
 		subst_attr TA_Unique th = (TA_Unique, th)
 
@@ -3201,8 +3432,7 @@ where
 					= curry_st.st_attr_vars -- [av \\ {atv_attribute=TA_Var av} <- forall_atvs]
 				, st_vars 
 					= curry_st.st_vars -- [atv_variable \\ {atv_variable} <- forall_atvs]
-				} 
-				//---> ("adjust forall", curry_st.st_vars, forall_atvs, curry_st.st_vars -- [atv_variable \\ {atv_variable} <- forall_atvs])								
+				}
 
 	build_body :: 
 			!SymbolType 
@@ -3655,9 +3885,7 @@ clearSymbolType st th
 	// clears not only st_vars and st_attrs, but also TFA variables
 	= clearType ((st.st_result, st.st_args), st.st_context) th
 
-//----------------------------------------------------------------------------------------
 // collect variables
-//----------------------------------------------------------------------------------------
 
 collectTypeVarsAndAttrVars ::
 		!type 
@@ -3763,7 +3991,6 @@ markAttrVarUsed {av_info_ptr} th_attrs
 	= case av_info of
 		AVI_Empty -> (False, writePtr av_info_ptr AVI_Used th_attrs)
 		AVI_Used  -> (True, th_attrs)
-		
 
 simplifyTypeApp :: !Type ![AType] -> Type
 simplifyTypeApp (TA type_cons=:{type_arity} cons_args) type_args
@@ -3778,11 +4005,8 @@ simplifyTypeApp (TV tv) type_args = CV tv :@: type_args
 simplifyTypeApp (TB _) type_args = TE
 simplifyTypeApp (TArrow1 _) type_args = TE
 		
-//----------------------------------------------------------------------------------------
 // substitutions
-//----------------------------------------------------------------------------------------
 
-//
 // Uninitialized variables are not substituted, but left intact
 //
 // This behaviour is needed for kind indexing generic types,
@@ -4196,8 +4420,7 @@ foldExpr f expr=:(DynamicExpr {dyn_expr}) st
 foldExpr f EE st 
 	= st
 foldExpr f expr st 
-	= abort "generic.icl: foldExpr does not match\n"//f expr st
-		---> ("foldExpr does not match", expr)
+	= abort "generic.icl: foldExpr does not match\n"
 
 // needed for collectCalls
 instance == FunCall where (==) (FunCall x _) (FunCall y _) = x == y
diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl
index 295e60b..851125e 100644
--- a/frontend/syntax.dcl
+++ b/frontend/syntax.dcl
@@ -551,12 +551,13 @@ NoGlobalIndex :== {gi_module=NoIndex,gi_index=NoIndex}
  	| GTSCons DefinedSymbol GenTypeStruct
  	| GTSField DefinedSymbol GenTypeStruct
  	| GTSObject DefinedSymbol GenTypeStruct
- 	| GTSE
+	| GTSPair !GenTypeStruct !GenTypeStruct		// for optimizing bimaps
+	| GTSEither !GenTypeStruct !GenTypeStruct	// for optimizing bimaps
 	| GTSArrow GenTypeStruct GenTypeStruct		// for optimizing bimaps
+ 	| GTSE
 	| GTSAppConsBimapKindConst					// for optimizing bimaps
 	| GTSAppBimap TypeKind [GenTypeStruct]		// for optimizing bimaps
-	| GTSPair !GenTypeStruct !GenTypeStruct		// for optimizing bimaps
-	| GTSEither !GenTypeStruct !GenTypeStruct	// for optimizing bimaps
+	| GTSAppConsSimpleType !(Global Index) !TypeKind ![GenTypeStruct]	// for optimizing bimaps
 
 :: GenericTypeRep = 
 	{ gtr_type :: GenTypeStruct		// generic structure type