[m-rev.] for review: type_desc and type_ctor_desc handling

Zoltan Somogyi zs at cs.mu.OZ.AU
Tue Mar 19 10:29:52 AEDT 2002


On 18-Mar-2002, Zoltan Somogyi <zs at cs.mu.OZ.AU> wrote:
> I will post an updated diff shortly.

Here it is.

Fix the RTTI of type_descs and type_ctor_descs. Make comparisons between
type_ctor_descs and type_ctor_infos (and therefore between type_descs and
type_infos) more predictable and consistent across backends by basing them
on programmer-visible attributes instead of accident of location in the
executable.

runtime/mercury_type_desc.[ch]:
	Implement unification and comparison functions for type_ctor_descs.
	(The unification and comparison functions for type_infos also double
	as the unification and comparison functions for type_descs.)

	Make the comparison function work on the module name, type name and
	arity instead of the address of the type_ctor_info structure. This
	ensures consistency across back ends.

	Add some useful macros.

runtime/mercury_type_info.[ch]:
	Make the comparison function on type_ctor_infos also work on module
	name, type name and arity. Since this makes comparison slower, add
	specialized unification functions for type_infos and type_ctor_infos.

runtime/mercury_type_info.h:
runtime/mercury_mcpp.{h,cpp}:
runtime/mercury.h:
library/private_builtin.m:
library/rtti_implementation.m:
java/runtime/TypeCtorRep.java:
	Add type_ctor_reps for type_descs and type_ctor_descs. Type_ctor_descs
	definitely need it, since their representation is very low level and
	not shared with anything else. Type_descs could use the type_ctor_rep
	of type_infos, since type_descs and type_infos share the same
	representation at the moment. However, we add a new one because
	profiling cares about the conceptual distinction between type_infos
	and type_descs.

library/type_desc.m:
	Delete the Mercury "definition" of type_desc, because it is misleading.
	Implement it as a builtin type.

runtime/mercury.[ch]:
	Implement type_ctor_desc as a builtin type.

	Add missing implementations of unify/compare on type_ctor_infos.

runtime/mercury_deconstruct.c:
runtime/mercury_ml_expand_body.h:
	Implement deconstruction for type_descs and type_ctor_descs.

runtime/mercury_ho_call.c:
runtime/mercury_unify_compare_body.h:
	Implement unify and compare for type_descs and type_ctor_descs.

	Implement unify for type_infos, type_ctor_infos, type_descs and
	type_ctor_descs by calling the relevant unification function,
	not the relevant comparison function, since the unification
	function will be faster.

runtime/mercury_deep_copy_body.h:
runtime/mercury_construct.c:
runtime/mercury_tabling.c:
	Minor changes to handle type_descs and type_ctor_descs.

trace/mercury_trace_vars.c:
	Enable the printing of type_descs and type_ctor_descs.

tests/debugger/type_desc_test.{m,inp,exp,exp2}:
	New test case to check the printing of type_descs and type_ctor_descs.

tests/debugger/Mmakefile:
	Enable the new test case.

tests/hard_coded/type_ctor_desc_manip.{m,exp}:
	New test case to check the deconstruction and comparison of type_descs
	and (especially) type_ctor_descs. Before this change, we got different
	results for comparisons of type_ctor_descs, results that were
	inconsistent with the results of comparisons of the type_descs
	that the type_ctor_descs were derived from.

tests/hard_coded/Mmakefile:
	Enable the new test case.

cvs diff: Diffing .
cvs diff: [10:24:52] waiting for mercury's lock in /home/mercury1/repository/mercury
cvs diff: [10:25:22] waiting for mercury's lock in /home/mercury1/repository/mercury
cvs diff: [10:25:52] waiting for mercury's lock in /home/mercury1/repository/mercury
cvs diff: [10:26:22] obtained lock in /home/mercury1/repository/mercury
cvs diff: Diffing bindist
cvs diff: Diffing boehm_gc
cvs diff: Diffing boehm_gc/Mac_files
cvs diff: Diffing boehm_gc/cord
cvs diff: Diffing boehm_gc/cord/private
cvs diff: Diffing boehm_gc/doc
cvs diff: Diffing boehm_gc/include
cvs diff: Diffing boehm_gc/include/private
cvs diff: Diffing boehm_gc/tests
cvs diff: Diffing browser
cvs diff: Diffing bytecode
cvs diff: Diffing compiler
cvs diff: Diffing compiler/notes
cvs diff: Diffing debian
cvs diff: Diffing deep_profiler
cvs diff: Diffing deep_profiler/notes
cvs diff: Diffing doc
cvs diff: Diffing extras
cvs diff: Diffing extras/aditi
cvs diff: Diffing extras/cgi
cvs diff: Diffing extras/complex_numbers
cvs diff: Diffing extras/complex_numbers/samples
cvs diff: Diffing extras/complex_numbers/tests
cvs diff: Diffing extras/concurrency
cvs diff: Diffing extras/curs
cvs diff: Diffing extras/curs/samples
cvs diff: Diffing extras/curses
cvs diff: Diffing extras/curses/sample
cvs diff: Diffing extras/dynamic_linking
cvs diff: Diffing extras/graphics
cvs diff: Diffing extras/graphics/mercury_opengl
cvs diff: Diffing extras/graphics/mercury_tcltk
cvs diff: Diffing extras/graphics/samples
cvs diff: Diffing extras/graphics/samples/calc
cvs diff: Diffing extras/graphics/samples/maze
cvs diff: Diffing extras/graphics/samples/pent
cvs diff: Diffing extras/lazy_evaluation
cvs diff: Diffing extras/lex
cvs diff: Diffing extras/lex/samples
cvs diff: Diffing extras/logged_output
cvs diff: Diffing extras/moose
cvs diff: Diffing extras/moose/samples
cvs diff: Diffing extras/morphine
cvs diff: Diffing extras/morphine/non-regression-tests
cvs diff: Diffing extras/morphine/scripts
cvs diff: Diffing extras/morphine/source
cvs diff: Diffing extras/odbc
cvs diff: Diffing extras/posix
cvs diff: Diffing extras/quickcheck
cvs diff: Diffing extras/quickcheck/tutes
cvs diff: Diffing extras/references
cvs diff: Diffing extras/references/samples
cvs diff: Diffing extras/references/tests
cvs diff: Diffing extras/stream
cvs diff: Diffing extras/trailed_update
cvs diff: Diffing extras/trailed_update/samples
cvs diff: Diffing extras/trailed_update/tests
cvs diff: Diffing extras/xml
cvs diff: Diffing extras/xml/samples
cvs diff: Diffing java
cvs diff: Diffing java/library
cvs diff: Diffing java/runtime
Index: java/runtime/TypeCtorRep.java
===================================================================
RCS file: /home/mercury1/repository/mercury/java/runtime/TypeCtorRep.java,v
retrieving revision 1.1
diff -u -b -r1.1 TypeCtorRep.java
--- java/runtime/TypeCtorRep.java	11 Feb 2002 06:31:32 -0000	1.1
+++ java/runtime/TypeCtorRep.java	14 Mar 2002 23:34:49 -0000
@@ -45,7 +45,9 @@
 	public static final int MR_TYPECTOR_REP_RESERVED_ADDR_USEREQ = 32;
 	public static final int MR_TYPECTOR_REP_TYPECTORINFO = 33;
 	public static final int MR_TYPECTOR_REP_BASETYPECLASSINFO = 34;
-	public static final int MR_TYPECTOR_REP_UNKNOWN = 35;
+	public static final int MR_TYPECTOR_REP_TYPEDESC = 35;
+	public static final int MR_TYPECTOR_REP_TYPECTORDESC = 36;
+	public static final int MR_TYPECTOR_REP_UNKNOWN = 37;
 	
 	// Instance variable for TypeCtorRep objects.
 	
cvs diff: Diffing library
Index: library/private_builtin.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/private_builtin.m,v
retrieving revision 1.99
diff -u -b -r1.99 private_builtin.m
--- library/private_builtin.m	18 Feb 2002 07:01:06 -0000	1.99
+++ library/private_builtin.m	14 Mar 2002 23:33:24 -0000
@@ -649,7 +649,9 @@
 static int MR_TYPECTOR_REP_RESERVED_ADDR_USEREQ	=32;
 static int MR_TYPECTOR_REP_TYPECTORINFO		=33;
 static int MR_TYPECTOR_REP_BASETYPECLASSINFO	=34;
-static int MR_TYPECTOR_REP_UNKNOWN		=35;
+static int MR_TYPECTOR_REP_TYPEDESC		=35;
+static int MR_TYPECTOR_REP_TYPECTORDESC		=36;
+static int MR_TYPECTOR_REP_UNKNOWN		=37;
 
 static int MR_SECTAG_NONE				= 0;
 static int MR_SECTAG_LOCAL				= 1;
Index: library/rtti_implementation.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/rtti_implementation.m,v
retrieving revision 1.14
diff -u -b -r1.14 rtti_implementation.m
--- library/rtti_implementation.m	5 Feb 2002 16:30:07 -0000	1.14
+++ library/rtti_implementation.m	14 Mar 2002 23:39:19 -0000
@@ -112,6 +112,8 @@
 	;	reserved_addr_usereq
 	;	type_ctor_info
 	;	base_typeclass_info
+	;	type_desc
+	;	type_ctor_desc
 	;	unknown.
 
 	% We keep all the other types abstract.
@@ -759,6 +761,16 @@
 	;
 		TypeCtorRep = base_typeclass_info,
 		Functor = "some_base_typeclass_info", 
+		Arity = 0,
+		Arguments = []
+	;
+		TypeCtorRep = type_desc,
+		Functor = "some_type_desc", 
+		Arity = 0,
+		Arguments = []
+	;
+		TypeCtorRep = type_ctor_desc,
+		Functor = "some_type_ctor_desc", 
 		Arity = 0,
 		Arguments = []
 	;
Index: library/type_desc.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/type_desc.m,v
retrieving revision 1.6
diff -u -b -r1.6 type_desc.m
--- library/type_desc.m	18 Feb 2002 07:01:11 -0000	1.6
+++ library/type_desc.m	15 Mar 2002 02:13:52 -0000
@@ -187,22 +187,38 @@
 #ifndef MR_HIGHLEVEL_CODE
 
 #ifdef	MR_DEEP_PROFILING
+MR_proc_static_compiler_empty(type_desc, __Unify__,   type_ctor_desc, 0, 0,
+	""type_desc.m"", 0, MR_TRUE);
+MR_proc_static_compiler_empty(type_desc, __Compare__, type_ctor_desc, 0, 0,
+	""type_desc.m"", 0, MR_TRUE);
 MR_proc_static_compiler_empty(type_desc, __Unify__,   type_desc, 0, 0,
 	""type_desc.m"", 0, MR_TRUE);
 MR_proc_static_compiler_empty(type_desc, __Compare__, type_desc, 0, 0,
 	""type_desc.m"", 0, MR_TRUE);
 #endif
 
+MR_DEFINE_BUILTIN_TYPE_CTOR_INFO(type_desc, type_ctor_desc, 0,
+	MR_TYPECTOR_REP_TYPECTORDESC);
 MR_DEFINE_BUILTIN_TYPE_CTOR_INFO(type_desc, type_desc, 0,
-	MR_TYPECTOR_REP_TYPEINFO);
+	MR_TYPECTOR_REP_TYPEDESC);
 
+MR_define_extern_entry(mercury____Unify___type_desc__type_ctor_desc_0_0);
+MR_define_extern_entry(mercury____Compare___type_desc__type_ctor_desc_0_0);
 MR_define_extern_entry(mercury____Unify___type_desc__type_desc_0_0);
 MR_define_extern_entry(mercury____Compare___type_desc__type_desc_0_0);
 
 MR_BEGIN_MODULE(type_desc_module)
+	MR_init_entry(mercury____Unify___type_desc__type_ctor_desc_0_0);
+	MR_init_entry(mercury____Compare___type_desc__type_ctor_desc_0_0);
 	MR_init_entry(mercury____Unify___type_desc__type_desc_0_0);
 	MR_init_entry(mercury____Compare___type_desc__type_desc_0_0);
 #ifdef	MR_DEEP_PROFILING
+	MR_init_label(mercury____Unify___type_desc__type_ctor_desc_0_0_i1);
+	MR_init_label(mercury____Unify___type_desc__type_ctor_desc_0_0_i2);
+	MR_init_label(mercury____Unify___type_desc__type_ctor_desc_0_0_i3);
+	MR_init_label(mercury____Unify___type_desc__type_ctor_desc_0_0_i4);
+	MR_init_label(mercury____Compare___type_desc__type_ctor_desc_0_0_i1);
+	MR_init_label(mercury____Compare___type_desc__type_ctor_desc_0_0_i2);
 	MR_init_label(mercury____Unify___type_desc__type_desc_0_0_i1);
 	MR_init_label(mercury____Unify___type_desc__type_desc_0_0_i2);
 	MR_init_label(mercury____Unify___type_desc__type_desc_0_0_i3);
@@ -212,6 +228,46 @@
 #endif
 MR_BEGIN_CODE
 
+#define	proc_label	mercury____Unify___type_desc__type_ctor_desc_0_0
+#define	proc_static	MR_proc_static_compiler_name(type_desc, __Unify__, \
+				type_ctor_desc, 0, 0)
+#define	body_code	do {						\
+				int	comp;				\
+									\
+				MR_save_transient_registers();		\
+				comp = MR_compare_type_ctor_desc(	\
+					(MR_TypeCtorDesc) MR_r1,	\
+					(MR_TypeCtorDesc) MR_r2);	\
+				MR_restore_transient_registers();	\
+				MR_r1 = (comp == MR_COMPARE_EQUAL);	\
+			} while (0)
+
+#include ""mercury_hand_unify_body.h""
+
+#undef	body_code
+#undef	proc_static
+#undef	proc_label
+
+#define	proc_label	mercury____Compare___type_desc__type_ctor_desc_0_0
+#define	proc_static	MR_proc_static_compiler_name(type_desc, __Compare__, \
+				type_ctor_desc, 0, 0)
+#define	body_code	do {						\
+				int	comp;				\
+									\
+				MR_save_transient_registers();		\
+				comp = MR_compare_type_ctor_desc(	\
+					(MR_TypeCtorDesc) MR_r1,	\
+					(MR_TypeCtorDesc) MR_r2);	\
+				MR_restore_transient_registers();	\
+				MR_r1 = comp;				\
+			} while (0)
+
+#include ""mercury_hand_compare_body.h""
+
+#undef	body_code
+#undef	proc_static
+#undef	proc_label
+
 #define	proc_label	mercury____Unify___type_desc__type_desc_0_0
 #define	proc_static	MR_proc_static_compiler_name(type_desc, __Unify__, \
 				type_desc, 0, 0)
@@ -265,6 +321,9 @@
 	type_desc_module();
 
 	MR_INIT_TYPE_CTOR_INFO(
+		mercury_data_type_desc__type_ctor_info_type_ctor_desc_0,
+		type_desc__type_desc_0_0);
+	MR_INIT_TYPE_CTOR_INFO(
 		mercury_data_type_desc__type_ctor_info_type_desc_0,
 		type_desc__type_desc_0_0);
 #endif
@@ -275,6 +334,8 @@
 {
 #ifndef	MR_HIGHLEVEL_CODE
 	MR_register_type_ctor_info(
+		&mercury_data_type_desc__type_ctor_info_type_ctor_desc_0);
+	MR_register_type_ctor_info(
 		&mercury_data_type_desc__type_ctor_info_type_desc_0);
 #endif
 }
@@ -284,11 +345,17 @@
 sys_init_type_desc_module_write_out_proc_statics(FILE *fp)
 {
 	MR_write_out_proc_static(fp, (MR_ProcStatic *)
-		&MR_proc_static_compiler_name(type_desc, __Compare__, type_desc,
-			0, 0));
+		&MR_proc_static_compiler_name(type_desc, __Compare__,
+			type_ctor_desc, 0, 0));
 	MR_write_out_proc_static(fp, (MR_ProcStatic *)
-		&MR_proc_static_compiler_name(type_desc, __Unify__, type_desc,
-			0, 0));
+		&MR_proc_static_compiler_name(type_desc, __Unify__,
+			type_ctor_desc, 0, 0));
+	MR_write_out_proc_static(fp, (MR_ProcStatic *)
+		&MR_proc_static_compiler_name(type_desc, __Compare__,
+			type_desc, 0, 0));
+	MR_write_out_proc_static(fp, (MR_ProcStatic *)
+		&MR_proc_static_compiler_name(type_desc, __Unify__,
+			type_desc, 0, 0));
 }
 #endif
 
@@ -296,8 +363,10 @@
 
 :- pragma foreign_code("MC++", "
 
+MR_DEFINE_BUILTIN_TYPE_CTOR_INFO(type_desc, type_ctor_desc, 0, 
+	MR_TYPECTOR_REP_TYPECTORDESC)
 MR_DEFINE_BUILTIN_TYPE_CTOR_INFO(type_desc, type_desc, 0, 
-	MR_TYPECTOR_REP_TYPEINFO)
+	MR_TYPECTOR_REP_TYPEDESC)
 
 static int MR_compare_type_info(MR_Word t1, MR_Word t2) {
 	MR_Word res;
@@ -308,6 +377,50 @@
 }
 
 static void
+__Compare____type_ctor_desc_0_0(
+	MR_Word_Ref result, MR_Word x, MR_Word y)
+{
+	mercury.runtime.Errors.SORRY(""foreign code for comparing type_ctor_descs"");
+}
+
+static MR_bool
+__Unify____type_ctor_desc_0_0(MR_Word x, MR_Word y)
+{
+	mercury.runtime.Errors.SORRY(""foreign code for unifying type_ctor_descs"");
+}
+
+static void
+special___Compare___type_ctor_desc_0_0(
+	MR_Word_Ref result, MR_Word x, MR_Word y)
+{
+	mercury.runtime.Errors.SORRY(""foreign code for comparing type_ctor_descs"");
+}
+
+static MR_bool
+special___Unify___type_ctor_desc_0_0(MR_Word x, MR_Word y)
+{
+	mercury.runtime.Errors.SORRY(""foreign code for unifying type_ctor_descs"");
+}
+
+static int
+do_unify__type_ctor_desc_0_0(MR_Box x, MR_Box y)
+{
+	return mercury::type_desc__cpp_code::mercury_code::__Unify____type_ctor_desc_0_0(
+		dynamic_cast<MR_Word>(x),
+		dynamic_cast<MR_Word>(y));
+}
+
+static void
+do_compare__type_ctor_desc_0_0(
+	MR_Word_Ref result, MR_Box x, MR_Box y)
+{
+	mercury::type_desc__cpp_code::mercury_code::__Compare____type_ctor_desc_0_0(
+		result,
+		dynamic_cast<MR_Word>(x),
+		dynamic_cast<MR_Word>(y));
+}
+
+static void
 __Compare____type_desc_0_0(
 	MR_Word_Ref result, MR_Word x, MR_Word y)
 {
@@ -361,10 +474,6 @@
 
 	% Prototypes and type definitions.
 
-	% A type_ctor_desc is not (quite) a subtype of type_desc,
-	% so we use a separate type for it.
-:- type type_ctor_desc ---> type_ctor_desc(c_pointer).
-
 :- pragma foreign_proc("C",
 	type_of(_Value::unused) = (TypeInfo::out),
 	[will_not_call_mercury, thread_safe, promise_pure],
@@ -572,7 +681,8 @@
 	if (MR_TYPECTOR_DESC_IS_VARIABLE_ARITY(type_ctor_desc)) {
 		arity = MR_TYPECTOR_DESC_GET_VA_ARITY(type_ctor_desc);
 	} else {
-        type_ctor_info = MR_TYPECTOR_DESC_GET_FIXED_ARITY_TYPE_CTOR_INFO(
+		type_ctor_info =
+			MR_TYPECTOR_DESC_GET_FIXED_ARITY_TYPE_CTOR_INFO(
             type_ctor_desc);
 		arity = type_ctor_info->MR_type_ctor_arity;
 	}
cvs diff: Diffing profiler
cvs diff: Diffing robdd
cvs diff: Diffing runtime
Index: runtime/mercury.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury.c,v
retrieving revision 1.38
diff -u -b -r1.38 mercury.c
--- runtime/mercury.c	4 Mar 2002 14:14:22 -0000	1.38
+++ runtime/mercury.c	18 Mar 2002 06:02:59 -0000
@@ -16,6 +16,7 @@
 
 #include "mercury.h"
 #include "mercury_type_info.h"	/* for MR_TYPECTOR_REP* */
+#include "mercury_type_desc.h"	/* for MR_TypeCtorDesc */
 #include "mercury_misc.h"	/* for MR_fatal_error() */
 #include "mercury_heap.h"	/* for MR_create[1-3]() prototypes */
 
@@ -89,6 +90,7 @@
 	mercury__private_builtin__do_unify__heap_pointer_0_0,
 	mercury__builtin__do_unify__func_0_0,
 	mercury__builtin__do_unify__pred_0_0,
+	mercury__type_desc__do_unify__type_ctor_desc_0_0,
 	mercury__type_desc__do_unify__type_desc_0_0;
 
 static MR_UnifyFunc_1
@@ -108,6 +110,7 @@
 	mercury__private_builtin__do_compare__heap_pointer_0_0,
 	mercury__builtin__do_compare__func_0_0,
 	mercury__builtin__do_compare__pred_0_0,
+	mercury__type_desc__do_compare__type_ctor_desc_0_0,
 	mercury__type_desc__do_compare__type_desc_0_0;
 
 static MR_CompareFunc_1
@@ -127,16 +130,19 @@
 */
 
 MR_define_type_ctor_info(builtin, int, 0, MR_TYPECTOR_REP_INT);
+MR_define_type_ctor_info(builtin, character, 0, MR_TYPECTOR_REP_CHAR);
 MR_define_type_ctor_info(builtin, string, 0, MR_TYPECTOR_REP_STRING);
 MR_define_type_ctor_info(builtin, float, 0, MR_TYPECTOR_REP_FLOAT);
-MR_define_type_ctor_info(builtin, character, 0, MR_TYPECTOR_REP_CHAR);
+MR_define_type_ctor_info(builtin, func, 0, MR_TYPECTOR_REP_FUNC);
+MR_define_type_ctor_info(builtin, pred, 0, MR_TYPECTOR_REP_PRED);
+MR_define_type_ctor_info(builtin, tuple, 0, MR_TYPECTOR_REP_TUPLE);
 MR_define_type_ctor_info(builtin, void, 0, MR_TYPECTOR_REP_VOID);
 MR_define_type_ctor_info(builtin, c_pointer, 0, MR_TYPECTOR_REP_C_POINTER);
 MR_define_type_ctor_info(private_builtin, heap_pointer, 0, MR_TYPECTOR_REP_HP);
-MR_define_type_ctor_info(builtin, pred, 0, MR_TYPECTOR_REP_PRED);
-MR_define_type_ctor_info(builtin, func, 0, MR_TYPECTOR_REP_FUNC);
-MR_define_type_ctor_info(builtin, tuple, 0, MR_TYPECTOR_REP_TUPLE);
-MR_define_type_ctor_info(type_desc, type_desc, 0, MR_TYPECTOR_REP_TYPEINFO);
+MR_define_type_ctor_info(type_desc, type_ctor_desc,
+	0, MR_TYPECTOR_REP_TYPECTORDESC);
+MR_define_type_ctor_info(type_desc, type_desc,
+	0, MR_TYPECTOR_REP_TYPEDESC);
 MR_define_type_ctor_info(private_builtin, type_ctor_info, 1,
 	MR_TYPECTOR_REP_TYPECTORINFO);
 MR_define_type_ctor_info(private_builtin, type_info, 1,
@@ -422,13 +428,17 @@
 }
 
 MR_bool MR_CALL
-mercury__type_desc____Unify____type_desc_0_0(MR_Type_Desc x, MR_Type_Desc y)
+mercury__type_desc____Unify____type_ctor_desc_0_0(
+	MR_Type_Ctor_Desc x, MR_Type_Ctor_Desc y)
 {
-	int             comp;
-
-	comp = MR_compare_type_info((MR_TypeInfo) x, (MR_TypeInfo) y);
+	return MR_unify_type_ctor_desc((MR_TypeCtorDesc) x,
+		(MR_TypeCtorDesc) y);
+}
 
-	return (comp == MR_COMPARE_EQUAL);
+MR_bool MR_CALL
+mercury__type_desc____Unify____type_desc_0_0(MR_Type_Desc x, MR_Type_Desc y)
+{
+	return MR_unify_type_info((MR_TypeInfo) x, (MR_TypeInfo) y);
 }
 
 MR_bool MR_CALL
@@ -436,7 +446,8 @@
 	MR_Mercury_Type_Info type_info,
 	MR_Mercury_Type_Ctor_Info x, MR_Mercury_Type_Ctor_Info y)
 {
-	SORRY("unify for type_ctor_info");
+	return MR_unify_type_ctor_info((MR_TypeCtorInfo) x,
+		(MR_TypeCtorInfo) y);
 }
 
 MR_bool MR_CALL
@@ -444,11 +455,7 @@
 	MR_Mercury_Type_Info type_info,
 	MR_Mercury_Type_Info x, MR_Mercury_Type_Info y)
 {
-	int             comp;
-
-	comp = MR_compare_type_info((MR_TypeInfo) x, (MR_TypeInfo) y);
-
-	return (comp == MR_COMPARE_EQUAL);
+	return MR_unify_type_info((MR_TypeInfo) x, (MR_TypeInfo) y);
 }
 
 MR_bool MR_CALL
@@ -577,13 +584,18 @@
 }
 
 void MR_CALL
+mercury__type_desc____Compare____type_ctor_desc_0_0(
+	MR_Comparison_Result *result, MR_Type_Ctor_Desc x, MR_Type_Ctor_Desc y)
+{
+	*result = MR_compare_type_ctor_desc((MR_TypeCtorDesc) x,
+		(MR_TypeCtorDesc) y);
+}
+
+void MR_CALL
 mercury__type_desc____Compare____type_desc_0_0(
 	MR_Comparison_Result *result, MR_Type_Desc x, MR_Type_Desc y)
 {
-	int             comp;
-
-	comp = MR_compare_type_info((MR_TypeInfo) x, (MR_TypeInfo) y);
-	*result = comp;
+	*result = MR_compare_type_info((MR_TypeInfo) x, (MR_TypeInfo) y);
 }
 
 void MR_CALL
@@ -591,7 +603,8 @@
 	MR_Mercury_Type_Info type_info, MR_Comparison_Result *result,
 	MR_Mercury_Type_Ctor_Info x, MR_Mercury_Type_Ctor_Info y)
 {
-	SORRY("compare for type_ctor_info");
+	*result = MR_compare_type_ctor_info((MR_TypeCtorInfo) x,
+		(MR_TypeCtorInfo) y);
 }
 
 void MR_CALL
@@ -599,10 +612,7 @@
 	MR_Mercury_Type_Info type_info, MR_Comparison_Result *result,
 	MR_Mercury_Type_Info x, MR_Mercury_Type_Info y)
 {
-	int             comp;
-
-	comp = MR_compare_type_info((MR_TypeInfo) x, (MR_TypeInfo) y);
-	*result = comp;
+	*result = MR_compare_type_info((MR_TypeInfo) x, (MR_TypeInfo) y);
 }
 
 void MR_CALL
@@ -696,6 +706,13 @@
 }
 
 static MR_bool MR_CALL
+mercury__type_desc__do_unify__type_ctor_desc_0_0(MR_Box x, MR_Box y)
+{
+	return mercury__type_desc____Unify____type_ctor_desc_0_0(
+		(MR_Type_Ctor_Desc) x, (MR_Type_Ctor_Desc) y);
+}
+
+static MR_bool MR_CALL
 mercury__type_desc__do_unify__type_desc_0_0(MR_Box x, MR_Box y)
 {
 	return mercury__type_desc____Unify____type_desc_0_0(
@@ -818,6 +835,14 @@
 {
 	mercury__builtin____Compare____tuple_0_0(
 		type_info, result, (MR_Tuple) x, (MR_Tuple) y);
+}
+
+static void MR_CALL
+mercury__type_desc__do_compare__type_ctor_desc_0_0(
+	MR_Comparison_Result *result, MR_Box x, MR_Box y)
+{
+	mercury__type_desc____Compare____type_ctor_desc_0_0(
+		result, (MR_Type_Ctor_Desc) x, (MR_Type_Ctor_Desc) y);
 }
 
 static void MR_CALL
Index: runtime/mercury.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury.h,v
retrieving revision 1.52
diff -u -b -r1.52 mercury.h
--- runtime/mercury.h	4 Mar 2002 07:51:22 -0000	1.52
+++ runtime/mercury.h	18 Mar 2002 06:09:09 -0000
@@ -134,6 +134,7 @@
   typedef struct mercury__array__array_1_s * MR_Array;
   typedef struct mercury__std_util__univ_0_s * MR_Univ;
   typedef struct mercury__type_desc__type_desc_0_s * MR_Type_Desc;
+  typedef struct mercury__type_desc__type_ctor_desc_0_s * MR_Type_Ctor_Desc;
   typedef struct mercury__private_builtin__type_info_1_s *
   	MR_Mercury_Type_Info;
   typedef struct mercury__private_builtin__type_ctor_info_1_s *
@@ -153,6 +154,7 @@
   typedef MR_Word MR_Array;
   typedef MR_Word MR_Univ;
   typedef MR_Word MR_Type_Desc;
+  typedef MR_Word MR_Type_Ctor_Desc;
   typedef MR_Word MR_Mercury_Type_Info;
   typedef MR_Word MR_Mercury_Type_Ctor_Info;
   typedef MR_Word MR_Mercury_TypeClass_Info;
@@ -327,6 +329,7 @@
 	mercury__builtin__builtin__type_ctor_info_tuple_0,
 	mercury__array__array__type_ctor_info_array_1,
 	mercury__std_util__std_util__type_ctor_info_univ_0,
+	mercury__type_desc__type_desc__type_ctor_info_type_ctor_desc_0,
 	mercury__type_desc__type_desc__type_ctor_info_type_desc_0,
 	mercury__private_builtin__private_builtin__type_ctor_info_type_ctor_info_1,
 	mercury__private_builtin__private_builtin__type_ctor_info_type_info_1,
@@ -561,6 +564,8 @@
 MR_bool MR_CALL mercury__builtin____Unify____pred_0_0(MR_Pred x, MR_Pred y); 
 MR_bool MR_CALL mercury__builtin____Unify____tuple_0_0(
 	MR_Mercury_Type_Info type_info, MR_Tuple x, MR_Tuple y); 
+MR_bool MR_CALL mercury__type_desc____Unify____type_ctor_desc_0_0(
+	MR_Type_Ctor_Desc x, MR_Type_Ctor_Desc y); 
 MR_bool MR_CALL mercury__type_desc____Unify____type_desc_0_0(
 	MR_Type_Desc x, MR_Type_Desc y); 
 MR_bool MR_CALL mercury__private_builtin____Unify____type_ctor_info_1_0(
@@ -597,6 +602,9 @@
 void MR_CALL mercury__builtin____Compare____tuple_0_0(
 	MR_Mercury_Type_Info type_info, MR_Comparison_Result *result,
 	MR_Tuple x, MR_Tuple y); 
+void MR_CALL mercury__type_desc____Compare____type_ctor_desc_0_0(
+	MR_Comparison_Result *result,
+	MR_Type_Ctor_Desc x, MR_Type_Ctor_Desc y);
 void MR_CALL mercury__type_desc____Compare____type_desc_0_0(
 	MR_Comparison_Result *result, MR_Type_Desc x, MR_Type_Desc y);
 void MR_CALL mercury__private_builtin____Compare____type_ctor_info_1_0(
Index: runtime/mercury_construct.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_construct.c,v
retrieving revision 1.2
diff -u -b -r1.2 mercury_construct.c
--- runtime/mercury_construct.c	18 Feb 2002 07:01:14 -0000	1.2
+++ runtime/mercury_construct.c	14 Mar 2002 23:50:49 -0000
@@ -145,6 +145,8 @@
     case MR_TYPECTOR_REP_C_POINTER:
     case MR_TYPECTOR_REP_TYPEINFO:
     case MR_TYPECTOR_REP_TYPECTORINFO:
+    case MR_TYPECTOR_REP_TYPEDESC:
+    case MR_TYPECTOR_REP_TYPECTORDESC:
     case MR_TYPECTOR_REP_TYPECLASSINFO:
     case MR_TYPECTOR_REP_BASETYPECLASSINFO:
     case MR_TYPECTOR_REP_ARRAY:
@@ -298,6 +300,8 @@
         case MR_TYPECTOR_REP_C_POINTER:
         case MR_TYPECTOR_REP_TYPEINFO:
         case MR_TYPECTOR_REP_TYPECTORINFO:
+        case MR_TYPECTOR_REP_TYPEDESC:
+        case MR_TYPECTOR_REP_TYPECTORDESC:
         case MR_TYPECTOR_REP_TYPECLASSINFO:
         case MR_TYPECTOR_REP_BASETYPECLASSINFO:
         case MR_TYPECTOR_REP_ARRAY:
Index: runtime/mercury_deconstruct.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_deconstruct.c,v
retrieving revision 1.8
diff -u -b -r1.8 mercury_deconstruct.c
--- runtime/mercury_deconstruct.c	12 Mar 2002 03:40:38 -0000	1.8
+++ runtime/mercury_deconstruct.c	14 Mar 2002 23:47:09 -0000
@@ -17,6 +17,7 @@
 #include "mercury_imp.h"
 #include "mercury_deconstruct.h"
 #include "mercury_deconstruct_macros.h"
+#include "mercury_type_desc.h"
 
 static  MR_ConstString  MR_expand_type_name(MR_TypeCtorInfo tci, MR_bool);
 
Index: runtime/mercury_deep_copy_body.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_deep_copy_body.h,v
retrieving revision 1.50
diff -u -b -r1.50 mercury_deep_copy_body.h
--- runtime/mercury_deep_copy_body.h	5 Mar 2002 11:33:34 -0000	1.50
+++ runtime/mercury_deep_copy_body.h	14 Mar 2002 23:49:18 -0000
@@ -514,12 +514,21 @@
         break;
 
     case MR_TYPECTOR_REP_TYPEINFO:
+    case MR_TYPECTOR_REP_TYPEDESC:
         new_data = (MR_Word) copy_type_info((MR_TypeInfo *) data_ptr,
             lower_limit, upper_limit);
         break;
 
     case MR_TYPECTOR_REP_TYPECTORINFO:
-        /* type_ctor_infos are always static */
+        /* type_ctor_infos are always pointers to static data */
+        new_data = data;
+        break;
+
+    case MR_TYPECTOR_REP_TYPECTORDESC:
+        /*
+        ** type_ctor_descs are always either encoded integers,
+        ** or pointers to static data
+        */
         new_data = data;
         break;
 
@@ -529,7 +538,7 @@
         break;
 
     case MR_TYPECTOR_REP_BASETYPECLASSINFO:
-        /* base_typeclass_infos are always static */
+        /* base_typeclass_infos are always pointers to static data */
         new_data = data;
         break;
 
Index: runtime/mercury_ho_call.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_ho_call.c,v
retrieving revision 1.51
diff -u -b -r1.51 mercury_ho_call.c
--- runtime/mercury_ho_call.c	18 Feb 2002 07:01:16 -0000	1.51
+++ runtime/mercury_ho_call.c	15 Mar 2002 02:08:54 -0000
@@ -21,6 +21,7 @@
 
 #include "mercury_imp.h"
 #include "mercury_ho_call.h"
+#include "mercury_type_desc.h"
 #include "mercury_deep_profiling.h"
 #include "mercury_deep_profiling_hand.h"
 
@@ -102,6 +103,14 @@
 	"mercury_ho_call.c", 0, MR_TRUE);
 MR_proc_static_user_builtin_empty(typectorinfo_compare, 3, 0,
 	"mercury_ho_call.c", 0, MR_TRUE);
+MR_proc_static_user_builtin_empty(typedesc_unify, 2, 0,
+	"mercury_ho_call.c", 0, MR_TRUE);
+MR_proc_static_user_builtin_empty(typedesc_compare, 3, 0,
+	"mercury_ho_call.c", 0, MR_TRUE);
+MR_proc_static_user_builtin_empty(typectordesc_unify, 2, 0,
+	"mercury_ho_call.c", 0, MR_TRUE);
+MR_proc_static_user_builtin_empty(typectordesc_compare, 3, 0,
+	"mercury_ho_call.c", 0, MR_TRUE);
 
 #endif
 
@@ -552,5 +561,13 @@
 		&MR_proc_static_user_builtin_name(typectorinfo_unify, 2, 0));
 	MR_write_out_proc_static(fp, (MR_ProcStatic *)
 		&MR_proc_static_user_builtin_name(typectorinfo_compare, 3, 0));
+	MR_write_out_proc_static(fp, (MR_ProcStatic *)
+		&MR_proc_static_user_builtin_name(typedesc_unify, 2, 0));
+	MR_write_out_proc_static(fp, (MR_ProcStatic *)
+		&MR_proc_static_user_builtin_name(typedesc_compare, 3, 0));
+	MR_write_out_proc_static(fp, (MR_ProcStatic *)
+		&MR_proc_static_user_builtin_name(typectordesc_unify, 2, 0));
+	MR_write_out_proc_static(fp, (MR_ProcStatic *)
+		&MR_proc_static_user_builtin_name(typectordesc_compare, 3, 0));
 }
 #endif
Index: runtime/mercury_mcpp.cpp
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_mcpp.cpp,v
retrieving revision 1.12
diff -u -b -r1.12 mercury_mcpp.cpp
--- runtime/mercury_mcpp.cpp	30 Jan 2002 05:09:00 -0000	1.12
+++ runtime/mercury_mcpp.cpp	14 Mar 2002 23:31:58 -0000
@@ -160,7 +160,9 @@
     static int MR_TYPECTOR_REP_RESERVED_ADDR_USEREQ	=32;
     static int MR_TYPECTOR_REP_TYPECTORINFO	        =33;
     static int MR_TYPECTOR_REP_BASETYPECLASSINFO        =34;
-    static int MR_TYPECTOR_REP_UNKNOWN		        =35;
+    static int MR_TYPECTOR_REP_TYPEDESC	        	=35;
+    static int MR_TYPECTOR_REP_TYPECTORDESC	        =36;
+    static int MR_TYPECTOR_REP_UNKNOWN		        =37;
 
     static int MR_SECTAG_NONE				= 0;
     static int MR_SECTAG_LOCAL				= 1;
Index: runtime/mercury_mcpp.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_mcpp.h,v
retrieving revision 1.18
diff -u -b -r1.18 mercury_mcpp.h
--- runtime/mercury_mcpp.h	20 Feb 2002 10:14:35 -0000	1.18
+++ runtime/mercury_mcpp.h	14 Mar 2002 23:31:30 -0000
@@ -161,7 +161,9 @@
 #define MR_TYPECTOR_REP_RESERVED_ADDR_USEREQ_val	32
 #define MR_TYPECTOR_REP_TYPECTORINFO_val		33
 #define MR_TYPECTOR_REP_BASETYPECLASSINFO_val		34
-#define MR_TYPECTOR_REP_UNKNOWN_val			35
+#define MR_TYPECTOR_REP_TYPEDESC_val			35
+#define MR_TYPECTOR_REP_TYPECTORDESC_val		36
+#define MR_TYPECTOR_REP_UNKNOWN_val			37
 
 // XXX we should integrate this macro in with the version in 
 // mercury_typeinfo.h
Index: runtime/mercury_ml_expand_body.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_ml_expand_body.h,v
retrieving revision 1.18
diff -u -b -r1.18 mercury_ml_expand_body.h
--- runtime/mercury_ml_expand_body.h	12 Mar 2002 03:40:38 -0000	1.18
+++ runtime/mercury_ml_expand_body.h	14 Mar 2002 23:46:49 -0000
@@ -904,6 +904,7 @@
             break;
 
         case MR_TYPECTOR_REP_TYPEINFO:
+        case MR_TYPECTOR_REP_TYPEDESC:
             {
                 MR_TypeInfo     data_type_info;
                 MR_TypeCtorInfo data_type_ctor_info;
@@ -1002,6 +1003,32 @@
 
                 data_type_ctor_info = (MR_TypeCtorInfo) *data_word_ptr;
                 handle_type_ctor_name(data_type_ctor_info);
+                handle_zero_arity_args();
+            }
+
+            break;
+
+        case MR_TYPECTOR_REP_TYPECTORDESC:
+            {
+                MR_TypeCtorDesc data_type_ctor_desc; 
+                MR_TypeCtorInfo data_type_ctor_info; 
+
+                if (noncanon == MR_NONCANON_ABORT) {
+                    /* XXX should throw an exception */
+                    MR_fatal_error(MR_STRINGIFY(EXPAND_FUNCTION_NAME)
+                        ": attempt to deconstruct noncanonical term");
+                }
+
+                data_type_ctor_desc = (MR_TypeCtorDesc) *data_word_ptr;
+                if (MR_TYPECTOR_DESC_IS_VARIABLE_ARITY(data_type_ctor_desc)) {
+                    handle_functor_name(MR_TYPECTOR_DESC_GET_VA_NAME(
+                        data_type_ctor_desc));
+                } else {
+                    data_type_ctor_info =
+                        MR_TYPECTOR_DESC_GET_FIXED_ARITY_TYPE_CTOR_INFO(
+                            data_type_ctor_desc);
+                    handle_type_ctor_name(data_type_ctor_info);
+                }
                 handle_zero_arity_args();
             }
 
Index: runtime/mercury_tabling.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_tabling.c,v
retrieving revision 1.49
diff -u -b -r1.49 mercury_tabling.c
--- runtime/mercury_tabling.c	18 Feb 2002 07:01:20 -0000	1.49
+++ runtime/mercury_tabling.c	15 Mar 2002 02:19:32 -0000
@@ -901,11 +901,16 @@
             break;
 
         case MR_TYPECTOR_REP_TYPEINFO:
+        case MR_TYPECTOR_REP_TYPEDESC:
             MR_DEBUG_TABLE_TYPEINFO(table, (MR_TypeInfo) data);
             break;
 
         case MR_TYPECTOR_REP_TYPECTORINFO:
             MR_fatal_error("Attempt to table a type_ctor_info");
+            break;
+
+        case MR_TYPECTOR_REP_TYPECTORDESC:
+            MR_fatal_error("Attempt to table a type_ctor_desc");
             break;
 
         case MR_TYPECTOR_REP_TYPECLASSINFO:
Index: runtime/mercury_type_desc.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_type_desc.c,v
retrieving revision 1.2
diff -u -b -r1.2 mercury_type_desc.c
--- runtime/mercury_type_desc.c	18 Feb 2002 07:01:22 -0000	1.2
+++ runtime/mercury_type_desc.c	18 Mar 2002 05:36:20 -0000
@@ -132,3 +132,87 @@
 
 	return (MR_TypeInfo) new_type_info_arena;
 }
+
+int
+MR_compare_type_ctor_desc(MR_TypeCtorDesc tcd1, MR_TypeCtorDesc tcd2)
+{
+	MR_TypeCtorInfo	tci1;
+	MR_TypeCtorInfo tci2;
+	int		arity1;
+	int		arity2;
+	int		result;
+
+	/*
+	** We use this algorithm to get comparison results that are
+	** consistent with MR_compare_type_ctor_info.
+	*/
+
+	tci1 = MR_TYPECTOR_DESC_GET_TYPE_CTOR_INFO(tcd1);
+	tci2 = MR_TYPECTOR_DESC_GET_TYPE_CTOR_INFO(tcd2);
+
+	result = MR_compare_type_ctor_info(tci1, tci2);
+	if (result != MR_COMPARE_EQUAL) {
+		return result;
+	}
+
+	if (MR_TYPECTOR_DESC_IS_VARIABLE_ARITY(tcd1)) {
+		/*
+		** We already know that the two type_ctor_descs refer to
+		** the same variable-arity type constructor, so they can
+		** differ only in the arity.
+		*/
+
+		arity1 = MR_TYPECTOR_DESC_GET_VA_ARITY(tcd1);
+		arity2 = MR_TYPECTOR_DESC_GET_VA_ARITY(tcd2);
+
+		if (arity1 < arity2) {
+			return MR_COMPARE_LESS;
+		} else if (arity1 > arity2) {
+			return MR_COMPARE_GREATER;
+		} else {
+			return MR_COMPARE_EQUAL;
+		}
+	} else {
+		return result;
+	}
+}
+
+MR_bool
+MR_unify_type_ctor_desc(MR_TypeCtorDesc tcd1, MR_TypeCtorDesc tcd2)
+{
+	MR_TypeCtorInfo	tci1;
+	MR_TypeCtorInfo tci2;
+	int		arity1;
+	int		arity2;
+
+	/*
+	** We use this algorithm to get comparison results that are
+	** consistent with MR_unify_type_ctor_info.
+	*/
+
+	tci1 = MR_TYPECTOR_DESC_GET_TYPE_CTOR_INFO(tcd1);
+	tci2 = MR_TYPECTOR_DESC_GET_TYPE_CTOR_INFO(tcd2);
+
+	if (! MR_unify_type_ctor_info(tci1, tci2)) {
+		return MR_FALSE;
+	}
+
+	if (MR_TYPECTOR_DESC_IS_VARIABLE_ARITY(tcd1)) {
+		/*
+		** We already know that the two type_ctor_descs refer to
+		** the same variable-arity type constructor, so they can
+		** differ only in the arity.
+		*/
+
+		arity1 = MR_TYPECTOR_DESC_GET_VA_ARITY(tcd1);
+		arity2 = MR_TYPECTOR_DESC_GET_VA_ARITY(tcd2);
+
+		if (arity1 == arity2) {
+			return MR_TRUE;
+		} else {
+			return MR_FALSE;
+		}
+	} else {
+		return MR_TRUE;
+	}
+}
Index: runtime/mercury_type_desc.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_type_desc.h,v
retrieving revision 1.2
diff -u -b -r1.2 mercury_type_desc.h
--- runtime/mercury_type_desc.h	18 Feb 2002 07:01:22 -0000	1.2
+++ runtime/mercury_type_desc.h	18 Mar 2002 05:32:23 -0000
@@ -24,7 +24,7 @@
 **
 ** Values of type `types:type_ctor_desc' are not guaranteed to be
 ** represented the same way as values of type `private_builtin:type_ctor_info'.
-** The representations *are* in fact identical for first order types, but they
+** The representations *are* in fact identical for fixed arity types, but they
 ** differ for higher order and tuple types. Instead of a type_ctor_desc
 ** being a structure containing a pointer to the type_ctor_info for pred/0
 ** or func/0 and an arity, we have a single small encoded integer. This
@@ -112,6 +112,10 @@
 		: (((MR_Unsigned) (T) % 4 == 1)				\
 			? (MR_address_of_type_ctor_info_for_func)	\
 			: (MR_address_of_type_ctor_info_for_tuple) ) )
+#define MR_TYPECTOR_DESC_GET_TYPE_CTOR_INFO(T)				\
+	( MR_TYPECTOR_DESC_IS_VARIABLE_ARITY(T)				\
+	  ? MR_TYPECTOR_DESC_GET_VA_TYPE_CTOR_INFO(T)			\
+	  : MR_TYPECTOR_DESC_GET_FIXED_ARITY_TYPE_CTOR_INFO(T))
 
 /*
 ** Create and return a MR_TypeCtorDesc that describes the same type as
@@ -155,5 +159,31 @@
 
 extern	MR_TypeInfo	MR_make_type(int arity, MR_TypeCtorDesc type_ctor_desc,
 				MR_Word arg_type_list);
+
+/* 
+** Compare two type_ctor_info structures, using an ordering based on the
+** module names, type names and arities of the types represented by tcd1/tcd2.
+** Return MR_COMPARE_GREATER, MR_COMPARE_EQUAL, or MR_COMPARE_LESS,
+** depending on whether tcd1 is greater than, equal to, or less than tcd2.
+** 
+** You need to wrap MR_{save/restore}_transient_hp() around
+** calls to this function.
+*/
+
+extern	int		MR_compare_type_ctor_desc(MR_TypeCtorDesc tcd1,
+				MR_TypeCtorDesc tcd2);
+
+/* 
+** Unify two type_ctor_info structures, using an ordering based on the
+** module names, type names and arities of the types represented by tcd1/tcd2.
+** Return MR_TRUE iff tcd1 and tcd2 represent the same type constructor,
+** and MR_FALSE otherwise.
+** 
+** You need to wrap MR_{save/restore}_transient_hp() around
+** calls to this function.
+*/
+
+extern	MR_bool		MR_unify_type_ctor_desc(MR_TypeCtorDesc tcd1,
+				MR_TypeCtorDesc tcd2);
 
 #endif	/* MERCURY_TYPE_DESC_H */
Index: runtime/mercury_type_info.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_type_info.c,v
retrieving revision 1.49
diff -u -b -r1.49 mercury_type_info.c
--- runtime/mercury_type_info.c	12 Mar 2002 03:40:39 -0000	1.49
+++ runtime/mercury_type_info.c	18 Mar 2002 05:29:26 -0000
@@ -117,7 +117,8 @@
 	MR_TypeCtorInfo	tci2;
 	MR_TypeInfo	*arg_vector_1;
 	MR_TypeInfo	*arg_vector_2;
-	int		num_arg_types;
+	int		num_arg_types_1;
+	int		num_arg_types_2;
 	int		i;
 	int		comp;
 
@@ -167,28 +168,26 @@
 	*/
 
 	if (MR_type_ctor_rep_is_variable_arity(MR_type_ctor_rep(tci1))) {
-		int	num_arg_types_2;
-
-		num_arg_types = MR_TYPEINFO_GET_HIGHER_ORDER_ARITY(ti1);
+		num_arg_types_1 = MR_TYPEINFO_GET_HIGHER_ORDER_ARITY(ti1);
 		num_arg_types_2 = MR_TYPEINFO_GET_HIGHER_ORDER_ARITY(ti2);
 
 			/* Check arity */
-		if (num_arg_types < num_arg_types_2) {
+		if (num_arg_types_1 < num_arg_types_2) {
 			return MR_COMPARE_LESS;
-		} else if (num_arg_types > num_arg_types_2) {
+		} else if (num_arg_types_1 > num_arg_types_2) {
 			return MR_COMPARE_GREATER;
 		}
 
 		arg_vector_1 = MR_TYPEINFO_GET_HIGHER_ORDER_ARG_VECTOR(ti1);
 		arg_vector_2 = MR_TYPEINFO_GET_HIGHER_ORDER_ARG_VECTOR(ti2);
 	} else {
-		num_arg_types = tci1->MR_type_ctor_arity;
+		num_arg_types_1 = tci1->MR_type_ctor_arity;
 		arg_vector_1 = MR_TYPEINFO_GET_FIRST_ORDER_ARG_VECTOR(ti1);
 		arg_vector_2 = MR_TYPEINFO_GET_FIRST_ORDER_ARG_VECTOR(ti2);
 	}
 
 		/* compare the argument types */
-	for (i = 1; i <= num_arg_types; i++) {
+	for (i = 1; i <= num_arg_types_1; i++) {
 		comp = MR_compare_type_info(arg_vector_1[i], arg_vector_2[i]);
 		if (comp != MR_COMPARE_EQUAL)
 			return comp;
@@ -197,30 +196,163 @@
 	return MR_COMPARE_EQUAL;
 }
 
+MR_bool
+MR_unify_type_info(MR_TypeInfo ti1, MR_TypeInfo ti2)
+{
+	MR_TypeCtorInfo	tci1;
+	MR_TypeCtorInfo	tci2;
+	MR_TypeInfo	*arg_vector_1;
+	MR_TypeInfo	*arg_vector_2;
+	int		num_arg_types_1;
+	int		num_arg_types_2;
+	int		i;
+	int		comp;
+
+	/* 
+	** Try to optimize a common case:
+	** If type_info addresses are equal, they must represent the
+	** same type.
+	*/
+
+	if (ti1 == ti2) {
+		return MR_TRUE;
+	}
+
+	/* 
+	** Otherwise, we need to expand equivalence types, if any.
+	*/
+
+	ti1 = MR_collapse_equivalences(ti1);
+	ti2 = MR_collapse_equivalences(ti2);
+
+	/* 
+	** Perhaps they are equal now...
+	*/
+
+	if (ti1 == ti2) {
+		return MR_TRUE;
+	}
+
+	/*
+	** Otherwise find the type_ctor_infos, and compare those.
+	*/
+
+	tci1 = MR_TYPEINFO_GET_TYPE_CTOR_INFO(ti1);
+	tci2 = MR_TYPEINFO_GET_TYPE_CTOR_INFO(ti2);
+
+	if (! MR_unify_type_ctor_info(tci1, tci2)) {
+		return MR_FALSE;
+	}
+
+	/*
+	** If the type_ctor_infos are equal, we don't need to compare
+	** the arity of the types - they must be the same - unless they are
+	** higher-order (which are all mapped to pred/0 or func/0) or tuples
+	** (which are all mapped to tuple/0), in which cases we must compare
+	** the arities before we can check the argument types.
+	*/
+
+	if (MR_type_ctor_rep_is_variable_arity(MR_type_ctor_rep(tci1))) {
+		num_arg_types_1 = MR_TYPEINFO_GET_HIGHER_ORDER_ARITY(ti1);
+		num_arg_types_2 = MR_TYPEINFO_GET_HIGHER_ORDER_ARITY(ti2);
+
+			/* Check arity */
+		if (num_arg_types_1 != num_arg_types_2) {
+			return MR_FALSE;
+		}
+
+		arg_vector_1 = MR_TYPEINFO_GET_HIGHER_ORDER_ARG_VECTOR(ti1);
+		arg_vector_2 = MR_TYPEINFO_GET_HIGHER_ORDER_ARG_VECTOR(ti2);
+	} else {
+		num_arg_types_1 = tci1->MR_type_ctor_arity;
+		arg_vector_1 = MR_TYPEINFO_GET_FIRST_ORDER_ARG_VECTOR(ti1);
+		arg_vector_2 = MR_TYPEINFO_GET_FIRST_ORDER_ARG_VECTOR(ti2);
+	}
+
+		/* compare the argument types */
+	for (i = 1; i <= num_arg_types_1; i++) {
+		if (! MR_unify_type_info(arg_vector_1[i], arg_vector_2[i])) {
+			return MR_FALSE;
+		}
+	}
+
+	return MR_TRUE;
+}
+
 int
 MR_compare_type_ctor_info(MR_TypeCtorInfo tci1, MR_TypeCtorInfo tci2)
 {
 	int		i;
+	int		comp;
+	MR_ConstString	modulename1;
+	MR_ConstString	modulename2;
+	MR_ConstString	typename1;
+	MR_ConstString	typename2;
+	int		arity1;
+	int		arity2;
 
 	/*
-	** Note: this is an arbitrary ordering. It doesn't matter
-	** what the ordering is, just so long as it is consistent.
-	** For consistency, we are relying on the fact that type_ctor_infos
-	** are always statically allocated.
-	** ANSI C doesn't guarantee much about pointer comparisons,
-	** so it is possible that this might not do the right thing
-	** on some obscure systems.
+	** We are relying on the fact that type_ctor_infos are always
+	** statically allocated to ensure that two type_ctor_infos are
+	** for the same type iff their address is the same.
+	**
 	** The casts to (MR_Unsigned) here are in the hope of increasing
 	** the chance that this will work on a segmented architecture.
 	*/
 
-	if ((MR_Unsigned) tci1 < (MR_Unsigned) tci2) {
+	if ((MR_Unsigned) tci1 == (MR_Unsigned) tci2) {
+		return MR_COMPARE_EQUAL;
+	}
+
+	modulename1 = tci1->MR_type_ctor_module_name;
+	modulename2 = tci2->MR_type_ctor_module_name;
+
+	comp = strcmp(modulename1, modulename2);
+	if (comp < 0) {
 		return MR_COMPARE_LESS;
-	} else if ((MR_Unsigned) tci1 > (MR_Unsigned) tci2) {
+	} else if (comp > 0) {
 		return MR_COMPARE_GREATER;
 	}
 
-	return MR_COMPARE_EQUAL;
+	typename1 = tci1->MR_type_ctor_name;
+	typename2 = tci2->MR_type_ctor_name;
+	comp = strcmp(typename1, typename2);
+	if (comp < 0) {
+		return MR_COMPARE_LESS;
+	} else if (comp > 0) {
+		return MR_COMPARE_GREATER;
+	}
+
+	arity1 = tci1->MR_type_ctor_arity;
+	arity2 = tci2->MR_type_ctor_arity;
+	if (arity1 < arity2) {
+		return MR_COMPARE_LESS;
+	} else if (arity1 > arity2) {
+		return MR_COMPARE_GREATER;
+	}
+
+	MR_fatal_error("type_ctor_info match at distinct addresses");
+}
+
+MR_bool
+MR_unify_type_ctor_info(MR_TypeCtorInfo tci1, MR_TypeCtorInfo tci2)
+{
+	int		i;
+
+	/*
+	** We are relying on the fact that type_ctor_infos are always
+	** statically allocated to ensure that two type_ctor_infos are
+	** for the same type iff their address is the same.
+	**
+	** The casts to (MR_Unsigned) here are in the hope of increasing
+	** the chance that this will work on a segmented architecture.
+	*/
+
+	if ((MR_Unsigned) tci1 == (MR_Unsigned) tci2) {
+		return MR_TRUE;
+	} else {
+		return MR_FALSE;
+	}
 }
 
 MR_TypeInfo
Index: runtime/mercury_type_info.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_type_info.h,v
retrieving revision 1.87
diff -u -b -r1.87 mercury_type_info.h
--- runtime/mercury_type_info.h	12 Mar 2002 03:40:39 -0000	1.87
+++ runtime/mercury_type_info.h	18 Mar 2002 05:28:46 -0000
@@ -467,7 +467,7 @@
 ** MR_CTOR_REP_NAMES below, in runtime/mercury_mcpp.{h,cpp}, in
 ** library/rtti_implementation.m (definitely the list of type_ctor_reps,
 ** maybe the bodies of predicates), in library/private_builtin.m,
-** and in java/TypeCtorRep.java.
+** and in java/runtime/TypeCtorRep.java.
 **
 ** Additions to the end of this enum can be handled naturally,
 ** but changes in the meanings of already assigned values
@@ -510,6 +510,8 @@
     MR_DEFINE_BUILTIN_ENUM_CONST(MR_TYPECTOR_REP_RESERVED_ADDR_USEREQ),
     MR_DEFINE_BUILTIN_ENUM_CONST(MR_TYPECTOR_REP_TYPECTORINFO),
     MR_DEFINE_BUILTIN_ENUM_CONST(MR_TYPECTOR_REP_BASETYPECLASSINFO),
+    MR_DEFINE_BUILTIN_ENUM_CONST(MR_TYPECTOR_REP_TYPEDESC),
+    MR_DEFINE_BUILTIN_ENUM_CONST(MR_TYPECTOR_REP_TYPECTORDESC),
     /*
     ** MR_TYPECTOR_REP_UNKNOWN should remain the last alternative;
     ** MR_TYPE_CTOR_STATS depends on this.
@@ -1206,9 +1208,9 @@
 /*---------------------------------------------------------------------------*/
 
 /*
-** Compare two type_info structures, using an arbitrary ordering based on
-** the addresses of the type_ctor_infos, or in the case of higher order types,
-** the arity). Return MR_COMPARE_GREATER, MR_COMPARE_EQUAL, or MR_COMPARE_LESS,
+** Compare two type_info structures, using an ordering based on the
+** module names, type names and arities of the types inside the type_info.
+** Return MR_COMPARE_GREATER, MR_COMPARE_EQUAL, or MR_COMPARE_LESS,
 ** depending on whether ti1 is greater than, equal to, or less than ti2.
 **
 ** You need to wrap MR_{save/restore}_transient_hp() around
@@ -1218,9 +1220,21 @@
 extern  int     MR_compare_type_info(MR_TypeInfo ti1, MR_TypeInfo ti2);
 
 /*
-** Compare two type_ctor_info structures, using an arbitrary ordering based on
-** the addresses of the type_ctor_infos, or in the case of higher order types,
-** the arity). Return MR_COMPARE_GREATER, MR_COMPARE_EQUAL, or MR_COMPARE_LESS,
+** Unify two type_info structures, using an ordering based on the
+** module names, type names and arities of the types inside the type_info.
+** Return MR_TRUE if ti1 represents the same type as ti2, and MR_FALSE
+** otherwise.
+**
+** You need to wrap MR_{save/restore}_transient_hp() around
+** calls to this function.
+*/
+
+extern  MR_bool MR_unify_type_info(MR_TypeInfo ti1, MR_TypeInfo ti2);
+
+/*
+** Compare two type_ctor_info structures, using an ordering based on the
+** module names, type names and arities of the types represented by tci1/tci2.
+** Return MR_COMPARE_GREATER, MR_COMPARE_EQUAL, or MR_COMPARE_LESS,
 ** depending on whether tci1 is greater than, equal to, or less than tci2.
 **
 ** You need to wrap MR_{save/restore}_transient_hp() around
@@ -1228,6 +1242,19 @@
 */
 
 extern  int     MR_compare_type_ctor_info(MR_TypeCtorInfo tci1,
+                    MR_TypeCtorInfo tci2);
+
+/*
+** Unify two type_ctor_info structures, using an ordering based on the
+** module names, type names and arities of the types represented by tci1/tci2.
+** Return MR_TRUE if tci1 represents the same type constructor as tci2, and
+** MR_FALSE otherwise.
+**
+** You need to wrap MR_{save/restore}_transient_hp() around
+** calls to this function.
+*/
+
+extern  MR_bool MR_unify_type_ctor_info(MR_TypeCtorInfo tci1,
                     MR_TypeCtorInfo tci2);
 
 /*
Index: runtime/mercury_unify_compare_body.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_unify_compare_body.h,v
retrieving revision 1.18
diff -u -b -r1.18 mercury_unify_compare_body.h
--- runtime/mercury_unify_compare_body.h	18 Feb 2002 07:01:23 -0000	1.18
+++ runtime/mercury_unify_compare_body.h	18 Mar 2002 05:44:04 -0000
@@ -1,4 +1,7 @@
 /*
+** vim:ts=4 sw=4 expandtab
+*/
+/*
 ** Copyright (C) 2000-2002 The University of Melbourne.
 ** This file may only be copied under the terms of the GNU Library General
 ** Public License - see the file COPYING.LIB in the Mercury distribution.
@@ -539,57 +542,130 @@
 
         case MR_TYPECTOR_REP_TYPEINFO:
             {
+#ifdef  select_compare_code
                 int result;
 
                 MR_save_transient_registers();
                 result = MR_compare_type_info(
                     (MR_TypeInfo) x, (MR_TypeInfo) y);
                 MR_restore_transient_registers();
-#ifdef	select_compare_code
   #if defined(MR_DEEP_PROFILING) && defined(entry_point_is_mercury)
                 compare_call_exit_code(typeinfo_compare);
   #endif
                 return_answer(result);
 #else
+                MR_bool result;
+
+                MR_save_transient_registers();
+                result = MR_unify_type_info(
+                    (MR_TypeInfo) x, (MR_TypeInfo) y);
+                MR_restore_transient_registers();
   #if defined(MR_DEEP_PROFILING) && defined(entry_point_is_mercury)
-                if (result == MR_COMPARE_EQUAL) {
+                if (result) {
                     unify_call_exit_code(typeinfo_unify);
-                    return_answer(MR_TRUE);
                 } else {
                     unify_call_fail_code(typeinfo_unify);
-                    return_answer(MR_FALSE);
                 }
-  #else
-                return_answer(result == MR_COMPARE_EQUAL);
   #endif
+                return_answer(result);
+#endif
+            }
+
+        case MR_TYPECTOR_REP_TYPEDESC:
+            /*
+            ** Differs from the code for MR_TYPECTOR_REP_TYPEINFO
+            ** only in recording profiling information elsewhere.
+            */
+
+            {
+#ifdef  select_compare_code
+                int result;
+
+                MR_save_transient_registers();
+                result = MR_compare_type_info(
+                    (MR_TypeInfo) x, (MR_TypeInfo) y);
+                MR_restore_transient_registers();
+  #if defined(MR_DEEP_PROFILING) && defined(entry_point_is_mercury)
+                compare_call_exit_code(typedesc_compare);
+  #endif
+                return_answer(result);
+#else
+                MR_bool result;
+
+                MR_save_transient_registers();
+                result = MR_unify_type_info(
+                    (MR_TypeInfo) x, (MR_TypeInfo) y);
+                MR_restore_transient_registers();
+  #if defined(MR_DEEP_PROFILING) && defined(entry_point_is_mercury)
+                if (result) {
+                    unify_call_exit_code(typedesc_unify);
+                } else {
+                    unify_call_fail_code(typedesc_unify);
+                }
+  #endif
+                return_answer(result);
 #endif
             }
 
         case MR_TYPECTOR_REP_TYPECTORINFO:
             {
+#ifdef  select_compare_code
                 int result;
 
                 MR_save_transient_registers();
                 result = MR_compare_type_ctor_info(
                     (MR_TypeCtorInfo) x, (MR_TypeCtorInfo) y);
                 MR_restore_transient_registers();
-#ifdef	select_compare_code
   #if defined(MR_DEEP_PROFILING) && defined(entry_point_is_mercury)
                 compare_call_exit_code(typectorinfo_compare);
   #endif
                 return_answer(result);
 #else
+                MR_bool result;
+
+                MR_save_transient_registers();
+                result = MR_unify_type_ctor_info(
+                    (MR_TypeCtorInfo) x, (MR_TypeCtorInfo) y);
+                MR_restore_transient_registers();
   #if defined(MR_DEEP_PROFILING) && defined(entry_point_is_mercury)
-                if (result == MR_COMPARE_EQUAL) {
+                if (result) {
                     unify_call_exit_code(typectorinfo_unify);
-                    return_answer(MR_TRUE);
                 } else {
                     unify_call_fail_code(typectorinfo_unify);
-                    return_answer(MR_FALSE);
                 }
-  #else
-                return_answer(result == MR_COMPARE_EQUAL);
   #endif
+                return_answer(result);
+#endif
+            }
+
+        case MR_TYPECTOR_REP_TYPECTORDESC:
+            {
+#ifdef  select_compare_code
+                int result;
+
+                MR_save_transient_registers();
+                result = MR_compare_type_ctor_desc(
+                    (MR_TypeCtorDesc) x, (MR_TypeCtorDesc) y);
+                MR_restore_transient_registers();
+  #if defined(MR_DEEP_PROFILING) && defined(entry_point_is_mercury)
+                compare_call_exit_code(typectordesc_compare);
+  #endif
+                return_answer(result);
+#else
+                MR_bool result;
+
+                MR_save_transient_registers();
+                result = MR_unify_type_ctor_desc(
+                    (MR_TypeCtorDesc) x, (MR_TypeCtorDesc) y);
+                MR_restore_transient_registers();
+  #if defined(MR_DEEP_PROFILING) && defined(entry_point_is_mercury)
+                if (result == MR_COMPARE_EQUAL) {
+                    unify_call_exit_code(typectordesc_unify);
+                } else {
+                    unify_call_fail_code(typectordesc_unify);
+                }
+  #endif
+                return_answer(result);
 #endif
             }
 
cvs diff: Diffing runtime/GETOPT
cvs diff: Diffing runtime/machdeps
cvs diff: Diffing samples
cvs diff: Diffing samples/c_interface
cvs diff: Diffing samples/c_interface/c_calls_mercury
cvs diff: Diffing samples/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/c_interface/mercury_calls_c
cvs diff: Diffing samples/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/diff
cvs diff: Diffing samples/muz
cvs diff: Diffing samples/rot13
cvs diff: Diffing samples/solutions
cvs diff: Diffing samples/tests
cvs diff: Diffing samples/tests/c_interface
cvs diff: Diffing samples/tests/c_interface/c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/tests/c_interface/mercury_calls_c
cvs diff: Diffing samples/tests/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/tests/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/tests/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/tests/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/tests/diff
cvs diff: Diffing samples/tests/muz
cvs diff: Diffing samples/tests/rot13
cvs diff: Diffing samples/tests/solutions
cvs diff: Diffing samples/tests/toplevel
cvs diff: Diffing scripts
cvs diff: Diffing tests
cvs diff: Diffing tests/benchmarks
cvs diff: Diffing tests/debugger
Index: tests/debugger/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/debugger/Mmakefile,v
retrieving revision 1.69
diff -u -b -r1.69 Mmakefile
--- tests/debugger/Mmakefile	8 Mar 2002 07:18:08 -0000	1.69
+++ tests/debugger/Mmakefile	15 Mar 2002 05:08:34 -0000
@@ -45,7 +45,8 @@
 	output_term_dep			\
 	polymorphic_output		\
 	resume_typeinfos		\
-	shallow
+	shallow				\
+	type_desc_test
 
 # The completion test requires mdb to use readline, even though
 # the input is not a terminal.
@@ -283,6 +284,10 @@
 tabled_read_decl.out: tabled_read_decl tabled_read_decl.inp tabled_read_decl.data
 	$(MDB) ./tabled_read_decl < tabled_read_decl.inp \
 		> tabled_read_decl.out 2>&1
+
+type_desc_test.out: type_desc_test type_desc_test.inp
+	$(MDB) ./type_desc_test < type_desc_test.inp \
+		> type_desc_test.out 2>&1
 
 # Note that interactive.out.orig depends on $(interactive.ints) because
 # interactive.inp contains interactive queries that require interactive.ints
Index: tests/debugger/type_desc_test.exp
===================================================================
RCS file: tests/debugger/type_desc_test.exp
diff -N tests/debugger/type_desc_test.exp
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/debugger/type_desc_test.exp	15 Mar 2002 05:15:12 -0000
@@ -0,0 +1,43 @@
+       1:      1  1 CALL pred type_desc_test:main/2-0 (det) type_desc_test.m:21
+mdb> echo on
+Command echo enabled.
+mdb> context none
+Contexts will not be printed.
+mdb> register --quiet
+mdb> break get_type_desc
+ 0: + stop  interface func type_desc_test:get_type_desc/1-0 (det)
+mdb> break get_type_ctor_desc
+ 1: + stop  interface func type_desc_test:get_type_ctor_desc/1-0 (det)
+mdb> continue
+       3:      3  3 CALL func type_desc_test:get_type_desc/1-0 (det)
+mdb> finish
+       4:      3  3 EXIT func type_desc_test:get_type_desc/1-0 (det)
+mdb> print *
+       HeadVar__1             	[1, 2]
+       HeadVar__2             	list:list(int)
+mdb> continue
+type_desc: list:list(int)
+       5:      4  3 CALL func type_desc_test:get_type_ctor_desc/1-0 (det)
+mdb> finish
+       6:      4  3 EXIT func type_desc_test:get_type_ctor_desc/1-0 (det)
+mdb> print *
+       HeadVar__1             	list:list(int)
+       HeadVar__2             	list:list/1
+mdb> continue
+type_ctor_desc: list:list/1
+       9:      6  3 CALL func type_desc_test:get_type_desc/1-0 (det)
+mdb> finish
+      10:      6  3 EXIT func type_desc_test:get_type_desc/1-0 (det)
+mdb> print *
+       HeadVar__1             	["one", "two", "three"]
+       HeadVar__2             	list:list(string)
+mdb> continue
+type_desc: list:list(string)
+      11:      7  3 CALL func type_desc_test:get_type_ctor_desc/1-0 (det)
+mdb> finish
+      12:      7  3 EXIT func type_desc_test:get_type_ctor_desc/1-0 (det)
+mdb> print *
+       HeadVar__1             	list:list(string)
+       HeadVar__2             	list:list/1
+mdb> continue -S
+type_ctor_desc: list:list/1
Index: tests/debugger/type_desc_test.exp2
===================================================================
RCS file: tests/debugger/type_desc_test.exp2
diff -N tests/debugger/type_desc_test.exp2
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/debugger/type_desc_test.exp2	18 Mar 2002 14:58:43 -0000
@@ -0,0 +1,43 @@
+       1:      1  1 CALL pred type_desc_test:main/2-0 (det) type_desc_test.m:21
+mdb> echo on
+Command echo enabled.
+mdb> context none
+Contexts will not be printed.
+mdb> register --quiet
+mdb> break get_type_desc
+ 0: + stop  interface func type_desc_test:get_type_desc/1-0 (det)
+mdb> break get_type_ctor_desc
+ 1: + stop  interface func type_desc_test:get_type_ctor_desc/1-0 (det)
+mdb> continue
+       3:      3  3 CALL func type_desc_test:get_type_desc/1-0 (det)
+mdb> finish
+       6:      3  3 EXIT func type_desc_test:get_type_desc/1-0 (det)
+mdb> print *
+       HeadVar__1             	[1, 2]
+       HeadVar__2             	list:list(int)
+mdb> continue
+type_desc: list:list(int)
+      13:      8  3 CALL func type_desc_test:get_type_ctor_desc/1-0 (det)
+mdb> finish
+      16:      8  3 EXIT func type_desc_test:get_type_ctor_desc/1-0 (det)
+mdb> print *
+       HeadVar__1             	list:list(int)
+       HeadVar__2             	list:list/1
+mdb> continue
+type_ctor_desc: list:list/1
+      25:     14  3 CALL func type_desc_test:get_type_desc/1-0 (det)
+mdb> finish
+      28:     14  3 EXIT func type_desc_test:get_type_desc/1-0 (det)
+mdb> print *
+       HeadVar__1             	["one", "two", "three"]
+       HeadVar__2             	list:list(string)
+mdb> continue
+type_desc: list:list(string)
+      35:     19  3 CALL func type_desc_test:get_type_ctor_desc/1-0 (det)
+mdb> finish
+      38:     19  3 EXIT func type_desc_test:get_type_ctor_desc/1-0 (det)
+mdb> print *
+       HeadVar__1             	list:list(string)
+       HeadVar__2             	list:list/1
+mdb> continue -S
+type_ctor_desc: list:list/1
Index: tests/debugger/type_desc_test.inp
===================================================================
RCS file: tests/debugger/type_desc_test.inp
diff -N tests/debugger/type_desc_test.inp
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/debugger/type_desc_test.inp	15 Mar 2002 05:09:57 -0000
@@ -0,0 +1,18 @@
+echo on
+context none
+register --quiet
+break get_type_desc
+break get_type_ctor_desc
+continue
+finish
+print *
+continue
+finish
+print *
+continue
+finish
+print *
+continue
+finish
+print *
+continue -S
Index: tests/debugger/type_desc_test.m
===================================================================
RCS file: tests/debugger/type_desc_test.m
diff -N tests/debugger/type_desc_test.m
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/debugger/type_desc_test.m	15 Mar 2002 05:10:36 -0000
@@ -0,0 +1,43 @@
+% This is a test of the debugger's handling of the builtin types type_desc and
+% type_ctor_desc.
+%
+% Note that we call type_of through get_type_desc instead of directly because
+% we want to get control when get_type_desc returns to print its arguments.
+% we can't do that without get_type_desc if deconstruct.m was compiled without
+% debugging enabled. We call type_ctor through get_type_ctor_desc for the
+% same reason.
+
+:- module type_desc_test.
+
+:- interface.
+:- import_module io.
+
+:- pred main(io__state::di, state::uo) is det.
+
+:- implementation.
+
+:- import_module type_desc, list.
+
+main -->
+	test([1, 2]),
+	test(["one", "two", "three"]).
+
+:- pred test(T::in, io__state::di, io__state::uo) is det.
+
+test(Val) -->
+	{ TypeDesc = get_type_desc(Val) },
+	io__write_string("type_desc: "),
+	io__write(TypeDesc),
+	io__nl,
+	{ TypeCtorDesc = get_type_ctor_desc(TypeDesc) },
+	io__write_string("type_ctor_desc: "),
+	io__write(TypeCtorDesc),
+	io__nl.
+
+:- func get_type_desc(T) = type_desc.
+
+get_type_desc(Val) = type_of(Val).
+
+:- func get_type_ctor_desc(type_desc) = type_ctor_desc.
+
+get_type_ctor_desc(TypeDesc) = type_ctor(TypeDesc).
cvs diff: Diffing tests/debugger/declarative
cvs diff: Diffing tests/dppd
cvs diff: Diffing tests/general
cvs diff: Diffing tests/general/accumulator
cvs diff: Diffing tests/general/structure_reuse
cvs diff: Diffing tests/hard_coded
Index: tests/hard_coded/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/Mmakefile,v
retrieving revision 1.144
diff -u -b -r1.144 Mmakefile
--- tests/hard_coded/Mmakefile	3 Mar 2002 13:45:47 -0000	1.144
+++ tests/hard_coded/Mmakefile	18 Mar 2002 05:37:08 -0000
@@ -129,6 +129,7 @@
 	tuple_test \
 	tuple_test \
 	type_ctor_desc \
+	type_ctor_desc_manip \
 	type_qual \
 	type_spec_ho_term \
 	type_spec_modes \
Index: tests/hard_coded/type_ctor_desc_manip.exp
===================================================================
RCS file: tests/hard_coded/type_ctor_desc_manip.exp
diff -N tests/hard_coded/type_ctor_desc_manip.exp
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/type_ctor_desc_manip.exp	18 Mar 2002 09:11:24 -0000
@@ -0,0 +1,220 @@
+func/1 [float, float]
+func/1 [int, int]
+func/2 [int, int, int]
+pred/1 [int]
+pred/2 [int, int]
+{}/1 [string]
+{}/3 [string, int, float]
+list:list/1 [float]
+list:list/1 [int]
+tree234:tree234/2 [float, int]
+tree234:tree234/2 [int, float]
+tree234:tree234/2 [int, int]
+func(float) = float = func(float) = float
+func(float) = float < func(int) = int
+func(float) = float < func(int, int) = int
+func(float) = float < pred(int)
+func(float) = float < pred(int, int)
+func(float) = float < {string}
+func(float) = float < {string, int, float}
+func(float) = float < list:list(float)
+func(float) = float < list:list(int)
+func(float) = float < tree234:tree234(float, int)
+func(float) = float < tree234:tree234(int, float)
+func(float) = float < tree234:tree234(int, int)
+func(int) = int > func(float) = float
+func(int) = int = func(int) = int
+func(int) = int < func(int, int) = int
+func(int) = int < pred(int)
+func(int) = int < pred(int, int)
+func(int) = int < {string}
+func(int) = int < {string, int, float}
+func(int) = int < list:list(float)
+func(int) = int < list:list(int)
+func(int) = int < tree234:tree234(float, int)
+func(int) = int < tree234:tree234(int, float)
+func(int) = int < tree234:tree234(int, int)
+func(int, int) = int > func(float) = float
+func(int, int) = int > func(int) = int
+func(int, int) = int = func(int, int) = int
+func(int, int) = int < pred(int)
+func(int, int) = int < pred(int, int)
+func(int, int) = int < {string}
+func(int, int) = int < {string, int, float}
+func(int, int) = int < list:list(float)
+func(int, int) = int < list:list(int)
+func(int, int) = int < tree234:tree234(float, int)
+func(int, int) = int < tree234:tree234(int, float)
+func(int, int) = int < tree234:tree234(int, int)
+pred(int) > func(float) = float
+pred(int) > func(int) = int
+pred(int) > func(int, int) = int
+pred(int) = pred(int)
+pred(int) < pred(int, int)
+pred(int) < {string}
+pred(int) < {string, int, float}
+pred(int) < list:list(float)
+pred(int) < list:list(int)
+pred(int) < tree234:tree234(float, int)
+pred(int) < tree234:tree234(int, float)
+pred(int) < tree234:tree234(int, int)
+pred(int, int) > func(float) = float
+pred(int, int) > func(int) = int
+pred(int, int) > func(int, int) = int
+pred(int, int) > pred(int)
+pred(int, int) = pred(int, int)
+pred(int, int) < {string}
+pred(int, int) < {string, int, float}
+pred(int, int) < list:list(float)
+pred(int, int) < list:list(int)
+pred(int, int) < tree234:tree234(float, int)
+pred(int, int) < tree234:tree234(int, float)
+pred(int, int) < tree234:tree234(int, int)
+{string} > func(float) = float
+{string} > func(int) = int
+{string} > func(int, int) = int
+{string} > pred(int)
+{string} > pred(int, int)
+{string} = {string}
+{string} < {string, int, float}
+{string} < list:list(float)
+{string} < list:list(int)
+{string} < tree234:tree234(float, int)
+{string} < tree234:tree234(int, float)
+{string} < tree234:tree234(int, int)
+{string, int, float} > func(float) = float
+{string, int, float} > func(int) = int
+{string, int, float} > func(int, int) = int
+{string, int, float} > pred(int)
+{string, int, float} > pred(int, int)
+{string, int, float} > {string}
+{string, int, float} = {string, int, float}
+{string, int, float} < list:list(float)
+{string, int, float} < list:list(int)
+{string, int, float} < tree234:tree234(float, int)
+{string, int, float} < tree234:tree234(int, float)
+{string, int, float} < tree234:tree234(int, int)
+list:list(float) > func(float) = float
+list:list(float) > func(int) = int
+list:list(float) > func(int, int) = int
+list:list(float) > pred(int)
+list:list(float) > pred(int, int)
+list:list(float) > {string}
+list:list(float) > {string, int, float}
+list:list(float) = list:list(float)
+list:list(float) < list:list(int)
+list:list(float) < tree234:tree234(float, int)
+list:list(float) < tree234:tree234(int, float)
+list:list(float) < tree234:tree234(int, int)
+list:list(int) > func(float) = float
+list:list(int) > func(int) = int
+list:list(int) > func(int, int) = int
+list:list(int) > pred(int)
+list:list(int) > pred(int, int)
+list:list(int) > {string}
+list:list(int) > {string, int, float}
+list:list(int) > list:list(float)
+list:list(int) = list:list(int)
+list:list(int) < tree234:tree234(float, int)
+list:list(int) < tree234:tree234(int, float)
+list:list(int) < tree234:tree234(int, int)
+tree234:tree234(float, int) > func(float) = float
+tree234:tree234(float, int) > func(int) = int
+tree234:tree234(float, int) > func(int, int) = int
+tree234:tree234(float, int) > pred(int)
+tree234:tree234(float, int) > pred(int, int)
+tree234:tree234(float, int) > {string}
+tree234:tree234(float, int) > {string, int, float}
+tree234:tree234(float, int) > list:list(float)
+tree234:tree234(float, int) > list:list(int)
+tree234:tree234(float, int) = tree234:tree234(float, int)
+tree234:tree234(float, int) < tree234:tree234(int, float)
+tree234:tree234(float, int) < tree234:tree234(int, int)
+tree234:tree234(int, float) > func(float) = float
+tree234:tree234(int, float) > func(int) = int
+tree234:tree234(int, float) > func(int, int) = int
+tree234:tree234(int, float) > pred(int)
+tree234:tree234(int, float) > pred(int, int)
+tree234:tree234(int, float) > {string}
+tree234:tree234(int, float) > {string, int, float}
+tree234:tree234(int, float) > list:list(float)
+tree234:tree234(int, float) > list:list(int)
+tree234:tree234(int, float) > tree234:tree234(float, int)
+tree234:tree234(int, float) = tree234:tree234(int, float)
+tree234:tree234(int, float) < tree234:tree234(int, int)
+tree234:tree234(int, int) > func(float) = float
+tree234:tree234(int, int) > func(int) = int
+tree234:tree234(int, int) > func(int, int) = int
+tree234:tree234(int, int) > pred(int)
+tree234:tree234(int, int) > pred(int, int)
+tree234:tree234(int, int) > {string}
+tree234:tree234(int, int) > {string, int, float}
+tree234:tree234(int, int) > list:list(float)
+tree234:tree234(int, int) > list:list(int)
+tree234:tree234(int, int) > tree234:tree234(float, int)
+tree234:tree234(int, int) > tree234:tree234(int, float)
+tree234:tree234(int, int) = tree234:tree234(int, int)
+func/1 = func/1
+func/1 < func/2
+func/1 < pred/1
+func/1 < pred/2
+func/1 < {}/1
+func/1 < {}/3
+func/1 < list:list/1
+func/1 < tree234:tree234/2
+func/2 > func/1
+func/2 = func/2
+func/2 < pred/1
+func/2 < pred/2
+func/2 < {}/1
+func/2 < {}/3
+func/2 < list:list/1
+func/2 < tree234:tree234/2
+pred/1 > func/1
+pred/1 > func/2
+pred/1 = pred/1
+pred/1 < pred/2
+pred/1 < {}/1
+pred/1 < {}/3
+pred/1 < list:list/1
+pred/1 < tree234:tree234/2
+pred/2 > func/1
+pred/2 > func/2
+pred/2 > pred/1
+pred/2 = pred/2
+pred/2 < {}/1
+pred/2 < {}/3
+pred/2 < list:list/1
+pred/2 < tree234:tree234/2
+{}/1 > func/1
+{}/1 > func/2
+{}/1 > pred/1
+{}/1 > pred/2
+{}/1 = {}/1
+{}/1 < {}/3
+{}/1 < list:list/1
+{}/1 < tree234:tree234/2
+{}/3 > func/1
+{}/3 > func/2
+{}/3 > pred/1
+{}/3 > pred/2
+{}/3 > {}/1
+{}/3 = {}/3
+{}/3 < list:list/1
+{}/3 < tree234:tree234/2
+list:list/1 > func/1
+list:list/1 > func/2
+list:list/1 > pred/1
+list:list/1 > pred/2
+list:list/1 > {}/1
+list:list/1 > {}/3
+list:list/1 = list:list/1
+list:list/1 < tree234:tree234/2
+tree234:tree234/2 > func/1
+tree234:tree234/2 > func/2
+tree234:tree234/2 > pred/1
+tree234:tree234/2 > pred/2
+tree234:tree234/2 > {}/1
+tree234:tree234/2 > {}/3
+tree234:tree234/2 > list:list/1
+tree234:tree234/2 = tree234:tree234/2
Index: tests/hard_coded/type_ctor_desc_manip.m
===================================================================
RCS file: tests/hard_coded/type_ctor_desc_manip.m
diff -N tests/hard_coded/type_ctor_desc_manip.m
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/type_ctor_desc_manip.m	18 Mar 2002 07:12:43 -0000
@@ -0,0 +1,125 @@
+% This is a regression test. Before 15/3/2002, we got incorrect answers
+% due to simplistic treatment of type_ctor_descs.
+
+:- module type_ctor_desc_manip.
+
+:- interface.
+:- import_module io.
+
+:- pred main(io__state, io__state).
+:- mode main(di, uo) is det.
+
+:- implementation.
+:- import_module int, float, list, map, type_desc.
+
+main -->
+	{ map__init(MapII0) },
+	{ map__det_insert(MapII0, 1, 1, MapII) },
+	{ map__init(MapIF0) },
+	{ map__det_insert(MapIF0, 1, 1.0, MapIF) },
+	{ map__init(MapFI0) },
+	{ map__det_insert(MapFI0, 1.0, 1, MapFI) },
+
+	{ TypeF1a = type_of(f1a) },
+	{ TypeF1b = type_of(f1b) },
+	{ TypeF2  = type_of(f2) },
+	{ TypeP1  = type_of(p1) },
+	{ TypeP2  = type_of(p2) },
+	{ TypeT1  = type_of({"one"}) },
+	{ TypeT3  = type_of({"one", 2, 3.0}) },
+	{ TypeLI  = type_of([1]) },
+	{ TypeLF  = type_of([1.0]) },
+	{ TypeMFI = type_of(MapFI) },
+	{ TypeMIF = type_of(MapIF) },
+	{ TypeMII = type_of(MapII) },
+
+	{ TypeDescs = [TypeF1a, TypeF1b, TypeF2, TypeP1, TypeP2,
+		TypeT1, TypeT3, TypeLF, TypeLI, TypeMFI, TypeMIF, TypeMII] },
+	{ TypeCtorDescs0 = list__map(type_ctor, TypeDescs) },
+	{ TypeCtorDescs = list__remove_adjacent_dups(TypeCtorDescs0) },
+
+	list__foldl(test_deconstruct, TypeDescs),
+	test_comparisons_among(TypeDescs, TypeDescs),
+	test_comparisons_among(TypeCtorDescs, TypeCtorDescs).
+
+:- pred test_deconstruct(type_desc::in, io__state::di, io__state::uo) is det.
+
+test_deconstruct(Type) -->
+	{ type_ctor_and_args(Type, TypeCtor, TypeArgs) },
+	io__write(TypeCtor),
+	io__write_string(" "),
+	io__write(TypeArgs),
+	io__nl.
+
+:- pred test_comparisons_among(list(T)::in, list(T)::in,
+	io__state::di, io__state::uo) is det.
+
+test_comparisons_among(L, All) -->
+	(
+		{ L = [] }
+	;
+		{ L = [H | T] },
+		test_comparisons_with(H, All),
+		test_comparisons_among(T, All)
+	).
+
+:- pred test_comparisons_with(T::in, list(T)::in,
+	io__state::di, io__state::uo) is det.
+
+test_comparisons_with(X, L) -->
+	(
+		{ L = [] }
+	;
+		{ L = [H | T] },
+		test_comparison(X, H),
+		test_comparisons_with(X, T)
+	).
+
+:- pred test_comparison(T::in, T::in, io__state::di, io__state::uo) is det.
+
+test_comparison(X, Y) -->
+	{ compare(R, X, Y) },
+	(
+		{ R = (<) },
+		io__write(X),
+		io__write_string(" < "),
+		io__write(Y),
+		io__nl
+	;
+		{ R = (=) },
+		io__write(X),
+		io__write_string(" = "),
+		io__write(Y),
+		io__nl
+	;
+		{ R = (>) },
+		io__write(X),
+		io__write_string(" > "),
+		io__write(Y),
+		io__nl
+	).
+
+:- func f1a(float) = float.
+
+f1a(X) = Y :-
+	Y = X + 1.0.
+
+:- func f1b(int) = int.
+
+f1b(X) = Y :-
+	Y = X + 1.
+
+:- func f2(int, int) = int.
+
+f2(X, Y) = Z :-
+	Z = X + Y.
+
+:- pred p1(int::in) is semidet.
+
+p1(X) :-
+	X < 42.
+
+:- pred p2(int::in, int::in) is semidet.
+
+p2(X, Y) :-
+	X < Y.
cvs diff: Diffing tests/hard_coded/exceptions
cvs diff: Diffing tests/hard_coded/purity
cvs diff: Diffing tests/hard_coded/sub-modules
cvs diff: Diffing tests/hard_coded/typeclasses
cvs diff: Diffing tests/invalid
cvs diff: Diffing tests/invalid/purity
cvs diff: Diffing tests/misc_tests
cvs diff: Diffing tests/recompilation
cvs diff: Diffing tests/tabling
cvs diff: Diffing tests/term
cvs diff: Diffing tests/valid
cvs diff: Diffing tests/warnings
cvs diff: Diffing tools
cvs diff: Diffing trace
Index: trace/mercury_trace_vars.c
===================================================================
RCS file: /home/mercury1/repository/mercury/trace/mercury_trace_vars.c,v
retrieving revision 1.38
diff -u -b -r1.38 mercury_trace_vars.c
--- trace/mercury_trace_vars.c	6 Mar 2002 14:35:06 -0000	1.38
+++ trace/mercury_trace_vars.c	15 Mar 2002 01:59:19 -0000
@@ -188,8 +188,6 @@
 #ifndef MR_HIGHLEVEL_CODE
 	/* we ignore these until the browser can handle their varying arity, */
 	/* or their definitions are updated. XXX */
-	&mercury_data_type_desc__type_ctor_info_type_desc_0,
-	&mercury_data_type_desc__type_ctor_info_type_ctor_desc_0,
 	&mercury_data_private_builtin__type_ctor_info_typeclass_info_1,
 	&mercury_data_private_builtin__type_ctor_info_base_typeclass_info_1,
 
cvs diff: Diffing util
--------------------------------------------------------------------------
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
--------------------------------------------------------------------------



More information about the reviews mailing list