[m-rev.] for review: record extras information about user-defined equality/comparison

[Julien Fischer]

Estimated hours taken: 10
Branches: main

Add a pass that adds information to locally defined types
about which, if any, procedures implement user-defined
equality/comparison

This information will be useful in several of the later
analysis/optimization passes and we currently do not have a
way of easily looking it up - I'm intending to use it in
an upcoming change to the termination analyser.

XXX Ideally this could all be set up during type/mode checking
but that is a considerably more substantial change.

I haven't included any tests in this diff partially because some
of the existing tests cover this and we (currently) do not
have anything in the compiler that makes use of this extra
information anyway.

compiler/hlds_data.m:
	Add extra fields to the `type_defn' structure that record
	the identity of the procedures that are used to
	implement user-defined equality/comparison.

	Add set/get predicates for the above.

	Add a comment about where the names for user-defined
	equality/comparison predicates for foreign types may
	be found.

compiler/user_special_ids.m:
	Make a pass over the HLDS and attach information
	about which procedures are implementing user-defined
	equality/comparison to their corresponding types.
	Only do this if the types are locally defined.

compiler/special_pred.m:
	Add an inst that allows us to switch on a subtype of
	the `special_pred_id' type.

compiler/mercury_compile.m:
	Change the comment about stage number assignments.
	It is inconsistent with the code and the compiler design
	document.

	Renumber the stages between 25 and 30 in order to fit this
	new pass in.

	Make the new pass the first thing we do in the middle pass.

compiler/transform_hlds.m:
	Changes to conform to the above.


Julien.

Index: compiler/hlds_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_data.m,v
retrieving revision 1.86
diff -u -r1.86 hlds_data.m
--- compiler/hlds_data.m	19 May 2004 03:59:11 -0000	1.86
+++ compiler/hlds_data.m	12 Jun 2004 07:52:02 -0000
@@ -284,6 +284,28 @@
 	is det.
 :- pred get_type_defn_context(hlds_type_defn::in, prog_context::out) is det.

+	% get_type_defn_user_equality(TypeDefn, PPId).
+	% Succeeds iff the type is a locally defined type that has
+	% user-defined equality.  On success, `PPId' is bound to the
+	% identity of the predicate that implements equality for the
+	% type.
+	%
+	% NOTE: This is only meaningful after the user_special_ids pass.
+	%
+:- pred get_type_defn_user_equality(hlds_type_defn::in, pred_proc_id::out)
+	is semidet.
+
+	% get_type_defn_user_compare(TypeDefn, PPId).
+	% Succeeds iff the type is a locally defined type that has
+	% user-defined comparison.  On success, `PPId' is bound to the
+	% identity of the predicate that implements comparison for the
+	% type.
+	%
+	% NOTE: This is only meaningful after the user_special_ids pass.
+	%
+:- pred get_type_defn_user_compare(hlds_type_defn::in, pred_proc_id::out)
+	is semidet.
+
 :- pred set_type_defn_body(hlds_type_body::in,
 	hlds_type_defn::in, hlds_type_defn::out) is det.
 :- pred set_type_defn_tvarset(tvarset::in,
@@ -293,6 +315,17 @@
 :- pred set_type_defn_in_exported_eqv(bool::in,
 	hlds_type_defn::in, hlds_type_defn::out) is det.

+	% Attach information about the identity of the procedure that
+	% implements user-defined equality/comparison to a type.
+	%
+	% Throws an exception if the type is not locally-defined.
+	%
+:- pred set_type_defn_user_equality(pred_proc_id::in, hlds_type_defn::in,
+	hlds_type_defn::out) is det.
+:- pred set_type_defn_user_compare(pred_proc_id::in, hlds_type_defn::in,
+	hlds_type_defn::out) is det.
+
+
 	% An `hlds_type_body' holds the body of a type definition:
 	% du = discriminated union, uu = undiscriminated union,
 	% eqv_type = equivalence type (a type defined to be equivalent
@@ -326,6 +359,11 @@
 			du_type_is_foreign_type	:: maybe(foreign_type_body)
 		)
 	;	eqv_type(type)
+
+			% NOTE: Information about user-defined eq-comp
+			% preds for foreign_types is stored inside
+			% the foreign_type_body.
+			%
 	;	foreign_type(foreign_type_body, is_solver_type)
 	;	abstract_type(is_solver_type).

@@ -583,16 +621,36 @@
 %				% :- type sorted_list(T) == list(T)
 %				%	where sorted.

-		type_defn_context	:: prog_context
+		type_defn_context	:: prog_context,
 					% The location of this type
 					% definition in the original
 					% source code
+
+		type_user_uc_preds	:: maybe(user_uc_ids)
+					% The ppid of any user-defined
+					% equality/comparison predicates for
+					% this type.  NOTE: These are the
+					% actual procedures *not* the compiler
+					% generated forwarding predicates.
+					%
+					% Meaningful only after the
+					% user_special_ids pass has been run.
+	).
+
+	% Information about which procedures implement equality
+	% and/or comparison for those types for which equality/comparison
+	% is user-defined.
+	%
+:- type user_uc_ids
+	---> user_uc_ids(
+		user_unify   :: maybe(pred_proc_id),
+		user_compare :: maybe(pred_proc_id)
 	).

 hlds_data__set_type_defn(Tvarset, Params, Body, Status,
 		InExportedEqv, NeedQual, Context, Defn) :-
 	Defn = hlds_type_defn(Tvarset, Params, Body, Status, InExportedEqv,
-		NeedQual, Context).
+		NeedQual, Context, no).

 get_type_defn_tvarset(Defn, Defn ^ type_defn_tvarset).
 get_type_defn_tparams(Defn, Defn ^ type_defn_params).
@@ -601,6 +659,14 @@
 get_type_defn_in_exported_eqv(Defn, Defn ^ type_defn_in_exported_eqv).
 get_type_defn_need_qualifier(Defn, Defn ^ type_defn_need_qualifier).
 get_type_defn_context(Defn, Defn ^ type_defn_context).
+get_type_defn_user_equality(Defn, PPId) :-
+	Defn ^ type_user_uc_preds = yes(UserUC_Preds),
+	MaybeUserEql = UserUC_Preds ^ user_unify,
+	MaybeUserEql = yes(PPId).
+get_type_defn_user_compare(Defn, PPId) :-
+	Defn ^ type_user_uc_preds = yes(UserUC_Preds),
+	MaybeUserCmp = UserUC_Preds ^ user_compare,
+	MaybeUserCmp = yes(PPId).

 set_type_defn_body(Body, Defn, Defn ^ type_defn_body := Body).
 set_type_defn_tvarset(TVarSet, Defn,
@@ -609,7 +675,45 @@
 		Defn ^ type_defn_import_status := Status).
 set_type_defn_in_exported_eqv(InExportedEqv, Defn,
 		Defn ^ type_defn_in_exported_eqv := InExportedEqv).
-
+set_type_defn_user_equality(PPId, Defn0, Defn) :-
+	(
+		Status = Defn0 ^ type_defn_import_status,
+		status_defined_in_this_module(Status, yes)
+	->
+		true
+	;
+		error(
+		"set_type_defn_user_equality/3 called with non-local type.")
+	),
+	UserUC_Preds0 = Defn0 ^ type_user_uc_preds,
+	(
+		UserUC_Preds0 = no,
+		UserUC_Preds  = yes(user_uc_ids(yes(PPId), no))
+	;
+		UserUC_Preds0 = yes(user_uc_ids(_, MaybeCmpPPId)),
+		UserUC_Preds  = yes(user_uc_ids(yes(PPId), MaybeCmpPPId))
+	),
+	Defn = Defn0 ^ type_user_uc_preds := UserUC_Preds.
+set_type_defn_user_compare(PPId, Defn0, Defn) :-
+	(
+		Status = Defn0 ^ type_defn_import_status,
+		status_defined_in_this_module(Status, yes)
+	->
+		true
+	;
+		error(
+		"set_type_defn_user_compare/3 called with non-local type.")
+	),
+	UserUC_Preds0 = Defn0 ^ type_user_uc_preds,
+	(
+		UserUC_Preds0 = no,
+		UserUC_Preds  = yes(user_uc_ids(no, yes(PPId)))
+	;
+		UserUC_Preds0 = yes(user_uc_ids(MaybeEqlPPId, _)),
+		UserUC_Preds  = yes(user_uc_ids(MaybeEqlPPId, yes(PPId)))
+	),
+	Defn = Defn0 ^ type_user_uc_preds := UserUC_Preds.
+
 %-----------------------------------------------------------------------------%
 %-----------------------------------------------------------------------------%

Index: compiler/mercury_compile.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_compile.m,v
retrieving revision 1.310
diff -u -r1.310 mercury_compile.m
--- compiler/mercury_compile.m	9 Jun 2004 07:56:12 -0000	1.310
+++ compiler/mercury_compile.m	10 Jun 2004 09:14:01 -0000
@@ -58,6 +58,7 @@

 	% high-level HLDS transformations
 :- import_module check_hlds__check_typeclass.
+:- import_module transform_hlds__user_special_ids.
 :- import_module transform_hlds__intermod.
 :- import_module transform_hlds__trans_opt.
 :- import_module transform_hlds__equiv_type_hlds.
@@ -1368,8 +1369,8 @@

 	% Stage number assignments:
 	%
-	%	 1 to 25	front end pass
-	%	26 to 50	middle pass
+	%	 1 to 24	front end pass
+	%	25 to 50	middle pass
 	%	51 to 99	back end pass
 	%
 	% The initial arrangement has the stage numbers increasing by three
@@ -2187,6 +2188,7 @@
 	( UnsafeToContinue = yes ->
 		FoundError = yes
 	;
+
 		mercury_compile__detect_switches(Verbose, Stats, !HLDS, !IO),
 		mercury_compile__maybe_dump_hlds(!.HLDS, "07",
 			"switch_detect", !IO),
@@ -2244,15 +2246,19 @@
 mercury_compile__middle_pass(ModuleName, !HLDS, !IO) :-
 	globals__io_lookup_bool_option(verbose, Verbose, !IO),
 	globals__io_lookup_bool_option(statistics, Stats, !IO),
+
+	mercury_compile__check_user_special_ids(Verbose, Stats, !HLDS, !IO),
+	mercury_compile__maybe_dump_hlds(!.HLDS, "25", "user_special_ids",
+		!IO),

 	mercury_compile__tabling(Verbose, Stats, !HLDS, !IO),
-	mercury_compile__maybe_dump_hlds(!.HLDS, "25", "tabling", !IO),
+	mercury_compile__maybe_dump_hlds(!.HLDS, "26", "tabling", !IO),

 	mercury_compile__process_lambdas(Verbose, Stats, !HLDS, !IO),
-	mercury_compile__maybe_dump_hlds(!.HLDS, "26", "lambda", !IO),
+	mercury_compile__maybe_dump_hlds(!.HLDS, "27", "lambda", !IO),

 	mercury_compile__expand_equiv_types_hlds(Verbose, Stats, !HLDS, !IO),
-	mercury_compile__maybe_dump_hlds(!.HLDS, "27", "equiv_types", !IO),
+	mercury_compile__maybe_dump_hlds(!.HLDS, "28", "equiv_types", !IO),

 	%
 	% Uncomment the following code to check that unique mode analysis
@@ -2272,10 +2278,10 @@
 	% ),

 	mercury_compile__maybe_termination(Verbose, Stats, !HLDS, !IO),
-	mercury_compile__maybe_dump_hlds(!.HLDS, "28", "termination", !IO),
+	mercury_compile__maybe_dump_hlds(!.HLDS, "29", "termination", !IO),

 	mercury_compile__maybe_type_ctor_infos(Verbose, Stats, !HLDS, !IO),
-	mercury_compile__maybe_dump_hlds(!.HLDS, "29", "type_ctor_infos", !IO),
+	mercury_compile__maybe_dump_hlds(!.HLDS, "30", "type_ctor_infos", !IO),

 	% warn_dead_procs must come after type_ctor_infos, so that it
 	% handles unification & comparison procedures correctly,
@@ -2283,33 +2289,33 @@
 	% specialization and inlining, which can make the original code
 	% for a procedure dead by inlining/specializing all uses of it.
 	mercury_compile__maybe_warn_dead_procs(Verbose, Stats, !HLDS, !IO),
-	mercury_compile__maybe_dump_hlds(!.HLDS, "30", "warn_dead_procs", !IO),
+	mercury_compile__maybe_dump_hlds(!.HLDS, "31", "warn_dead_procs", !IO),

 	mercury_compile__maybe_bytecodes(!.HLDS, ModuleName, Verbose, Stats,
 		!IO),
-	% stage number 31 is used by mercury_compile__maybe_bytecodes
+	% stage number 32 is used by mercury_compile__maybe_bytecodes

 	mercury_compile__maybe_higher_order(Verbose, Stats, !HLDS, !IO),
-	mercury_compile__maybe_dump_hlds(!.HLDS, "32", "higher_order", !IO),
+	mercury_compile__maybe_dump_hlds(!.HLDS, "33", "higher_order", !IO),

 	mercury_compile__maybe_introduce_accumulators(Verbose, Stats, !HLDS,
 		!IO),
-	mercury_compile__maybe_dump_hlds(!.HLDS, "33", "accum", !IO),
+	mercury_compile__maybe_dump_hlds(!.HLDS, "34", "accum", !IO),

 	mercury_compile__maybe_do_inlining(Verbose, Stats, !HLDS, !IO),
-	mercury_compile__maybe_dump_hlds(!.HLDS, "34", "inlining", !IO),
+	mercury_compile__maybe_dump_hlds(!.HLDS, "35", "inlining", !IO),

-	% Hoisting loop invariants first invokes pass 35, "mark_static".
+	% Hoisting loop invariants first invokes pass 36, "mark_static".
 	% "mark_static" is also run at stage 60.
 	%
 	mercury_compile__maybe_loop_inv(Verbose, Stats, !HLDS, !IO),
-	mercury_compile__maybe_dump_hlds(!.HLDS, "36", "loop_inv", !IO),
+	mercury_compile__maybe_dump_hlds(!.HLDS, "37", "loop_inv", !IO),

 	mercury_compile__maybe_deforestation(Verbose, Stats, !HLDS, !IO),
-	mercury_compile__maybe_dump_hlds(!.HLDS, "37", "deforestation", !IO),
+	mercury_compile__maybe_dump_hlds(!.HLDS, "38", "deforestation", !IO),

 	mercury_compile__maybe_delay_construct(Verbose, Stats, !HLDS, !IO),
-	mercury_compile__maybe_dump_hlds(!.HLDS, "38", "delay_construct", !IO),
+	mercury_compile__maybe_dump_hlds(!.HLDS, "39", "delay_construct", !IO),

 	mercury_compile__maybe_unused_args(Verbose, Stats, !HLDS, !IO),
 	mercury_compile__maybe_dump_hlds(!.HLDS, "40", "unused_args", !IO),
@@ -2698,6 +2704,17 @@
 			"% Program is mode-correct.\n", !IO)
 	),
 	maybe_report_stats(Stats, !IO).
+
+:- pred mercury_compile__check_user_special_ids(bool::in, bool::in,
+	module_info::in, module_info::out, io::di, io::uo) is det.
+
+mercury_compile__check_user_special_ids(Verbose, Stats, !HLDS, !IO) :-
+	maybe_write_string(Verbose,
+		"% Propagating user special pred ids...\n", !IO),
+	maybe_flush_output(Verbose, !IO),
+	user_special_ids.pass(!HLDS, !IO),
+	maybe_write_string(Verbose, "% done.\n", !IO),
+	maybe_report_stats(Stats, !IO).

 :- pred mercury_compile__detect_switches(bool::in, bool::in,
 	module_info::in, module_info::out, io::di, io::uo) is det.
@@ -3292,7 +3309,7 @@
 			%
 		mercury_compile__maybe_mark_static_terms(Verbose, Stats,
 			!HLDS, !IO),
-		mercury_compile__maybe_dump_hlds(!.HLDS, "35", "mark_static",
+		mercury_compile__maybe_dump_hlds(!.HLDS, "36", "mark_static",
 			!IO),

 		maybe_write_string(Verbose,
Index: compiler/special_pred.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/special_pred.m,v
retrieving revision 1.44
diff -u -r1.44 special_pred.m
--- compiler/special_pred.m	23 Mar 2004 06:56:42 -0000	1.44
+++ compiler/special_pred.m	24 May 2004 07:01:20 -0000
@@ -32,6 +32,10 @@
 	;	index
 	;	compare.

+:- inst user_special_pred
+	--->	unify
+	;	compare.
+
 	% Return the predicate name we should use for the given special_pred
 	% for the given type constructor.
 :- func special_pred_name(special_pred_id, type_ctor) = string.
Index: compiler/transform_hlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/transform_hlds.m,v
retrieving revision 1.9
diff -u -r1.9 transform_hlds.m
--- compiler/transform_hlds.m	23 Mar 2004 10:52:13 -0000	1.9
+++ compiler/transform_hlds.m	10 Jun 2004 08:56:03 -0000
@@ -23,6 +23,8 @@

 :- include_module equiv_type_hlds.

+:- include_module user_special_ids.
+
 :- include_module table_gen.

 :- include_module (lambda).
Index: compiler/user_special_ids.m
===================================================================
RCS file: compiler/user_special_ids.m
diff -N compiler/user_special_ids.m
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ compiler/user_special_ids.m	12 Jun 2004 07:36:29 -0000
@@ -0,0 +1,236 @@
+%-----------------------------------------------------------------------------%
+% Copyright (C) 2004 The University of Melbourne.
+% This file may only be copied under the terms of the GNU General
+% Public License - see the file COPYING in the Mercury distribution.
+%-----------------------------------------------------------------------------%
+%
+% File: user_special_ids.m
+% Author: juliensf
+%
+% This module performs a pass over the HLDS that annotates types
+% defined in the module that have user-defined equality or comparison
+% predicates defined for them with information about the identity of the
+% procedures implementing the equality and/or comparison.
+%
+% Having this information is useful during several of the later
+% analysis/optimization passes.
+%
+%-----------------------------------------------------------------------------%
+
+:- module transform_hlds.user_special_ids.
+
+:- interface.
+
+:- import_module hlds.hlds_module.
+
+:- import_module io.
+
+:- pred user_special_ids.pass(module_info::in, module_info::out,
+	io::di, io::uo) is det.
+
+%----------------------------------------------------------------------------%
+%----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module backend_libs.
+:- import_module backend_libs.foreign.
+
+:- import_module check_hlds.type_util.
+
+:- import_module hlds.hlds_data.
+:- import_module hlds.hlds_goal.
+:- import_module hlds.hlds_pred.
+:- import_module hlds.special_pred.
+
+:- import_module parse_tree.error_util.
+:- import_module parse_tree.prog_data.
+
+:- import_module bool.
+:- import_module list.
+:- import_module map.
+:- import_module std_util.
+:- import_module string.
+
+%-----------------------------------------------------------------------------%
+%
+% The procedure we carry out below is as follows:
+%
+%	* Check each procedure in the module to see if it is a compiler
+%	  generate unify/comparison predicate.
+%
+%	* If yes, check to see if the corresponding type is locally defined
+%	  and has user-defined equality or comparison; if no check the next
+%	  predicate.
+%
+%	* If yes, then examine the compiler generated wrapper predicate
+%	  to see what procedure is called; if no check the next predicate.
+%
+%	* Attach the identity of the procedure to the type definition.
+%
+%-----------------------------------------------------------------------------%
+
+user_special_ids.pass(!Module, !IO) :-
+	module_info_predids(!.Module, PredIds),
+	list.foldl2(maybe_add_user_uc_info_to_type, PredIds, !Module, !IO).
+
+:- pred maybe_add_user_uc_info_to_type(pred_id::in,
+	module_info::in, module_info::out, io::di, io::uo) is det.
+
+maybe_add_user_uc_info_to_type(PredId, !Module, !IO) :-
+	module_info_pred_info(!.Module, PredId, PredInfo),
+	pred_info_get_maybe_special_pred(PredInfo, MaybeSpecialPred),
+	(
+		MaybeSpecialPred = no
+	;
+		MaybeSpecialPred = yes(SpecialPredId - TypeCtor),
+		%
+		% Tuple types are not a problem here since they cannot
+		% have user defined equality/comparison.
+		%
+		( not type_ctor_is_tuple(TypeCtor) ->
+		    %
+		    % Index predicates cannot be specified by the user so
+		    % they aren't relevant here.
+		    %
+		    (
+	    		SpecialPredId = index
+		    ;
+			SpecialPredId = unify,
+			check_for_user_defined_pred(unify, TypeCtor,
+				PredInfo, !Module, !IO)
+		    ;
+			SpecialPredId = compare,
+			check_for_user_defined_pred(compare, TypeCtor,
+				PredInfo, !Module, !IO)
+		    )
+		;
+			true
+		)
+	).
+
+:- pred check_for_user_defined_pred(
+	special_pred_id::in(user_special_pred),
+	type_ctor::in, pred_info::in, module_info::in,
+	module_info::out, io::di, io::uo) is det.
+
+check_for_user_defined_pred(SpecialPredId, TypeCtor, PredInfo, !Module,
+		!IO) :-
+	module_info_types(!.Module, TypeTable0),
+	TypeDefn0 = TypeTable0 ^ det_elem(TypeCtor),
+	get_type_defn_status(TypeDefn0, ImportStatus),
+	status_defined_in_this_module(ImportStatus, Status),
+	(
+		% We are only interested in types defined in this
+		% module.
+		Status = no
+	;
+		Status = yes,
+		%
+		% Does this type have user-defined unify/compare predicate
+		% matching the one we have just found?
+		%
+		get_type_defn_body(TypeDefn0, TypeBody),
+		(
+		    (
+		        TypeBody = du_type(_, _, _, MaybeUserEq, _, _, _),
+			MaybeUserEq = yes(UnifyCompare)
+		    ;
+			TypeBody = foreign_type(ForeignTypeBody, _),
+			UnifyCompare =
+			    foreign_type_body_has_user_defined_eq_comp_pred(
+			        !.Module, ForeignTypeBody)
+		    )
+		->
+		    (
+			% We can worry about these when we
+			% compile the module that defines them.
+			UnifyCompare = abstract_noncanonical_type
+		    ;
+			UnifyCompare = unify_compare(MaybeUnify, MaybeCompare),
+			( SpecialPredId = unify, MaybeUnify = yes(_) ->
+				PPId = get_special_pred_ppid(PredInfo),
+				set_type_defn_user_equality(PPId, TypeDefn0,
+					TypeDefn),
+				TypeTable = TypeTable0 ^ det_elem(TypeCtor) :=
+					TypeDefn,
+				module_info_set_types(TypeTable, !Module)
+
+			; SpecialPredId = compare, MaybeCompare = yes(_) ->
+				PPId = get_special_pred_ppid(PredInfo),
+				set_type_defn_user_compare(PPId, TypeDefn0,
+					TypeDefn),
+				TypeTable = TypeTable0 ^ det_elem(TypeCtor) :=
+					TypeDefn,
+				module_info_set_types(TypeTable, !Module)
+			 ;
+			      true
+		         )
+		     )
+		;
+		     true
+		)
+	).
+
+	% For user-defined equality (unify) and comparison the forwarding
+	% predicate just contains a call to the specified predicate,
+	% in a conjunction preceded by some unifications involving
+	% type_infos and alike.
+	% (See unify_proc.m for further details).
+	%
+:- func get_special_pred_ppid(pred_info) = pred_proc_id.
+
+get_special_pred_ppid(PredInfo) = PPId :-
+	pred_info_procedures(PredInfo, ProcTable),
+	%
+	% Special preds are *always* mode 0.
+	%
+	proc_id_to_int(ProcId, 0),
+	ProcInfo = ProcTable ^ det_elem(ProcId),
+	PPId = extract_user_uc_proc(ProcInfo).
+
+	% Given an automatically generated forwarding predicate
+	% for a user-defined unify/comparison pred - extract
+	% the ppid of the real predicate.
+	%
+:- func extract_user_uc_proc(proc_info) = pred_proc_id.
+
+extract_user_uc_proc(ProcInfo) = PPId :-
+	proc_info_goal(ProcInfo, Goal),
+	Goal = GoalExpr - _GoalInfo,
+	(
+		(
+			GoalExpr = conj(Conjuncts),
+			extract_call_from_conjuncts(Conjuncts, PredId, ProcId)
+		;
+			GoalExpr = call(PredId, ProcId, _, _, _, _)
+		)
+	->
+		PPId = proc(PredId, ProcId)
+	;
+		unexpected(this_file,
+		"Couldn't find user-defined equality/comparison predicate.")
+	).
+
+:- pred extract_call_from_conjuncts(hlds_goals::in, pred_id::out,
+	proc_id::out) is det.
+
+extract_call_from_conjuncts([], _, _) :-
+	unexpected(this_file, "Could not find call to user uc pred.").
+extract_call_from_conjuncts([ Goal | Goals ], PredId, ProcId) :-
+	( Goal = call(PredId0, ProcId0, _, _, _, _) - _GoalInfo ->
+			PredId = PredId0,
+			ProcId = ProcId0
+	;
+		extract_call_from_conjuncts(Goals, PredId, ProcId)
+	).
+
+%----------------------------------------------------------------------------%
+
+:- func this_file = string.
+
+this_file = "user_special_ids.m".
+
+%----------------------------------------------------------------------------%
+:- end_module user_special_ids.
+%----------------------------------------------------------------------------%
--------------------------------------------------------------------------
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
--------------------------------------------------------------------------