[m-rev.] for review: fix existential typeclass reordering bug

[Simon Taylor]

Estimated hours taken: 1.5
Branches: main, release

compiler/polymorphism.m:
	Previously, we assumed that when a type variable had not
	been seen before, a type_info would be produced for
	it by a later goal. This didn't work when the type_info
	was contained in a typeclass_info produced by the later
	goal. Now whenever an existential typeclass_info is produced
	by a call or deconstruction unification, the type_info_varmap
	entries for such type variables are updated to point to the
	type_class_info, and code is generated to extract the type_info
	from the typeclass_info.

tests/hard_coded/Mmakefile:
tests/hard_coded/existential_reordering_class.{m,exp}:
	Before this change, the compiler reported a spurious mode
	error for this test case.

Index: compiler/polymorphism.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/polymorphism.m,v
retrieving revision 1.224
diff -u -u -r1.224 polymorphism.m
--- compiler/polymorphism.m	11 Jun 2002 09:30:49 -0000	1.224
+++ compiler/polymorphism.m	11 Jun 2002 15:50:27 -0000
@@ -1580,17 +1580,11 @@
 	;
 		IsConstruction = no,
 		% assume it's a deconstruction
-		polymorphism__make_typeclass_info_head_vars(	
-				ExistentialConstraints, 
-				ExtraTypeClassVars,
-				PolyInfo1, PolyInfo2),
-		ExtraTypeClassGoals = [],
-		polymorphism__update_typeclass_infos(
+		polymorphism__make_existq_typeclass_info_vars(
 			ExistentialConstraints, ExtraTypeClassVars,
-			PolyInfo2, PolyInfo3)
+			ExtraTypeClassGoals, PolyInfo1, PolyInfo3)
 	),
 
-
 	%
 	% Compute the set of _unconstrained_ existentially quantified type
 	% variables, and then apply the type bindings to those type variables
@@ -1950,12 +1944,9 @@
 			% insert them into the typeclass_info map
 		apply_rec_subst_to_constraint_list(TypeSubst,
 			ExistentialConstraints1, ExistentialConstraints),
-		polymorphism__make_typeclass_info_head_vars(
-			ExistentialConstraints, ExistTypeClassVars,
-			Info2, Info3),
-		polymorphism__update_typeclass_infos(
+		polymorphism__make_existq_typeclass_info_vars(
 			ExistentialConstraints, ExistTypeClassVars,
-			Info3, Info4),
+			ExtraExistClassGoals, Info2, Info4),
 
 		list__append(UnivTypeClassVars, ExistTypeClassVars,
 			ExtraTypeClassVars),
@@ -1975,10 +1966,9 @@
 			Info4, Info),
 		list__append(ExtraTypeClassVars, ArgVars0, ArgVars1),
 		list__append(ExtraTypeInfoVars, ArgVars1, ArgVars),
-		list__append(ExtraTypeClassGoals, ExtraTypeInfoGoals,
-			ExtraGoals),
-		list__append(ExtraTypeClassVars, ExtraTypeInfoVars,
-			ExtraVars),
+		ExtraGoals = ExtraTypeClassGoals ++ ExtraExistClassGoals
+				++ ExtraTypeInfoGoals,
+		ExtraVars = ExtraTypeClassVars ++ ExtraTypeInfoVars,
 
 		%
 		% update the non-locals
@@ -2613,6 +2603,60 @@
 maybe_insert_var(no, Vars, Vars).
 maybe_insert_var(yes(Var), Vars, [Var | Vars]).
 
+%-----------------------------------------------------------------------------%
+
+	% Produce the typeclass_infos for the existential class
+	% constraints for a call or deconstruction unification.
+:- pred polymorphism__make_existq_typeclass_info_vars(
+		list(class_constraint), list(prog_var), list(hlds_goal),
+		poly_info, poly_info).
+:- mode polymorphism__make_existq_typeclass_info_vars(in, out, out,
+		in, out) is det.
+
+polymorphism__make_existq_typeclass_info_vars(
+		ExistentialConstraints, ExtraTypeClassVars,
+		ExtraGoals, PolyInfo0, PolyInfo) :-
+	poly_info_get_type_info_map(PolyInfo0, OldTypeInfoMap),
+	polymorphism__make_typeclass_info_head_vars(ExistentialConstraints,
+		ExtraTypeClassVars, PolyInfo0, PolyInfo1),
+	polymorphism__update_typeclass_infos(ExistentialConstraints,
+		ExtraTypeClassVars, PolyInfo1, PolyInfo2),
+
+	constraint_list_get_tvars(ExistentialConstraints, TVars0),
+	list__sort_and_remove_dups(TVars0, TVars),
+
+	%
+	% For code which requires mode reordering, we may have
+	% already seen some of the type-infos produced by this
+	% call. The type-info locations for those variables will
+	% be a type-info
+	%
+	list__foldl2(polymorphism__maybe_extract_type_info(OldTypeInfoMap),
+		TVars, [], ExtraGoals, PolyInfo2, PolyInfo).
+
+:- pred polymorphism__maybe_extract_type_info(type_info_varmap,
+		tvar, list(hlds_goal), list(hlds_goal),
+		poly_info, poly_info).
+:- mode polymorphism__maybe_extract_type_info(in, in, in, out, in, out) is det.
+
+polymorphism__maybe_extract_type_info(OldTypeInfoMap, TVar,
+		ExtraGoals0, ExtraGoals, Info0, Info) :-
+	poly_info_get_type_info_map(Info0, TypeInfoMap),
+	(
+		map__search(OldTypeInfoMap, TVar, type_info(TypeInfoVar0)),
+		map__search(TypeInfoMap, TVar,
+			typeclass_info(TypeClassInfoVar, Index))
+	->
+		extract_type_info(TVar, TypeClassInfoVar,
+			Index, ExtraGoals1, TypeInfoVar1, Info0, Info),
+		polymorphism__assign_var(TypeInfoVar0,
+			TypeInfoVar1, AssignGoal),
+		ExtraGoals = ExtraGoals1 ++ [AssignGoal | ExtraGoals0]
+	;
+		ExtraGoals = ExtraGoals0,
+		Info = Info0
+	).
+
 %---------------------------------------------------------------------------%
 
 % Given a list of types, create a list of variables to hold the type_info
@@ -3231,10 +3275,22 @@
 			First, _),
 			
 
-			% Work out which ones haven't been seen before
+			% Work out which type variables we haven't seen
+			% before, or which we assumed earlier would be
+			% produced in a type-info (this can happen for
+			% code which needs mode reordering and which calls
+			% existentially quantified predicates or
+			% deconstructs existentially quantified terms).
 		IsNew = (pred(TypeVar0::in) is semidet :-
 				TypeVar0 = TypeVar - _Index,
-				\+ map__search(TypeInfoMap0, TypeVar, _)
+				(
+					map__search(TypeInfoMap0,
+						TypeVar, TypeInfoLocn)
+				->
+					TypeInfoLocn = type_info(_)
+				;
+					true
+				)	
 			),
 		list__filter(IsNew, ClassTypeVars, NewClassTypeVars),
 
Index: tests/hard_coded/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/Mmakefile,v
retrieving revision 1.153
diff -u -u -r1.153 Mmakefile
--- tests/hard_coded/Mmakefile	11 Jun 2002 09:30:53 -0000	1.153
+++ tests/hard_coded/Mmakefile	11 Jun 2002 11:05:59 -0000
@@ -46,6 +46,7 @@
 	existential_bound_tvar \
 	existential_float \
 	existential_reordering \
+	existential_reordering_class \
 	existential_type_switch_opt \
 	existential_types_test \
 	expand \
Index: tests/hard_coded/existential_reordering_class.exp
===================================================================
RCS file: tests/hard_coded/existential_reordering_class.exp
diff -N tests/hard_coded/existential_reordering_class.exp
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/existential_reordering_class.exp	13 Jan 2001 02:30:30 -0000
@@ -0,0 +1 @@
+univ_cons([])
Index: tests/hard_coded/existential_reordering_class.m
===================================================================
RCS file: tests/hard_coded/existential_reordering_class.m
diff -N tests/hard_coded/existential_reordering_class.m
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/existential_reordering_class.m	11 Jun 2002 10:15:06 -0000
@@ -0,0 +1,29 @@
+% This module tests the use of existential types,
+% including type inference.
+
+:- module existential_reordering_class.
+:- interface.
+
+:- import_module io.
+
+:- pred main(io__state::di, state::uo) is det.
+
+:- implementation.
+:- import_module enum, int, std_util, list.
+
+main -->
+	% do something which requires knowing the type of L
+	{ L = [] },
+	{ Univ = univ(L) },
+	write(Univ),
+	nl,
+
+	% now do something which binds the type of L
+	{ same_type(L, [my_exist_t]) }.
+
+:- pred same_type(T::unused, T::unused) is det.
+same_type(_, _).
+
+:- some [T] func my_exist_t = T => enum(T).
+
+my_exist_t = 42.
--------------------------------------------------------------------------
mercury-reviews mailing list
post:  mercury-reviews at cs.mu.oz.au
administrative address: owner-mercury-reviews at cs.mu.oz.au
unsubscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: unsubscribe
subscribe:   Address: mercury-reviews-request at cs.mu.oz.au Message: subscribe
--------------------------------------------------------------------------