[m-dev.] For review: new data structure for declarative debugging
Mark Anthony BROWN
dougl at cs.mu.OZ.AU
Tue Oct 26 18:16:50 AEST 1999
Hi,
This is the first installment of the new declarative debugger
design. This is for Zoltan to review, since we have already
discussed the design.
Cheers,
Mark
Estimated hours taken: 160
Implement a new data structure for declarative debugging. The
major differences between this and the old implementation are:
- The data structure is implemented in Mercury. The definition
of the type, and procedures for constructing values of that
type, have been moved from trace/mercury_trace_declarative.{c,h}
to browser/declarative_execution.m (which is a new module).
- The front end no longer needs to call the back end via an
indirect pointer---the front end does not call the back end at
all.
- The data structure is not specifically for wrong answer
analysis, it is intended to be used for any sort of analysis.
- The data structure represents execution at a lower level---the
new front end defines a more abstract view in terms of this
data structure.
Implement a test harness for debugging the front end code. This allows
the front end to run as a stand-alone program, which can then be
debugged using `mdb'.
The code in the front end does not currently handle the new structure
very nicely. This is because that code is about to undergo some major
structural changes, so there is little point cleaning it up now.
Consequently:
- Some of the code in the front end is incorrect (eg. the
user interface does not print missing answer nodes
properly).
- The tests have not been reinstated.
These things will be fixed in subsequent changes.
Likewise the compiler still reserves two stack slots, even though
only one is required. After this change the algorithm should be able
to get away with using no stack slots, so modifications to the compiler
will be postponed until then.
browser/declarative_execution.m:
New module. Implement the execution_tree typeclass, which
represents the execution of a Mercury program. Implement
two instances of this typeclass, one for normal use and one for
testing purposes.
browser/declarative_test.m:
New module. A test harness that can be compiled as a
stand-alone program, enabling the front end to be debugged.
trace/mercury_trace_declarative.c:
trace/mercury_trace_declarative.h:
- Remove the definition of the old data structure.
- Add some macros which enable the new Mercury data structure
to be destructively updated by C code.
- Change the interface to this module so that it reflects more
general diagnosis, not just wrong answer analysis.
- Implement the new algorithm.
- Call an alternative front end if in test mode.
- Update coments.
trace/mercury_trace_internal.h:
Add a new mode for debugging the declarative debugger.
trace/mercury_trace_internal.c:
Change the command from `dd_wrong' to `dd', since it is not
specifically for wrong answer analysis. Add a new command
`dd_dd' which calls the alternative front end used for testing.
runtime/mercury_init.h:
runtime/mercury_wrapper.c:
runtime/mercury_wrapper.h:
util/mkinit.c:
Remove any reference to `MR_edt_root_node', since it is no
longer used.
browser/declarative_debugger.m:
- Add a case for missing answer nodes to `edt_node'.
- Change the `evaluation_tree' typeclass into `mercury_edt'
typeclass. This is to make it more distinct from the new
`execution_tree' typeclass, which is a lower level concept.
- New interface to the diagnoser: types `diagnoser_response'
and `diagnoser_state', and procedure `diagnosis'.
- Define an instance of `mercury_edt' from an instance of
`execution_tree'.
- Updates to the analyser to get it to compile---further changes
will be forthcoming.
browser/declarative_user.m:
- Updates to the user interface to get it to compile---further
changes will be forthcoming.
browser/browser_library.m:
Import the new module (declarative_execution.m).
browser/debugger_interface.m:
browser/util.m:
Move the definitions of trace_port_type and goal_path_string
to browser/util.m, since they are now used by more than just
the external debugger.
browser/Mmakefile:
Add the test harness as a `depend' target.
browser/browse_test.m:
Use the correct interface to the browser.
? browser/declarative_execution.m
? browser/declarative_test.m
Index: browser/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/mercury/browser/Mmakefile,v
retrieving revision 1.6
diff -u -r1.6 Mmakefile
--- Mmakefile 1999/09/16 04:46:24 1.6
+++ Mmakefile 1999/10/26 05:56:59
@@ -84,10 +84,11 @@
# targets
.PHONY: all
-all : library browse_test
+all : library browse_test declarative_test
.PHONY: depend
-depend : browser_library.depend browse_test.depend
+depend : browser_library.depend browse_test.depend \
+ declarative_test.depend
.PHONY: check
check : browser_library.check
@@ -96,7 +97,7 @@
all-ints: ints int3s
.PHONY: ints
-ints : browser_library.ints browse_test.ints
+ints : browser_library.ints browse_test.ints declarative_test.ints
.PHONY: int3s
int3s : browser_library.int3s
Index: browser/browse_test.m
===================================================================
RCS file: /home/mercury1/repository/mercury/browser/browse_test.m,v
retrieving revision 1.1
diff -u -r1.1 browse_test.m
--- browse_test.m 1998/10/25 07:16:38 1.1
+++ browse_test.m 1999/10/26 05:56:59
@@ -36,8 +36,10 @@
{ assoc_list__from_corresponding_lists(Words, Words,
AssocList) },
{ tree234__assoc_list_to_tree234(AssocList, Tree) },
- { type_to_univ(Tree, Univ) },
- browse__browse(Univ),
+ io__stdin_stream(StdIn),
+ io__stdout_stream(StdOut),
+ browse__init_state(State),
+ browse__browse(Tree, StdIn, StdOut, State, _),
io__set_exit_status(EXIT_SUCCESS)
).
Index: browser/browser_library.m
===================================================================
RCS file: /home/mercury1/repository/mercury/browser/browser_library.m,v
retrieving revision 1.5
diff -u -r1.5 browser_library.m
--- browser_library.m 1999/08/20 06:47:23 1.5
+++ browser_library.m 1999/10/26 05:56:59
@@ -15,6 +15,7 @@
:- import_module browse, frame, help, parse, util.
:- import_module debugger_interface.
:- import_module declarative_debugger, declarative_oracle, declarative_user.
+:- import_module declarative_execution.
:- import_module interactive_query, dl, name_mangle.
% See library/library.m for why we implement this predicate this way.
Index: browser/debugger_interface.m
===================================================================
RCS file: /home/mercury1/repository/mercury/browser/debugger_interface.m,v
retrieving revision 1.12
diff -u -r1.12 debugger_interface.m
--- debugger_interface.m 1999/10/20 14:06:51 1.12
+++ debugger_interface.m 1999/10/26 05:57:05
@@ -32,7 +32,7 @@
:- implementation.
:- import_module io, require.
:- import_module list, bool, std_util.
-:- import_module interactive_query.
+:- import_module interactive_query, util.
dummy_pred_to_avoid_warning_about_nothing_exported.
@@ -43,32 +43,6 @@
:- type determinism == int.
% encoded as specified in ../runtime/mercury_stack_layout.h
% and ../compiler/stack_layout.m.
-
-% The stuff defined below is similar to types goal_path and trace_port
-% defined in modules compiler/hlds_goal.m and compiler/trace.m.
-% This enumeration must be EXACTLY the same as the MR_trace_port enum in
-% runtime/mercury_trace_base.h, and in the same order, since the code
-% assumes the representation is the same.
-
-:- type trace_port_type
- ---> call
- ; exit
- ; redo
- ; fail
- ; ite_cond
- ; ite_then
- ; ite_else
- ; neg_enter
- ; neg_success
- ; neg_failure
- ; disj
- ; switch
- ; nondet_pragma_first
- ; nondet_pragma_later
- ; exception
- .
-
-:- type goal_path_string == string.
% This enumeration must be EXACTLY the same as the MR_PredFunc enum in
% runtime/mercury_stack_layout.h, and in the same order, since the code
Index: browser/declarative_debugger.m
===================================================================
RCS file: /home/mercury1/repository/mercury/browser/declarative_debugger.m,v
retrieving revision 1.5
diff -u -r1.5 declarative_debugger.m
--- declarative_debugger.m 1999/08/20 06:47:23 1.5
+++ declarative_debugger.m 1999/10/26 05:57:08
@@ -11,12 +11,9 @@
% a Mercury declarative debugger, and
% - to implement a front end.
%
-% The interface between the front and back ends is partly defined
-% by the evaluation_tree typeclass. An instance of this typeclass
-% implements evaluation dependency trees (EDTs), which are created
-% in the back end and passed to the front end for analysis. The rest
-% of the interface is via analyse_edt/7, which is how the front end
-% is called from the back end.
+% The interface is defined by a procedure that can be called from
+% the back end to perform diagnosis, and a typeclass which represents
+% a declarative view of execution used by the front end.
%
% The front end implemented in this module analyses the EDT it is
% passed to diagnose a bug. It does this by a simple top-down search.
@@ -24,179 +21,303 @@
:- module declarative_debugger.
:- interface.
-:- import_module io, list, string, std_util, bool.
-:- import_module declarative_oracle.
+:- import_module io, list, bool.
+:- import_module declarative_execution.
- %
% This type represents the possible truth values for nodes
% in the EDT.
%
:- type edt_truth == bool.
- %
% Values of this type represent EDT nodes. This representation
% is used by the front end (in this module), as well as the
% oracle and user interface.
%
- % There will be nodes other than wrong_answer in future, such
- % as for missing answer analysis.
- %
:- type edt_node
+ % The node is a suspected wrong answer. The
+ % argument is the atom in its final state of
+ % instantiatedness (ie. at the EXIT event).
%
- % The node is a possible wrong answer. The first
- % argument is the procedure name and the second
- % is the list of arguments at exit.
- %
- ---> wrong_answer(string, list(univ)).
+ ---> wrong_answer(edt_atom)
- %
- % See comments above.
+ % The node is a suspected missing answer. The
+ % first argument is the atom in its initial state
+ % of instantiatedness (ie. at the CALL event),
+ % and the second argument is the list of solutions.
+ %
+ ; missing_answer(edt_atom, list(edt_atom)).
+
+:- type edt_atom == trace_atom.
+
+ % This typeclass represents a declarative view of execution.
%
-:- typeclass evaluation_tree(Tree) where [
- pred edt_root(Tree, edt_node),
- mode edt_root(in, out) is det,
+:- typeclass mercury_edt(S, T) where [
+ pred edt_root(S, T, edt_node),
+ mode edt_root(in, in, out) is det,
- pred edt_children(Tree, list(Tree)),
- mode edt_children(in, out) is det
+ pred edt_children(S, T, list(T)),
+ mode edt_children(in, in, out) is det
].
+
+ % The diagnoser eventually responds with a value of this type
+ % when it is called.
+ %
+ % XXX need to have a case for expanding an implicit tree.
+ %
+:- type diagnoser_response
+ ---> bug_found(edt_node)
+ ; no_bug_found.
-:- pred analyse_edt(T, io__input_stream, io__output_stream, oracle_state,
- oracle_state, io__state, io__state) <= evaluation_tree(T).
-:- mode analyse_edt(in, in, in, in, out, di, uo) is det.
+:- type diagnoser_state.
+:- pred diagnoser_state_init(diagnoser_state).
+:- mode diagnoser_state_init(out) is det.
+
+:- pred diagnosis(io__input_stream, io__output_stream, S, trace_node(R),
+ diagnoser_response, diagnoser_state, diagnoser_state,
+ io__state, io__state) <= execution_tree(S, R).
+:- mode diagnosis(in, in, in, in, out, in, out, di, uo) is det.
+
%-----------------------------------------------------------------------------%
:- implementation.
:- import_module require, int, char.
-:- import_module declarative_user.
+:- import_module declarative_oracle, declarative_user.
- %
- % This section defines the Mercury instance of the evaluation
- % tree.
+:- type diagnoser_state == oracle_state.
+
+:- pragma export(diagnoser_state_init(out),
+ "MR_DD_diagnoser_state_init").
+
+diagnoser_state_init(Oracle) :-
+ oracle_state_init(Oracle).
+
+diagnosis(MdbIn, MdbOut, Store, Node, Response, State0, State) -->
+ io__set_input_stream(MdbIn, OldIn),
+ io__set_output_stream(MdbOut, OldOut),
+ analyse_edt(wrap(Store), Node, Response, State0, State),
+ io__set_input_stream(OldIn, _),
+ io__set_output_stream(OldOut, _).
+
+ % Export a monomorphic version of diagnosis/9, to make it
+ % easier to call from C code.
%
+:- pred diagnosis_store(io__input_stream, io__output_stream,
+ trace_node_store, trace_node(trace_node_id),
+ diagnoser_response, diagnoser_state, diagnoser_state,
+ io__state, io__state).
+:- mode diagnosis_store(in, in, in, in, out, in, out, di, uo) is det.
-:- instance evaluation_tree(mercury_edt) where [
- pred(edt_root/2) is mercury_edt_root,
- pred(edt_children/2) is mercury_edt_children
-].
+:- pragma export(diagnosis_store(in, in, in, in, out, in, out, di, uo),
+ "MR_DD_decl_diagnosis").
+
+diagnosis_store(In, Out, Store, Node, Response, State0, State) -->
+ diagnosis(In, Out, Store, Node, Response, State0, State).
+
+%-----------------------------------------------------------------------------%
%
- % This is defined as a "no-tag" type, to avoid problems with
- % equivalence types being used as type class instances.
+ % This section defines an instance of the EDT in terms of
+ % any instance of execution tree.
%
-:- type mercury_edt
- ---> mercury_edt(c_pointer).
+:- instance mercury_edt(wrap(S), trace_node(R)) <= execution_tree(S, R)
+ where [
+ pred(edt_root/3) is trace_root,
+ pred(edt_children/3) is trace_children
+ ].
-:- pred mercury_edt_children(mercury_edt, list(mercury_edt)).
-:- mode mercury_edt_children(in, out) is det.
+ % The wrap/1 around the first argument of the instance is
+ % required by the language.
+ %
+:- type wrap(T) ---> wrap(T).
+
+:- pred trace_root(wrap(S), trace_node(R), edt_node) <= execution_tree(S, R).
+:- mode trace_root(in, in, out) is det.
-mercury_edt_children(mercury_edt(EDT), Children) :-
+trace_root(wrap(Store), Node, Root) :-
(
- mercury_edt_first_child(EDT, FirstChild)
+ Node = fail(_, CallId)
->
- mercury_edt_children_2(FirstChild, Children0),
- Children = [mercury_edt(FirstChild) | Children0]
+ call_node_from_id(Store, CallId, Call),
+ Call = call(_, RedoId, CallAtom),
+ get_answers(Store, RedoId, [], Answers),
+ Root = missing_answer(CallAtom, Answers)
;
- Children = []
+ Node = exit(_, _, _, ExitAtom)
+ ->
+ Root = wrong_answer(ExitAtom)
+ ;
+ error("trace_root: not an EXIT or FAIL node")
).
+:- pred get_answers(S, R, list(edt_atom), list(edt_atom))
+ <= execution_tree(S, R).
+:- mode get_answers(in, in, in, out) is det.
-:- pred mercury_edt_children_2(c_pointer, list(mercury_edt)).
-:- mode mercury_edt_children_2(in, out) is det.
+get_answers(Store, RedoId, As0, As) :-
+ (
+ maybe_redo_node_from_id(Store, RedoId, redo(_, ExitId))
+ ->
+ exit_node_from_id(Store, ExitId, exit(_, _, NextId, Atom)),
+ get_answers(Store, NextId, [Atom | As0], As)
+ ;
+ As = As0
+ ).
-mercury_edt_children_2(Child, Siblings) :-
+:- pred trace_children(wrap(S), trace_node(R), list(trace_node(R)))
+ <= execution_tree(S, R).
+:- mode trace_children(in, in, out) is det.
+
+trace_children(wrap(Store), Node, Children) :-
(
- mercury_edt_sibling(Child, Sibling)
+ Node = fail(PrecId, _)
->
- mercury_edt_children_2(Sibling, Siblings0),
- Siblings = [mercury_edt(Sibling) | Siblings0]
+ missing_answer_children(Store, PrecId, [], Children)
;
- Siblings = []
+ Node = exit(PrecId, _, _, _)
+ ->
+ wrong_answer_children(Store, PrecId, [], Children)
+ ;
+ error("trace_children: not an EXIT or FAIL node")
).
+:- pred wrong_answer_children(S, R, list(trace_node(R)), list(trace_node(R)))
+ <= execution_tree(S, R).
+:- mode wrong_answer_children(in, in, in, out) is det.
-:- pragma c_header_code("
- #include ""mercury_trace_declarative.h""
- #include ""mercury_type_info.h""
- #include ""mercury_wrapper.h""
-").
-
-:- pred mercury_edt_first_child(c_pointer, c_pointer).
-:- mode mercury_edt_first_child(in, out) is semidet.
-
-:- pragma c_code(mercury_edt_first_child(Parent::in, Child::out),
- [will_not_call_mercury],
- "
- MR_Edt_Node *parent;
- MR_Edt_Node *child;
-
- parent = (MR_Edt_Node *) Parent;
- child = parent->MR_edt_node_children;
- if (child != NULL) {
- Child = (Word) child;
- SUCCESS_INDICATOR = TRUE;
- } else {
- SUCCESS_INDICATOR = FALSE;
- }
- "
-).
-
-:- pred mercury_edt_sibling(c_pointer, c_pointer).
-:- mode mercury_edt_sibling(in, out) is semidet.
-
-:- pragma c_code(mercury_edt_sibling(Child::in, Sibling::out),
- [will_not_call_mercury],
- "
- MR_Edt_Node *child;
- MR_Edt_Node *sibling;
-
- child = (MR_Edt_Node *) Child;
- sibling = child->MR_edt_node_sibling;
- if (sibling != NULL) {
- Sibling = (Word) sibling;
- SUCCESS_INDICATOR = TRUE;
- } else {
- SUCCESS_INDICATOR = FALSE;
- }
- "
-).
-
-:- pred mercury_edt_root(mercury_edt, edt_node).
-:- mode mercury_edt_root(in, out) is det.
-
-mercury_edt_root(mercury_edt(CPtr), Root) :-
- mercury_edt_root_imp(CPtr, Root).
-
-
-:- pred mercury_edt_root_imp(c_pointer, edt_node).
-:- mode mercury_edt_root_imp(in, out) is det.
-
-:- pragma c_code(mercury_edt_root_imp(EDT::in, Root::out),
- [will_not_call_mercury],
- "
- #ifdef MR_USE_DECLARATIVE_DEBUGGER
- /*
- ** We wish to call MR_edt_root_node in the trace
- ** directory, but due to problems with linking we
- ** call it indirectly via a pointer defined in
- ** runtime/mercury_wrapper.c.
- */
- MR_address_of_edt_root_node(EDT, &Root);
- #else
- fatal_error(\"this should never be reached\");
- #endif
- "
-).
+wrong_answer_children(Store, NodeId, Ns0, Ns) :-
+ det_trace_node_from_id(Store, NodeId, Node),
+ (
+ Node = call(_, _, _),
+ Ns = Ns0
+ ;
+ Node = neg(_, _, _),
+ Ns = Ns0
+ ;
+ Node = exit(_, Call, _, _),
+ call_node_from_id(Store, Call, call(Prec, _, _)),
+ wrong_answer_children(Store, Prec, [Node | Ns0], Ns)
+ ;
+ Node = redo(_, _),
+ error("wrong_answer_children: unexpected REDO node")
+ ;
+ Node = fail(_, Call),
+ call_node_from_id(Store, Call, call(Prec, _, _)),
+ wrong_answer_children(Store, Prec, [Node | Ns0], Ns)
+ ;
+ Node = cond(Prec, _, Flag),
+ (
+ Flag = succeeded
+ ->
+ wrong_answer_children(Store, Prec, Ns0, Ns)
+ ;
+ Ns = Ns0
+ )
+ ;
+ Node = first_disj(Back, _, _),
+ wrong_answer_children(Store, Back, Ns0, Ns)
+ ;
+ Node = later_disj(_, Back, _),
+ wrong_answer_children(Store, Back, Ns0, Ns)
+ ;
+ Node = then(Back, _),
+ wrong_answer_children(Store, Back, Ns0, Ns)
+ ;
+ Node = else(Prec, Cond),
+ missing_answer_children(Store, Prec, Ns0, Ns1),
+ cond_node_from_id(Store, Cond, cond(Back, _, _)),
+ wrong_answer_children(Store, Back, Ns1, Ns)
+ ;
+ Node = neg_succ(Prec, Neg),
+ missing_answer_children(Store, Prec, Ns0, Ns1),
+ neg_node_from_id(Store, Neg, neg(Back, _, _)),
+ wrong_answer_children(Store, Back, Ns1, Ns)
+ ;
+ Node = neg_fail(Prec, Neg),
+ wrong_answer_children(Store, Prec, Ns0, Ns1),
+ neg_node_from_id(Store, Neg, neg(Back, _, _)),
+ wrong_answer_children(Store, Back, Ns1, Ns)
+ ).
+
+:- pred missing_answer_children(S, R, list(trace_node(R)), list(trace_node(R)))
+ <= execution_tree(S, R).
+:- mode missing_answer_children(in, in, in, out) is det.
+
+missing_answer_children(Store, NodeId, Ns0, Ns) :-
+ det_trace_node_from_id(Store, NodeId, Node),
+ (
+ Node = call(_, _, _),
+ Ns = Ns0
+ ;
+ Node = neg(_, _, _),
+ Ns = Ns0
+ ;
+ Node = exit(_, Call, Redo, _),
+ (
+ maybe_redo_node_from_id(Store, Redo, redo(Prec0, _))
+ ->
+ Prec = Prec0
+ ;
+ call_node_from_id(Store, Call, call(Prec, _, _))
+ ),
+ wrong_answer_children(Store, Prec, [Node | Ns0], Ns)
+ ;
+ Node = redo(_, Exit),
+ exit_node_from_id(Store, Exit, exit(Prec, _, _, _)),
+ wrong_answer_children(Store, Prec, Ns0, Ns)
+ ;
+ Node = fail(_, Call),
+ call_node_from_id(Store, Call, call(Back, Answer, _)),
+ (
+ maybe_redo_node_from_id(Store, Answer, redo(Prec, _))
+ ->
+ Next = Prec
+ ;
+ Next = Back
+ ),
+ missing_answer_children(Store, Next, [Node | Ns0], Ns)
+ ;
+ Node = cond(Prec, _, Flag),
+ (
+ Flag = succeeded
+ ->
+ missing_answer_children(Store, Prec, Ns0, Ns)
+ ;
+ Ns = Ns0
+ )
+ ;
+ Node = first_disj(Prec, _, _),
+ missing_answer_children(Store, Prec, Ns0, Ns)
+ ;
+ Node = later_disj(Prec, _, _),
+ missing_answer_children(Store, Prec, Ns0, Ns)
+ ;
+ Node = then(Prec, _),
+ missing_answer_children(Store, Prec, Ns0, Ns)
+ ;
+ Node = else(Prec, Cond),
+ missing_answer_children(Store, Prec, Ns0, Ns1),
+ cond_node_from_id(Store, Cond, cond(Back, _, _)),
+ missing_answer_children(Store, Back, Ns1, Ns)
+ ;
+ Node = neg_succ(_, Neg),
+ neg_node_from_id(Store, Neg, neg(Prec, _, _)),
+ missing_answer_children(Store, Prec, Ns0, Ns)
+ ;
+ Node = neg_fail(Prec, Neg),
+ wrong_answer_children(Store, Prec, Ns0, Ns1),
+ neg_node_from_id(Store, Neg, neg(Back, _, _)),
+ missing_answer_children(Store, Back, Ns1, Ns)
+ ).
+
%-----------------------------------------------------------------------------%
%
- % This section implements the front end. It exports the function
- % ML_DD_analyse_edt to C to be called from
- % trace/mercury_trace_declarative.c, and is passed an EDT.
- % This structure is then analysed to find a cause of the bug,
- % which is then presented to the user.
+ % This section implements the analysis.
+ % It is passed an EDT, which is analysed to find a cause of the bug,
+ % and this bug is then presented to the user.
%
% The current implementation uses a simple top-down strategy to
% analyse the EDT.
@@ -215,32 +336,12 @@
; e_bug(T).
- %
- % To simplify calling this module from C code, we export
- % a version of analyse_edt which is specifically for the instance
- % used by the current back end.
- %
-:- pred analyse_mercury_edt(mercury_edt, io__input_stream, io__output_stream,
- io__state, io__state).
-:- mode analyse_mercury_edt(in, in, in, di, uo) is det.
+:- pred analyse_edt(S, T, diagnoser_response, oracle_state,
+ oracle_state, io__state, io__state) <= mercury_edt(S, T).
+:- mode analyse_edt(in, in, out, in, out, di, uo) is det.
-:- pragma export(declarative_debugger__analyse_mercury_edt(in, in, in, di, uo),
- "ML_DD_analyse_edt").
-
-analyse_mercury_edt(EDT, MdbIn, MdbOut) -->
- %
- % XXX this data structure needs to be more
- % persistent. It really should be saved between
- % calls to this predicate.
- %
- { oracle_state_init(Oracle0) },
- analyse_edt(EDT, MdbIn, MdbOut, Oracle0, _).
-
-
-analyse_edt(EDT, MdbIn, MdbOut, Oracle0, Oracle) -->
- io__set_input_stream(MdbIn, OldIn),
- io__set_output_stream(MdbOut, OldOut),
- { edt_root(EDT, RootNode) },
+analyse_edt(Store, EDT, no_bug_found, Oracle0, Oracle) -->
+ { edt_root(Store, EDT, RootNode) },
query_oracle(RootNode, Answer, Oracle0, Oracle1),
(
{ Answer = truth_value(yes) },
@@ -248,92 +349,91 @@
{ Oracle = Oracle1 }
;
{ Answer = truth_value(no) },
- analyse_edt_2(EDT, Bug, Oracle1, Oracle)
+ analyse_edt_2(Store, EDT, Bug, Oracle1, Oracle)
;
{ Answer = deferred(_) },
{ Bug = not_found },
{ Oracle = Oracle1 }
),
- report_bug(Bug),
- io__set_input_stream(OldIn, _),
- io__set_output_stream(OldOut, _).
+ report_bug(Store, Bug).
%
% Assumes the root note is not valid.
%
-:- pred analyse_edt_2(T, declarative_bug(T), oracle_state, oracle_state,
- io__state, io__state) <= evaluation_tree(T).
-:- mode analyse_edt_2(in, out, in, out, di, uo) is det.
+:- pred analyse_edt_2(S, T, declarative_bug(T), oracle_state, oracle_state,
+ io__state, io__state) <= mercury_edt(S, T).
+:- mode analyse_edt_2(in, in, out, in, out, di, uo) is det.
-analyse_edt_2(EDT, Bug, Oracle0, Oracle) -->
- { edt_children(EDT, Children) },
- analyse_children(Children, e_bug(EDT), Bug, Oracle0, Oracle).
+analyse_edt_2(Store, EDT, Bug, Oracle0, Oracle) -->
+ { edt_children(Store, EDT, Children) },
+ analyse_children(Store, Children, e_bug(EDT), Bug, Oracle0, Oracle).
-:- pred analyse_children(list(T), declarative_bug(T), declarative_bug(T),
+:- pred analyse_children(S, list(T), declarative_bug(T), declarative_bug(T),
oracle_state, oracle_state, io__state, io__state)
- <= evaluation_tree(T).
-:- mode analyse_children(in, in, out, in, out, di, uo) is det.
+ <= mercury_edt(S, T).
+:- mode analyse_children(in, in, in, out, in, out, di, uo) is det.
-analyse_children([], Bug, Bug, Oracle, Oracle) -->
+analyse_children(_, [], Bug, Bug, Oracle, Oracle) -->
[].
-analyse_children([Child | Children], Bug0, Bug, Oracle0, Oracle) -->
- { edt_root(Child, ChildNode) },
+analyse_children(Store, [Child | Children], Bug0, Bug, Oracle0, Oracle) -->
+ { edt_root(Store, Child, ChildNode) },
query_oracle(ChildNode, Answer, Oracle0, Oracle1),
(
{ Answer = truth_value(yes) },
- analyse_children(Children, Bug0, Bug, Oracle1, Oracle)
+ analyse_children(Store, Children, Bug0, Bug, Oracle1, Oracle)
;
{ Answer = truth_value(no) },
- analyse_edt_2(Child, Bug, Oracle1, Oracle)
+ analyse_edt_2(Store, Child, Bug, Oracle1, Oracle)
;
{ Answer = deferred(_) },
{ append(Children, [Child], NewChildren) },
- analyse_children(NewChildren, Bug0, Bug, Oracle1, Oracle)
+ analyse_children(Store, NewChildren, Bug0, Bug, Oracle1,
+ Oracle)
).
-:- pred report_bug(declarative_bug(T), io__state, io__state)
- <= evaluation_tree(T).
-:- mode report_bug(in, di, uo) is det.
+:- pred report_bug(S, declarative_bug(T), io__state, io__state)
+ <= mercury_edt(S, T).
+:- mode report_bug(in, in, di, uo) is det.
-report_bug(not_found) -->
+report_bug(_, not_found) -->
io__write_string("Bug not found.\n").
-report_bug(e_bug(EDT)) -->
+report_bug(Store, e_bug(EDT)) -->
io__write_string("Incorrect instance found:\n\n"),
- write_root_node(EDT),
- { edt_children(EDT, Children0) },
+ write_root_node(Store, EDT),
+ { edt_children(Store, EDT, Children0) },
(
{ Children0 = [Child | Children1] }
->
io__write_string(" :-\n"),
{ list__reverse(Children1, Children) },
- write_children(Children),
+ write_children(Store, Children),
io__write_char('\t'),
- write_root_node(Child)
+ write_root_node(Store, Child)
;
[]
),
io__write_string(".\n\n").
-:- pred write_children(list(T), io__state, io__state) <= evaluation_tree(T).
-:- mode write_children(in, di, uo) is det.
+:- pred write_children(S, list(T), io__state, io__state) <= mercury_edt(S, T).
+:- mode write_children(in, in, di, uo) is det.
-write_children([]) -->
+write_children(_, []) -->
[].
-write_children([Child | Children]) -->
+write_children(Store, [Child | Children]) -->
io__write_char('\t'),
- write_root_node(Child),
+ write_root_node(Store, Child),
io__write_string(",\n"),
- write_children(Children).
+ write_children(Store, Children).
-:- pred write_root_node(T, io__state, io__state) <= evaluation_tree(T).
-:- mode write_root_node(in, di, uo) is det.
+:- pred write_root_node(S, T, io__state, io__state) <= mercury_edt(S, T).
+:- mode write_root_node(in, in, di, uo) is det.
-write_root_node(EDT) -->
- { edt_root(EDT, RootNode) },
+write_root_node(Store, EDT) -->
+ { edt_root(Store, EDT, RootNode) },
write_edt_node(RootNode).
Index: browser/declarative_user.m
===================================================================
RCS file: /home/mercury1/repository/mercury/browser/declarative_user.m,v
retrieving revision 1.1
diff -u -r1.1 declarative_user.m
--- declarative_user.m 1999/08/20 06:49:13 1.1
+++ declarative_user.m 1999/10/26 05:57:10
@@ -49,7 +49,7 @@
%-----------------------------------------------------------------------------%
:- implementation.
-:- import_module util.
+:- import_module declarative_execution, util.
:- import_module std_util, io, bool, list, char, string.
query_user(Node, Answer) -->
@@ -137,7 +137,15 @@
write_edt_node(Node) -->
- { Node = wrong_answer(Name, Args) },
+ {
+ Node = wrong_answer(atom(Name, Args))
+ ;
+ % XXX this is wrong, but most of the module is
+ % going to be re-written again soon anyway, so I
+ % won't fix it yet.
+ %
+ Node = missing_answer(atom(Name, Args), _)
+ },
io__write_string(Name),
(
{ Args = [Arg1 | Args0] }
Index: browser/util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/browser/util.m,v
retrieving revision 1.3
diff -u -r1.3 util.m
--- util.m 1999/05/30 03:54:33 1.3
+++ util.m 1999/10/26 05:57:11
@@ -10,6 +10,32 @@
:- import_module list, string, io.
+% The stuff defined below is similar to types goal_path and trace_port
+% defined in modules compiler/hlds_goal.m and compiler/trace.m.
+% This enumeration must be EXACTLY the same as the MR_trace_port enum in
+% runtime/mercury_trace_base.h, and in the same order, since the code
+% assumes the representation is the same.
+
+:- type trace_port_type
+ ---> call
+ ; exit
+ ; redo
+ ; fail
+ ; ite_cond
+ ; ite_then
+ ; ite_else
+ ; neg_enter
+ ; neg_success
+ ; neg_failure
+ ; disj
+ ; switch
+ ; nondet_pragma_first
+ ; nondet_pragma_later
+ ; exception
+ .
+
+:- type goal_path_string == string.
+
% Get user input via the same method used by the internal
% debugger.
:- pred util__trace_getline(string, io__result(string), io__state,
Index: runtime/mercury_init.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_init.h,v
retrieving revision 1.16
diff -u -r1.16 mercury_init.h
--- mercury_init.h 1999/10/05 07:26:19 1.16
+++ mercury_init.h 1999/10/26 05:57:45
@@ -120,9 +120,6 @@
/* in trace/mercury_trace_internal.h */
extern char *MR_trace_getline(const char *, FILE *mdb_in, FILE *mdb_out);
-/* in trace/mercury_trace_declarative.h */
-extern void MR_edt_root_node(Word EDT, Word *Node);
-
/* in trace/mercury_trace_external.h */
extern void MR_trace_init_external(void);
extern void MR_trace_final_external(void);
Index: runtime/mercury_wrapper.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_wrapper.c,v
retrieving revision 1.47
diff -u -r1.47 mercury_wrapper.c
--- mercury_wrapper.c 1999/10/18 15:47:02 1.47
+++ mercury_wrapper.c 1999/10/26 05:57:57
@@ -153,10 +153,6 @@
void (*MR_address_of_trace_final_external)(void);
#endif
-#ifdef MR_USE_DECLARATIVE_DEBUGGER
-void (*MR_address_of_edt_root_node)(Word, Word *);
-#endif
-
#ifdef CONSERVATIVE_GC
void (*address_of_init_gc)(void);
#endif
Index: runtime/mercury_wrapper.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_wrapper.h,v
retrieving revision 1.24
diff -u -r1.24 mercury_wrapper.h
--- mercury_wrapper.h 1999/10/10 02:35:19 1.24
+++ mercury_wrapper.h 1999/10/26 05:57:59
@@ -83,15 +83,6 @@
extern void (*MR_address_of_trace_final_external)(void);
/*
-** MR_edt_root_node(Word, Word *) is defined in
-** trace/mercury_trace_declarative.c but is referenced in
-** browser/declarative_debugger.m. As we can not do direct calls from
-** browse/ to trace/, we do an indirect call via the following pointer.
-*/
-
-extern void (*MR_address_of_edt_root_node)(Word, Word *);
-
-/*
** XXX This is obsolete too.
** This variable has been replaced by MR_io_print_to_*_stream,
** but the installed mkinit executable may still generate references to it.
Index: trace/mercury_trace_declarative.c
===================================================================
RCS file: /home/mercury1/repository/mercury/trace/mercury_trace_declarative.c,v
retrieving revision 1.11
diff -u -r1.11 mercury_trace_declarative.c
--- mercury_trace_declarative.c 1999/10/18 15:47:17 1.11
+++ mercury_trace_declarative.c 1999/10/26 05:58:29
@@ -9,21 +9,21 @@
**
** This file implements the back end of the declarative debugger. The
** back end is an extension to the internal debugger which collects
-** related trace events and builds them into an Evaluation Dependency
-** Tree (EDT). Once built, the EDT is passed to the front end where it can
-** be analysed to find bugs. The front end is implemented in
+** related trace events and builds them into an execution tree. Once
+** built, the tree is passed to the front end where it can be analysed
+** to find bugs. The front end is implemented in
** browse/declarative_debugger.m.
**
** The interface between the front and back ends is via the
-** evaluation_tree typeclass, which is documented in
+** execution_tree/2 typeclass, which is documented in
** browse/declarative_debugger.m. It would be possible to replace
** the front end or the back end with an alternative implementation
** which also conforms to the typeclass constraints. For example:
-** - An alternative back end could generate the same EDT
+** - An alternative back end could generate the same tree
** structure in a different way, such as via program
** transformation.
** - An alternative front end could graphically display the
-** generated EDTs as part of a visualization tool rather
+** generated trees as part of a visualization tool rather
** than analyzing them for bugs.
*/
@@ -41,9 +41,11 @@
#include "mercury_deep_copy.h"
#include "mercury_string.h"
#include "declarative_debugger.h"
+#include "declarative_execution.h"
#include "std_util.h"
-#include <stdio.h>
+#include <errno.h>
+
/*
** We only build the execution tree to a certain depth. The following
** macro gives the default depth limit (relative to the starting depth).
@@ -54,8 +56,8 @@
/*
** The declarative debugger back end is controlled by the
** settings of the following variables. They are set in
-** MR_trace_start_wrong_answer when the back end is started. They
-** are used by MR_trace_decl_wrong_answer to decide what action to
+** MR_trace_start_decl_debug when the back end is started. They
+** are used by MR_trace_decl_debug to decide what action to
** take for a particular trace event. Events that are outside
** the given depth range are ignored. Events that are beyond the
** given last event cause the internal debugger to be switched
@@ -66,59 +68,112 @@
static Unsigned MR_edt_max_depth;
static Unsigned MR_edt_last_event;
+/*
+** This is used as the abstract map from node identifiers to nodes
+** in the data structure passed to the front end. It should be
+** incremented each time the data structure is destructively
+** updated, before being passed to Mercury code again.
+*/
+
+static Unsigned MR_trace_node_store;
+
+/*
+** The front end state is stored here in between calls to it.
+*/
+
+static Word MR_trace_front_end_state = (Word) NULL;
+
+/*
+** MR_trace_current_node always contains the last node allocated,
+** or NULL if the collection has just started.
+*/
+
+static MR_Trace_Node MR_trace_current_node;
+
/*
-** MR_edt_parent points to the the parent edt_node of a procedure
-** that is being called. When a CALL event occurs, this value is
-** saved in a dedicated stackvar (or framevar). It is then set to
-** point to the new edt_node for that procedure, ready to be used
-** by CALL events at the next depth down.
+** When in test mode, MR_trace_store_file points to an open file to
+** which the store should be written when built.
*/
+
+static FILE *MR_trace_store_file;
+
+static void
+MR_trace_decl_call(MR_Event_Info *event_info);
+
+static void
+MR_trace_decl_exit(MR_Event_Info *event_info);
+
+static void
+MR_trace_decl_redo(MR_Event_Info *event_info);
+
+static void
+MR_trace_decl_fail(MR_Event_Info *event_info);
-static MR_Edt_Node *MR_edt_parent;
+static void
+MR_trace_decl_switch(MR_Event_Info *event_info);
-static void
-MR_trace_decl_wrong_answer_call(MR_Trace_Cmd_Info *cmd,
- MR_Event_Info *event_info, int decl_slot);
+static void
+MR_trace_decl_disj(MR_Event_Info *event_info);
-static void
-MR_trace_decl_wrong_answer_exit(MR_Trace_Cmd_Info *cmd,
- MR_Event_Info *event_info, int decl_slot);
+static void
+MR_trace_decl_cond(MR_Event_Info *event_info);
-static void
-MR_trace_decl_wrong_answer_redo(MR_Trace_Cmd_Info *cmd,
- MR_Event_Info *event_info, int decl_slot);
+static void
+MR_trace_decl_then_else(MR_Event_Info *event_info);
-static void
-MR_trace_decl_wrong_answer_fail(MR_Trace_Cmd_Info *cmd,
- MR_Event_Info *event_info, int decl_slot);
+static void
+MR_trace_decl_enter_neg(MR_Event_Info *event_info);
-static void
-MR_trace_decl_update_path(MR_Event_Info *event_info, int decl_slot);
+static void
+MR_trace_decl_leave_neg(MR_Event_Info *event_info);
-static void
-MR_trace_decl_save_args(const MR_Stack_Layout_Label *layout, Word *saved_regs,
- MR_Edt_Node *edt_node);
+static MR_Trace_Node
+MR_trace_decl_get_slot(const MR_Stack_Layout_Entry *entry, Word *saved_regs);
static void
-MR_analyse_edt(MR_Edt_Node *root);
+MR_trace_decl_set_slot(const MR_Stack_Layout_Entry *entry, Word *saved_regs,
+ MR_Trace_Node node);
+
+static bool
+MR_trace_matching_cond(const char *path, MR_Trace_Node node);
+
+static bool
+MR_trace_matching_neg(const char *path, MR_Trace_Node node);
+
+static bool
+MR_trace_matching_disj(const char *path, MR_Trace_Node node);
+
+static bool
+MR_trace_same_construct(const char *p1, const char *p2);
+
+static bool
+MR_trace_single_component(const char *path);
-static MR_Edt_Node *
-MR_edt_node_construct(const MR_Stack_Layout_Label *layout,
- MR_Edt_Node_Type node_tag, int start_event);
+static Word
+MR_decl_make_atom(const MR_Stack_Layout_Label *layout, Word *saved_regs);
static ConstString
-MR_edt_root_node_name(const MR_Stack_Layout_Entry *entry);
+MR_decl_atom_name(const MR_Stack_Layout_Entry *entry);
static Word
-MR_edt_root_node_args(const MR_Edt_Node *edt);
+MR_decl_atom_args(const MR_Stack_Layout_Label *layout, Word *saved_regs);
+
+static void
+MR_decl_diagnosis(MR_Trace_Node root);
+
+static void
+MR_decl_diagnosis_test(MR_Trace_Node root);
+
+static String
+MR_trace_node_path(MR_Trace_Node node);
+static MR_Trace_Node
+MR_trace_scan_backwards(MR_Trace_Node node);
+
Code *
-MR_trace_decl_wrong_answer(MR_Trace_Cmd_Info *cmd,
- MR_Event_Info *event_info)
+MR_trace_decl_debug(MR_Trace_Cmd_Info *cmd, MR_Event_Info *event_info)
{
- int decl_slot;
MR_Stack_Layout_Entry *entry;
- MR_Edt_Node *edt_node;
Unsigned depth;
entry = event_info->MR_event_sll->MR_sll_entry;
@@ -127,6 +182,9 @@
if (event_info->MR_event_number > MR_edt_last_event) {
/* This shouldn't ever be reached. */
fprintf(MR_mdb_err, "Warning: missed final event.\n");
+ fprintf(MR_mdb_err, "event %d\nlast event %d\n",
+ event_info->MR_event_number,
+ MR_edt_last_event);
MR_trace_decl_mode = MR_TRACE_INTERACTIVE;
return MR_trace_event_internal(cmd, TRUE, event_info);
}
@@ -153,41 +211,70 @@
}
MR_trace_enabled = FALSE;
- decl_slot = entry->MR_sle_maybe_decl_debug;
switch (event_info->MR_trace_port) {
case MR_PORT_CALL:
- MR_trace_decl_wrong_answer_call(cmd, event_info,
- decl_slot);
+ MR_trace_decl_call(event_info);
break;
case MR_PORT_EXIT:
- MR_trace_decl_wrong_answer_exit(cmd, event_info,
- decl_slot);
+ MR_trace_decl_exit(event_info);
break;
case MR_PORT_REDO:
- MR_trace_decl_wrong_answer_redo(cmd, event_info,
- decl_slot);
+ MR_trace_decl_redo(event_info);
break;
case MR_PORT_FAIL:
- MR_trace_decl_wrong_answer_fail(cmd, event_info,
- decl_slot);
+ MR_trace_decl_fail(event_info);
break;
- case MR_PORT_THEN:
- case MR_PORT_ELSE:
case MR_PORT_DISJ:
+ MR_trace_decl_disj(event_info);
+ break;
case MR_PORT_SWITCH:
- MR_trace_decl_update_path(event_info, decl_slot);
+ MR_trace_decl_switch(event_info);
+ break;
+ case MR_PORT_COND:
+ MR_trace_decl_cond(event_info);
+ break;
+ case MR_PORT_THEN:
+ case MR_PORT_ELSE:
+ MR_trace_decl_then_else(event_info);
+ break;
+ case MR_PORT_NEG_ENTER:
+ MR_trace_decl_enter_neg(event_info);
+ break;
+ case MR_PORT_NEG_SUCCESS:
+ case MR_PORT_NEG_FAILURE:
+ MR_trace_decl_leave_neg(event_info);
+ break;
case MR_PORT_PRAGMA_FIRST:
case MR_PORT_PRAGMA_LATER:
break;
+ case MR_PORT_EXCEPTION:
+ fatal_error("MR_trace_decl_debug: "
+ "exceptions are not handled (yet)");
default:
- fatal_error("Unknown port type");
+ fatal_error("MR_trace_decl_debug: unknown port");
}
if (MR_trace_event_number == MR_edt_last_event) {
- /* Call the front end */
- MR_analyse_edt(MR_edt_parent->MR_edt_node_children);
+ switch (MR_trace_decl_mode) {
+ case MR_TRACE_DECL_DEBUG:
+ /* Call the front end */
+ MR_decl_diagnosis(MR_trace_current_node);
+ break;
+
+ case MR_TRACE_DECL_DEBUG_TEST:
+ MR_decl_diagnosis_test(MR_trace_current_node);
+ break;
+
+ default:
+ fatal_error("MR_trace_decl_debug: "
+ "unexpected mode");
+ }
+ /*
+ ** XXX we should return to the CALL event of the buggy
+ ** node, if one was found.
+ */
MR_trace_decl_mode = MR_TRACE_INTERACTIVE;
return MR_trace_event_internal(cmd, TRUE, event_info);
}
@@ -197,195 +284,465 @@
return NULL;
}
-static void
-MR_trace_decl_wrong_answer_call(MR_Trace_Cmd_Info *cmd,
- MR_Event_Info *event_info, int decl_slot)
+static void
+MR_trace_decl_call(MR_Event_Info *event_info)
{
- MR_Edt_Node *edt_node;
- MR_Edt_Node_Type node_tag;
- MR_Stack_Layout_Entry *entry;
- Word *saved_regs;
+ MR_Trace_Node node;
+ Word atom;
+ const MR_Stack_Layout_Label *layout = event_info->MR_event_sll;
+
+ atom = MR_decl_make_atom(layout, event_info->MR_saved_regs);
+ MR_TRACE_CALL_MERCURY(
+ node = (MR_Trace_Node) MR_DD_construct_call_node(
+ (Word) MR_trace_current_node, atom);
+ );
+ MR_trace_decl_set_slot(layout->MR_sll_entry,
+ event_info->MR_saved_regs, node);
+
+ MR_trace_current_node = node;
+}
- entry = event_info->MR_event_sll->MR_sll_entry;
- saved_regs = event_info->MR_saved_regs;
+static void
+MR_trace_decl_exit(MR_Event_Info *event_info)
+{
+ MR_Trace_Node node;
+ MR_Trace_Node call;
+ Word atom;
+
+ atom = MR_decl_make_atom(event_info->MR_event_sll,
+ event_info->MR_saved_regs);
+ call = MR_trace_decl_get_slot(event_info->MR_event_sll->MR_sll_entry,
+ event_info->MR_saved_regs);
+ MR_TRACE_CALL_MERCURY(
+ node = (MR_Trace_Node) MR_DD_construct_exit_node(
+ (Word) MR_trace_current_node,
+ (Word) call,
+ MR_trace_call_node_answer(call),
+ atom);
+ );
+ MR_trace_call_node_answer(call) = (Word) node;
+
+ MR_trace_current_node = node;
+}
+
+static void
+MR_trace_decl_redo(MR_Event_Info *event_info)
+{
+ MR_Trace_Node node;
+ MR_Trace_Node call;
+
+ call = MR_trace_decl_get_slot(event_info->MR_event_sll->MR_sll_entry,
+ event_info->MR_saved_regs);
+ MR_TRACE_CALL_MERCURY(
+ node = (MR_Trace_Node) MR_DD_construct_redo_node(
+ (Word) MR_trace_current_node,
+ MR_trace_call_node_answer(call));
+ );
+ MR_trace_call_node_answer(call) = (Word) node;
+
+ MR_trace_current_node = node;
+}
+
+static void
+MR_trace_decl_fail(MR_Event_Info *event_info)
+{
+ MR_Trace_Node node;
+ MR_Trace_Node call;
+
+ call = MR_trace_decl_get_slot(event_info->MR_event_sll->MR_sll_entry,
+ event_info->MR_saved_regs);
+ MR_TRACE_CALL_MERCURY(
+ node = (MR_Trace_Node) MR_DD_construct_fail_node(
+ (Word) MR_trace_current_node,
+ (Word) call);
+ );
+
+ MR_trace_current_node = node;
+}
+
+static void
+MR_trace_decl_cond(MR_Event_Info *event_info)
+{
+ MR_Trace_Node node;
+
+ MR_TRACE_CALL_MERCURY(
+ node = (MR_Trace_Node) MR_DD_construct_cond_node(
+ (Word) MR_trace_current_node,
+ (String) event_info->MR_event_path);
+ );
+ MR_trace_current_node = node;
+}
+
+static void
+MR_trace_decl_then_else(MR_Event_Info *event_info)
+{
+ MR_Trace_Node node;
+ MR_Trace_Node prev;
+
+ prev = MR_trace_current_node;
+
+ /*
+ ** Search through previous nodes for a matching COND event.
+ */
+ while (prev != (MR_Trace_Node) NULL)
+ {
+ if (MR_trace_matching_cond(event_info->MR_event_path, prev))
+ {
+ break;
+ }
+ prev = MR_trace_scan_backwards(prev);
+ }
+ if (prev == (MR_Trace_Node) NULL) {
+ fatal_error("MR_trace_decl_then_else: no matching COND");
+ }
+
+ switch (event_info->MR_trace_port) {
+ case MR_PORT_THEN:
+ MR_trace_cond_node_status(prev) =
+ MR_TRACE_STATUS_SUCCEEDED;
+ MR_TRACE_CALL_MERCURY(
+ node = (MR_Trace_Node)
+ MR_DD_construct_then_node(
+ (Word) MR_trace_current_node,
+ (Word) prev);
+ );
+ break;
+ case MR_PORT_ELSE:
+ MR_trace_cond_node_status(prev) =
+ MR_TRACE_STATUS_FAILED;
+ MR_TRACE_CALL_MERCURY(
+ node = (MR_Trace_Node)
+ MR_DD_construct_else_node(
+ (Word) MR_trace_current_node,
+ (Word) prev);
+ );
+ break;
+ default:
+ fatal_error("MR_trace_decl_then_else: invalid node");
+ break;
+ }
+
+ MR_trace_current_node = node;
+}
+
+static void
+MR_trace_decl_enter_neg(MR_Event_Info *event_info)
+{
+ MR_Trace_Node node;
+
+ MR_TRACE_CALL_MERCURY(
+ node = (MR_Trace_Node) MR_DD_construct_neg_node(
+ (Word) MR_trace_current_node,
+ (String) event_info->MR_event_path);
+ );
+ MR_trace_current_node = node;
+}
+
+static void
+MR_trace_decl_leave_neg(MR_Event_Info *event_info)
+{
+ MR_Trace_Node node;
+ MR_Trace_Node prev;
- if (event_info->MR_call_depth < MR_edt_max_depth) {
- node_tag = MR_EDT_WRONG_ANSWER_EXPLICIT;
+ prev = MR_trace_current_node;
+
+ /*
+ ** Search through previous nodes for a matching NEGE event.
+ */
+ while (prev != (MR_Trace_Node) NULL)
+ {
+ if (MR_trace_matching_neg(event_info->MR_event_path, prev))
+ {
+ break;
+ }
+ prev = MR_trace_scan_backwards(prev);
+ }
+ if (prev == (MR_Trace_Node) NULL) {
+ fatal_error("MR_trace_decl_leave_neg: no matching NEGE");
+ }
+
+ switch (event_info->MR_trace_port) {
+ case MR_PORT_NEG_SUCCESS:
+ MR_trace_neg_node_status(prev) =
+ MR_TRACE_STATUS_SUCCEEDED;
+ MR_TRACE_CALL_MERCURY(
+ node = (MR_Trace_Node)
+ MR_DD_construct_neg_succ_node(
+ (Word) MR_trace_current_node,
+ (Word) prev);
+ );
+ break;
+ case MR_PORT_NEG_FAILURE:
+ MR_trace_neg_node_status(prev) =
+ MR_TRACE_STATUS_FAILED;
+ MR_TRACE_CALL_MERCURY(
+ node = (MR_Trace_Node)
+ MR_DD_construct_neg_fail_node(
+ (Word) MR_trace_current_node,
+ (Word) prev);
+ );
+ break;
+ default:
+ fatal_error("MR_trace_decl_leave_neg: invalid node");
+ break;
+ }
+
+ MR_trace_current_node = node;
+}
+
+static void
+MR_trace_decl_switch(MR_Event_Info *event_info)
+{
+ MR_Trace_Node node;
+
+ MR_TRACE_CALL_MERCURY(
+ node = (MR_Trace_Node) MR_DD_construct_first_disj_node(
+ (Word) MR_trace_current_node,
+ (String) event_info->MR_event_path,
+ (Word) TRUE);
+ );
+ MR_trace_current_node = node;
+}
+
+static void
+MR_trace_decl_disj(MR_Event_Info *event_info)
+{
+ MR_Trace_Node node;
+ MR_Trace_Node prev;
+ MR_Trace_Node back;
+
+ prev = MR_trace_current_node;
+
+ /*
+ ** Search through previous nodes for a matching DISJ event.
+ */
+ while (prev != (MR_Trace_Node) NULL)
+ {
+ if (MR_trace_matching_disj(event_info->MR_event_path, prev))
+ {
+ break;
+ }
+ prev = MR_trace_scan_backwards(prev);
+ }
+
+ if (prev == (MR_Trace_Node) NULL) {
+ /*
+ ** This is a first_disj.
+ */
+ MR_TRACE_CALL_MERCURY(
+ node = (MR_Trace_Node) MR_DD_construct_first_disj_node(
+ (Word) MR_trace_current_node,
+ (String) event_info->MR_event_path,
+ (Word) FALSE);
+ );
} else {
/*
- ** At this point depth == MR_edt_max_depth.
+ ** This is a later_disj.
*/
-
- node_tag = MR_EDT_WRONG_ANSWER_IMPLICIT;
+ back = MR_trace_scan_backwards(prev);
+ MR_TRACE_CALL_MERCURY(
+ node = (MR_Trace_Node) MR_DD_construct_later_disj_node(
+ (Word) MR_trace_current_node,
+ (Word) back,
+ (String) event_info->MR_event_path);
+ );
}
- edt_node = MR_edt_node_construct(event_info->MR_event_sll, node_tag,
- event_info->MR_event_number);
+ MR_trace_current_node = node;
+}
+static MR_Trace_Node
+MR_trace_decl_get_slot(const MR_Stack_Layout_Entry *entry, Word *saved_regs)
+{
+ int decl_slot;
+ Word *saved_sp;
+ Word *saved_curfr;
+ MR_Trace_Node node;
+
+ decl_slot = entry->MR_sle_maybe_decl_debug;
+
if (MR_DETISM_DET_STACK(entry->MR_sle_detism)) {
- MR_based_stackvar(MR_saved_sp(saved_regs), decl_slot) =
- (Word) edt_node;
- MR_based_stackvar(MR_saved_sp(saved_regs), decl_slot + 1) =
- (Word) MR_edt_parent;
+ saved_sp = (Word *) MR_saved_sp(saved_regs);
+ node = (MR_Trace_Node) MR_based_stackvar(saved_sp, decl_slot);
} else {
- MR_based_framevar(MR_saved_curfr(saved_regs), decl_slot) =
- (Word) edt_node;
- MR_based_framevar(MR_saved_curfr(saved_regs), decl_slot + 1) =
- (Word) MR_edt_parent;
+ saved_curfr = (Word *) MR_saved_curfr(saved_regs);
+ node = (MR_Trace_Node) MR_based_framevar(saved_curfr,
+ decl_slot);
}
- /*
- ** The children of edt_node will refer to the
- ** global variable MR_edt_parent to locate their
- ** parent.
- */
- MR_edt_parent = edt_node;
+
+ return node;
}
-static void
-MR_trace_decl_wrong_answer_exit(MR_Trace_Cmd_Info *cmd,
- MR_Event_Info *event_info, int decl_slot)
+static void
+MR_trace_decl_set_slot(const MR_Stack_Layout_Entry *entry,
+ Word *saved_regs, MR_Trace_Node node)
{
- MR_Edt_Node *edt_node;
- const MR_Stack_Layout_Label *layout;
- Word *saved_regs;
+ int decl_slot;
+ Word *saved_sp;
+ Word *saved_curfr;
- layout = event_info->MR_event_sll;
- saved_regs = event_info->MR_saved_regs;
-
- if (MR_DETISM_DET_STACK(layout->MR_sll_entry->MR_sle_detism)) {
- edt_node = (MR_Edt_Node *) MR_based_stackvar(
- MR_saved_sp(saved_regs), decl_slot);
- MR_edt_parent = (MR_Edt_Node *) MR_based_stackvar(
- MR_saved_sp(saved_regs), decl_slot + 1);
+ decl_slot = entry->MR_sle_maybe_decl_debug;
+
+ if (MR_DETISM_DET_STACK(entry->MR_sle_detism)) {
+ saved_sp = (Word *) MR_saved_sp(saved_regs);
+ MR_based_stackvar(saved_sp, decl_slot) = (Word) node;
} else {
- edt_node = (MR_Edt_Node *) MR_based_framevar(
- MR_saved_curfr(saved_regs), decl_slot);
- MR_edt_parent = (MR_Edt_Node *) MR_based_framevar(
- MR_saved_curfr(saved_regs), decl_slot + 1);
+ saved_curfr = (Word *) MR_saved_curfr(saved_regs);
+ MR_based_framevar(saved_curfr, decl_slot) = (Word) node;
}
+}
- edt_node->MR_edt_node_layout = layout;
- edt_node->MR_edt_node_end_event = event_info->MR_event_number;
- edt_node->MR_edt_node_seqno = event_info->MR_call_seqno;
+static bool
+MR_trace_matching_cond(const char *path, MR_Trace_Node node)
+{
+ MR_Trace_Port port;
+ const char *node_path;
- MR_trace_decl_save_args(layout, saved_regs, edt_node);
+ MR_TRACE_CALL_MERCURY(
+ port = (MR_Trace_Port) MR_DD_trace_node_port(node);
+ );
+ if (port != MR_PORT_COND)
+ {
+ return FALSE;
+ }
+ node_path = MR_trace_node_path(node);
- /*
- ** Attach this node to the child list of its parent.
- */
- edt_node->MR_edt_node_sibling = MR_edt_parent->MR_edt_node_children;
- MR_edt_parent->MR_edt_node_children = edt_node;
+ return MR_trace_same_construct(path, node_path);
}
-static void
-MR_trace_decl_wrong_answer_redo(MR_Trace_Cmd_Info *cmd,
- MR_Event_Info *event_info, int decl_slot)
+static bool
+MR_trace_matching_neg(const char *path, MR_Trace_Node node)
{
- MR_Edt_Node *edt_node;
- MR_Stack_Layout_Entry *entry;
- Word *saved_regs;
-
- entry = event_info->MR_event_sll->MR_sll_entry;
- saved_regs = event_info->MR_saved_regs;
+ MR_Trace_Port port;
+ const char *node_path;
- /*
- ** Re-use the node that was allocated at the CALL event.
- */
- if (MR_DETISM_DET_STACK(entry->MR_sle_detism)) {
- edt_node = (MR_Edt_Node *) MR_based_stackvar(
- MR_saved_sp(saved_regs), decl_slot);
- MR_edt_parent = (MR_Edt_Node *) MR_based_stackvar(
- MR_saved_sp(saved_regs), decl_slot + 1);
+ MR_TRACE_CALL_MERCURY(
+ port = (MR_Trace_Port) MR_DD_trace_node_port(node);
+ );
+ if (port != MR_PORT_NEG_ENTER) {
+ return FALSE;
+ }
+ node_path = MR_trace_node_path(node);
+
+ return MR_trace_same_construct(path, node_path);
+}
+
+static bool
+MR_trace_matching_disj(const char *path, MR_Trace_Node node)
+{
+ MR_Trace_Port port;
+ const char *node_path;
+
+ MR_TRACE_CALL_MERCURY(
+ port = (MR_Trace_Port) MR_DD_trace_node_port(node);
+ );
+ if (port == MR_PORT_DISJ || port == MR_PORT_SWITCH) {
+ node_path = MR_trace_node_path(node);
+ return MR_trace_same_construct(path, node_path);
} else {
- edt_node = (MR_Edt_Node *) MR_based_framevar(
- MR_saved_curfr(saved_regs), decl_slot);
- MR_edt_parent = (MR_Edt_Node *) MR_based_framevar(
- MR_saved_curfr(saved_regs), decl_slot + 1);
+ return FALSE;
}
+}
+static bool
+MR_trace_same_construct(const char *p1, const char *p2)
+{
/*
- ** Remove the nodes that we have bactracked over. Since we have
- ** a REDO event for this goal, we must have had an EXIT event
- ** earlier, therefore the current node is known to be attached
- ** to the current parent.
- **
- ** XXX need to deallocate properly.
+ ** Checks if the two arguments represent goals in the same
+ ** construct. If both strings are identical up to the last
+ ** component, return TRUE, otherwise return FALSE.
+ ** If the arguments point to identical strings, return TRUE.
*/
- if (MR_edt_parent != NULL ) {
- MR_edt_parent->MR_edt_node_children =
- edt_node->MR_edt_node_sibling;
+ while (*p1 == *p2) {
+ if (*p1 == '\0' && *p2 == '\0') {
+ return TRUE; /* They are identical. */
+ }
+ if (*p1 == '\0' || *p2 == '\0') {
+ return FALSE; /* Different number of elements. */
+ }
+
+ p1++;
+ p2++;
}
- MR_edt_parent = edt_node;
+ /*
+ ** If there is exactly one component left in each string, then
+ ** the goal paths match, otherwise they don't.
+ */
+ return MR_trace_single_component(p1) && MR_trace_single_component(p2);
}
-static void
-MR_trace_decl_wrong_answer_fail(MR_Trace_Cmd_Info *cmd,
- MR_Event_Info *event_info, int decl_slot)
+static bool
+MR_trace_single_component(const char *path)
{
- MR_Edt_Node *edt_node;
- MR_Stack_Layout_Entry *entry;
- Word *saved_regs;
-
- entry = event_info->MR_event_sll->MR_sll_entry;
- saved_regs = event_info->MR_saved_regs;
-
- if (MR_DETISM_DET_STACK(entry->MR_sle_detism)) {
- edt_node = (MR_Edt_Node *) MR_based_stackvar(
- MR_saved_sp(saved_regs), decl_slot);
- MR_edt_parent = (MR_Edt_Node *) MR_based_stackvar(
- MR_saved_sp(saved_regs), decl_slot + 1);
- } else {
- edt_node = (MR_Edt_Node *) MR_based_framevar(
- MR_saved_curfr(saved_regs), decl_slot);
- MR_edt_parent = (MR_Edt_Node *) MR_based_framevar(
- MR_saved_curfr(saved_regs), decl_slot + 1);
+ while (*path != ';') {
+ if (*path == '\0') {
+ return FALSE;
+ }
+ path++;
}
- MR_free(edt_node);
+ path++;
+ return (*path == '\0');
}
-/*
-** MR_trace_decl_update_path adds to the record of the execution path
-** taken for the current EDT parent node.
-**
-** XXX It currently doesn't do anything useful. When implemented properly
-** it will add a new type of node to the current parent to indicate the
-** path taken.
-*/
-static void
-MR_trace_decl_update_path(MR_Event_Info *event_info, int decl_slot)
+static Word
+MR_decl_make_atom(const MR_Stack_Layout_Label *layout, Word *saved_regs)
+{
+ ConstString name;
+ Word args;
+ Word atom;
+
+ name = MR_decl_atom_name(layout->MR_sll_entry);
+ args = MR_decl_atom_args(layout, saved_regs);
+
+ MR_TRACE_USE_HP(
+ MR_trace_atom(atom, name, args);
+ );
+
+ return atom;
+}
+
+static ConstString
+MR_decl_atom_name(const MR_Stack_Layout_Entry *entry)
{
- MR_Edt_Node *edt_node;
- const MR_Stack_Layout_Label *layout;
- Word *saved_regs;
-
- layout = event_info->MR_event_sll;
- saved_regs = event_info->MR_saved_regs;
-
- if (MR_DETISM_DET_STACK(layout->MR_sll_entry->MR_sle_detism)) {
- edt_node = (MR_Edt_Node *) MR_based_stackvar(
- MR_saved_sp(saved_regs), decl_slot);
+ ConstString name;
+
+ if (MR_ENTRY_LAYOUT_HAS_PROC_ID(entry)) {
+ if (MR_ENTRY_LAYOUT_COMPILER_GENERATED(entry)) {
+ MR_TRACE_USE_HP(
+ make_aligned_string(name, "<<internal>>");
+ );
+ } else {
+ name = entry->MR_sle_proc_id.MR_proc_user.MR_user_name;
+ }
} else {
- edt_node = (MR_Edt_Node *) MR_based_framevar(
- MR_saved_curfr(saved_regs), decl_slot);
+ MR_TRACE_USE_HP(
+ make_aligned_string(name, "<<unknown>>");
+ );
}
- edt_node->MR_edt_node_path = event_info->MR_event_path;
+
+ return name;
}
-static void
-MR_trace_decl_save_args(const MR_Stack_Layout_Label *layout, Word *saved_regs,
- MR_Edt_Node *edt_node)
+static Word
+MR_decl_atom_args(const MR_Stack_Layout_Label *layout, Word *saved_regs)
{
- Word *arg_values;
- Word *arg_types;
- int arg_count;
+ int i;
+ Word arglist;
+ Word tail;
+ Word head;
const MR_Stack_Layout_Vars *vars;
+ int arg_count;
Word *base_sp;
Word *base_curfr;
Word *type_params;
- Word typeinfo_type;
- int i;
+ Word arg_type;
+ Word arg_value;
+ MR_TRACE_USE_HP(
+ arglist = MR_list_empty();
+ );
+
vars = &layout->MR_sll_var_info;
if (!MR_has_valid_var_count(vars)) {
fprintf(MR_mdb_err, "mdb: no info about live variables.\n");
@@ -393,55 +750,46 @@
if (!MR_has_valid_var_info(vars)) {
/* there are no live variables */
- edt_node->MR_edt_node_arg_values = NULL;
- edt_node->MR_edt_node_arg_types = NULL;
- return;
+
+ return arglist;
}
arg_count = MR_all_desc_var_count(vars);
- arg_values = MR_NEW_ARRAY(Word, arg_count);
- arg_types = MR_NEW_ARRAY(Word, arg_count);
-
base_sp = MR_saved_sp(saved_regs);
base_curfr = MR_saved_curfr(saved_regs);
type_params = MR_materialize_typeinfos_base(vars, saved_regs,
base_sp, base_curfr);
-
- MR_TRACE_CALL_MERCURY(
- ML_get_type_info_for_type_info(&typeinfo_type);
- );
- for (i = 0; i < arg_count; i++) {
- Word arg_type;
-
- MR_get_type_and_value_base(vars, i, saved_regs, base_sp,
- base_curfr, type_params, &arg_type,
- &arg_values[i]);
-
- arg_types[i] = MR_make_permanent(arg_type,
- (Word *) typeinfo_type);
+ MR_TRACE_USE_HP(
+ for (i = arg_count - 1; i >= 0; i--) {
+ MR_get_type_and_value_base(vars, i, saved_regs,
+ base_sp, base_curfr, type_params,
+ &arg_type, &arg_value);
-#ifdef MR_DEBUG_DD_BACK_END
- fprintf(MR_mdb_out, "\t");
- fflush(MR_mdb_out);
- MR_trace_print(arg_types[i], arg_values[i]);
-#endif
- }
+ tail = arglist;
+ tag_incr_hp(head, MR_mktag(0), 2);
+ MR_field(MR_mktag(0), head, UNIV_OFFSET_FOR_TYPEINFO) =
+ arg_type;
+ MR_field(MR_mktag(0), head, UNIV_OFFSET_FOR_DATA) =
+ arg_value;
+ arglist = MR_list_cons(head, tail);
+ }
+ );
- edt_node->MR_edt_node_arg_values = arg_values;
- edt_node->MR_edt_node_arg_types = arg_types;
+ return arglist;
}
bool
-MR_trace_start_wrong_answer(MR_Trace_Cmd_Info *cmd, MR_Event_Info *event_info,
- MR_Event_Details *event_details, Code **jumpaddr)
+MR_trace_start_decl_debug(const char *outfile, MR_Trace_Cmd_Info *cmd,
+ MR_Event_Info *event_info, MR_Event_Details *event_details,
+ Code **jumpaddr)
{
MR_Stack_Layout_Entry *entry;
int decl_slot;
const char *message;
+ FILE *out;
entry = event_info->MR_event_sll->MR_sll_entry;
-
if (!MR_ENTRY_LAYOUT_HAS_EXEC_TRACE(entry)) {
return FALSE;
}
@@ -452,19 +800,41 @@
return FALSE;
}
- MR_trace_decl_mode = MR_TRACE_WRONG_ANSWER;
- MR_edt_parent = MR_edt_node_construct(NULL,
- MR_EDT_WRONG_ANSWER_EXPLICIT, 0);
- MR_edt_last_event = MR_trace_event_number;
- MR_edt_min_depth = event_info->MR_call_depth;
- MR_edt_max_depth = event_info->MR_call_depth + MR_EDT_DEPTH_STEP_SIZE;
-
message = MR_trace_retry(event_info, event_details, jumpaddr);
-
if (message != NULL) {
return FALSE;
}
+ if (outfile == (const char *) NULL) {
+ /* Normal debugging mode */
+ MR_trace_decl_mode = MR_TRACE_DECL_DEBUG;
+ } else {
+ /* Test mode */
+ out = fopen(outfile, "w");
+ if (out == NULL) {
+ fflush(MR_mdb_out);
+ fprintf(MR_mdb_err, "mdb: cannot open file `%s' "
+ "for output: %s.\n",
+ outfile, strerror(errno));
+ return FALSE;
+ } else {
+ MR_trace_decl_mode = MR_TRACE_DECL_DEBUG_TEST;
+ MR_trace_store_file = out;
+ }
+ }
+
+ MR_edt_last_event = event_info->MR_event_number;
+ MR_edt_min_depth = event_info->MR_call_depth;
+ MR_edt_max_depth = event_info->MR_call_depth + MR_EDT_DEPTH_STEP_SIZE;
+ MR_trace_node_store = 0;
+ MR_trace_current_node = (MR_Trace_Node) NULL;
+
+ if (MR_trace_front_end_state == (Word) NULL) {
+ MR_TRACE_CALL_MERCURY(
+ MR_DD_diagnoser_state_init(&MR_trace_front_end_state);
+ );
+ }
+
cmd->MR_trace_cmd = MR_CMD_GOTO;
cmd->MR_trace_stop_event = MR_trace_event_number + 1;
cmd->MR_trace_strict = FALSE;
@@ -473,27 +843,11 @@
return TRUE;
}
-static MR_Edt_Node *
-MR_edt_node_construct(const MR_Stack_Layout_Label *layout,
- MR_Edt_Node_Type node_tag, int start_event)
-{
- MR_Edt_Node *edt_node;
-
- edt_node = MR_NEW(MR_Edt_Node);
- edt_node->MR_edt_node_tag = node_tag;
- edt_node->MR_edt_node_layout = layout;
- edt_node->MR_edt_node_path = NULL;
- edt_node->MR_edt_node_start_event = start_event;
- edt_node->MR_edt_node_children = NULL;
- edt_node->MR_edt_node_sibling = NULL;
-
- return edt_node;
-}
-
-static void
-MR_analyse_edt(MR_Edt_Node *root)
+static void
+MR_decl_diagnosis(MR_Trace_Node root)
{
- MercuryFile mdb_in, mdb_out;
+ MercuryFile mdb_in, mdb_out;
+ Word response;
mdb_in.file = MR_mdb_in;
mdb_in.line_number = 1;
@@ -501,94 +855,52 @@
mdb_out.line_number = 1;
MR_TRACE_CALL_MERCURY(
- ML_DD_analyse_edt((Word) root,
- (Word) &mdb_in,
- (Word) &mdb_out
+ MR_DD_decl_diagnosis((Word) &mdb_in, (Word) &mdb_out,
+ MR_trace_node_store, root, &response,
+ MR_trace_front_end_state,
+ &MR_trace_front_end_state
);
);
}
-extern void
-MR_edt_root_node(Word EDT, Word *Node)
+static void
+MR_decl_diagnosis_test(MR_Trace_Node root)
{
- MR_Edt_Node *edt;
- MR_Stack_Layout_Entry *entry;
- ConstString name;
- Word args;
-
- edt = (MR_Edt_Node *) EDT;
- entry = edt->MR_edt_node_layout->MR_sll_entry;
-
- switch (edt->MR_edt_node_tag) {
- case MR_EDT_WRONG_ANSWER_EXPLICIT:
- case MR_EDT_WRONG_ANSWER_IMPLICIT:
- name = MR_edt_root_node_name(entry);
- args = MR_edt_root_node_args(edt);
- MR_TRACE_USE_HP(
- incr_hp(*Node, 2);
- );
- MR_field(MR_mktag(0), *Node, 0) = (Word) name;
- MR_field(MR_mktag(0), *Node, 1) = args;
- break;
- default:
- fatal_error("MR_edt_root_node: unknown tag");
- }
-}
+ MercuryFile stream;
-static ConstString
-MR_edt_root_node_name(const MR_Stack_Layout_Entry *entry)
-{
- ConstString name;
+ stream.file = MR_trace_store_file;
+ stream.line_number = 1;
- if (MR_ENTRY_LAYOUT_HAS_PROC_ID(entry)) {
- if (MR_ENTRY_LAYOUT_COMPILER_GENERATED(entry)) {
- MR_TRACE_USE_HP(
- make_aligned_string(name, "(internal)");
- );
- } else {
- name = entry->MR_sle_proc_id.MR_proc_user.MR_user_name;
- }
- } else {
- MR_TRACE_USE_HP(
- make_aligned_string(name, "(unknown)");
- );
- }
+ MR_TRACE_CALL_MERCURY(
+ MR_DD_save_trace((Word) &stream, MR_trace_node_store, root);
+ );
- return name;
+ fclose(MR_trace_store_file);
}
-static Word
-MR_edt_root_node_args(const MR_Edt_Node *edt)
+static String
+MR_trace_node_path(MR_Trace_Node node)
{
- int i;
- int argc;
- Word arglist;
- Word tail;
- Word head;
- const MR_Stack_Layout_Vars *vars;
+ String path;
- vars = &edt->MR_edt_node_layout->MR_sll_var_info;
+ MR_trace_node_store++;
+ MR_TRACE_CALL_MERCURY(
+ path = MR_DD_trace_node_path(MR_trace_node_store, (Word) node);
+ );
+ return path;
+}
- if (MR_has_valid_var_info(vars)) {
- argc = MR_all_desc_var_count(vars);
- } else {
- argc = 0;
- }
+static MR_Trace_Node
+MR_trace_scan_backwards(MR_Trace_Node node)
+{
+ MR_Trace_Node prev;
- MR_TRACE_USE_HP(
- arglist = MR_list_empty();
- for (i = argc - 1; i >= 0; i--) {
- tail = arglist;
- incr_hp(head, 2);
- MR_field(MR_mktag(0), head, UNIV_OFFSET_FOR_TYPEINFO) =
- edt->MR_edt_node_arg_types[i];
- MR_field(MR_mktag(0), head, UNIV_OFFSET_FOR_DATA) =
- edt->MR_edt_node_arg_values[i];
- arglist = MR_list_cons(head, tail);
- }
+ MR_trace_node_store++;
+ MR_TRACE_CALL_MERCURY(
+ prev = (MR_Trace_Node) MR_DD_scan_backwards(
+ MR_trace_node_store, node);
);
-
- return arglist;
+ return prev;
}
-#endif
+#endif /* defined(MR_USE_DECLARATIVE_DEBUGGER) */
Index: trace/mercury_trace_declarative.h
===================================================================
RCS file: /home/mercury1/repository/mercury/trace/mercury_trace_declarative.h,v
retrieving revision 1.4
diff -u -r1.4 mercury_trace_declarative.h
--- mercury_trace_declarative.h 1999/04/30 04:00:22 1.4
+++ mercury_trace_declarative.h 1999/10/26 05:58:29
@@ -7,114 +7,54 @@
#ifndef MERCURY_TRACE_DECLARATIVE_H
#define MERCURY_TRACE_DECLARATIVE_H
-/*
-** This file defines the MR_Edt_Node data type, which stores nodes
-** of an Evaluation Dependency Tree (EDT), used for declarative
-** debugging. This is the underlying implementation of mercury_edt,
-** which is an instance of the evaluation_tree typeclass. These
-** are defined in browser/declarative_debugger.m.
-*/
-
#include "mercury_imp.h"
#include "mercury_trace.h"
/*
-** Each node in an EDT has a tag to denote its type. At the moment
-** the only type of analysis is wrong answer analysis, so the tag
-** is just used to distinguish between implicitly and explicitly
-** represented nodes.
-**
-** Implicit nodes are similar to explicit nodes, but they do not
-** store their children. They do, however, store enough information
-** to allow execution to be resumed at that point, so children can
-** be created by re-executing the events in the stored range and
-** collecting a new EDT. XXX this is not yet implemented, though.
-**
-** In the future there will also be nodes to handle:
-** - missing answer analysis
-** - calls to solutions/2 and related predicates
-** - exceptions
-** and possibly other things as well.
+** When in declarative debugging mode, the internal debugger calls
+** MR_trace_decl_debug for each event.
*/
-typedef enum {
- MR_EDT_WRONG_ANSWER_EXPLICIT,
- MR_EDT_WRONG_ANSWER_IMPLICIT
-} MR_Edt_Node_Type;
+extern Code *MR_trace_decl_debug(MR_Trace_Cmd_Info *cmd,
+ MR_Event_Info *event_info);
/*
-** Wrong answer analysis is currently the only type of analysis available.
-** Consequently, the EDT nodes only contain enough information to support
-** this type of analysis.
+** The internal (interactive) debugger calls this function to enter
+** declarative debugging mode. It returns TRUE if successful, and
+** FALSE if there was some problem that prevented this mode from
+** being entered.
*/
-typedef struct MR_Edt_Node_Struct MR_Edt_Node;
-
-struct MR_Edt_Node_Struct {
- /*
- ** Type of EDT node.
- */
- MR_Edt_Node_Type MR_edt_node_tag;
- /*
- ** The layout of the EXIT port.
- */
- const MR_Stack_Layout_Label *MR_edt_node_layout;
- /*
- ** The arguments.
- */
- Word *MR_edt_node_arg_values;
- Word *MR_edt_node_arg_types;
- /*
- ** This goal path gives the location, in the calling
- ** procedure, of the call that this proof is for.
- */
- const char *MR_edt_node_path;
- /*
- ** The event numbers of the CALL and EXIT events for
- ** this proof.
- */
- Unsigned MR_edt_node_start_event;
- Unsigned MR_edt_node_end_event;
- /*
- ** The sequence number of the CALL and EXIT events.
- */
- Unsigned MR_edt_node_seqno;
- /*
- ** The rightmost child of this node, or NULL if there
- ** are no children.
- */
- MR_Edt_Node *MR_edt_node_children;
- /*
- ** The next sibling to the left of this node, or NULL
- ** if this is the leftmost.
- */
- MR_Edt_Node *MR_edt_node_sibling;
-};
+extern bool MR_trace_start_decl_debug(const char *out,
+ MR_Trace_Cmd_Info *cmd, MR_Event_Info *event_info,
+ MR_Event_Details *event_details, Code **jumpaddr);
/*
-** The following function is part of an interface to the EDT that can be
-** used by a front end written in Mercury (see browser/declarative_debugger.m).
+** The following macros are provided to help C code manipulate the
+** Mercury data structure. The values here must match the corresponding
+** values in the definitions in browser/declarative_execution.m.
*/
-extern void MR_edt_root_node(Word EDT, Word *Node);
+typedef Word MR_Trace_Node;
-/*
-** When in declarative debugging mode, the internal debugger calls
-** MR_trace_decl_wrong_answer for each event.
-*/
+#define MR_trace_call_node_answer(node) \
+ MR_field(MR_mktag(0), (node), (Integer) 1)
-extern Code *MR_trace_decl_wrong_answer(MR_Trace_Cmd_Info *cmd,
- MR_Event_Info *event_info);
+#define MR_trace_cond_node_status(node) \
+ MR_field(MR_mktag(3), (node), (Integer) 3)
-/*
-** The internal (interactive) debugger calls this function to enter
-** declarative debugging mode. It returns TRUE if successful, and
-** FALSE if there was some problem that prevented this mode from
-** being entered.
-*/
+#define MR_trace_neg_node_status(node) \
+ MR_field(MR_mktag(3), (node), (Integer) 3)
-extern bool MR_trace_start_wrong_answer(MR_Trace_Cmd_Info *cmd,
- MR_Event_Info *event_info,
- MR_Event_Details *event_details, Code **jumpaddr);
+#define MR_TRACE_STATUS_SUCCEEDED (Word) 0
+#define MR_TRACE_STATUS_FAILED (Word) 1
+#define MR_TRACE_STATUS_UNDECIDED (Word) 2
+
+#define MR_trace_atom(atom, name, args) \
+ do { \
+ tag_incr_hp((atom), MR_mktag(0), 2); \
+ MR_field(MR_mktag(0), (atom), 0) = (Word) (name); \
+ MR_field(MR_mktag(0), (atom), 1) = (args); \
+ } while(0)
#endif /* MERCURY_TRACE_DECLARATIVE_H */
Index: trace/mercury_trace_internal.c
===================================================================
RCS file: /home/mercury1/repository/mercury/trace/mercury_trace_internal.c,v
retrieving revision 1.56
diff -u -r1.56 mercury_trace_internal.c
--- mercury_trace_internal.c 1999/10/18 15:47:18 1.56
+++ mercury_trace_internal.c 1999/10/26 05:58:48
@@ -193,8 +193,10 @@
}
#ifdef MR_USE_DECLARATIVE_DEBUGGER
- if (MR_trace_decl_mode == MR_TRACE_WRONG_ANSWER) {
- return MR_trace_decl_wrong_answer(cmd, event_info);
+ if (MR_trace_decl_mode == MR_TRACE_DECL_DEBUG
+ || MR_trace_decl_mode == MR_TRACE_DECL_DEBUG_TEST)
+ {
+ return MR_trace_decl_debug(cmd, event_info);
}
#endif MR_USE_DECLARATIVE_DEBUGGER
@@ -1443,23 +1445,57 @@
MR_trace_usage("misc", "quit");
}
#ifdef MR_USE_DECLARATIVE_DEBUGGER
- } else if (streq(words[0], "dd_wrong")) {
+ } else if (streq(words[0], "dd")) {
+ MR_Trace_Port port = event_info->MR_trace_port;
+
if (word_count != 1) {
fflush(MR_mdb_out);
fprintf(MR_mdb_err,
- "mdb: dd_wrong requires no arguments.\n");
- } else if (event_info->MR_trace_port != MR_PORT_EXIT) {
+ "mdb: dd requires no arguments.\n");
+ } else if (port == MR_PORT_EXIT || port == MR_PORT_FAIL) {
+ if (MR_trace_start_decl_debug((const char *) NULL, cmd,
+ event_info, event_details,
+ jumpaddr))
+ {
+ return STOP_INTERACTING;
+ }
+ else
+ {
+ fflush(MR_mdb_out);
+ fprintf(MR_mdb_err, "mdb: unable to start "
+ "declarative debugging.\n");
+ }
+ } else {
fflush(MR_mdb_out);
fprintf(MR_mdb_err,
- "mdb: wrong answer analysis is only "
- "available from EXIT events.\n");
- } else if (MR_trace_start_wrong_answer(cmd, event_info,
- event_details, jumpaddr)) {
- return STOP_INTERACTING;
+ "mdb: declarative debugging is only "
+ "available from EXIT or FAIL events.\n");
+ }
+ } else if (streq(words[0], "dd_dd")) {
+ MR_Trace_Port port = event_info->MR_trace_port;
+
+ if (word_count != 2) {
+ fflush(MR_mdb_out);
+ fprintf(MR_mdb_err,
+ "mdb: dd_dd requires one argument.\n");
+ } else if (port == MR_PORT_EXIT || port == MR_PORT_FAIL) {
+ if (MR_trace_start_decl_debug((const char *) words[1],
+ cmd, event_info, event_details,
+ jumpaddr))
+ {
+ return STOP_INTERACTING;
+ }
+ else
+ {
+ fflush(MR_mdb_out);
+ fprintf(MR_mdb_err, "mdb: unable to start "
+ "declarative debugging.\n");
+ }
} else {
fflush(MR_mdb_out);
- fprintf(MR_mdb_err, "mdb: unable to start declarative "
- "debugging.\n");
+ fprintf(MR_mdb_err,
+ "mdb: declarative debugging is only "
+ "available from EXIT or FAIL events.\n");
}
#endif /* MR_USE_DECLARATIVE_DEBUGGER */
} else {
Index: trace/mercury_trace_internal.h
===================================================================
RCS file: /home/mercury1/repository/mercury/trace/mercury_trace_internal.h,v
retrieving revision 1.8
diff -u -r1.8 mercury_trace_internal.h
--- mercury_trace_internal.h 1999/05/30 03:55:13 1.8
+++ mercury_trace_internal.h 1999/10/26 05:58:48
@@ -15,20 +15,17 @@
/*
** The following enum gives the possible modes that the declarative
** debugger can be in (see trace/mercury_trace_declarative.{c,h}).
-** MR_TRACE_INTERACTIVE indicates the usual operation of the internal
-** debugger. The other modes refer to what type of analysis is
-** being performed.
*/
typedef enum {
- MR_TRACE_INTERACTIVE,
- MR_TRACE_WRONG_ANSWER
+ MR_TRACE_INTERACTIVE, /* Use internal debugger. */
+ MR_TRACE_DECL_DEBUG, /* Normal declarative debugging. */
+ MR_TRACE_DECL_DEBUG_TEST /* Test mode declarative debugging. */
} MR_Trace_Mode;
/*
** This variable is modified whenever we start or stop collecting
-** an EDT for a particular type of analysis (see
-** trace/mercury_trace_declarative.c).
+** an execution tree.
*/
extern MR_Trace_Mode MR_trace_decl_mode;
Index: util/mkinit.c
===================================================================
RCS file: /home/mercury1/repository/mercury/util/mkinit.c,v
retrieving revision 1.54
diff -u -r1.54 mkinit.c
--- mkinit.c 1999/09/23 11:25:26 1.54
+++ mkinit.c 1999/10/26 05:58:56
@@ -175,13 +175,6 @@
" MR_address_of_trace_final_external = NULL;\n"
" #endif\n"
"#endif\n"
- "#ifdef MR_USE_DECLARATIVE_DEBUGGER\n"
- " #if MR_TRACE_ENABLED\n"
- " MR_address_of_edt_root_node = MR_edt_root_node;\n"
- " #else\n"
- " MR_address_of_edt_root_node = NULL;\n"
- " #endif\n"
- "#endif\n"
"#if MR_TRACE_ENABLED\n"
" MR_trace_func_ptr = MR_trace_real;\n"
" MR_register_module_layout = MR_register_module_layout_real;\n"
%-----------------------------------------------------------------------------%
% Copyright (C) 1999 The University of Melbourne.
% This file may only be copied under the terms of the GNU Library General
% Public License - see the file COPYING.LIB in the Mercury distribution.
%-----------------------------------------------------------------------------%
% File: declarative_execution.m
% Author: Mark Brown
%
% This module defines a Mercury representation of Mercury program
% execution. The declarative debugging infrastructure in the trace
% directory builds such a representation, using predicates exported
% from this module. The debugging front end analyses the structure
% to produce a bug diagnosis.
:- module declarative_execution.
:- interface.
:- import_module bool, list, std_util, string, io.
:- import_module util.
% This type represents a port in a stored event trace.
% The type R is the type of references to other nodes
% in the store.
%
% If this type is modified, some of the macros in
% trace/mercury_trace_declarative.h may also need to be
% updated.
%
:- type trace_node(R)
---> call(
R, % Preceding event.
R, % Last EXIT or REDO event.
trace_atom % Atom that was called.
)
; exit(
R, % Preceding event.
R, % CALL event.
R, % Previous REDO event.
trace_atom % Atom in its final state.
)
; redo(
R, % Preceding event.
R % EXIT event.
)
; fail(
R, % Preceding event.
R % CALL event.
)
; first_disj(
R, % Preceding event.
goal_path, % Path for this event.
bool % Was this a switch?
)
; later_disj(
R, % Preceding event.
R, % Event before the first DISJ.
goal_path % Path for this event.
)
; cond(
R, % Preceding event.
goal_path, % Path for this event.
goal_status % Whether we have reached
% a THEN or ELSE event.
)
; then(
R, % Preceding event.
R % COND event.
)
; else(
R, % Preceding event.
R % COND event.
)
; neg(
R, % Preceding event.
goal_path, % Path for this event.
goal_status % Whether we have reached
% a NEGS or NEGF event.
)
; neg_succ(
R, % Preceding event.
R % NEGE event.
)
; neg_fail(
R, % Preceding event.
R % NEGE event.
)
.
% If either of the following two types are modified, some of
% the macros in trace/mercury_trace_declarative.h may need
% to be updated.
%
:- type trace_atom
---> atom(
string, % Procedure name.
list(univ) % Arguments.
% XXX we also need to store some information about
% where the arguments come from, since they will
% not necessarily be in the right order or all
% present (we do not store unbound variables).
).
:- type goal_status
---> succeeded
; failed
; undecided.
:- type goal_path == goal_path_string.
% Members of this typeclass represent an entire stored
% event trace. The second parameter is the type of identifiers
% for trace nodes, and the first parameter is the type of
% an abstract mapping from the identfiers to the nodes they
% identify.
%
:- typeclass execution_tree(S, R) where [
% Dereference the identifier. This fails if the
% identifier does not refer to any trace_node (ie.
% it is a NULL pointer).
%
pred trace_node_from_id(S, R, trace_node(R)),
mode trace_node_from_id(in, in, out) is semidet
].
% The following procedures also dereference the identifiers,
% but they give an error if the node is not of the expected type.
%
:- pred det_trace_node_from_id(S, R, trace_node(R)) <= execution_tree(S, R).
:- mode det_trace_node_from_id(in, in, out) is det.
:- inst trace_node_call = bound(call(ground, ground, ground)).
:- pred call_node_from_id(S, R, trace_node(R)) <= execution_tree(S, R).
:- mode call_node_from_id(in, in, out(trace_node_call)) is det.
:- inst trace_node_redo = bound(redo(ground, ground)).
% maybe_redo_node_from_id/3 fails if the argument is a
% NULL reference.
%
:- pred maybe_redo_node_from_id(S, R, trace_node(R)) <= execution_tree(S, R).
:- mode maybe_redo_node_from_id(in, in, out(trace_node_redo)) is semidet.
:- inst trace_node_exit = bound(exit(ground, ground, ground, ground)).
:- pred exit_node_from_id(S, R, trace_node(R)) <= execution_tree(S, R).
:- mode exit_node_from_id(in, in, out(trace_node_exit)) is det.
:- inst trace_node_cond = bound(cond(ground, ground, ground)).
:- pred cond_node_from_id(S, R, trace_node(R)) <= execution_tree(S, R).
:- mode cond_node_from_id(in, in, out(trace_node_cond)) is det.
:- inst trace_node_neg = bound(neg(ground, ground, ground)).
:- pred neg_node_from_id(S, R, trace_node(R)) <= execution_tree(S, R).
:- mode neg_node_from_id(in, in, out(trace_node_neg)) is det.
% Load an execution tree which was previously saved by
% the back end.
%
:- pred load_trace_node_map(io__input_stream, trace_node_map,
trace_node_key, io__state, io__state).
:- mode load_trace_node_map(in, out, out, di, uo) is det.
% Save an execution tree generated by the back end. It is
% first converted into a trace_node_map/trace_node_key pair.
%
:- pred save_trace_node_store(io__output_stream, trace_node_store,
trace_node_id, io__state, io__state).
:- mode save_trace_node_store(in, in, in, di, uo) is det.
%-----------------------------------------------------------------------------%
% This instance is used when the declarative debugger is in
% normal mode. Values of this instance are produced by the
% back end and passed directly to the front end.
%
:- type trace_node_store.
:- type trace_node_id.
:- instance execution_tree(trace_node_store, trace_node_id).
% This instance is used when the declarative debugger is in
% test mode. Values of this instance are produced by copying
% values of the previous instance. Unlike the previous
% instance, values of this one can be fed through a stream.
%
:- type trace_node_map.
:- type trace_node_key.
:- instance execution_tree(trace_node_map, trace_node_key).
%-----------------------------------------------------------------------------%
:- implementation.
:- import_module map, require.
det_trace_node_from_id(Store, NodeId, Node) :-
(
trace_node_from_id(Store, NodeId, Node0)
->
Node = Node0
;
error("det_trace_node_from_id: NULL node id")
).
call_node_from_id(Store, NodeId, Node) :-
(
trace_node_from_id(Store, NodeId, Node0),
Node0 = call(_, _, _)
->
Node = Node0
;
error("call_node_from_id: not a CALL node")
).
maybe_redo_node_from_id(Store, NodeId, Node) :-
trace_node_from_id(Store, NodeId, Node0),
(
Node0 = redo(_, _)
->
Node = Node0
;
error("maybe_redo_node_from_id: not a REDO node or NULL")
).
exit_node_from_id(Store, NodeId, Node) :-
(
trace_node_from_id(Store, NodeId, Node0),
Node0 = exit(_, _, _, _)
->
Node = Node0
;
error("exit_node_from_id: not an EXIT node")
).
cond_node_from_id(Store, NodeId, Node) :-
(
trace_node_from_id(Store, NodeId, Node0),
Node0 = cond(_, _, _)
->
Node = Node0
;
error("cond_node_from_id: not a COND node")
).
neg_node_from_id(Store, NodeId, Node) :-
(
trace_node_from_id(Store, NodeId, Node0),
Node0 = neg(_, _, _)
->
Node = Node0
;
error("neg_node_from_id: not a NEG node")
).
%-----------------------------------------------------------------------------%
:- instance execution_tree(trace_node_store, trace_node_id) where [
pred(trace_node_from_id/3) is search_trace_node_store
].
% The "map" is actually just an integer representing the version
% of the map. The empty map should be given the value 0, and
% each time the map is destructively modified (by C code), the
% value should be incremented.
%
:- type trace_node_store ---> store(int).
% The implementation of the identifiers is the same as what
% is identified. This fact is hidden, however, to force the
% abstract map to be explicitly used whenever a new node is
% accessed.
%
:- type trace_node_id ---> id(c_pointer).
:- pred search_trace_node_store(trace_node_store, trace_node_id,
trace_node(trace_node_id)).
:- mode search_trace_node_store(in, in, out) is semidet.
:- pragma c_code(
search_trace_node_store(_Store::in, Id::in, Node::out),
[will_not_call_mercury, thread_safe],
"
Node = Id;
SUCCESS_INDICATOR = (Id != (Word) NULL);
"
).
%
% Following are some predicates that are useful for
% manipulating the above instance in C code.
%
:- func trace_node_port(trace_node(trace_node_id)) = trace_port_type.
:- pragma export(trace_node_port(in) = out,
"MR_DD_trace_node_port").
trace_node_port(call(_, _, _)) = call.
trace_node_port(exit(_, _, _, _)) = exit.
trace_node_port(redo(_, _)) = redo.
trace_node_port(fail(_, _)) = fail.
trace_node_port(first_disj(_, _, yes)) = switch.
trace_node_port(first_disj(_, _, no)) = disj.
trace_node_port(later_disj(_, _, _)) = disj.
trace_node_port(cond(_, _, _)) = ite_cond.
trace_node_port(then(_, _)) = ite_then.
trace_node_port(else(_, _)) = ite_else.
trace_node_port(neg(_, _, _)) = neg_enter.
trace_node_port(neg_succ(_, _)) = neg_success.
trace_node_port(neg_fail(_, _)) = neg_failure.
:- func trace_node_path(trace_node_store, trace_node(trace_node_id))
= goal_path_string.
:- pragma export(trace_node_path(in, in) = out,
"MR_DD_trace_node_path").
trace_node_path(_, call(_, _, _)) = "".
trace_node_path(_, exit(_, _, _, _)) = "".
trace_node_path(_, redo(_, _)) = "".
trace_node_path(_, fail(_, _)) = "".
trace_node_path(_, first_disj(_, P, _)) = P.
trace_node_path(_, later_disj(_, _, P)) = P.
trace_node_path(_, cond(_, P, _)) = P.
trace_node_path(S, then(_, Cond)) = P :-
cond_node_from_id(S, Cond, cond(_, P, _)).
trace_node_path(S, else(_, Cond)) = P :-
cond_node_from_id(S, Cond, cond(_, P, _)).
trace_node_path(_, neg(_, P, _)) = P.
trace_node_path(S, neg_succ(_, Neg)) = P :-
neg_node_from_id(S, Neg, neg(_, P, _)).
trace_node_path(S, neg_fail(_, Neg)) = P :-
neg_node_from_id(S, Neg, neg(_, P, _)).
% Given any node in a stored event trace, find the most recent
% node in the same context which has not been backtracked over,
% skipping negations, conditions, the bodies of calls, and
% alternative disjuncts. Return the NULL reference if there
% is no such node (eg. if we are at the start of a negation,
% condition, or call).
%
:- func scan_backwards(trace_node_store, trace_node(trace_node_id))
= trace_node_id.
:- pragma export(scan_backwards(in, in) = out,
"MR_DD_scan_backwards").
scan_backwards(_, call(_, _, _)) = NULL :-
null_trace_node_id(NULL).
scan_backwards(_, cond(_, _, _)) = NULL :-
null_trace_node_id(NULL).
scan_backwards(_, neg(_, _, _)) = NULL :-
null_trace_node_id(NULL).
scan_backwards(Store, exit(_, Call, _, _)) = Prec :-
call_node_from_id(Store, Call, call(Prec, _, _)).
scan_backwards(Store, fail(_, Call)) = Prec :-
call_node_from_id(Store, Call, call(Prec, _, _)).
scan_backwards(Store, redo(_, Exit)) = Prec :-
exit_node_from_id(Store, Exit, exit(Prec, _, _, _)).
scan_backwards(_, first_disj(Prec, _, _)) = Prec.
scan_backwards(_, later_disj(_, Back, _)) = Back.
scan_backwards(Store, then(_, Cond)) = Prec :-
cond_node_from_id(Store, Cond, cond(Prec, _, _)).
scan_backwards(Store, else(_, Cond)) = Prec :-
cond_node_from_id(Store, Cond, cond(Prec, _, _)).
scan_backwards(Store, neg_succ(_, Neg)) = Prec :-
neg_node_from_id(Store, Neg, neg(Prec, _, _)).
scan_backwards(Store, neg_fail(_, Neg)) = Prec :-
neg_node_from_id(Store, Neg, neg(Prec, _, _)).
%
% Each node type has a Mercury function which constructs
% a node of that type. The functions are exported to C so
% that the back end can build an execution tree.
%
:- func construct_call_node(trace_node_id, trace_atom)
= trace_node(trace_node_id).
:- pragma export(construct_call_node(in, in) = out,
"MR_DD_construct_call_node").
construct_call_node(Preceding, Atom) = call(Preceding, Answer, Atom) :-
null_trace_node_id(Answer).
:- func construct_exit_node(trace_node_id, trace_node_id, trace_node_id,
trace_atom) = trace_node(trace_node_id).
:- pragma export(construct_exit_node(in, in, in, in) = out,
"MR_DD_construct_exit_node").
construct_exit_node(Preceding, Call, Previous, Atom)
= exit(Preceding, Call, Previous, Atom).
:- func construct_redo_node(trace_node_id, trace_node_id)
= trace_node(trace_node_id).
:- pragma export(construct_redo_node(in, in) = out,
"MR_DD_construct_redo_node").
construct_redo_node(Preceding, Exit) = redo(Preceding, Exit).
:- func construct_fail_node(trace_node_id, trace_node_id)
= trace_node(trace_node_id).
:- pragma export(construct_fail_node(in, in) = out,
"MR_DD_construct_fail_node").
construct_fail_node(Preceding, Call) = fail(Preceding, Call).
:- func construct_first_disj_node(trace_node_id, goal_path_string, bool)
= trace_node(trace_node_id).
:- pragma export(construct_first_disj_node(in, in, in) = out,
"MR_DD_construct_first_disj_node").
construct_first_disj_node(Preceding, Path, Flag) =
first_disj(Preceding, Path, Flag).
:- func construct_later_disj_node(trace_node_id, trace_node_id,
goal_path_string) = trace_node(trace_node_id).
:- pragma export(construct_later_disj_node(in, in, in) = out,
"MR_DD_construct_later_disj_node").
construct_later_disj_node(Preceding, Back, Path)
= later_disj(Preceding, Back, Path).
:- func construct_cond_node(trace_node_id, goal_path_string)
= trace_node(trace_node_id).
:- pragma export(construct_cond_node(in, in) = out,
"MR_DD_construct_cond_node").
construct_cond_node(Preceding, Path) = cond(Preceding, Path, undecided).
:- func construct_then_node(trace_node_id, trace_node_id)
= trace_node(trace_node_id).
:- pragma export(construct_then_node(in, in) = out,
"MR_DD_construct_then_node").
construct_then_node(Preceding, Cond) = then(Preceding, Cond).
:- func construct_else_node(trace_node_id, trace_node_id)
= trace_node(trace_node_id).
:- pragma export(construct_else_node(in, in) = out,
"MR_DD_construct_else_node").
construct_else_node(Preceding, Cond) = else(Preceding, Cond).
:- func construct_neg_node(trace_node_id, goal_path_string)
= trace_node(trace_node_id).
:- pragma export(construct_neg_node(in, in) = out,
"MR_DD_construct_neg_node").
construct_neg_node(Preceding, Path) = neg(Preceding, Path, undecided).
:- func construct_neg_succ_node(trace_node_id, trace_node_id)
= trace_node(trace_node_id).
:- pragma export(construct_neg_succ_node(in, in) = out,
"MR_DD_construct_neg_succ_node").
construct_neg_succ_node(Preceding, Neg) = neg_succ(Preceding, Neg).
:- func construct_neg_fail_node(trace_node_id, trace_node_id)
= trace_node(trace_node_id).
:- pragma export(construct_neg_fail_node(in, in) = out,
"MR_DD_construct_neg_fail_node").
construct_neg_fail_node(Preceding, Neg) = neg_fail(Preceding, Neg).
:- pred null_trace_node_id(trace_node_id).
:- mode null_trace_node_id(out) is det.
:- pragma c_code(
null_trace_node_id(Id::out),
[will_not_call_mercury, thread_safe],
"Id = (Word) NULL;"
).
%-----------------------------------------------------------------------------%
% The most important property of this instance is that it
% can be written to or read in from a stream easily. It
% is not as efficient to use as the earlier instance, though.
%
:- instance execution_tree(trace_node_map, trace_node_key) where [
pred(trace_node_from_id/3) is search_trace_node_map
].
:- type trace_node_map
---> map(map(trace_node_key, trace_node(trace_node_key))).
% Values of this type are represented in the same way (in the
% underlying C code) as corresponding values of the other
% instance.
%
:- type trace_node_key
---> key(int).
:- pred search_trace_node_map(trace_node_map, trace_node_key,
trace_node(trace_node_key)).
:- mode search_trace_node_map(in, in, out) is semidet.
search_trace_node_map(map(Map), Key, Node) :-
map__search(Map, Key, Node).
load_trace_node_map(Stream, Map, Key) -->
io__read(Stream, ResKey),
{
ResKey = ok(Key)
;
ResKey = eof,
error("load_trace_node_map: unexpected EOF")
;
ResKey = error(Msg, _),
error(Msg)
},
io__read(Stream, ResMap),
{
ResMap = ok(Map)
;
ResMap = eof,
error("load_trace_node_map: unexpected EOF")
;
ResMap = error(Msg, _),
error(Msg)
}.
:- pragma export(save_trace_node_store(in, in, in, di, uo),
"MR_DD_save_trace").
save_trace_node_store(Stream, Store, NodeId) -->
{ map__init(Map0) },
{ node_id_to_key(NodeId, Key) },
{ node_map(Store, NodeId, map(Map0), Map) },
io__write(Stream, Key),
io__write_string(Stream, ".\n"),
io__write(Stream, Map),
io__write_string(Stream, ".\n").
:- pred node_map(trace_node_store, trace_node_id, trace_node_map,
trace_node_map).
:- mode node_map(in, in, in, out) is det.
node_map(Store, NodeId, map(Map0), Map) :-
(
search_trace_node_store(Store, NodeId, Node1)
->
node_id_to_key(NodeId, Key),
convert_node(Node1, Node2),
map__det_insert(Map0, Key, Node2, Map1),
Next = preceding_node(Node1),
node_map(Store, Next, map(Map1), Map)
;
Map = map(Map0)
).
:- pred node_id_to_key(trace_node_id, trace_node_key).
:- mode node_id_to_key(in, out) is det.
:- pragma c_code(node_id_to_key(Id::in, Key::out),
[will_not_call_mercury, thread_safe],
"Key = (Integer) Id;").
:- pred convert_node(trace_node(trace_node_id), trace_node(trace_node_key)).
:- mode convert_node(in, out) is det.
:- pragma c_code(convert_node(N1::in, N2::out),
[will_not_call_mercury, thread_safe],
"N2 = N1;").
% Given a node in a stored trace, return a reference to
% the preceding node in the trace, or a NULL reference if
% it is the first.
%
:- func preceding_node(trace_node(T)) = T.
preceding_node(call(P, _, _)) = P.
preceding_node(exit(P, _, _, _)) = P.
preceding_node(redo(P, _)) = P.
preceding_node(fail(P, _)) = P.
preceding_node(first_disj(P, _, _)) = P.
preceding_node(later_disj(P, _, _)) = P.
preceding_node(cond(P, _, _)) = P.
preceding_node(then(P, _)) = P.
preceding_node(else(P, _)) = P.
preceding_node(neg(P, _, _)) = P.
preceding_node(neg_succ(P, _)) = P.
preceding_node(neg_fail(P, _)) = P.
%-----------------------------------------------------------------------------%
% Copyright (C) 1999 The University of Melbourne.
% This file may only be copied under the terms of the GNU Library General
% Public License - see the file COPYING.LIB in the Mercury distribution.
%-----------------------------------------------------------------------------%
% File: declarative_test.m
% Author: Mark Brown
%
% This module is a stand-alone version of the front end, suitable for
% testing.
:- module declarative_test.
:- interface.
:- import_module io.
:- pred main(io__state, io__state).
:- mode main(di, uo) is det.
:- implementation.
:- import_module declarative_debugger, declarative_execution.
:- import_module list, std_util, map, require.
main -->
process_arguments(MaybeFile),
(
{ MaybeFile = yes(File) }
->
load_trace_node_map(File, Map, Key),
{ diagnoser_state_init(State) },
io__stdin_stream(StdIn),
io__stdout_stream(StdOut),
{ det_trace_node_from_id(Map, Key, Node) },
diagnosis(StdIn, StdOut, Map, Node, Response, State, _),
io__write_string("Diagnoser response:\n"),
io__write(Response),
io__nl
;
usage
).
:- pred process_arguments(maybe(io__input_stream),
io__state, io__state).
:- mode process_arguments(out, di, uo) is det.
process_arguments(MaybeFile) -->
io__command_line_arguments(Args),
(
{ Args = [FileName] }
->
io__open_input(FileName, Res),
(
{ Res = ok(File) }
->
{ MaybeFile = yes(File) }
;
{ MaybeFile = no }
)
;
{ MaybeFile = no }
).
:- pred usage(io__state, io__state).
:- mode usage(di, uo) is det.
usage -->
io__progname_base("declarative_test", Name),
io__write_strings(["Usage: ", Name, " <filename>\n"]).
--
Mark Brown, PhD student )O+ | "Another of Fortran's breakthroughs
(m.brown at cs.mu.oz.au) | was the GOTO statement, which was...
Dept. of Computer Science and Software | uniquely simple and understandable"
Engineering, University of Melbourne | -- IEEE, 1994
--------------------------------------------------------------------------
mercury-developers mailing list
Post messages to: mercury-developers at cs.mu.oz.au
Administrative Queries: owner-mercury-developers at cs.mu.oz.au
Subscriptions: mercury-developers-request at cs.mu.oz.au
--------------------------------------------------------------------------
More information about the developers
mailing list