[m-rev.] for review: do not generate trace events in private_builtin
Ian MacLarty
maclarty at cs.mu.OZ.AU
Fri Nov 18 08:15:14 AEDT 2005
On Thu, Nov 17, 2005 at 11:56:44PM +1100, Julien Fischer wrote:
>
> On Thu, 17 Nov 2005, Ian MacLarty wrote:
>
> > Oops, forgot the following:
> >
> > Estimated hours taken: 3
> > Branches: main
> >
> > On Thu, Nov 17, 2005 at 11:03:56PM +1100, Ian MacLarty wrote:
> > > Define locals copies of some procedures called by private_builtin that
> > > are in modules which could be traced. In decldebug grades the
> > ...
>
> You also forgot the diff ;-)
>
Here it is:
Index: library/builtin.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/builtin.m,v
retrieving revision 1.112
diff -u -r1.112 builtin.m
--- library/builtin.m 17 Oct 2005 11:35:16 -0000 1.112
+++ library/builtin.m 17 Nov 2005 08:43:23 -0000
@@ -368,15 +368,6 @@
:- implementation.
-:- import_module char.
-:- import_module float.
-:- import_module int.
-:- import_module list.
-:- import_module require.
-:- import_module std_util.
-:- import_module string.
-:- import_module string.
-
%-----------------------------------------------------------------------------%
false :-
Index: library/exception.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/exception.m,v
retrieving revision 1.100
diff -u -r1.100 exception.m
--- library/exception.m 20 Sep 2005 03:47:30 -0000 1.100
+++ library/exception.m 16 Nov 2005 12:50:21 -0000
@@ -720,10 +720,18 @@
% builtin_throw and builtin_catch are implemented below using
% hand-coded low-level C code.
+% builtin_throw is exported, so that it can be called from private_builtin.
+% private_builtin needs to call builtin_throw directly to avoid generating
+% trace events.
%
:- pragma terminates(builtin_throw/1).
+
+:- interface.
+
:- pred builtin_throw(univ::in) is erroneous.
+:- implementation.
+
:- /* impure */
pred builtin_catch(pred(T), handler(T), T).
:- mode builtin_catch(pred(out) is det, in(handler), out) is det.
Index: library/private_builtin.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/private_builtin.m,v
retrieving revision 1.148
diff -u -r1.148 private_builtin.m
--- library/private_builtin.m 17 Oct 2005 07:43:28 -0000 1.148
+++ library/private_builtin.m 16 Nov 2005 12:57:58 -0000
@@ -25,6 +25,11 @@
% definitions because the compiler generates code for them inline. Some others
% are implemented in the runtime.
+% NOTE: This module is never traced, even in debugging grades. To avoid
+% confusing the declarative debugger, all predicates and functions defined in
+% this module should avoid calling predicates or functions in other modules
+% which could be traced.
+
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -34,6 +39,8 @@
:- interface.
+:- import_module type_desc.
+
% This section of the module contains predicates that are used
% by the compiler, to implement polymorphism. These predicates
% should not be used by user programs directly.
@@ -102,20 +109,31 @@
%
:- pred typed_compare(comparison_result::uo, T1::in, T2::in) is det.
+ % The function type_of/1 returns a representation of the type
+ % of its argument.
+ %
+ % (Note: it is not possible for the type of a variable to be an unbound
+ % type variable; if there are no constraints on a type variable, then the
+ % typechecker will use the type `void'. `void' is a special (builtin) type
+ % that has no constructors. There is no way of creating an object of
+ % type `void'. `void' is not considered to be a discriminated union, so
+ % get_functor/5 and construct/3 will fail if used upon a value of
+ % this type.)
+ %
+:- func type_of(T::unused) = (type_desc__type_desc::out) is det.
+
% N.B. interface continued below.
%-----------------------------------------------------------------------------%
:- implementation.
-:- import_module char.
+:- import_module exception.
:- import_module float.
:- import_module int.
:- import_module list.
:- import_module require.
:- import_module std_util.
-:- import_module string.
-:- import_module string.
:- pragma foreign_code("C#", "
@@ -147,8 +165,8 @@
builtin_unify_character(C, C).
builtin_compare_character(R, X, Y) :-
- char__to_int(X, XI),
- char__to_int(Y, YI),
+ private_builtin.to_int(X, XI),
+ private_builtin.to_int(Y, YI),
( XI < YI ->
R = (<)
; XI = YI ->
@@ -200,20 +218,20 @@
).
builtin_unify_tuple(_, _) :-
- ( semidet_succeed ->
+ ( private_builtin.semidet_succeed ->
% The generic unification function in the runtime
% should handle this itself.
- error("builtin_unify_tuple called")
+ private_builtin.error("builtin_unify_tuple called")
;
% The following is never executed.
- semidet_succeed
+ private_builtin.semidet_succeed
).
builtin_compare_tuple(Res, _, _) :-
- ( semidet_succeed ->
+ ( private_builtin.semidet_succeed ->
% The generic comparison function in the runtime
% should handle this itself.
- error("builtin_compare_tuple called")
+ private_builtin.error("builtin_compare_tuple called")
;
% The following is never executed.
Res = (<)
@@ -221,17 +239,17 @@
:- pragma no_inline(builtin_unify_pred/2).
builtin_unify_pred(_X, _Y) :-
- ( semidet_succeed ->
- error("attempted higher-order unification")
+ ( private_builtin.semidet_succeed ->
+ private_builtin.error("attempted higher-order unification")
;
% The following is never executed.
- semidet_succeed
+ private_builtin.semidet_succeed
).
:- pragma no_inline(builtin_compare_pred/3).
builtin_compare_pred(Result, _X, _Y) :-
- ( semidet_succeed ->
- error("attempted higher-order comparison")
+ ( private_builtin.semidet_succeed ->
+ private_builtin.error("attempted higher-order comparison")
;
% The following is never executed.
Result = (<)
@@ -240,10 +258,11 @@
:- pragma no_inline(builtin_compare_non_canonical_type/3).
builtin_compare_non_canonical_type(Res, X, _Y) :-
% suppress determinism warning
- ( semidet_succeed ->
+ ( private_builtin.semidet_succeed ->
+ % XXX The call to type_name below may generate trace events.
Message = "call to compare/3 for non-canonical type `"
- ++ type_name(type_of(X)) ++ "'",
- error(Message)
+ ++ type_desc.type_name(private_builtin.type_of(X)) ++ "'",
+ private_builtin.error(Message)
;
% The following is never executed.
Res = (<)
@@ -251,19 +270,19 @@
:- pragma no_inline(compare_error/0).
compare_error :-
- error("internal error in compare/3").
+ private_builtin.error("internal error in compare/3").
%-----------------------------------------------------------------------------%
typed_unify(X, Y) :-
- ( type_of(X) = type_of(Y) ->
+ ( private_builtin.type_of(X) = private_builtin.type_of(Y) ->
unsafe_type_cast(X, Y)
;
fail
).
typed_compare(R, X, Y) :-
- compare(R0, type_of(X), type_of(Y)),
+ compare(R0, private_builtin.type_of(X), private_builtin.type_of(Y)),
( R0 = (=) ->
unsafe_type_cast(X, Z),
compare(R, Z, Y)
@@ -271,6 +290,26 @@
R = R0
).
+:- pragma foreign_proc("C",
+ type_of(_Value::unused) = (TypeInfo::out),
+ [will_not_call_mercury, thread_safe, promise_pure],
+"{
+ TypeInfo = TypeInfo_for_T;
+
+ /*
+ ** We used to collapse equivalences for efficiency here, but that's not
+ ** always desirable, due to the reverse mode of make_type/2, and efficiency
+ ** of type_infos probably isn't very important anyway.
+ */
+#if 0
+ MR_save_transient_registers();
+ TypeInfo = (MR_Word) MR_collapse_equivalences(
+ (MR_TypeInfo) TypeInfo_for_T);
+ MR_restore_transient_registers();
+#endif
+
+}").
+
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -901,13 +940,11 @@
").
trailed_nondet_pragma_foreign_code :-
- Msg = string__append_list([
- "Sorry, not implemented:\n",
- "for the MLDS back-end (`--high-level-code')\n",
- "nondet `pragma c_code' or `pragma foreign_code'\n",
- "is not supported when trailing (`--use-trail') is enabled."
- ]),
- error(Msg).
+ Msg = "Sorry, not implemented:\n\
+for the MLDS back-end (`--high-level-code')\n\
+nondet `pragma c_code' or `pragma foreign_code'\n\
+is not supported when trailing (`--use-trail') is enabled.",
+ private_builtin.error(Msg).
%-----------------------------------------------------------------------------%
@@ -1076,13 +1113,11 @@
").
reclaim_heap_nondet_pragma_foreign_code :-
- Msg = string__append_list([
- "Sorry, not implemented:\n",
- "for the MLDS back-end (`--high-level-code')\n",
- "nondet `pragma c_code' or `pragma foreign_code'\n",
- "is not supported when `--reclaim-heap-on-failure' is enabled."
- ]),
- error(Msg).
+ Msg = "Sorry, not implemented:\n\
+for the MLDS back-end (`--high-level-code')\n\
+nondet `pragma c_code' or `pragma foreign_code'\n\
+is not supported when `--reclaim-heap-on-failure' is enabled.",
+ private_builtin.error(Msg).
%-----------------------------------------------------------------------------%
@@ -1226,22 +1261,22 @@
:- implementation.
unused :-
- ( semidet_succeed ->
- error("attempted use of dead predicate")
+ ( private_builtin.semidet_succeed ->
+ private_builtin.error("attempted use of dead predicate")
;
% the following is never executed
true
).
nyi_foreign_type_unify(_, _) :-
- ( semidet_succeed ->
+ ( private_builtin.semidet_succeed ->
sorry("unify for foreign types")
;
- semidet_succeed
+ private_builtin.semidet_succeed
).
nyi_foreign_type_compare(Result, _, _) :-
- ( semidet_succeed ->
+ ( private_builtin.semidet_succeed ->
sorry("compare for foreign types")
;
Result = (=)
@@ -1301,11 +1336,11 @@
nonvar(_::unused) :- fail.
sorry(PredName) :-
- error("sorry, " ++ PredName ++ " not implemented\n" ++
+ private_builtin.error("sorry, " ++ PredName ++ " not implemented\n" ++
"for this target language (or compiler back-end).").
no_clauses(PredName) :-
- error("no clauses for " ++ PredName).
+ private_builtin.error("no clauses for " ++ PredName).
:- pragma foreign_proc(c,
imp,
@@ -1528,4 +1563,73 @@
").
%-----------------------------------------------------------------------------%
+%
+% The following predicates are duplicates of their versions in the
+% publically visible part of the standard library. They are duplicated here
+% to guarantee that calls to procedures in private_builtin do not generate
+% any trace events.
+%
+
+:- pred semidet_succeed is semidet.
+
+:- pragma foreign_proc("C",
+ semidet_succeed,
+ [will_not_call_mercury, thread_safe, promise_pure],
+"
+ SUCCESS_INDICATOR = MR_TRUE;
+").
+
+:- pragma foreign_proc("C#",
+ semidet_succeed,
+ [will_not_call_mercury, thread_safe, promise_pure],
+"
+ SUCCESS_INDICATOR = true;
+").
+
+semidet_succeed :-
+ 0 + 0 = 0.
+
+:- pred to_int(character::in, int::out) is det.
+
+:- pragma foreign_proc("C",
+ to_int(Character::in, Int::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ Int = (MR_UnsignedChar) Character;
+").
+
+:- pragma foreign_proc("C#",
+ to_int(Character::in, Int::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ Int = Character;
+").
+
+:- pragma foreign_proc("Java",
+ to_int(Character::in, Int::out),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"
+ Int = (int) Character;
+").
+
+:- func string ++ string = string.
+:- mode in ++ in = uo is det.
+
+:- pragma foreign_proc("C",
+ (S1::in) ++ (S2::in) = (S3::uo),
+ [will_not_call_mercury, promise_pure, thread_safe],
+"{
+ size_t len_1, len_2;
+ len_1 = strlen(S1);
+ len_2 = strlen(S2);
+ MR_allocate_aligned_string_msg(S3, len_1 + len_2, MR_PROC_LABEL);
+ strcpy(S3, S1);
+ strcpy(S3 + len_1, S2);
+}").
+
+:- pred private_builtin.error(string::in) is erroneous.
+
+error(Message) :-
+ exception.builtin_throw('new univ_cons'(software_error(Message))).
+
%-----------------------------------------------------------------------------%
Index: library/std_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/std_util.m,v
retrieving revision 1.303
diff -u -r1.303 std_util.m
--- library/std_util.m 17 Oct 2005 11:35:20 -0000 1.303
+++ library/std_util.m 16 Nov 2005 12:50:40 -0000
@@ -1642,11 +1642,18 @@
%-----------------------------------------------------------------------------%
+:- interface.
+
% We call the constructor for univs `univ_cons' to avoid ambiguity
% with the univ/1 function which returns a univ.
+ % The univ type is exported so that private_builtin can create
+ % univs without generating trace events.
+ %
:- type univ
---> some [T] univ_cons(T).
+:- implementation.
+
univ_to_type(Univ, X) :- type_to_univ(X, Univ).
univ(X) = Univ :- type_to_univ(X, Univ).
Index: library/type_desc.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/type_desc.m,v
retrieving revision 1.33
diff -u -r1.33 type_desc.m
--- library/type_desc.m 19 Sep 2005 04:29:01 -0000 1.33
+++ library/type_desc.m 16 Nov 2005 12:03:43 -0000
@@ -391,25 +391,7 @@
error("ground_pseudo_type_desc_to_type_desc_det: not ground")
).
-:- pragma foreign_proc("C",
- type_of(_Value::unused) = (TypeInfo::out),
- [will_not_call_mercury, thread_safe, promise_pure],
-"{
- TypeInfo = TypeInfo_for_T;
-
- /*
- ** We used to collapse equivalences for efficiency here, but that's not
- ** always desirable, due to the reverse mode of make_type/2, and efficiency
- ** of type_infos probably isn't very important anyway.
- */
-#if 0
- MR_save_transient_registers();
- TypeInfo = (MR_Word) MR_collapse_equivalences(
- (MR_TypeInfo) TypeInfo_for_T);
- MR_restore_transient_registers();
-#endif
-
-}").
+type_of(Value) = private_builtin.type_of(Value).
:- pragma foreign_proc("C#",
type_of(_Value::unused) = (TypeInfo::out),
Index: tests/debugger/loopcheck.exp3
===================================================================
RCS file: /home/mercury1/repository/tests/debugger/loopcheck.exp3,v
retrieving revision 1.3
diff -u -r1.3 loopcheck.exp3
--- tests/debugger/loopcheck.exp3 1 Apr 2005 02:09:39 -0000 1.3
+++ tests/debugger/loopcheck.exp3 17 Nov 2005 11:52:34 -0000
@@ -22,5 +22,5 @@
mdb> continue
Uncaught Mercury exception:
Software Error: detected infinite recursion in pred loopcheck.loop/1
-Last trace event was event #312.
+Last trace event was event #304.
Last trace event before the unhandled exception was event #8.
Index: tests/debugger/declarative/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/debugger/declarative/Mmakefile,v
retrieving revision 1.85
diff -u -r1.85 Mmakefile
--- tests/debugger/declarative/Mmakefile 2 Nov 2005 14:17:37 -0000 1.85
+++ tests/debugger/declarative/Mmakefile 13 Nov 2005 05:18:10 -0000
@@ -84,7 +84,8 @@
DECLDEBUG_DECLARATIVE_PROGS= \
builtin_call_rep \
sort \
- priv_builtin_bug
+ priv_builtin_bug \
+ typed_unify
# The following should not be run in decldebug grades.
#
@@ -425,6 +426,11 @@
priv_builtin_bug.out 2>&1 \
|| { grep . $@ /dev/null; exit 1; }
+typed_unify.out: typed_unify typed_unify.inp
+ $(MDB_STD) ./typed_unify < typed_unify.inp > \
+ typed_unify.out 2>&1 \
+ || { grep . $@ /dev/null; exit 1; }
+
propositional.out: propositional propositional.inp
$(MDB_STD) ./propositional < propositional.inp > \
propositional.out 2>&1 || { grep . $@ /dev/null; exit 1; }
Index: tests/debugger/declarative/typed_unify.exp
===================================================================
RCS file: tests/debugger/declarative/typed_unify.exp
diff -N tests/debugger/declarative/typed_unify.exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/debugger/declarative/typed_unify.exp 17 Nov 2005 09:38:37 -0000
@@ -0,0 +1,31 @@
+ E1: C1 CALL pred typed_unify.main/2-0 (det) typed_unify.m:13
+mdb> mdb> echo on
+Command echo enabled.
+mdb> table_io start
+I/O tabling started.
+mdb> step
+ E2: C2 CALL func std_util.univ/1-1 (det) std_util.m:1659 (typed_unify.m:14)
+mdb> finish
+ E3: C2 EXIT func std_util.univ/1-1 (det) std_util.m:1659 (typed_unify.m:14)
+mdb> step
+ E4: C1 COND pred typed_unify.main/2-0 (det) c4;?; typed_unify.m:15
+mdb> step
+ E5: C3 CALL pred std_util.type_to_univ/2-2 (semidet) std_util.m:1683 (typed_unify.m:15)
+mdb> finish
+ E6: C3 EXIT pred std_util.type_to_univ/2-2 (semidet) std_util.m:1683 (typed_unify.m:15)
+mdb> untrust 0
+mdb> dd
+type_to_univ(1, univ_cons(1))
+Valid? b 1
+browser> track -a
+type_to_univ(1, univ_cons(1))
+Valid? info
+Context of current question : std_util.m:1683 (typed_unify.m:15)
+Search mode : top down
+The current question was chosen because the marked subterm was bound by
+the untraced call inside the predicate std_util.type_to_univ/2
+(std_util.m:1685). The path to the subterm in the atom is 1.
+dd> quit
+Diagnosis aborted.
+ E6: C3 EXIT pred std_util.type_to_univ/2-2 (semidet) std_util.m:1683 (typed_unify.m:15)
+mdb> quit -y
Index: tests/debugger/declarative/typed_unify.inp
===================================================================
RCS file: tests/debugger/declarative/typed_unify.inp
diff -N tests/debugger/declarative/typed_unify.inp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/debugger/declarative/typed_unify.inp 17 Nov 2005 09:35:53 -0000
@@ -0,0 +1,15 @@
+register --quiet
+echo on
+table_io start
+step
+finish
+step
+step
+finish
+untrust 0
+dd
+b 1
+track -a
+info
+quit
+quit -y
Index: tests/debugger/declarative/typed_unify.m
===================================================================
RCS file: tests/debugger/declarative/typed_unify.m
diff -N tests/debugger/declarative/typed_unify.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/debugger/declarative/typed_unify.m 16 Nov 2005 02:55:29 -0000
@@ -0,0 +1,20 @@
+:- module typed_unify.
+
+:- interface.
+
+:- import_module io.
+
+:- pred main(io::di, io::uo) is det.
+
+:- implementation.
+
+:- import_module std_util.
+
+main(!IO) :-
+ U = univ(1),
+ ( type_to_univ(I, U) ->
+ io.write_int(I, !IO)
+ ;
+ true
+ ),
+ nl(!IO).
--------------------------------------------------------------------------
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