[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