[m-rev.] for review: make the HLDS of unify/compare procs more type correct

[Zoltan Somogyi]

compiler/unify_proc.m:
	Make the headvars of unification and comparison predicates for
	equivalence types the right (unexpanded) type, and cast them to the
	expanded type before calling the unification/comparison predicate
	on the cast values. This should make the HLDS "more" type correct,
	as the expansion of the equivalence is now explicit.

	Also introduce explicit casts into compare pred for enums (their unify
	preds don't need them).

Zoltan.

Index: compiler/unify_proc.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/unify_proc.m,v
retrieving revision 1.97
diff -u -b -r1.97 unify_proc.m
--- compiler/unify_proc.m	2001/10/31 16:58:11	1.97
+++ compiler/unify_proc.m	2001/11/01 06:01:42
@@ -668,12 +668,7 @@
 
 unify_proc__generate_clause_info(SpecialPredId, Type, TypeBody, Context,
 		ModuleInfo, ClauseInfo) :-
-	( TypeBody = eqv_type(EqvType) ->
-		HeadVarType = EqvType
-	;
-		HeadVarType = Type
-	),
-	special_pred_info(SpecialPredId, HeadVarType,
+	special_pred_info(SpecialPredId, Type,
 		_PredName, ArgTypes, _Modes, _Det),
 	unify_proc__info_init(ModuleInfo, VarTypeInfo0),
 	unify_proc__make_fresh_named_vars_from_types(ArgTypes, "HeadVar__", 1,
@@ -699,10 +694,9 @@
 			Types, Args, Clauses, TI_VarMap, TCI_VarMap,
 			HasForeignClauses).
 
-:- pred unify_proc__generate_unify_clauses(hlds_type_body, prog_var, prog_var,
-		prog_context, list(clause), unify_proc_info, unify_proc_info).
-:- mode unify_proc__generate_unify_clauses(in, in, in, in, out, in, out)
-	is det.
+:- pred unify_proc__generate_unify_clauses(hlds_type_body::in,
+	prog_var::in, prog_var::in, prog_context::in, list(clause)::out,
+	unify_proc_info::in, unify_proc_info::out) is det.
 
 unify_proc__generate_unify_clauses(TypeBody, H1, H2, Context, Clauses) -->
 	(
@@ -740,19 +734,29 @@
 				Context, Clauses)
 		)
 	;
-		{ TypeBody = eqv_type(_Type) },
-		% We should check whether _Type is a type variable,
+		{ TypeBody = eqv_type(EqvType) },
+		% We should check whether EqvType is a type variable,
 		% an abstract type or a concrete type.
 		% If it is type variable, then we should generate the same code
 		% we generate now. If it is an abstract type, we should call
 		% its unification procedure directly; if it is a concrete type,
 		% we should generate the body of its unification procedure
 		% inline here.
-		%
-		% XXX Somebody should document here what the later stages
-		% of the compiler do to prevent an infinite recursion here.
-		{ create_atomic_unification(H1, var(H2), Context, explicit, [],
-			Goal) },
+		unify_proc__make_fresh_named_var_from_type(EqvType,
+			"Cast_HeadVar", 1, CastVar1),
+		unify_proc__make_fresh_named_var_from_type(EqvType,
+			"Cast_HeadVar", 2, CastVar2),
+		unify_proc__build_call("unsafe_type_cast", [H1, CastVar1],
+			Context, Cast1Goal),
+		unify_proc__build_call("unsafe_type_cast", [H2, CastVar2],
+			Context, Cast2Goal),
+		{ create_atomic_unification(CastVar1, var(CastVar2), Context,
+			explicit, [], UnifyGoal) },
+
+		{ goal_info_init(GoalInfo0) },
+		{ goal_info_set_context(GoalInfo0, Context, GoalInfo) },
+		{ conj_list_to_goal([Cast1Goal, Cast2Goal, UnifyGoal],
+			GoalInfo, Goal) },
 		unify_proc__quantify_clauses_body([H1, H2], Goal, Context,
 			Clauses)
 	;
@@ -780,10 +784,9 @@
 	% of special preds to define only for the kinds of types which do not
 	% lead this predicate to abort.
 
-:- pred unify_proc__generate_index_clauses(hlds_type_body, prog_var, prog_var,
-	prog_context, list(clause), unify_proc_info, unify_proc_info).
-:- mode unify_proc__generate_index_clauses(in, in, in, in, out, in, out)
-	is det.
+:- pred unify_proc__generate_index_clauses(hlds_type_body::in,
+	prog_var::in, prog_var::in, prog_context::in, list(clause)::out,
+	unify_proc_info::in, unify_proc_info::out) is det.
 
 unify_proc__generate_index_clauses(TypeBody, X, Index, Context, Clauses) -->
 	(
@@ -850,44 +853,54 @@
 				Context, Clauses)
 		; { IsEnum = yes } ->
 			{ IntType = int_type },
-			unify_proc__info_new_var(IntType, TC1),
-			unify_proc__info_new_var(IntType, TC2),
-			{ TC1ArgVars = [H1, TC1] },
+			unify_proc__make_fresh_named_var_from_type(IntType,
+				"Cast_HeadVar", 1, CastVar1),
+			unify_proc__make_fresh_named_var_from_type(IntType,
+				"Cast_HeadVar", 2, CastVar2),
 			unify_proc__build_call("unsafe_type_cast",
-				TC1ArgVars, Context, TC1Goal),
-			{ TC2ArgVars = [H2, TC2] },
+				[H1, CastVar1], Context, Cast1Goal),
 			unify_proc__build_call("unsafe_type_cast",
-				TC2ArgVars, Context, TC2Goal),
-			{ CompareArgVars = [Res, TC1, TC2] },
+				[H2, CastVar2], Context, Cast2Goal),
 			unify_proc__build_call("builtin_compare_int",
-				CompareArgVars, Context, CompareGoal),
+				[Res, CastVar1, CastVar2], Context,
+				CompareGoal),
+
 			{ goal_info_init(GoalInfo0) },
 			{ goal_info_set_context(GoalInfo0, Context,
 				GoalInfo) },
-			{ conj_list_to_goal([TC1Goal, TC2Goal, CompareGoal],
-				GoalInfo, Goal) },
-			{ ArgVars = [Res, H1, H2] },
-			unify_proc__quantify_clauses_body(ArgVars, Goal,
+			{ conj_list_to_goal([Cast1Goal, Cast2Goal,
+				CompareGoal], GoalInfo, Goal) },
+			unify_proc__quantify_clauses_body([Res, H1, H2], Goal,
 				Context, Clauses)
 		;
 			unify_proc__generate_du_compare_clauses(Type, Ctors,
 				Res, H1, H2, Context, Clauses)
 		)
 	;
-		{ TypeBody = eqv_type(_) },
-		% We should check whether _Type is a type variable,
+		{ TypeBody = eqv_type(EqvType) },
+		% We should check whether EqvType is a type variable,
 		% an abstract type or a concrete type.
 		% If it is type variable, then we should generate the same code
 		% we generate now. If it is an abstract type, we should call
-		% its compare procedure directly; if it is a concrete type,
-		% we should generate the body of its compare procedure
+		% its comparison procedure directly; if it is a concrete type,
+		% we should generate the body of its comparison procedure
 		% inline here.
-		%
-		% XXX Somebody should document here what the later stages
-		% of the compiler do to prevent an infinite recursion here.
-		{ ArgVars = [Res, H1, H2] },
-		unify_proc__build_call("compare", ArgVars, Context, Goal),
-		unify_proc__quantify_clauses_body(ArgVars, Goal, Context,
+		unify_proc__make_fresh_named_var_from_type(EqvType,
+			"Cast_HeadVar", 1, CastVar1),
+		unify_proc__make_fresh_named_var_from_type(EqvType,
+			"Cast_HeadVar", 2, CastVar2),
+		unify_proc__build_call("unsafe_type_cast", [H1, CastVar1],
+			Context, Cast1Goal),
+		unify_proc__build_call("unsafe_type_cast", [H2, CastVar2],
+			Context, Cast2Goal),
+		unify_proc__build_call("compare", [Res, CastVar1, CastVar2],
+			Context, CompareGoal),
+
+		{ goal_info_init(GoalInfo0) },
+		{ goal_info_set_context(GoalInfo0, Context, GoalInfo) },
+		{ conj_list_to_goal([Cast1Goal, Cast2Goal, CompareGoal],
+			GoalInfo, Goal) },
+		unify_proc__quantify_clauses_body([Res, H1, H2], Goal, Context,
 			Clauses)
 	;
 		{ TypeBody = foreign_type(_, _) },
@@ -1580,32 +1593,37 @@
 
 %-----------------------------------------------------------------------------%
 
-:- pred unify_proc__make_fresh_named_vars_from_types(list(type), string, int,
-	list(prog_var), unify_proc_info, unify_proc_info).
-:- mode unify_proc__make_fresh_named_vars_from_types(in, in, in, out, in, out)
-	is det.
+:- pred unify_proc__make_fresh_named_var_from_type((type)::in,
+	string::in, int::in, prog_var::out,
+	unify_proc_info::in, unify_proc_info::out) is det.
 
+unify_proc__make_fresh_named_var_from_type(Type, BaseName, Num, Var) -->
+	{ string__int_to_string(Num, NumStr) },
+	{ string__append(BaseName, NumStr, Name) },
+	unify_proc__info_new_named_var(Type, Name, Var).
+
+:- pred unify_proc__make_fresh_named_vars_from_types(list(type)::in,
+	string::in, int::in, list(prog_var)::out,
+	unify_proc_info::in, unify_proc_info::out) is det.
+
 unify_proc__make_fresh_named_vars_from_types([], _, _, []) --> [].
 unify_proc__make_fresh_named_vars_from_types([Type | Types], BaseName, Num,
 		[Var | Vars]) -->
-	{ string__int_to_string(Num, NumStr) },
-	{ string__append(BaseName, NumStr, Name) },
-	unify_proc__info_new_named_var(Type, Name, Var),
+	unify_proc__make_fresh_named_var_from_type(Type, BaseName, Num, Var),
 	unify_proc__make_fresh_named_vars_from_types(Types, BaseName, Num + 1,
 		Vars).
 
-:- pred unify_proc__make_fresh_vars_from_types(list(type), list(prog_var),
-			unify_proc_info, unify_proc_info).
-:- mode unify_proc__make_fresh_vars_from_types(in, out, in, out) is det.
+:- pred unify_proc__make_fresh_vars_from_types(list(type)::in,
+	list(prog_var)::out, unify_proc_info::in, unify_proc_info::out) is det.
 
 unify_proc__make_fresh_vars_from_types([], []) --> [].
 unify_proc__make_fresh_vars_from_types([Type | Types], [Var | Vars]) -->
 	unify_proc__info_new_var(Type, Var),
 	unify_proc__make_fresh_vars_from_types(Types, Vars).
 
-:- pred unify_proc__make_fresh_vars(list(constructor_arg), existq_tvars,
-			list(prog_var), unify_proc_info, unify_proc_info).
-:- mode unify_proc__make_fresh_vars(in, in, out, in, out) is det.
+:- pred unify_proc__make_fresh_vars(list(constructor_arg)::in,
+	existq_tvars::in, list(prog_var)::out,
+	unify_proc_info::in, unify_proc_info::out) is det.
 
 unify_proc__make_fresh_vars(CtorArgs, ExistQTVars, Vars) -->
 	( { ExistQTVars = [] } ->
--------------------------------------------------------------------------
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
--------------------------------------------------------------------------