[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