[m-rev.] for review: Implement unify/compare of tuples in Mercury.

Peter Wang novalazy at gmail.com
Mon Jul 7 16:03:22 AEST 2014


Branches: master

The hand-written C unify and compare predicates for tuples did not preserve
deep profiler invariants correctly across the recursive unify/compare of
tuple arguments.  I tried to do so, and failed.  Instead, implement the
predicates in Mercury so the compiler can perform the deep profiling
transformation on them.  Bug #3.

A micro-benchmark on my machine is about twice as fast in asm_fast.gc
after this patch, and equally fast in hlc.gc.  The change to the
high-level C backend is only to reduce code duplication.

I seem to have hit an unrelated bug in compare_representation so I did
not implement the compare_representation predicate for tuples yet.

library/builtin.m:
	Add `unify_tuple' and `compare_tuple' predicates.

	Add module initialisation predicate which sets
	`MR_special_pred_hooks' to point to those predicates.

	Delete unused predicates `call_rtti_generic_unify',
	`call_rtti_generic_compare'.

runtime/mercury_ho_call.c:
runtime/mercury_ho_call.h:
	Add a global variable `MR_special_pred_hooks' for the library to
	set up during initialisation.

	Add `tailcall' macros for use by `mercury_unify_compare_body.h'.
	Rename `tailcall_user_pred' to `tailcall_tci_pred'.

	Call the new unify/compare predicates in the high-level C
	backend via `MR_special_pred_hooks'.

	Delete `unify_tuples' and `compare_tuples' for the high-level C
	and call the Mercury predicates set in `MR_special_pred_hooks'.

runtime/mercury_unify_compare_body.h:
	Delete the unify and compare code for tuples in the low-level C
	backend.  Jump to the Mercury predicates set in
	`MR_special_pred_hooks' instead.

	Add some comments.

tests/hard_coded/Mmakefile:
tests/hard_coded/tuple_test2.exp
tests/hard_coded/tuple_test2.m:
	Add test case.

NEWS:
	Announce the change.
---
 NEWS                                 |   3 +
 library/builtin.m                    | 120 ++++++++++++++++++++++++++++++---
 runtime/mercury_ho_call.c            | 125 +++++++++++++++--------------------
 runtime/mercury_ho_call.h            |  20 ++++++
 runtime/mercury_unify_compare_body.h |  66 ++++++++----------
 tests/hard_coded/Mmakefile           |   1 +
 tests/hard_coded/tuple_test2.exp     |  11 +++
 tests/hard_coded/tuple_test2.m       |  66 ++++++++++++++++++
 8 files changed, 294 insertions(+), 118 deletions(-)
 create mode 100644 tests/hard_coded/tuple_test2.exp
 create mode 100644 tests/hard_coded/tuple_test2.m

diff --git a/NEWS b/NEWS
index 4c0a461..a6f5798 100644
--- a/NEWS
+++ b/NEWS
@@ -29,6 +29,9 @@ Changes to the Mercury standard library:
 
 Changes to the Mercury compiler:
 
+* We have fixed a long-standing bug causing crashes in deep profiling
+  grades, related to unify/compare of tuples.  (Bug #3)
+
 * We have removed legacy support for the following systems: 
     - IRIX
     - OSF/1
diff --git a/library/builtin.m b/library/builtin.m
index 25ca53d..7b55ff0 100644
--- a/library/builtin.m
+++ b/library/builtin.m
@@ -554,22 +554,120 @@ X @>= Y :-
     not compare((<), X, Y).
 
 %-----------------------------------------------------------------------------%
+%
+% Unify/compare of tuples
+%
+% These are implemented in Mercury mainly to allow the compiler to perform the
+% deep profiling transformation.
+%
 
-:- pragma foreign_decl("C", "#include ""mercury_type_info.h""").
+:- pragma foreign_decl("C", "#include ""mercury_ho_call.h""").
 
-:- interface.
+:- initialise(init_special_tuple_preds/0).
 
-:- pred call_rtti_generic_unify(T::in, T::in) is semidet.
-:- pred call_rtti_generic_compare(comparison_result::out, T::in, T::in) is det.
+:- impure pred init_special_tuple_preds is det.
 
-:- implementation.
-:- use_module erlang_rtti_implementation.
-:- use_module rtti_implementation.
+init_special_tuple_preds.
+
+:- pragma foreign_proc("C",
+    init_special_tuple_preds,
+    [will_not_call_mercury, thread_safe],
+"
+#ifdef MR_HIGHLEVEL_CODE
+    MR_special_pred_hooks.MR_unify_tuple_pred = ML_unify_tuple;
+    MR_special_pred_hooks.MR_compare_tuple_pred = ML_compare_tuple;
+#else
+    MR_special_pred_hooks.MR_unify_tuple_pred =
+        MR_ENTRY(mercury__builtin__unify_tuple_2_0);
+    MR_special_pred_hooks.MR_compare_tuple_pred =
+        MR_ENTRY(mercury__builtin__compare_tuple_3_0);
+#endif
+").
+
+:- pred unify_tuple(T::in, T::in) is semidet.
+
+:- pragma foreign_export("C", unify_tuple(in, in), "ML_unify_tuple").
+
+unify_tuple(TermA, TermB) :-
+    tuple_arity(TermA, Arity),
+    unify_tuple_pos(TermA, TermB, 0, Arity).
 
-call_rtti_generic_unify(X, Y) :-
-    rtti_implementation.generic_unify(X, Y).
-call_rtti_generic_compare(Res, X, Y) :-
-    rtti_implementation.generic_compare(Res, X, Y).
+:- pred unify_tuple_pos(T::in, T::in, int::in, int::in) is semidet.
+
+unify_tuple_pos(TermA, TermB, Index, Arity) :-
+    ( Index >= Arity ->
+        true
+    ;
+        tuple_arg(TermA, Index, SubTermA),
+        tuple_arg(TermB, Index, SubTermB),
+        private_builtin.unsafe_type_cast(SubTermB, CastSubTermB),
+        ( builtin.unify(SubTermA, CastSubTermB) ->
+            unify_tuple_pos(TermA, TermB, Index + 1, Arity)
+        ;
+            fail
+        )
+    ).
+
+:- pred compare_tuple(comparison_result::uo, T::in, T::in) is det.
+
+:- pragma foreign_export("C", compare_tuple(uo, in, in), "ML_compare_tuple").
+
+compare_tuple(Result, TermA, TermB) :-
+    tuple_arity(TermA, Arity),
+    compare_tuple_pos(Result, TermA, TermB, 0, Arity).
+
+:- pred compare_tuple_pos(comparison_result::uo, T::in, T::in,
+    int::in, int::in) is det.
+
+compare_tuple_pos(Result, TermA, TermB, Index, Arity) :-
+    ( Index >= Arity ->
+        Result = (=)
+    ;
+        tuple_arg(TermA, Index, SubTermA),
+        tuple_arg(TermB, Index, SubTermB),
+        private_builtin.unsafe_type_cast(SubTermB, CastSubTermB),
+        builtin.compare(SubResult, SubTermA, CastSubTermB),
+        (
+            SubResult = (=),
+            compare_tuple_pos(Result, TermA, TermB, Index + 1, Arity)
+        ;
+            ( SubResult = (<)
+            ; SubResult = (>)
+            ),
+            Result = SubResult
+        )
+    ).
+
+:- pred tuple_arity(T::in, int::out) is det.
+
+:- pragma foreign_proc("C",
+    tuple_arity(_Term::in, Arity::out),
+    [will_not_call_mercury, promise_pure, thread_safe],
+"
+    Arity = MR_TYPEINFO_GET_VAR_ARITY_ARITY((MR_TypeInfo) TypeInfo_for_T);
+").
+
+tuple_arity(_, _) :-
+   private_builtin.sorry("tuple_arity/2").
+
+:- some [ArgT] pred tuple_arg(T::in, int::in, ArgT::out) is det.
+
+:- pragma foreign_proc("C",
+    tuple_arg(Term::in, Index::in, Arg::out),
+    [will_not_call_mercury, promise_pure, thread_safe],
+"
+    MR_TypeInfo type_info = (MR_TypeInfo) TypeInfo_for_T;
+    MR_Word     *arg_vector = (MR_Word *) Term;
+
+    TypeInfo_for_ArgT =
+        (MR_Word) MR_TYPEINFO_GET_VAR_ARITY_ARG_VECTOR(type_info)[1 + Index];
+    Arg = arg_vector[Index];
+").
+
+tuple_arg(_, _, -1) :-
+   private_builtin.sorry("tuple_arg/3").
+
+%-----------------------------------------------------------------------------%
 
 :- pragma foreign_code("C#", "
     //
diff --git a/runtime/mercury_ho_call.c b/runtime/mercury_ho_call.c
index f528925..3598e8f 100644
--- a/runtime/mercury_ho_call.c
+++ b/runtime/mercury_ho_call.c
@@ -39,6 +39,8 @@ ENDINIT
 #include "mercury_types.h"
 #include "mercury_bitmap.h"
 
+MR_SpecialPredHooks MR_special_pred_hooks;
+
 #ifdef  MR_DEEP_PROFILING
   #ifdef MR_DEEP_PROFILING_STATISTICS
     #define maybe_incr_prof_call_builtin_new()                              \
@@ -91,54 +93,6 @@ ENDINIT
 
 #ifdef MR_HIGHLEVEL_CODE
 
-static MR_bool MR_CALL
-unify_tuples(MR_Mercury_Type_Info ti, MR_Tuple x, MR_Tuple y)
-{
-    int         i, arity;
-    MR_bool     result;
-    MR_TypeInfo type_info;
-    MR_TypeInfo arg_type_info;
-
-    type_info = (MR_TypeInfo) ti;
-    arity = MR_TYPEINFO_GET_VAR_ARITY_ARITY(type_info);
-
-    for (i = 0; i < arity; i++) {
-        /* type_infos are counted starting at one. */
-        arg_type_info = MR_TYPEINFO_GET_VAR_ARITY_ARG_VECTOR(type_info)[i + 1];
-        result = mercury__builtin__unify_2_p_0(
-            (MR_Mercury_Type_Info) arg_type_info, x[i], y[i]);
-        if (result == MR_FALSE) {
-            return MR_FALSE;
-        }
-    }
-
-    return MR_TRUE;
-}
-
-static void MR_CALL
-compare_tuples(MR_Mercury_Type_Info ti, MR_Comparison_Result *result,
-    MR_Tuple x, MR_Tuple y)
-{
-    int         i, arity;
-    MR_TypeInfo type_info;
-    MR_TypeInfo arg_type_info;
-
-    type_info = (MR_TypeInfo) ti;
-    arity = MR_TYPEINFO_GET_VAR_ARITY_ARITY(type_info);
-
-    for (i = 0; i < arity; i++) {
-        /* type_infos are counted starting at one. */
-        arg_type_info = MR_TYPEINFO_GET_VAR_ARITY_ARG_VECTOR(type_info)[i + 1];
-        mercury__builtin__compare_3_p_0(
-            (MR_Mercury_Type_Info) arg_type_info, result, x[i], y[i]);
-        if (*result != MR_COMPARE_EQUAL) {
-            return;
-        }
-    }
-
-    *result = MR_COMPARE_EQUAL;
-}
-
 /*
 ** Define the generic unify/2 and compare/3 functions.
 */
@@ -163,7 +117,10 @@ mercury__builtin__unify_2_p_0(MR_Mercury_Type_Info ti, MR_Box x, MR_Box y)
     */
     type_ctor_rep = MR_type_ctor_rep(type_ctor_info);
     if (type_ctor_rep == MR_TYPECTOR_REP_TUPLE) {
-        return unify_tuples(ti, (MR_Tuple) x, (MR_Tuple) y);
+        if (MR_special_pred_hooks.MR_unify_tuple_pred != NULL) {
+            return MR_special_pred_hooks.MR_unify_tuple_pred(ti,
+                (MR_Word) x, (MR_Word) y);
+        }
     } else if (type_ctor_rep == MR_TYPECTOR_REP_PRED) {
         return mercury__builtin____Unify____pred_0_0((MR_Pred) x, (MR_Pred) y);
     } else if (type_ctor_rep == MR_TYPECTOR_REP_FUNC) {
@@ -229,8 +186,11 @@ mercury__builtin__compare_3_p_0(MR_Mercury_Type_Info ti,
     */
     type_ctor_rep = MR_type_ctor_rep(type_ctor_info);
     if (type_ctor_rep == MR_TYPECTOR_REP_TUPLE) {
-        compare_tuples(ti, res, (MR_Tuple) x, (MR_Tuple) y);
-        return;
+        if (MR_special_pred_hooks.MR_compare_tuple_pred != NULL) {
+            MR_special_pred_hooks.MR_compare_tuple_pred(ti, res,
+                (MR_Word) x, (MR_Word) y);
+            return;
+        }
     } else if (type_ctor_rep == MR_TYPECTOR_REP_PRED) {
         mercury__builtin____Compare____pred_0_0(res, (MR_Pred) x, (MR_Pred) y);
         return;
@@ -519,9 +479,11 @@ MR_define_entry(mercury__builtin__unify_2_0);
         MR_proceed();                                                       \
     } while(0)
 
-#define tailcall_user_pred()                                                \
-    MR_tailcall(type_ctor_info->MR_type_ctor_unify_pred,                    \
-        MR_LABEL(mercury__builtin__unify_2_0))
+#define tailcall_tci_pred()                                                 \
+    tailcall(type_ctor_info->MR_type_ctor_unify_pred)
+
+#define tailcall(label)                                                     \
+    MR_tailcall(label, MR_LABEL(mercury__builtin__unify_2_0))
 
 #define start_label                 unify_start
 #define call_user_code_label        call_unify_in_proc
@@ -534,7 +496,8 @@ MR_define_entry(mercury__builtin__unify_2_0);
 #undef  DECLARE_LOCALS
 #undef  initialize
 #undef  raw_return_answer
-#undef  tailcall_user_pred
+#undef  tailcall_tci_pred
+#undef  tailcall
 #undef  start_label
 #undef  call_user_code_label
 #undef  type_stat_struct
@@ -595,9 +558,11 @@ MR_define_entry(mercury__builtin__compare_3_3);
         MR_proceed();                                                       \
     } while(0)
 
-#define tailcall_user_pred()                                                \
-    MR_tailcall(type_ctor_info->MR_type_ctor_compare_pred,                  \
-        MR_LABEL(mercury__builtin__compare_3_3))
+#define tailcall_tci_pred()                                                 \
+    tailcall(type_ctor_info->MR_type_ctor_compare_pred)
+
+#define tailcall(label)                                                     \
+    MR_tailcall(label, MR_LABEL(mercury__builtin__compare_3_3))
 
 #define start_label                 compare_start
 #define call_user_code_label        call_compare_in_proc
@@ -611,7 +576,8 @@ MR_define_entry(mercury__builtin__compare_3_3);
 #undef  DECLARE_LOCALS
 #undef  initialize
 #undef  raw_return_answer
-#undef  tailcall_user_pred
+#undef  tailcall_tci_pred
+#undef  tailcall
 #undef  start_label
 #undef  call_user_code_label
 #undef  type_stat_struct
@@ -651,6 +617,9 @@ MR_define_entry(mercury__builtin__compare_representation_3_0);
         MR_proceed();                                                       \
     } while(0)
 
+#define tailcall(label)                                                     \
+    MR_tailcall(label, MR_LABEL(mercury__builtin__compare_representation_3_0))
+
 #define start_label                 compare_rep_start
 #define call_user_code_label        call_compare_rep_in_proc
 #define type_stat_struct            MR_type_stat_mer_compare
@@ -664,6 +633,7 @@ MR_define_entry(mercury__builtin__compare_representation_3_0);
 #undef  DECLARE_LOCALS
 #undef  initialize
 #undef  raw_return_answer
+#undef  tailcall
 #undef  start_label
 #undef  call_user_code_label
 #undef  type_stat_struct
@@ -687,18 +657,20 @@ MR_generic_unify(MR_TypeInfo type_info, MR_Word x, MR_Word y)
     do {                                                                      \
         MR_restore_transient_registers();                                     \
     } while (0)
-                                                                              \
+
 #define raw_return_answer(answer)                                             \
     do {                                                                      \
         MR_save_transient_registers();                                        \
         return (answer);                                                      \
     } while (0)
-                                                                              \
-#define tailcall_user_pred()                                                  \
+
+#define tailcall_tci_pred()                                                   \
+    tailcall(type_ctor_info->MR_type_ctor_unify_pred)
+
+#define tailcall(label)                                                       \
     do {                                                                      \
         MR_save_transient_registers();                                        \
-        (void) MR_call_engine(type_ctor_info->MR_type_ctor_unify_pred,        \
-            MR_FALSE);                                                        \
+        (void) MR_call_engine(label, MR_FALSE);                               \
         MR_restore_transient_registers();                                     \
         return (MR_r1);                                                       \
     } while (0)
@@ -713,7 +685,8 @@ MR_generic_unify(MR_TypeInfo type_info, MR_Word x, MR_Word y)
 #undef  DECLARE_LOCALS
 #undef  initialize
 #undef  raw_return_answer
-#undef  tailcall_user_pred
+#undef  tailcall_tci_pred
+#undef  tailcall
 #undef  start_label
 #undef  call_user_code_label
 #undef  type_stat_struct
@@ -737,11 +710,13 @@ MR_generic_compare(MR_TypeInfo type_info, MR_Word x, MR_Word y)
         return (answer);                                                    \
     } while (0)
 
-#define tailcall_user_pred()                                                \
+#define tailcall_tci_pred()                                                 \
+    tailcall(type_ctor_info->MR_type_ctor_compare_pred)
+
+#define tailcall(label)                                                     \
     do {                                                                    \
         MR_save_transient_registers();                                      \
-        (void) MR_call_engine(type_ctor_info->MR_type_ctor_compare_pred,    \
-            MR_FALSE);                                                      \
+        (void) MR_call_engine(label, MR_FALSE);                             \
         MR_restore_transient_registers();                                   \
         return (MR_r1);                                                     \
     } while (0)
@@ -757,7 +732,8 @@ MR_generic_compare(MR_TypeInfo type_info, MR_Word x, MR_Word y)
 #undef  DECLARE_LOCALS
 #undef  initialize
 #undef  raw_return_answer
-#undef  tailcall_user_pred
+#undef  tailcall_tci_pred
+#undef  tailcall
 #undef  start_label
 #undef  call_user_code_label
 #undef  type_stat_struct
@@ -782,10 +758,18 @@ MR_generic_compare_representation(MR_TypeInfo type_info, MR_Word x, MR_Word y)
         return (answer);                                                    \
     } while (0)
 
+#define tailcall(label)                                                     \
+    do {                                                                    \
+        MR_save_transient_registers();                                      \
+        (void) MR_call_engine(label, MR_FALSE);                             \
+        MR_restore_transient_registers();                                   \
+        return (MR_r1);                                                     \
+    } while (0)
+
 #define start_label                 compare_rep_func_start
 #define call_user_code_label        call_compare_rep_in_func
 #define type_stat_struct            MR_type_stat_c_compare
-#define attempt_msg                 "attempt to compare representation"
+#define attempt_msg                 "attempt to compare representation "
 #define select_compare_code
 #define include_compare_rep_code
 
@@ -794,6 +778,7 @@ MR_generic_compare_representation(MR_TypeInfo type_info, MR_Word x, MR_Word y)
 #undef  DECLARE_LOCALS
 #undef  initialize
 #undef  raw_return_answer
+#undef  tailcall
 #undef  start_label
 #undef  call_user_code_label
 #undef  type_stat_struct
diff --git a/runtime/mercury_ho_call.h b/runtime/mercury_ho_call.h
index 62446e2..6c83809 100644
--- a/runtime/mercury_ho_call.h
+++ b/runtime/mercury_ho_call.h
@@ -194,4 +194,24 @@ MR_declare_entry(mercury__builtin__compare_representation_3_0);
 
 #endif	/* MR_HIGHLEVEL_CODE */
 
+/*
+** Special predicates implemented in the standard library
+**
+** The library sets the fields in this structure to the actual
+** implementations of the predicates during initialization.
+*/
+
+typedef struct MR_SpecialPredHooks_Struct {
+  #ifdef MR_HIGHLEVEL_CODE
+    MR_bool     (*MR_unify_tuple_pred)(MR_Word ti, MR_Word x, MR_Word y);
+    MR_bool     (*MR_compare_tuple_pred)(MR_Word ti, MR_Word *res,
+                    MR_Word x, MR_Word y);
+  #else
+    MR_ProcAddr MR_unify_tuple_pred;
+    MR_ProcAddr MR_compare_tuple_pred;
+  #endif
+} MR_SpecialPredHooks;
+
+extern MR_SpecialPredHooks  MR_special_pred_hooks;
+
 #endif	/* not MERCURY_HO_CALL_H */
diff --git a/runtime/mercury_unify_compare_body.h b/runtime/mercury_unify_compare_body.h
index 08c3941..dfbaedb 100644
--- a/runtime/mercury_unify_compare_body.h
+++ b/runtime/mercury_unify_compare_body.h
@@ -36,6 +36,11 @@
 ** using recursion in Mercury. The Mercury procedure and C function share code
 ** because they implement the same task.
 **
+** XXX does the rationale still hold? Only rarely used code paths still have
+** loop bodies in C and they are likely incorrect for deep profiling.  The
+** Mercury implementation of tuple unify/compare predicates is faster in
+** asm_fast.gc, and only slightly slower in hlc.gc grades. --pw
+**
 ** We need separate C functions for unifications and comparison because
 ** with --no-special-preds, a type with user-defined equality (but not
 ** comparison) has a non-NULL unify_pred field in its type_ctor_info but a
@@ -170,6 +175,8 @@ start_label:
             ** When deep profiling is enabled, we use the call, exit and (for
             ** unifications) fail ports of dummy unify, compare and compare_rep
             ** predicates for the dummy type_ctor builtin.user_by_rtti/0.
+            **
+            ** XXX the deep profiler invariants are likely broken in the loop
             */
 
             {
@@ -582,48 +589,33 @@ start_label:
                 MR_restore_registers();
             }
 
-            tailcall_user_pred();
+            tailcall_tci_pred();
 #endif  /* !include_compare_rep_code */
 
         case MR_TYPECTOR_REP_TUPLE:
-            {
-                int     i;
-                int     type_arity;
-                int     result;
-
-                type_arity = MR_TYPEINFO_GET_VAR_ARITY_ARITY(type_info);
-
-                for (i = 0; i < type_arity; i++) {
-                    MR_TypeInfo arg_type_info;
-
-                    /* type_infos are counted from one */
-                    arg_type_info =
-                        MR_TYPEINFO_GET_VAR_ARITY_ARG_VECTOR(type_info)[i + 1];
-
-#ifdef  select_compare_code
-                    MR_save_transient_registers();
-                    result = MR_generic_compare(arg_type_info,
-                        ((MR_Word *) x)[i], ((MR_Word *) y)[i]);
-                    MR_restore_transient_registers();
-                    if (result != MR_COMPARE_EQUAL) {
-                        return_compare_answer(builtin, tuple, 0, result);
-                    }
-#else
-                    MR_save_transient_registers();
-                    result = MR_generic_unify(arg_type_info,
-                        ((MR_Word *) x)[i], ((MR_Word *) y)[i]);
-                    MR_restore_transient_registers();
-                    if (! result) {
-                        return_unify_answer(builtin, tuple, 0, MR_FALSE);
-                    }
-#endif
-                }
-#ifdef  select_compare_code
-                return_compare_answer(builtin, tuple, 0, MR_COMPARE_EQUAL);
+            /*
+            ** The tuple unify and compare predicates are implemented in
+            ** Mercury, mainly so that the compiler can perform the deep
+            ** profiler tranformation on them.
+            */
+#ifdef select_compare_code
+    #ifdef include_compare_rep_code
+            MR_fatal_error("sorry, not implemented: "
+                "compare_representation for tuples");
+    #else
+            if (MR_special_pred_hooks.MR_compare_tuple_pred != NULL) {
+                tailcall(MR_special_pred_hooks.MR_compare_tuple_pred);
+            } else {
+                tailcall_tci_pred();
+            }
+    #endif
 #else
-                return_unify_answer(builtin, tuple, 0, MR_TRUE);
-#endif
+            if (MR_special_pred_hooks.MR_unify_tuple_pred != NULL) {
+                tailcall(MR_special_pred_hooks.MR_unify_tuple_pred);
+            } else {
+                tailcall_tci_pred();
             }
+#endif
 
 #ifdef  include_compare_rep_code
         case MR_TYPECTOR_REP_ENUM_USEREQ:
diff --git a/tests/hard_coded/Mmakefile b/tests/hard_coded/Mmakefile
index 4e94294..a326523 100644
--- a/tests/hard_coded/Mmakefile
+++ b/tests/hard_coded/Mmakefile
@@ -325,6 +325,7 @@ ORDINARY_PROGS=	\
 	transitive_inst_type \
 	trigraphs \
 	tuple_test \
+	tuple_test2 \
 	type_ctor_desc \
 	type_ctor_desc_manip \
 	type_info_const_inst \
diff --git a/tests/hard_coded/tuple_test2.exp b/tests/hard_coded/tuple_test2.exp
new file mode 100644
index 0000000..54b0921
--- /dev/null
+++ b/tests/hard_coded/tuple_test2.exp
@@ -0,0 +1,11 @@
+unify:
+node({nil, fruit("apple")}) =  node({nil, fruit("apple")})
+node({nil, fruit("apple")}) \= node({nil, fruit("peach")})
+node({nil, fruit("peach")}) \= node({nil, fruit("apple")})
+node({nil, fruit("peach")}) =  node({nil, fruit("peach")})
+
+compare:
+node({nil, fruit("apple")}) = node({nil, fruit("apple")})
+node({nil, fruit("apple")}) < node({nil, fruit("peach")})
+node({nil, fruit("peach")}) > node({nil, fruit("apple")})
+node({nil, fruit("peach")}) = node({nil, fruit("peach")})
diff --git a/tests/hard_coded/tuple_test2.m b/tests/hard_coded/tuple_test2.m
new file mode 100644
index 0000000..354c2b0
--- /dev/null
+++ b/tests/hard_coded/tuple_test2.m
@@ -0,0 +1,66 @@
+% Unify/compare of tuples did not maintain deep profiler invariants.
+
+:- module tuple_test2.
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di, io::uo) is det.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module list.
+
+:- type list
+    --->    nil
+    ;       node({list, fruit}).
+
+:- type fruit
+    --->    fruit(string).
+
+main(!IO) :-
+    A = node({nil, fruit("apple")}),
+    B = node({nil, fruit("peach")}),
+    Cases = [{A, A}, {A, B}, {B, A}, {B, B}],
+
+    io.write_string("unify:\n", !IO),
+    list.foldl(test_unify, Cases, !IO),
+
+    io.write_string("\ncompare:\n", !IO),
+    list.foldl(test_compare, Cases, !IO).
+
+:- pred test_unify({T, T}::in, io::di, io::uo) is det.
+
+test_unify({A, B}, !IO) :-
+    io.write(A, !IO),
+    ( unify(A, B) ->
+        io.write_string(" =  ", !IO)
+    ;
+        io.write_string(" \\= ", !IO)
+    ),
+    io.write(B, !IO),
+    io.nl(!IO).
+
+:- pred test_compare({T, T}::in, io::di, io::uo) is det.
+
+test_compare({A, B}, !IO) :-
+    compare(R, A, B),
+    io.write(A, !IO),
+    (
+        R = (=),
+        io.write_string(" = ", !IO)
+    ;
+        R = (<),
+        io.write_string(" < ", !IO)
+    ;
+        R = (>),
+        io.write_string(" > ", !IO)
+    ),
+    io.write(B, !IO),
+    io.nl(!IO).
+
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=8 sw=4 et wm=0 tw=0
-- 
1.8.4



More information about the reviews mailing list