[m-rev.] for review: comparison of preds/funcs
Mark Brown
dougl at cs.mu.OZ.AU
Fri Apr 12 19:38:33 AEST 2002
Hi,
The following change is required by the declarative debugger's oracle,
so it can store and retrieve data pertaining to higher order terms.
(The change to the debugger will come later.) One question is: is the
following feature generally useful enough to be part of the standard
library? If so, I'll add a NEWS entry, otherwise I'll move it into the
browser directory. My vote is that it is generally useful.
Cheers,
Mark.
Estimated hours taken: 4
Branches: main
Implement compare_approx/3, which is like compare except that it is cc_multi,
and it doesn't abort on pred and func types. The implementation only
works for the LLDS backend; in other cases, the behaviour is the same as
compare/3.
library/std_util.m:
Implement the new predicate.
runtime/mercury_ho_call.c:
runtime/mercury_ho_call.h:
Add a global variable which says which kind of comparison we are
doing. Implement the function MR_compare_closure_approx which
compares closures.
runtime/mercury_unify_compare_body.h:
If the global variable is MR_TRUE, compare preds and funcs rather
than abort.
runtime/mercury.c:
Provide a "Sorry, not implemented" message, for when
MR_HIGHLEVEL_CODE is set.
tests/hard_coded/Mmakefile:
tests/hard_coded/compare_approx.m:
tests/hard_coded/compare_approx.exp:
A test case.
Index: library/std_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/std_util.m,v
retrieving revision 1.265
diff -u -r1.265 std_util.m
--- library/std_util.m 15 Mar 2002 07:32:15 -0000 1.265
+++ library/std_util.m 12 Apr 2002 09:19:17 -0000
@@ -708,6 +708,15 @@
:- pred limited_deconstruct_cc(T::in, int::in, string::out,
int::out, list(univ)::out) is cc_nondet.
+ % compare_approx(Result, X, Y)
+ %
+ % compare_approx is similar to the builtin predicate compare/3,
+ % except that it attempts to compare non-canonical terms by
+ % comparing their representations.
+ %
+:- pred compare_approx(comparison_result, T, T).
+:- mode compare_approx(uo, in, in) is cc_multi.
+
%-----------------------------------------------------------------------------%
:- implementation.
@@ -1619,6 +1628,27 @@
det_named_argument_cc(Type, Name, ArgumentUniv) :-
deconstruct__det_named_arg(Type, include_details_cc, Name, Argument),
type_to_univ(Argument, ArgumentUniv).
+
+:- pragma promise_pure(compare_approx/3).
+
+compare_approx(Result, X, Y) :-
+ impure set_compare_approx_flag(1),
+ compare(Result0, X, Y),
+ impure set_compare_approx_flag(0),
+ cc_multi_equal(Result0, Result).
+
+:- pragma foreign_decl("C", "extern MR_bool MR_generic_compare_approx;").
+
+:- impure pred set_compare_approx_flag(int).
+:- mode set_compare_approx_flag(in) is det.
+
+:- pragma foreign_proc("C",
+ set_compare_approx_flag(Flag::in),
+ [will_not_call_mercury],
+ "MR_generic_compare_approx = (MR_bool) Flag;").
+
+set_compare_approx_flag(_::in) :-
+ private_builtin__sorry("std_util__set_compare_approx_flag/1").
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
Index: runtime/mercury.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury.c,v
retrieving revision 1.40
diff -u -r1.40 mercury.c
--- runtime/mercury.c 12 Apr 2002 01:24:22 -0000 1.40
+++ runtime/mercury.c 12 Apr 2002 09:19:22 -0000
@@ -19,6 +19,7 @@
#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 */
+#include "mercury_ho_call.h" /* for MR_generic_compare_approx */
#ifdef MR_HIGHLEVEL_CODE
@@ -549,14 +550,22 @@
mercury__builtin____Compare____func_0_0(MR_Comparison_Result *result,
MR_Func x, MR_Func y)
{
- MR_fatal_error("called compare/3 for `func' type");
+ if (!MR_generic_compare_approx) {
+ MR_fatal_error("called compare/3 for `func' type");
+ } else {
+ SORRY("compare_approx/3 for `func' type");
+ }
}
void MR_CALL
mercury__builtin____Compare____pred_0_0(MR_Comparison_Result *result,
MR_Pred x, MR_Pred y)
{
- MR_fatal_error("called compare/3 for `pred' type");
+ if (!MR_generic_compare_approx) {
+ MR_fatal_error("called compare/3 for `pred' type");
+ } else {
+ SORRY("compare_approx/3 for `pred' type");
+ }
}
void MR_CALL
Index: runtime/mercury_ho_call.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_ho_call.c,v
retrieving revision 1.53
diff -u -r1.53 mercury_ho_call.c
--- runtime/mercury_ho_call.c 12 Apr 2002 04:45:36 -0000 1.53
+++ runtime/mercury_ho_call.c 12 Apr 2002 09:19:26 -0000
@@ -24,6 +24,7 @@
#include "mercury_type_desc.h"
#include "mercury_deep_profiling.h"
#include "mercury_deep_profiling_hand.h"
+#include "mercury_layout_util.h"
#ifdef MR_DEEP_PROFILING
#ifdef MR_DEEP_PROFILING_STATISTICS
@@ -114,9 +115,12 @@
#endif
+MR_bool MR_generic_compare_approx = MR_FALSE;
+
#ifndef MR_HIGHLEVEL_CODE
static MR_Word MR_generic_compare(MR_TypeInfo type_info, MR_Word x, MR_Word y);
static MR_Word MR_generic_unify(MR_TypeInfo type_info, MR_Word x, MR_Word y);
+static MR_Word MR_compare_closure_approx(MR_Closure *x, MR_Closure *y);
/*
** The called closure may contain only input arguments. The extra arguments
@@ -504,6 +508,85 @@
#undef type_stat_struct
#undef attempt_msg
#undef select_compare_code
+}
+
+static MR_Word
+MR_compare_closure_approx(MR_Closure *x, MR_Closure *y)
+{
+ MR_Closure_Layout *x_layout;
+ MR_Closure_Layout *y_layout;
+ MR_Proc_Id *x_proc_id;
+ MR_Proc_Id *y_proc_id;
+ MR_TypeInfo *x_type_params;
+ MR_TypeInfo *y_type_params;
+ int x_num_args;
+ int y_num_args;
+ int num_args;
+ int i;
+ int result;
+
+ /*
+ ** Optimize the simple case.
+ */
+ if (x == y) {
+ return MR_COMPARE_EQUAL;
+ }
+
+ x_layout = x->MR_closure_layout;
+ y_layout = y->MR_closure_layout;
+
+ x_proc_id = &x_layout->MR_closure_id->MR_closure_proc_id;
+ y_proc_id = &y_layout->MR_closure_id->MR_closure_proc_id;
+ if (x_proc_id < y_proc_id) {
+ return MR_COMPARE_LESS;
+ } else if (x_proc_id > y_proc_id) {
+ return MR_COMPARE_GREATER;
+ }
+
+ x_num_args = x->MR_closure_num_hidden_args;
+ y_num_args = y->MR_closure_num_hidden_args;
+ if (x_num_args < y_num_args) {
+ return MR_COMPARE_LESS;
+ } else if (x_num_args > y_num_args) {
+ return MR_COMPARE_GREATER;
+ }
+
+ num_args = x_num_args;
+ x_type_params = MR_materialize_closure_type_params(x);
+ y_type_params = MR_materialize_closure_type_params(y);
+ for (i = 0; i < num_args; i++) {
+ MR_TypeInfo x_arg_type_info;
+ MR_TypeInfo y_arg_type_info;
+ MR_TypeInfo arg_type_info;
+
+ x_arg_type_info = MR_create_type_info(x_type_params,
+ x_layout->MR_closure_arg_pseudo_type_info[i]);
+ y_arg_type_info = MR_create_type_info(y_type_params,
+ y_layout->MR_closure_arg_pseudo_type_info[i]);
+ result = MR_compare_type_info(x_arg_type_info, y_arg_type_info);
+ if (result != MR_COMPARE_EQUAL) {
+ goto finish_closure_compare;
+ }
+
+ arg_type_info = x_arg_type_info;
+ result = MR_generic_compare(arg_type_info,
+ x->MR_closure_hidden_args_0[i],
+ y->MR_closure_hidden_args_0[i]);
+ if (result != MR_COMPARE_EQUAL) {
+ goto finish_closure_compare;
+ }
+ }
+
+ result = MR_COMPARE_EQUAL;
+
+finish_closure_compare:
+ if (x_type_params != NULL) {
+ MR_free(x_type_params);
+ }
+ if (y_type_params != NULL) {
+ MR_free(y_type_params);
+ }
+ return result;
}
#endif /* not MR_HIGHLEVEL_CODE */
Index: runtime/mercury_ho_call.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_ho_call.h,v
retrieving revision 1.6
diff -u -r1.6 mercury_ho_call.h
--- runtime/mercury_ho_call.h 24 Feb 2002 11:53:32 -0000 1.6
+++ runtime/mercury_ho_call.h 12 Apr 2002 09:19:27 -0000
@@ -114,4 +114,18 @@
#define MR_closure_hidden_args(i) MR_closure_hidden_args_0[(i) - 1]
+/*
+** Comparison of noncanonical types such as preds or funcs normally results
+** in a runtime abort. If MR_generic_compare_approx is set to MR_TRUE, the
+** generic comparison routine will approximate the correct answer by
+** comparing the internal representations of the values. This operation is
+** non-deterministic, in the sense that the same value may have different
+** representations and so give different answers, so when calling the builtin
+** predicate compare/3 (which is det) this variable should always be set to
+** MR_FALSE.
+**
+** This is intended to be used by compare_approx/3 in library/std_util.m.
+*/
+extern MR_bool MR_generic_compare_approx;
+
#endif /* not MERCURY_HO_CALL_H */
Index: runtime/mercury_unify_compare_body.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_unify_compare_body.h,v
retrieving revision 1.21
diff -u -r1.21 mercury_unify_compare_body.h
--- runtime/mercury_unify_compare_body.h 12 Apr 2002 04:45:37 -0000 1.21
+++ runtime/mercury_unify_compare_body.h 12 Apr 2002 09:19:31 -0000
@@ -674,7 +674,23 @@
case MR_TYPECTOR_REP_FUNC:
case MR_TYPECTOR_REP_PRED:
- MR_fatal_error(attempt_msg "higher-order terms");
+ {
+#ifdef select_compare_code
+ if (!MR_generic_compare_approx) {
+ MR_fatal_error(attempt_msg "higher-order terms");
+ } else {
+ int result;
+
+ MR_save_transient_registers();
+ result = MR_compare_closure_approx((MR_Closure *) x,
+ (MR_Closure *) y);
+ MR_restore_transient_registers();
+ return_answer(result);
+ }
+#else
+ MR_fatal_error(attempt_msg "higher-order terms");
+#endif
+ }
case MR_TYPECTOR_REP_TYPECLASSINFO:
MR_fatal_error(attempt_msg "typeclass_infos");
Index: tests/hard_coded/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/Mmakefile,v
retrieving revision 1.145
diff -u -r1.145 Mmakefile
--- tests/hard_coded/Mmakefile 27 Mar 2002 05:18:55 -0000 1.145
+++ tests/hard_coded/Mmakefile 12 Apr 2002 09:19:36 -0000
@@ -141,7 +141,7 @@
write_reg1 \
write_reg2
-# These test require the implementation to support closure layouts
+# These tests require the implementation to support closure layouts
CLOSURE_LAYOUT_PROGS = \
copy_pred \
copy_pred_2
@@ -168,11 +168,13 @@
EXCEPTION_PROGS =
endif
+# compare_approx does not work in the hl* grades (e.g. hlc.gc), because
+# comparison of closures gives "Sorry, not implemented" when HIGHLEVEL_CODE
+# is set.
#
-# factt_non does not work in the hl* grades (e.g. hlc.gc),
-# because the code for nondet fact tables assumes that
-# we're using the LLDS back-end. Also, fact tables and deep profiling do not
-# (yet) mix.
+# factt_non does not work in the hl* grades because the code for nondet
+# fact tables assumes that we're using the LLDS back-end. Also, fact tables
+# and deep profiling do not (yet) mix.
#
# type_tables does not work in the hl* grades because the test itself
# is a quick hack that assumes the use of the LLDS backend; it should
@@ -182,10 +184,12 @@
ifeq "$(findstring hl,$(GRADE))" ""
ifeq "$(findstring profdeep,$(GRADE))" ""
BACKEND_PROGS = \
+ compare_approx \
factt_non \
type_tables
else
BACKEND_PROGS = \
+ compare_approx \
type_tables
endif
else
Index: tests/hard_coded/compare_approx.exp
===================================================================
RCS file: tests/hard_coded/compare_approx.exp
diff -N tests/hard_coded/compare_approx.exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/compare_approx.exp 12 Apr 2002 09:19:36 -0000
@@ -0,0 +1,20 @@
+1 : int
+1 : int
+equal
+
+1 : int
+main : pred(io__state, io__state)
+not equal
+
+main : pred(io__state, io__state)
+main : pred(io__state, io__state)
+equal
+
+main : pred(io__state, io__state)
+test(d1, dm) : pred(io__state, io__state)
+not equal
+
+foo(1) : func(int) = int
+foo(2) : func(int) = int
+not equal
+
Index: tests/hard_coded/compare_approx.m
===================================================================
RCS file: tests/hard_coded/compare_approx.m
diff -N tests/hard_coded/compare_approx.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/compare_approx.m 12 Apr 2002 09:19:36 -0000
@@ -0,0 +1,50 @@
+:- module compare_approx.
+:- interface.
+:- import_module io.
+:- pred main(io__state::di, io__state::uo) is cc_multi.
+:- implementation.
+:- import_module std_util.
+
+main -->
+ test(d1, d1),
+ test(d1, dm),
+ test(dm, dm),
+ test(dm, dt),
+ test(df1, df2).
+
+:- type val == pair(string, univ).
+
+:- func d1 = val.
+d1 = "1 : int" - univ(1).
+
+:- func dm = val.
+dm = "main : pred(io__state, io__state)" - univ(main).
+
+:- func dt = val.
+dt = "test(d1, dm) : pred(io__state, io__state)" - univ(test(d1, dm)).
+
+:- func df1 = val.
+df1 = "foo(1) : func(int) = int" - univ(foo(1)).
+
+:- func df2 = val.
+df2 = "foo(2) : func(int) = int" - univ(foo(2)).
+
+:- func foo(int, int) = int.
+foo(_, Z) = Z.
+
+:- pred test(val::in, val::in, io__state::di, io__state::uo) is cc_multi.
+test(SA - A, SB - B) -->
+ io__write_string(SA),
+ io__nl,
+ io__write_string(SB),
+ io__nl,
+ { std_util__compare_approx(Res, A, B) },
+ (
+ { Res = (=) }
+ ->
+ []
+ ;
+ io__write_string("not ")
+ ),
+ io__write_string("equal\n\n").
+
--------------------------------------------------------------------------
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