[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