[m-rev.] for review: fix unification type_info bug

[Simon Taylor]

Estimated hours taken: 3

compiler/polymorphism.m:
	Make sure the type-infos needed for complicated argument
	unifications of var-functor unifications are included in
	the non-locals set of the unification.
	This bug caused an MLDS code generator abort when compiling
	library/set_bbbtree.m with `--target asm'.

tests/hard_coded/Mmakefile:
tests/hard_coded/unify_typeinfo_bug.{m,exp}:
	Test case.

Index: compiler/polymorphism.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/polymorphism.m,v
retrieving revision 1.223
diff -u -u -r1.223 polymorphism.m
--- compiler/polymorphism.m	17 Apr 2002 00:52:39 -0000	1.223
+++ compiler/polymorphism.m	10 Jun 2002 17:43:02 -0000
@@ -1197,11 +1197,10 @@
 		% quantification.m uses when requantifying things.
 		%
 		=(Info0),
-		{ poly_info_get_type_info_map(Info0, TypeInfoMap) },
 		{ poly_info_get_var_types(Info0, VarTypes) },
 		{ map__lookup(VarTypes, XVar, Type) },
-		{ polymorphism__unification_typeinfos(Type, TypeInfoMap,
-			Unification0, GoalInfo0, Unification, GoalInfo) },
+		polymorphism__unification_typeinfos(Type,
+			Unification0, GoalInfo0, Unification, GoalInfo),
 		{ Goal = unify(XVar, Y, Mode, Unification,
 		 		UnifyContext) - GoalInfo }
 	; 
@@ -1230,10 +1229,38 @@
                 { goal_info_get_nonlocals(GoalInfo0, NonLocals0) },
 		{ set__union(NonLocals0, NonLocalTypeInfos, NonLocals) },
 		{ goal_info_set_nonlocals(GoalInfo0, NonLocals, GoalInfo) },
+
+		%
+		% Complicated (in-in) argument unifications are impossible
+		% for lambda expressions, so we don't need to worry about
+		% adding the type-infos that would be required for such
+		% unifications.
+		%
 		{ Goal = unify(XVar, Y1, Mode, Unification0, UnifyContext)
 				- GoalInfo }
 	).
 
+:- pred polymorphism__unification_typeinfos(type, unification,
+	hlds_goal_info, unification, hlds_goal_info, poly_info, poly_info).
+:- mode polymorphism__unification_typeinfos(in, in, in,
+	out, out, in, out) is det.
+
+polymorphism__unification_typeinfos(Type, Unification0, GoalInfo0,
+		Unification, GoalInfo, Info0, Info) :-
+	%
+	% Compute the type_info/type_class_info variables that would be
+	% used if this unification ends up being a complicated_unify.
+	%
+	type_util__vars(Type, TypeVars),
+	list__map_foldl(get_type_info_locn, TypeVars, TypeInfoLocns,
+		Info0, Info),
+
+	polymorphism__add_unification_typeinfos(TypeInfoLocns,
+		Unification0, GoalInfo0, Unification, GoalInfo).
+
+	% This variant is for use by modecheck_unify.m.
+	% During mode-checking all the type-infos should appear in
+	% the type_info_varmap.
 polymorphism__unification_typeinfos(Type, TypeInfoMap,
 		Unification0, GoalInfo0, Unification, GoalInfo) :-
 	%
@@ -1242,6 +1269,16 @@
 	%
 	type_util__vars(Type, TypeVars),
 	map__apply_to_list(TypeVars, TypeInfoMap, TypeInfoLocns),
+
+	polymorphism__add_unification_typeinfos(TypeInfoLocns,
+		Unification0, GoalInfo0, Unification, GoalInfo).
+
+:- pred polymorphism__add_unification_typeinfos(list(type_info_locn)::in,
+		unification::in, hlds_goal_info::in,
+		unification::out, hlds_goal_info::out) is det.
+
+polymorphism__add_unification_typeinfos(TypeInfoLocns,
+		Unification0, GoalInfo0, Unification, GoalInfo) :-
 	list__map(type_info_locn_var, TypeInfoLocns, TypeInfoVars0),
 	list__remove_dups(TypeInfoVars0, TypeInfoVars),
 
@@ -1366,23 +1403,33 @@
 		goal_info_get_context(GoalInfo0, Context),
 		polymorphism__process_existq_unify_functor(ConsDefn,
 			IsConstruction, ActualArgTypes, TypeOfX, Context,
-			ExtraVars, ExtraGoals, PolyInfo0, PolyInfo),
+			ExtraVars, ExtraGoals, PolyInfo0, PolyInfo1),
 		list__append(ExtraVars, ArgVars0, ArgVars),
 		goal_info_get_nonlocals(GoalInfo0, NonLocals0),
 		set__insert_list(NonLocals0, ExtraVars, NonLocals),
-		goal_info_set_nonlocals(GoalInfo0, NonLocals, GoalInfo),
+		goal_info_set_nonlocals(GoalInfo0, NonLocals, GoalInfo1),
+
+		%
+		% Some of the argument unifications may be complicated
+		% unifications, which may need type-infos.
+		%
+		polymorphism__unification_typeinfos(TypeOfX, Unification0,
+			GoalInfo1, Unification, GoalInfo, PolyInfo1, PolyInfo),
+
 		Unify = unify(X0, functor(ConsId, ArgVars), Mode0,
-				Unification0, UnifyContext) - GoalInfo,
+				Unification, UnifyContext) - GoalInfo,
 		list__append(ExtraGoals, [Unify], GoalList),
 		conj_list_to_goal(GoalList, GoalInfo0, Goal)
 	;
 		%
-		% ordinary construction/deconstruction unifications
-		% we leave alone
+		% We leave construction/deconstruction unifications alone.
+		% Some of the argument unifications may be complicated
+		% unifications, which may need type-infos.
 		%
+		polymorphism__unification_typeinfos(TypeOfX, Unification0,
+			GoalInfo0, Unification, GoalInfo, PolyInfo0, PolyInfo),
 		Goal = unify(X0, functor(ConsId0, ArgVars0), Mode0,
-				Unification0, UnifyContext) - GoalInfo0,
-		PolyInfo = PolyInfo0
+			Unification, UnifyContext) - GoalInfo
 	).
 
 convert_pred_to_lambda_goal(EvalMethod, X0, PredId, ProcId,
@@ -2631,30 +2678,46 @@
 	%
 		Type = term__variable(TypeVar)
 	->
-		poly_info_get_type_info_map(Info0, TypeInfoMap0),
-		%
-		% If we have already allocated a location for this type_info,
-		% then all we need to do is to extract the type_info variable
-		% from its location.
-		%
-		( map__search(TypeInfoMap0, TypeVar, TypeInfoLocn) ->
-			get_type_info(TypeInfoLocn, TypeVar, ExtraGoals, Var,
-				Info0, Info)
-		;
-			%
-			% Otherwise, we need to create a new type_info
-			% variable, and set the location for this type
-			% variable to be that type_info variable.
-			%
-			polymorphism__new_type_info_var(Type, "type_info",
-				typeinfo_prefix, Var, Info0, Info1),
-			map__det_insert(TypeInfoMap0, TypeVar, type_info(Var),
-				TypeInfoMap),
-			poly_info_set_type_info_map(TypeInfoMap, Info1, Info),
-			ExtraGoals = []
-		)
+		get_type_info_locn(TypeVar, TypeInfoLocn, Info0, Info1),
+		get_type_info(TypeInfoLocn, TypeVar, ExtraGoals, Var,
+				Info1, Info)
 	;
 		error("polymorphism__make_var: unknown type")
+	).
+
+:- pred get_type_info_locn(tvar, type_info_locn, poly_info, poly_info).
+:- mode get_type_info_locn(in, out, in, out) is det.
+
+get_type_info_locn(TypeVar, TypeInfoLocn, Info0, Info) :-
+	%
+	% If we have already allocated a location for this type_info,
+	% then all we need to do is to extract the type_info variable
+	% from its location.
+	%
+	poly_info_get_type_info_map(Info0, TypeInfoMap0),
+	( map__search(TypeInfoMap0, TypeVar, TypeInfoLocn0) ->
+		TypeInfoLocn = TypeInfoLocn0,
+		Info = Info0
+	;
+		%
+		% Otherwise, we need to create a new type_info
+		% variable, and set the location for this type
+		% variable to be that type_info variable.
+		%
+		% XXX This is wrong if the type variable is one of
+		% the existentially quantified variables of a called
+		% predicate and the variable occurs in an existential
+		% type-class constraint. In that case the type-info
+		% will be stored in the typeclass_info variable produced
+		% by the predicate, not in a type_info variable.
+		%
+		type_util__var(Type, TypeVar),
+		polymorphism__new_type_info_var(Type, "type_info",
+			typeinfo_prefix, Var, Info0, Info1),
+		TypeInfoLocn = type_info(Var),
+		map__det_insert(TypeInfoMap0, TypeVar, TypeInfoLocn,
+			TypeInfoMap),
+		poly_info_set_type_info_map(TypeInfoMap, Info1, Info)
 	).
 
 :- pred polymorphism__construct_type_info(type, type_ctor, list(type),
Index: tests/hard_coded/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/Mmakefile,v
retrieving revision 1.152
diff -u -u -r1.152 Mmakefile
--- tests/hard_coded/Mmakefile	10 Jun 2002 10:05:54 -0000	1.152
+++ tests/hard_coded/Mmakefile	10 Jun 2002 18:36:14 -0000
@@ -139,6 +139,7 @@
 	type_spec_modes \
 	type_to_term_bug \
 	unify_expression \
+	unify_typeinfo_bug \
 	unused_float_box_test \
 	user_defined_equality2 \
 	write \
Index: tests/hard_coded/unify_typeinfo_bug.exp
===================================================================
RCS file: tests/hard_coded/unify_typeinfo_bug.exp
diff -N tests/hard_coded/unify_typeinfo_bug.exp
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/unify_typeinfo_bug.exp	10 Jun 2002 18:35:51 -0000
@@ -0,0 +1,4 @@
+Succeeded
+Succeeded
+Succeeded
+Succeeded
Index: tests/hard_coded/unify_typeinfo_bug.m
===================================================================
RCS file: tests/hard_coded/unify_typeinfo_bug.m
diff -N tests/hard_coded/unify_typeinfo_bug.m
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/unify_typeinfo_bug.m	10 Jun 2002 18:35:31 -0000
@@ -0,0 +1,57 @@
+:- module unify_typeinfo_bug.  
+:- interface.
+
+:- import_module io, list.
+
+:- pred main(io__state::di, io__state::uo) is det.
+
+:- pred unify_bug(list(T)::in, list(T)::in) is semidet.
+
+:- pred exist_unify_bug(list(T)::in, list(T)::in) is semidet.
+
+:- type set_bbbtree(T).
+
+:- pred singleton_set(set_bbbtree(T), T).
+:- mode singleton_set(in, in) is semidet.
+
+:- implementation.
+
+main -->
+	( { unify_bug([1], [1]) } ->
+		io__write_string("Succeeded\n")
+	;
+		io__write_string("Failed\n")
+	),
+	( { exist_unify_bug([1], [1]) } ->
+		io__write_string("Succeeded\n")
+	;
+		io__write_string("Failed\n")
+	),
+	( { exist_unify_bug([1], [1]) } ->
+		io__write_string("Succeeded\n")
+	;
+		io__write_string("Failed\n")
+	),
+	( { singleton_set(tree([1], 1, empty, empty), [1]) } ->
+		io__write_string("Succeeded\n")
+	;
+		io__write_string("Failed\n")
+	).
+
+unify_bug(A, B) :-
+	A = [H | _],
+	B = [H | _].
+
+exist_unify_bug(A, B) :-
+	C = D,
+	exist_id(A, B, C, D).
+
+:- some [U] pred exist_id(T::in, T::in, U::out, U::out) is det.
+
+exist_id(A, B, A, B).
+
+:- type set_bbbtree(T)
+	--->	empty
+	;	tree(T, int, set_bbbtree(T), set_bbbtree(T)).
+
+singleton_set(tree(V, 1, empty, empty), V).
--------------------------------------------------------------------------
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
--------------------------------------------------------------------------