[m-rev.] For review: changes to declarative debugger (Part 1)
Ian MacLarty
maclarty at cs.mu.OZ.AU
Wed Sep 29 14:10:58 AEST 2004
For review by Zoltan.
Estimated hours taken: 200
Branches: main
The main changes to the declarative debugger are:
When you mark a subterm (using the term browser from within the DD), the
next question will be about the node that bound that subterm. If that node is
correct then a binary search will be done between that node and the last
node you asserted was erroneous.
The declarative debugger is now a 3-valued debugger. This means you can answer
inadmissible if a call's inputs violate some precondition of the call. The
debugger will also infer a call is inadmissible if you mark one of its inputs
from the browser.
You don't have to give an argument number when invoking the term browser from
within the DD. If an argument number is omitted then the whole call is
browsed as if it were a data term.
The subterm dependency tracking code now has the ability to track subterms of
closures, including subterms used when creating the closure by currying.
Subterm dependency tracking is also now more reliable when tracing information
is missing.
Lot's of stuff in declarative_analyser.m has been redesigned to facilitate
future improvements, such as probabalistic debugging.
browser/declarative_analyser.m
Transferred the definition of the mercury_edt type class to
declarative_edt.m. Added two new search algorithms: one to use
suspicious subterm information to direct the bug search and one to do
a binary search on a path in the EDT.
browser/declarative_debugger.m
Added inadmissible as a truth value for the declarative debugger.
Added ignore and skip responses. Ignore responses are used when a
call is to a trusted predicate. Ignore tells the analyser that the
node is not a bug itself, though it may have buggy children. Skip
means the oracle has skipped the question.
browser/declarative_edt.m
Definition of the EDT type class and search_space type. Search spaces
are an extra layer on top of the EDT and provide useful services to
the analyser such as keeping track of which nodes in the EDT might
contain a bug. In the future the search space will also be used to
hold information like the probability that a node is buggy.
Extended the mercury_edt type class with some useful methods.
browser/declarative_execution.m
Added some utility predicates to extract information from a proc_id.
browser/declarative_oracle.m
The oracle now only answers one question at a time. This makes the
implementation simpler. I plan to get the oracle to tell the
analyser everything it knows, without having to ask the user, whenever
children are added to the search space, so that maximum information
is always available to the search algorithms.
Added a mechanism so the analyser can explicitly request that a
question be re-asked of the user.
Made some changes to handle inadmissible calls.
browser/declarative_tree.m
Can now produce an i_bug as well as an e_bug.
Made changes to handle dependency tracking of closure arguments.
There are now two slightly different modes of subterm dependency
tracking. A fall-back mode where not all trace information is
available and a "full" mode that assumes everything has been traced
(which will be the case if compilation was with a debug grade). The
main difference is with higher order calls. Because the id of the
pred being called in a higher order call is not (easily) available,
we can't safely match the HO call up with events on the contour if
everything is not traced. If everything is traced, then we can be sure
the HO call's events will be where we expect them.
Handled builtin calls which are treated as primitive ops.
browser/declarative_user.m
User can now browse an entire call, instead of only one argument at
a time.
Allowed user to answer inadmissible.
browser/mdb.m
Added mdb.declarative_edt.
browser/program_representation.m
Added builtin_call_rep to represent builtin calls.
Made plain calls to UCI predicates be treated as primitive ops.
Added function to say if a goal generates internal events directly.
Added a function to say whether an atomic goal is identifiable (i.e.
whether we can get from its goal_rep its name, module and arity).
compiler/prog_rep.m
Now creates builtin_call_rep atomic goal if the plain call was to
a builtin.
compiler/trace_params.m
Made minimum tracing for decldebug grade include program
representations. This is so the libraries compile with program
representations, so we can do subterm dependency tracking through
library calls.
Trace level decl now includes the program representation.
The default trace level for decldebug grade now includes the program
representation.
tests/debugger/declarative/Mercury.options
Removed superflous `--trace rep' options (since this is now implied by
--trace decl).
tests/debugger/declarative/Mmakefile
tests/debugger/declarative/binary_search.exp
tests/debugger/declarative/binary_search.exp2
tests/debugger/declarative/binary_search.inp
tests/debugger/declarative/binary_search.inp2
tests/debugger/declarative/binary_search.m
tests/debugger/declarative/binary_search_1.m
tests/debugger/declarative/builtin_call_rep.exp
tests/debugger/declarative/builtin_call_rep.inp
tests/debugger/declarative/builtin_call_rep.m
tests/debugger/declarative/catch.exp3
tests/debugger/declarative/catch.inp3
tests/debugger/declarative/closure_dependency.exp
tests/debugger/declarative/closure_dependency.exp2
tests/debugger/declarative/closure_dependency.inp
tests/debugger/declarative/closure_dependency.inp2
tests/debugger/declarative/closure_dependency.m
tests/debugger/declarative/confirm_abort.exp
tests/debugger/declarative/confirm_abort.inp
tests/debugger/declarative/dependency.exp
tests/debugger/declarative/dependency2.exp
tests/debugger/declarative/explicit_subtree.exp
tests/debugger/declarative/explicit_subtree.exp2
tests/debugger/declarative/explicit_subtree.inp
tests/debugger/declarative/explicit_subtree.m
tests/debugger/declarative/family.exp
tests/debugger/declarative/family.inp
tests/debugger/declarative/find_origin.exp
tests/debugger/declarative/find_origin.exp2
tests/debugger/declarative/find_origin.exp3
tests/debugger/declarative/find_origin.inp
tests/debugger/declarative/find_origin.inp2
tests/debugger/declarative/find_origin.inp3
tests/debugger/declarative/find_origin.m
tests/debugger/declarative/ho5.exp3
tests/debugger/declarative/ignore.exp
tests/debugger/declarative/ignore.exp2
tests/debugger/declarative/ignore.exp3
tests/debugger/declarative/ignore.inp
tests/debugger/declarative/ignore.inp2
tests/debugger/declarative/ignore.inp3
tests/debugger/declarative/ignore.m
tests/debugger/declarative/ignore_1.m
tests/debugger/declarative/inadmissible.exp
tests/debugger/declarative/inadmissible.exp2
tests/debugger/declarative/inadmissible.inp
tests/debugger/declarative/inadmissible.inp2
tests/debugger/declarative/inadmissible.m
tests/debugger/declarative/ingore.exp
tests/debugger/declarative/input_term_dep.exp
tests/debugger/declarative/input_term_dep.inp
tests/debugger/declarative/lpe_example.exp3
tests/debugger/declarative/mismatch_on_call.exp
tests/debugger/declarative/mismatch_on_call.exp2
tests/debugger/declarative/mismatch_on_call.inp
tests/debugger/declarative/mismatch_on_call.m
tests/debugger/declarative/revise.exp
tests/debugger/declarative/revise.inp
tests/debugger/declarative/skip.exp
tests/debugger/declarative/skip.exp2
tests/debugger/declarative/skip.inp
tests/debugger/declarative/skip.m
tests/debugger/declarative/solutions.exp3
tests/debugger/declarative/solutions.inp3
tests/debugger/declarative/special_term_dep.exp
tests/debugger/declarative/throw.exp3
tests/debugger/declarative/trust.exp2
tests/debugger/declarative/trust.inp2
Tests for new debugger features and changes to some old tests.
trace/mercury_trace_declarative.c
Made the depth step size used when deciding which events to put in
the annotated trace a variable so that it can be dynamically adjusted
in the future.
The EDT depth is now calculated instead of using the call depth (which
is not always consistent with the EDT depth).
When generating an annotated trace for an explicit subtree the
first event's preceeding event now points to the correct event in the
existing annotated trace (instead of NULL). This allows the parent of
the root of the new explicit subtree to be calculated.
Made changes so that all the interface events for the sub-calls inside
a call are included in the annotated trace, so that contours are built
correctly.
I have included the full version of declarative_analyser.m as most of it has
changed:
browser/declarative_analyser.m:
%-----------------------------------------------------------------------------%
% Copyright (C) 1999-2003 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_analyser.m
% Authors: Mark Brown, Ian MacLarty
%
% This module implements some analysis algorithms that search for bugs in
% Evaluation Dependency Trees (EDTs). The search algorithms use information
% provided by the search_space data type which acts as a layer on top of the
% EDT, storing information relevant to the bug search. Throughout this module
% the type variables T and S refer to the types of nodes in the EDT and the
% store of EDT nodes respectively.
%
:- module mdb.declarative_analyser.
:- interface.
:- import_module mdb.declarative_debugger.
:- import_module mdb.io_action.
:- import_module mdb.declarative_edt.
:- import_module std_util.
:- type analyser_response(T)
% There are no suspects left, and no incorrect
% nodes have been found.
---> no_suspects
% A suspect who is guilty, along with the evidence
% against the suspect.
; bug_found(decl_bug, decl_evidence(T))
% The analyser desires an answer to the question.
; oracle_question(decl_question(T))
% The analyser requires the given implicit sub-tree
% to be made explicit.
; require_explicit(T)
% The analyser would like the oracle to re-ask the user
% this question and then for analysis to continue.
; revise(decl_question(T)).
:- type analyser_state(T).
:- pred analyser_state_init(io_action_map::in, analyser_state(T)::out) is det.
% Resets the state of the analyser except for the io_action_map.
:- pred reset_analyser(analyser_state(T)::in, analyser_state(T)::out) is det.
:- pred analyser_state_replace_io_map(io_action_map::in,
analyser_state(T)::in, analyser_state(T)::out) is det.
% Perform analysis on the given EDT, which may be a new tree
% to diagnose, or a sub-tree that was required to be made
% explicit.
%
:- pred start_analysis(S::in, T::in, analyser_response(T)::out,
analyser_state(T)::in, analyser_state(T)::out) is det
<= mercury_edt(S, T).
% Continue analysis after the oracle has responded with an
% answer.
%
:- pred continue_analysis(S::in, decl_answer(T)::in,
analyser_response(T)::out, analyser_state(T)::in,
analyser_state(T)::out) is det <= mercury_edt(S, T).
% Revise the current analysis. This is done when a bug determined
% by the analyser has been overruled by the oracle.
%
:- pred revise_analysis(S::in, analyser_response(T)::out, analyser_state(T)::in,
analyser_state(T)::out) is det <= mercury_edt(S, T).
% Return information within the analyser state that is intended for
% debugging the declarative debugger itself.
%
:- pred debug_analyser_state(analyser_state(T)::in,
maybe(subterm_origin(T))::out) is det.
%-----------------------------------------------------------------------------%
:- implementation.
:- import_module mdb.declarative_edt.
:- import_module mdbcomp.program_representation.
:- import_module bool, exception, string, map, int, counter, array, list.
% Describes what search strategy is being used by the analyser and the
% state of the search.
%
:- type search_mode
% Look for the first unknown suspect in a breadth-first
% fashion, starting at the root. If no unknown
% suspects are found then choose a skipped suspect
% to requery.
---> breadth_first
%
% Follow the subterm all the way to where it's bound or
% until it can't be followed any further (for example
% when there is a call to a module with no tracing),
% and ask a question about the nearest unknown suspect
% on the subterm dependency chain. Then proceed to do
% a binary search between this node and the root of the
% search space (The binary search will only come into
% effect if the oracle asserts the suspect is correct
% or inadmissible). The arguments of this field give
% the atom and subterm position in that atom where the
% search got up to if it needs to stop to wait for an
% explicit subtree to be generated. The last argument
% is the last suspect on the dependency chain whos
% status was unknown (initially this is no).
%
; follow_subterm_end(
suspect_id,
arg_pos,
term_path,
maybe(suspect_id)
)
%
% Perform a binary search on the array of suspects.
% The range field gives the subrange of the array to
% search. last_tested is the index into the array of
% the last suspect about which a question was asked.
%
; binary(
suspects :: array(suspect_id),
range :: pair(int, int),
last_testsed :: int
).
% Each search algorithm should respond with either a question
% or a request for an explicit subtree to be generated for a suspect
% which is the root of an implicit subtree.
%
:- type search_response
---> question(suspect_id)
; require_explicit(suspect_id).
% The analyser state records all of the information that needs
% to be remembered across multiple invocations of the analyser.
%
:- type analyser_state(T)
---> analyser(
% Information about the EDT nodes relevent to
% the bug search.
search_space :: search_space(T),
% Previous roots of the search space. These
% will be revisited if the analysis is
% revised (for instance when the user
% overrules a bug found by the analyser).
previous_roots :: list(suspect_id),
% This is set to yes when an explicit subtree
% needs to be generated. The suspect_id of the
% suspect in the search space is stored here so
% we know which node in the search space to
% update once the explicit subtree has been
% generated.
require_explicit :: maybe(suspect_id),
% The method currently being employed to search
% the search space for questions for the
% oracle.
search_mode :: search_mode,
% Everytime a search finds a suspect to
% ask the oracle about it is put in this field
% before asking the oracle, so the analyser
% knows how to modify the search space when
% it gets an answer.
last_search_question :: maybe(suspect_id),
% This field allows us to map I/O action
% numbers to the actions themselves.
io_action_map :: io_action_map,
% This field is present only to make it easier
% to debug the dependency tracking algorithm;
% if bound to yes, it records the result of
% the invocation of that algorithm on the last
% analysis step.
debug_origin :: maybe(subterm_origin(T))
).
analyser_state_init(IoActionMap, Analyser) :-
empty_search_space(EmptySearchSpace),
Analyser = analyser(EmptySearchSpace, [], no, breadth_first, no,
IoActionMap, no).
reset_analyser(!Analyser) :-
empty_search_space(EmptySearchSpace),
!:Analyser = analyser(EmptySearchSpace, [], no, breadth_first, no,
!.Analyser ^ io_action_map, no).
analyser_state_replace_io_map(IoActionMap, Analyser0, Analyser) :-
Analyser = Analyser0 ^ io_action_map := IoActionMap.
debug_analyser_state(Analyser, Analyser ^ debug_origin).
start_analysis(Store, Tree, Response, !Analyser) :-
MaybeRequireExplicit = !.Analyser ^ require_explicit,
(
MaybeRequireExplicit = yes(SuspectId),
incorporate_explicit_subtree(SuspectId, Tree,
!.Analyser ^ search_space, SearchSpace),
!:Analyser = !.Analyser ^ search_space := SearchSpace,
!:Analyser = !.Analyser ^ require_explicit := no,
decide_analyser_response(Store, Response, !Analyser)
;
MaybeRequireExplicit = no,
%
% An explicit subtree was not requested, so this is the
% start of a new declarative debugging session.
%
reset_analyser(!Analyser),
initialise_search_space(Tree, SearchSpace),
!:Analyser = !.Analyser ^ search_space := SearchSpace,
root_det(SearchSpace, RootId),
!:Analyser = !.Analyser ^ last_search_question := yes(RootId),
edt_question(!.Analyser ^ io_action_map, Store, Tree,
Question),
Response = revise(Question)
).
continue_analysis(Store, Answer, Response, !Analyser) :-
(
!.Analyser ^ last_search_question = yes(SuspectId),
process_answer(Store, Answer, SuspectId, !Analyser)
;
!.Analyser ^ last_search_question = no,
throw(internal_error("continue_analysis",
"received answer to unasked question"))
),
!:Analyser = !.Analyser ^ last_search_question := no,
decide_analyser_response(Store, Response, !Analyser).
:- pred process_answer(S::in, decl_answer(T)::in, suspect_id::in,
analyser_state(T)::in, analyser_state(T)::out)
is det <= mercury_edt(S, T).
process_answer(_, skip(_), SuspectId, !Analyser) :-
skip_suspect(SuspectId, !.Analyser ^ search_space, SearchSpace),
!:Analyser = !.Analyser ^ search_space := SearchSpace.
process_answer(_, ignore(_), SuspectId, !Analyser) :-
ignore_suspect(SuspectId, !.Analyser ^ search_space, SearchSpace),
!:Analyser = !.Analyser ^ search_space := SearchSpace.
process_answer(_, truth_value(_, correct), SuspectId, !Analyser) :-
assert_suspect_is_correct(SuspectId, !.Analyser ^ search_space,
SearchSpace),
!:Analyser = !.Analyser ^ search_space := SearchSpace.
process_answer(_, truth_value(_, inadmissible), SuspectId, !Analyser) :-
assert_suspect_is_inadmissible(SuspectId, !.Analyser ^ search_space,
SearchSpace),
!:Analyser = !.Analyser ^ search_space := SearchSpace.
process_answer(_, truth_value(_, erroneous), SuspectId, !Analyser) :-
assert_suspect_is_erroneous(SuspectId, !.Analyser ^ search_space,
SearchSpace),
PreviousRoots = !.Analyser ^ previous_roots,
!:Analyser = !.Analyser ^ previous_roots := [SuspectId| PreviousRoots],
!:Analyser = !.Analyser ^ search_space := SearchSpace.
process_answer(Store, suspicious_subterm(Node, ArgPos, TermPath), SuspectId,
!Analyser) :-
%
% XXX The following 2 lines just done so that debugging info can be
% printed for tests run when declarative_analyser.m not compiled with
% tracing (so can't use dd_dd command in mdb). Should be removed when
% edt_dependency becomes stable enough.
%
edt_dependency(Store, Node, ArgPos, TermPath, _, DebugOrigin),
!:Analyser = !.Analyser ^ debug_origin := yes(DebugOrigin),
edt_subterm_mode(Store, Node, ArgPos, TermPath, Mode),
(
Mode = subterm_in,
assert_suspect_is_inadmissible(SuspectId,
!.Analyser ^ search_space, SearchSpace)
;
Mode = subterm_out,
assert_suspect_is_erroneous(SuspectId,
!.Analyser ^ search_space, SearchSpace),
!:Analyser = !.Analyser ^ previous_roots :=
[SuspectId | !.Analyser ^ previous_roots]
),
!:Analyser = !.Analyser ^ search_space := SearchSpace,
!:Analyser = !.Analyser ^ search_mode := follow_subterm_end(SuspectId,
ArgPos, TermPath, no).
revise_analysis(Store, Response, !Analyser) :-
%
% The head of the previous_roots field in the analyser is just the
% current root of the search space, so we make the second element in
% previous_roots the new erroneous root, make everything below it
% unknown and re-query the current root. If there's only one previous
% root (the current root) then we make it and all its descendents
% unknown and re-query it. If there are no previous roots then we give
% up the search.
%
(
!.Analyser ^ previous_roots = [Current | PreviousRoots],
(
PreviousRoots = [LastRoot | _],
revise_suspect(LastRoot, !.Analyser ^ search_space,
SearchSpace0),
assert_suspect_is_erroneous(LastRoot, SearchSpace0,
SearchSpace1)
;
PreviousRoots = [],
revise_suspect(Current, !.Analyser ^ search_space,
SearchSpace1)
),
edt_question(!.Analyser ^ io_action_map, Store,
get_edt_node(SearchSpace1, Current), Question),
Response = revise(Question),
!:Analyser = !.Analyser ^ search_space := SearchSpace1,
!:Analyser = !.Analyser ^ previous_roots := PreviousRoots,
!:Analyser = !.Analyser ^ search_mode := breadth_first,
!:Analyser = !.Analyser ^ last_search_question := yes(Current)
;
!.Analyser ^ previous_roots = [],
Response = no_suspects
).
:- pred decide_analyser_response(S::in, analyser_response(T)::out,
analyser_state(T)::in, analyser_state(T)::out)
is det <= mercury_edt(S, T).
decide_analyser_response(Store, Response, !Analyser) :-
SearchSpace0 = !.Analyser ^ search_space,
root_det(SearchSpace0, RootId),
(
no_more_questions(Store, SearchSpace0, SearchSpace1,
CorrectDescendents, InadmissibleChildren)
->
(
suspect_erroneous(SearchSpace1, RootId)
->
bug_response(Store, !.Analyser ^ io_action_map,
SearchSpace1, RootId,
[RootId | CorrectDescendents],
InadmissibleChildren, Response),
!:Analyser = !.Analyser ^ search_space := SearchSpace1
;
revise_analysis(Store, Response, !Analyser)
)
;
% Search the search space for questions for the oracle.
search(Store, SearchSpace0, SearchSpace,
!.Analyser ^ search_mode, NewMode, SearchResponse),
!:Analyser = !.Analyser ^ search_mode := NewMode,
!:Analyser = !.Analyser ^ search_space := SearchSpace,
handle_search_response(Store, SearchResponse, !Analyser,
Response)
).
:- pred handle_search_response(S::in, search_response::in,
analyser_state(T)::in, analyser_state(T)::out,
analyser_response(T)::out) is det <= mercury_edt(S, T).
handle_search_response(Store, question(SuspectId), !Analyser, Response) :-
SearchSpace = !.Analyser ^ search_space,
Node = get_edt_node(SearchSpace, SuspectId),
edt_question(!.Analyser ^ io_action_map, Store, Node,
OracleQuestion),
(
(
suspect_unknown(SearchSpace, SuspectId)
;
suspect_skipped(SearchSpace, SuspectId)
)
->
Response = oracle_question(OracleQuestion)
;
suspect_ignored(SearchSpace, SuspectId)
->
% Searches should not respond with questions about suspects we
% already know to be trusted.
throw(internal_error("handle_search_response",
"search responded with query about ignored suspect"))
;
% We already known something about this suspect, but the search
% wants the oracle to be requeried. This may happen if the
% search thinks the user might have answered the question
% incorrectly before.
Response = revise(OracleQuestion)
),
!:Analyser = !.Analyser ^ last_search_question := yes(SuspectId).
handle_search_response(_, require_explicit(SuspectId), !Analyser,
Response) :-
!:Analyser = !.Analyser ^ require_explicit := yes(SuspectId),
Response = require_explicit(get_edt_node(!.Analyser ^ search_space,
SuspectId)).
% bug_response(Store, IoActionMap, SearchSpace, BugId, Evidence,
% InadmissibleChildren, Response)
% Create a bug analyser-response using the given Evidence. If
% InadmissibleChildren isn't empty then an i_bug will be created,
% otherwise an e_bug will be created.
%
:- pred bug_response(S::in, io_action_map::in, search_space(T)::in,
suspect_id::in, list(suspect_id)::in, list(suspect_id)::in,
analyser_response(T)::out) is det <= mercury_edt(S, T).
bug_response(Store, IoActionMap, SearchSpace, BugId, Evidence,
InadmissibleChildren, Response) :-
BugNode = get_edt_node(SearchSpace, BugId),
(
InadmissibleChildren = [InadmissibleChild | _],
edt_root_i_bug(Store, BugNode,
get_edt_node(SearchSpace, InadmissibleChild), IBug),
Bug = i_bug(IBug)
;
InadmissibleChildren = [],
edt_root_e_bug(IoActionMap, Store, BugNode, EBug),
Bug = e_bug(EBug)
),
EDTNodes = list.map(get_edt_node(SearchSpace), Evidence),
list.map(edt_question(IoActionMap, Store), EDTNodes,
EvidenceAsQuestions),
Response = bug_found(Bug, EvidenceAsQuestions).
%-----------------------------------------------------------------------------%
% Search the search space for a question for the oracle. The search
% should respond with a question about a suspect, or a request for an
% explicit subree to be generated. A new search mode is returned so
% that the search algorithm being used can remember its current state
% next time round.
%
:- pred search(S::in, search_space(T)::in, search_space(T)::out,
search_mode::in, search_mode::out, search_response::out)
is det <= mercury_edt(S, T).
search(Store, !SearchSpace, breadth_first, NewMode, Response) :-
breadth_first_search(Store, !SearchSpace, Response, NewMode).
search(Store, !SearchSpace, follow_subterm_end(SuspectId, ArgPos, TermPath,
LastUnknown), NewMode, Response) :-
follow_subterm_end_search(Store, !SearchSpace, LastUnknown, SuspectId,
ArgPos, TermPath, NewMode, Response).
search(Store, !SearchSpace, binary(PathArray, From - To, LastTested),
NewMode, Response) :-
binary_search(Store, PathArray, From, To, LastTested, !SearchSpace,
NewMode, Response).
:- pred breadth_first_search(S::in, search_space(T)::in, search_space(T)::out,
search_response::out, search_mode::out) is det <= mercury_edt(S, T).
breadth_first_search(Store, !SearchSpace, Response, NewMode) :-
root_det(!.SearchSpace, RootId),
(
first_unknown_descendent_breadth(Store, RootId,
!.SearchSpace, SearchSpace1, MaybeDescendent)
->
SearchSpace1 = !:SearchSpace,
(
MaybeDescendent = yes(Unknown),
Response = question(Unknown),
NewMode = breadth_first
;
MaybeDescendent = no,
(
choose_skipped_suspect(!.SearchSpace,
LeastSkipped)
->
Response = question(LeastSkipped),
NewMode = breadth_first
;
throw(internal_error("breadth_first_search",
"no unknown or skipped suspects"))
)
)
;
%
% An explicit subtree is required, so pick an implicit root
% to make explicit.
%
(
pick_implicit_root(Store, !.SearchSpace, ImplicitRoot)
->
Response = require_explicit(ImplicitRoot),
NewMode = breadth_first
;
throw(internal_error("breadth_first_search",
"first_unknown_descendent_breadth required "++
"an explicit subtree, but pick_implicit_roo"++
"t couldn't find an implicit root"))
)
).
:- pred follow_subterm_end_search(S::in, search_space(T)::in,
search_space(T)::out, maybe(suspect_id)::in, suspect_id::in,
arg_pos::in, term_path::in, search_mode::out, search_response::out)
is det <= mercury_edt(S, T).
follow_subterm_end_search(Store, !SearchSpace, LastUnknown, SuspectId, ArgPos,
TermPath, NewMode, SearchResponse) :-
find_subterm_origin(Store, SuspectId, ArgPos, TermPath, !SearchSpace,
FindOriginResponse),
root_det(!.SearchSpace, RootId),
(
FindOriginResponse = primitive_op(_, _),
(
LastUnknown = yes(Unknown),
SearchResponse = question(Unknown),
setup_binary_search(!.SearchSpace, RootId, Unknown,
NewMode)
;
LastUnknown = no,
breadth_first_search(Store, !SearchSpace,
SearchResponse, NewMode)
)
;
FindOriginResponse = not_found,
(
LastUnknown = yes(Unknown),
SearchResponse = question(Unknown),
setup_binary_search(!.SearchSpace, RootId, Unknown,
NewMode)
;
LastUnknown = no,
breadth_first_search(Store, !SearchSpace,
SearchResponse, NewMode)
)
;
FindOriginResponse = require_explicit,
SearchResponse = require_explicit(SuspectId),
NewMode = follow_subterm_end(SuspectId, ArgPos, TermPath,
LastUnknown)
;
FindOriginResponse = origin(OriginId, OriginArgPos,
OriginTermPath),
(
suspect_unknown(!.SearchSpace, OriginId)
->
follow_subterm_end_search(Store, !SearchSpace,
yes(OriginId), OriginId, OriginArgPos,
OriginTermPath, NewMode, SearchResponse)
;
follow_subterm_end_search(Store, !SearchSpace,
LastUnknown, OriginId, OriginArgPos,
OriginTermPath, NewMode, SearchResponse)
)
).
% setup_binary_search(SearchSpace, TopId, BottomId, Response,
% SearchMode).
% Sets up the search mode to do a binary search between BottomId
% and TopId.
%
:- pred setup_binary_search(search_space(T)::in, suspect_id::in,
suspect_id::in, search_mode::out) is det.
setup_binary_search(SearchSpace, TopId, BottomId, SearchMode) :-
(
get_path(SearchSpace, BottomId, TopId, [], Path)
->
PathArray = array.from_list(Path),
array.bounds(PathArray, From, To),
SearchMode = binary(PathArray, From - To, From)
;
throw(internal_error("setup_binary_search",
"TopId not an ancestor of BottomId"))
).
:- pred binary_search(S::in, array(suspect_id)::in, int::in, int::in, int::in,
search_space(T)::in, search_space(T)::out, search_mode::out,
search_response::out) is det <= mercury_edt(S, T).
binary_search(Store, PathArray, From, To, LastTested, !SearchSpace, NewMode,
Response) :-
SuspectId = PathArray ^ elem(LastTested),
%
% Check what the result of the query about LastTested was and adjust
% the range appropriately.
%
(
% The oracle answered `erroneous'.
suspect_in_excluded_complement(!.SearchSpace, SuspectId)
->
NewFrom = LastTested + 1,
NewTo = To
;
% The oracle answered `correct' or `inadmissible'
suspect_in_excluded_subtree(!.SearchSpace, SuspectId)
->
NewFrom = From,
NewTo = LastTested - 1
;
% The suspect is trusted(ignored) or was skipped.
NewFrom = From,
NewTo = To
),
(
NewFrom > NewTo
->
% Revert to breadth first search when binary search is over.
breadth_first_search(Store, !SearchSpace, Response, NewMode)
;
(
find_unknown_closest_to_middle(!.SearchSpace,
PathArray, NewFrom, NewTo,
UnknownClosestToMiddle)
->
NewMode = binary(PathArray, NewFrom - NewTo,
UnknownClosestToMiddle),
Response = question(PathArray ^ elem(
UnknownClosestToMiddle))
;
% No unknown suspects on the path, so revert to
% breadth first search.
breadth_first_search(Store, !SearchSpace, Response,
NewMode)
)
).
% find_unknown_closest_to_middle(SearchSpace, PathArray, From, To,
% Unknown).
% Unknown is the position in PathArray of the suspect which has status
% unknown and is closest to halfway between From and To which are
% also indexes into PathArray. Fails if there are no unknown suspects
% between From and To (inclusive).
%
:- pred find_unknown_closest_to_middle(search_space(T)::in,
array(suspect_id)::in, int::in, int::in, int::out) is semidet.
find_unknown_closest_to_middle(SearchSpace, PathArray, From, To, Unknown) :-
Middle = From + ((To - From) // 2),
find_unknown_closest_to_range(SearchSpace, PathArray, From, To,
Middle, Middle, Unknown).
% find_unknown_closest_to_range(SearchSpace, PathArray, OuterFrom,
% OuterTo, InnerFrom, InnerTo, Unknown)
% Unknown is the position in PathArray between OuterFrom and InnerFrom
% (inclusive) or between InnerTo and OuterTo (inclusive) where the
% status of the suspect is unknown. If there are multiple such
% suspects then the one closest to the halfway point between InnerFrom
% and InnerTo is chosen. Fails if there are no unknown suspects
% matching the above criteria.
%
:- pred find_unknown_closest_to_range(search_space(T)::in,
array(suspect_id)::in, int::in, int::in, int::in, int::in, int::out)
is semidet.
find_unknown_closest_to_range(SearchSpace, PathArray, OuterFrom, OuterTo,
InnerFrom, InnerTo, Unknown) :-
InnerFrom =< InnerTo,
( OuterFrom =< InnerFrom ; InnerTo =< OuterTo ),
(
OuterFrom =< InnerFrom,
suspect_unknown(SearchSpace, PathArray ^ elem(InnerFrom))
->
Unknown = InnerFrom
;
InnerTo =< OuterTo,
suspect_unknown(SearchSpace, PathArray ^ elem(InnerTo))
->
Unknown = InnerTo
;
find_unknown_closest_to_range(SearchSpace, PathArray,
OuterFrom, OuterTo, InnerFrom - 1, InnerTo + 1,
Unknown)
).
Index: browser/declarative_debugger.m
===================================================================
RCS file: /home/mercury1/repository/mercury/browser/declarative_debugger.m,v
retrieving revision 1.39
diff -u -r1.39 declarative_debugger.m
--- browser/declarative_debugger.m 20 Sep 2004 04:50:22 -0000 1.39
+++ browser/declarative_debugger.m 27 Sep 2004 09:23:26 -0000
@@ -42,12 +42,15 @@
:- import_module mdb__io_action.
:- import_module mdbcomp__program_representation.
-:- import_module io, bool, list, std_util, string.
+:- import_module io, list, std_util, string.
% This type represents the possible truth values for nodes
% in the EDT.
%
-:- type decl_truth == bool.
+:- type decl_truth
+ ---> correct
+ ; erroneous
+ ; inadmissible.
% This type represents the possible responses to being
% asked to confirm that a node is a bug.
@@ -149,7 +152,15 @@
% value, but is suspicious of the subterm at the
% given term_path and arg_pos.
%
- ; suspicious_subterm(T, arg_pos, term_path).
+ ; suspicious_subterm(T, arg_pos, term_path)
+
+ % This node should be ignored. It cannot contain a bug
+ % but it's children may or may not contain a bug.
+ %
+ ; ignore(T)
+
+ % The oracle has deferred answering this question.
+ ; skip(T).
% The evidence that a certain node is a bug. This consists of the
% smallest set of questions whose answers are sufficient to
@@ -185,7 +196,7 @@
% The diagnoser eventually responds with a value of this type
% after it is called.
%
-:- type diagnoser_response
+:- type diagnoser_response(R)
% There was a bug found and confirmed. The
% event number is for a call port (inadmissible
@@ -211,9 +222,12 @@
% depth bound. The event number and sequence
% number are for the final event required (the
% first event required is the call event with
- % the same sequence number).
+ % the same sequence number).
+ % R is the node preceeding the call node. This is
+ % needed so the root of the new tree can have the
+ % correct preceding node.
%
- ; require_subtree(event_number, sequence_number).
+ ; require_subtree(event_number, sequence_number, R).
:- type diagnoser_state(R).
@@ -221,7 +235,7 @@
io__output_stream::in, diagnoser_state(R)::out) is det.
:- pred diagnosis(S::in, R::in, int::in, int::in, int::in,
- diagnoser_response::out,
+ diagnoser_response(R)::out,
diagnoser_state(R)::in, diagnoser_state(R)::out,
io__state::di, io__state::uo) is cc_multi <= annotated_trace(S, R).
@@ -250,11 +264,12 @@
:- implementation.
:- import_module mdb__declarative_analyser.
+:- import_module mdb__declarative_edt.
:- import_module mdb__declarative_oracle.
:- import_module mdb__declarative_tree.
:- import_module mdb__util.
-:- import_module exception, int, map.
+:- import_module exception, int, map, bool.
unravel_decl_atom(DeclAtom, TraceAtom, IoActions) :-
(
@@ -287,22 +302,22 @@
diagnoser_get_analyser(diagnoser(Analyser, _), Analyser).
-:- pred diagnoser_set_analyser(diagnoser_state(R), analyser_state(edt_node(R)),
- diagnoser_state(R)).
-:- mode diagnoser_set_analyser(in, in, out) is det.
+:- pred diagnoser_set_analyser(analyser_state(edt_node(R))::in,
+ diagnoser_state(R)::in, diagnoser_state(R)::out) is det.
-diagnoser_set_analyser(diagnoser(_, B), A, diagnoser(A, B)).
+diagnoser_set_analyser(Analyser, diagnoser(_, Oracle),
+ diagnoser(Analyser, Oracle)).
:- pred diagnoser_get_oracle(diagnoser_state(R), oracle_state).
:- mode diagnoser_get_oracle(in, out) is det.
diagnoser_get_oracle(diagnoser(_, Oracle), Oracle).
-:- pred diagnoser_set_oracle(diagnoser_state(R), oracle_state,
- diagnoser_state(R)).
-:- mode diagnoser_set_oracle(in, in, out) is det.
+:- pred diagnoser_set_oracle(oracle_state::in, diagnoser_state(R)::in,
+ diagnoser_state(R)::out) is det.
-diagnoser_set_oracle(diagnoser(A, _), B, diagnoser(A, B)).
+diagnoser_set_oracle(Oracle, diagnoser(Analyser, _),
+ diagnoser(Analyser, Oracle)).
diagnoser_state_init(IoActionMap, InStr, OutStr, Diagnoser) :-
analyser_state_init(IoActionMap, Analyser),
@@ -336,106 +351,107 @@
).
:- pred diagnosis_2(S::in, R::in, diagnoser_state(R)::in,
- {diagnoser_response, diagnoser_state(R)}::out,
+ {diagnoser_response(R), diagnoser_state(R)}::out,
io__state::di, io__state::uo) is cc_multi <= annotated_trace(S, R).
-diagnosis_2(Store, NodeId, Diagnoser0, {Response, Diagnoser}) -->
- { Analyser0 = Diagnoser0 ^ analyser_state },
- { start_analysis(wrap(Store), dynamic(NodeId), AnalyserResponse,
- Analyser0, Analyser) },
- { diagnoser_set_analyser(Diagnoser0, Analyser, Diagnoser1) },
- { debug_analyser_state(Analyser, MaybeOrigin) },
+diagnosis_2(Store, NodeId, Diagnoser0, {Response, Diagnoser}, !IO) :-
+ Analyser0 = Diagnoser0 ^ analyser_state,
+ start_analysis(wrap(Store), dynamic(NodeId), AnalyserResponse,
+ Analyser0, Analyser),
+ diagnoser_set_analyser(Analyser, Diagnoser0, Diagnoser1),
+ debug_analyser_state(Analyser, MaybeOrigin),
handle_analyser_response(Store, AnalyserResponse, MaybeOrigin,
- Response, Diagnoser1, Diagnoser).
+ Response, Diagnoser1, Diagnoser, !IO).
:- pred handle_analyser_response(S::in, analyser_response(edt_node(R))::in,
- maybe(subterm_origin(edt_node(R)))::in, diagnoser_response::out,
- diagnoser_state(R)::in, diagnoser_state(R)::out,
- io__state::di, io__state::uo) is cc_multi <= annotated_trace(S, R).
+ maybe(subterm_origin(edt_node(R)))::in, diagnoser_response(R)::out,
+ diagnoser_state(R)::in, diagnoser_state(R)::out, io__state::di,
+ io__state::uo) is cc_multi <= annotated_trace(S, R).
handle_analyser_response(_, no_suspects, _, no_bug_found, D, D) -->
io__write_string("No bug found.\n").
handle_analyser_response(Store, bug_found(Bug, Evidence), _, Response,
- Diagnoser0, Diagnoser) -->
-
+ Diagnoser0, Diagnoser) -->
confirm_bug(Store, Bug, Evidence, Response, Diagnoser0, Diagnoser).
-handle_analyser_response(Store, oracle_queries(Queries), MaybeOrigin, Response,
- Diagnoser0, Diagnoser) -->
- { diagnoser_get_oracle(Diagnoser0, Oracle0) },
- debug_origin(Flag),
+handle_analyser_response(Store, oracle_question(Question), MaybeOrigin,
+ Response, !Diagnoser, !IO) :-
+ diagnoser_get_oracle(!.Diagnoser, Oracle0),
+ debug_origin(Flag, !IO),
(
- { MaybeOrigin = yes(Origin) },
- { Flag > 0 }
+ MaybeOrigin = yes(Origin),
+ Flag > 0
->
- io__write_string("Origin: "),
- write_origin(wrap(Store), Origin),
- io__nl
+ io__write_string("Origin: ", !IO),
+ write_origin(wrap(Store), Origin, !IO),
+ io__nl(!IO)
;
- []
+ true
),
- query_oracle(Queries, OracleResponse, Oracle0, Oracle),
- { diagnoser_set_oracle(Diagnoser0, Oracle, Diagnoser1) },
- handle_oracle_response(Store, OracleResponse, Response, Diagnoser1,
- Diagnoser).
+ query_oracle(Question, OracleResponse, Oracle0, Oracle, !IO),
+ diagnoser_set_oracle(Oracle, !Diagnoser),
+ handle_oracle_response(Store, OracleResponse, Response, !Diagnoser,
+ !IO).
handle_analyser_response(Store, require_explicit(Tree), _, Response,
- Diagnoser, Diagnoser) -->
- {
- edt_subtree_details(Store, Tree, Event, Seqno),
- Response = require_subtree(Event, Seqno)
- }.
+ Diagnoser, Diagnoser, !IO) :-
+ edt_subtree_details(Store, Tree, Event, Seqno, CallPreceding),
+ Response = require_subtree(Event, Seqno, CallPreceding).
+
+handle_analyser_response(Store, revise(Question), _, Response, !Diagnoser, !IO)
+ :-
+ Oracle0 = !.Diagnoser ^ oracle_state,
+ revise_oracle(Question, Oracle0, Oracle),
+ !:Diagnoser = !.Diagnoser ^ oracle_state := Oracle,
+ handle_analyser_response(Store, oracle_question(Question), no,
+ Response, !Diagnoser, !IO).
:- pred handle_oracle_response(S::in, oracle_response(edt_node(R))::in,
- diagnoser_response::out,
- diagnoser_state(R)::in, diagnoser_state(R)::out,
- io__state::di, io__state::uo) is cc_multi <= annotated_trace(S, R).
-
-handle_oracle_response(Store, oracle_answers(Answers), Response, Diagnoser0,
- Diagnoser) -->
- { diagnoser_get_analyser(Diagnoser0, Analyser0) },
- { continue_analysis(wrap(Store), Answers, AnalyserResponse,
- Analyser0, Analyser) },
- { diagnoser_set_analyser(Diagnoser0, Analyser, Diagnoser1) },
- { debug_analyser_state(Analyser, MaybeOrigin) },
+ diagnoser_response(R)::out, diagnoser_state(R)::in,
+ diagnoser_state(R)::out, io__state::di, io__state::uo)
+ is cc_multi <= annotated_trace(S, R).
+
+handle_oracle_response(Store, oracle_answer(Answer), Response, !Diagnoser,
+ !IO) :-
+ diagnoser_get_analyser(!.Diagnoser, Analyser0),
+ continue_analysis(wrap(Store), Answer, AnalyserResponse,
+ Analyser0, Analyser),
+ diagnoser_set_analyser(Analyser, !Diagnoser),
+ debug_analyser_state(Analyser, MaybeOrigin),
handle_analyser_response(Store, AnalyserResponse, MaybeOrigin,
- Response, Diagnoser1, Diagnoser).
-
-handle_oracle_response(_, no_oracle_answers, no_bug_found, D, D) -->
- [].
+ Response, !Diagnoser, !IO).
-handle_oracle_response(Store, exit_diagnosis(Node), Response, D, D) -->
- { edt_subtree_details(Store, Node, Event, _) },
- { Response = symptom_found(Event) }.
+handle_oracle_response(Store, exit_diagnosis(Node), Response, !Diagnoser, !IO)
+ :-
+ edt_subtree_details(Store, Node, Event, _, _),
+ Response = symptom_found(Event).
-handle_oracle_response(_, abort_diagnosis, no_bug_found, D, D) -->
- io__write_string("Diagnosis aborted.\n").
+handle_oracle_response(_, abort_diagnosis, no_bug_found, !Diagnoser, !IO) :-
+ io__write_string("Diagnosis aborted.\n", !IO).
:- pred confirm_bug(S::in, decl_bug::in, decl_evidence(T)::in,
- diagnoser_response::out, diagnoser_state(R)::in,
+ diagnoser_response(R)::out, diagnoser_state(R)::in,
diagnoser_state(R)::out, io__state::di, io__state::uo) is cc_multi
<= annotated_trace(S, R).
-confirm_bug(Store, Bug, Evidence, Response, Diagnoser0, Diagnoser) -->
- { diagnoser_get_oracle(Diagnoser0, Oracle0) },
- oracle_confirm_bug(Bug, Evidence, Confirmation, Oracle0, Oracle),
- { diagnoser_set_oracle(Diagnoser0, Oracle, Diagnoser1) },
+confirm_bug(Store, Bug, Evidence, Response, !Diagnoser, !IO) :-
+ diagnoser_get_oracle(!.Diagnoser, Oracle0),
+ oracle_confirm_bug(Bug, Evidence, Confirmation, Oracle0, Oracle, !IO),
+ diagnoser_set_oracle(Oracle, !Diagnoser),
(
- { Confirmation = confirm_bug },
- { decl_bug_get_event_number(Bug, Event) },
- { Response = bug_found(Event) },
- { Diagnoser = Diagnoser1 }
+ Confirmation = confirm_bug,
+ decl_bug_get_event_number(Bug, Event),
+ Response = bug_found(Event)
;
- { Confirmation = overrule_bug },
- overrule_bug(Store, Response, Diagnoser1, Diagnoser)
+ Confirmation = overrule_bug,
+ overrule_bug(Store, Response, !Diagnoser, !IO)
;
- { Confirmation = abort_diagnosis },
- { Response = no_bug_found },
- { Diagnoser = Diagnoser1 }
+ Confirmation = abort_diagnosis,
+ Response = no_bug_found
).
-:- pred overrule_bug(S::in, diagnoser_response::out, diagnoser_state(R)::in,
+:- pred overrule_bug(S::in, diagnoser_response(R)::out, diagnoser_state(R)::in,
diagnoser_state(R)::out, io__state::di, io__state::uo) is cc_multi
<= annotated_trace(S, R).
@@ -466,7 +482,7 @@
% easier to call from C code.
%
:- pred diagnosis_store(trace_node_store::in, trace_node_id::in,
- int::in, int::in, int::in, diagnoser_response::out,
+ int::in, int::in, int::in, diagnoser_response(trace_node_id)::out,
diagnoser_state(trace_node_id)::in,
diagnoser_state(trace_node_id)::out, io__state::di, io__state::uo)
is cc_multi.
@@ -482,14 +498,15 @@
% Export some predicates so that C code can interpret the
% diagnoser response.
%
-:- pred diagnoser_bug_found(diagnoser_response, event_number).
+:- pred diagnoser_bug_found(diagnoser_response(trace_node_id), event_number).
:- mode diagnoser_bug_found(in, out) is semidet.
:- pragma export(diagnoser_bug_found(in, out), "MR_DD_diagnoser_bug_found").
diagnoser_bug_found(bug_found(Event), Event).
-:- pred diagnoser_symptom_found(diagnoser_response, event_number).
+:- pred diagnoser_symptom_found(diagnoser_response(trace_node_id),
+ event_number).
:- mode diagnoser_symptom_found(in, out) is semidet.
:- pragma export(diagnoser_symptom_found(in, out),
@@ -497,21 +514,22 @@
diagnoser_symptom_found(symptom_found(Event), Event).
-:- pred diagnoser_no_bug_found(diagnoser_response).
+:- pred diagnoser_no_bug_found(diagnoser_response(trace_node_id)).
:- mode diagnoser_no_bug_found(in) is semidet.
:- pragma export(diagnoser_no_bug_found(in), "MR_DD_diagnoser_no_bug_found").
diagnoser_no_bug_found(no_bug_found).
-:- pred diagnoser_require_subtree(diagnoser_response, event_number,
- sequence_number).
-:- mode diagnoser_require_subtree(in, out, out) is semidet.
+:- pred diagnoser_require_subtree(diagnoser_response(trace_node_id),
+ event_number, sequence_number, trace_node_id).
+:- mode diagnoser_require_subtree(in, out, out, out) is semidet.
-:- pragma export(diagnoser_require_subtree(in, out, out),
+:- pragma export(diagnoser_require_subtree(in, out, out, out),
"MR_DD_diagnoser_require_subtree").
-diagnoser_require_subtree(require_subtree(Event, SeqNo), Event, SeqNo).
+diagnoser_require_subtree(require_subtree(Event, SeqNo, CallPreceding), Event,
+ SeqNo, CallPreceding).
%-----------------------------------------------------------------------------%
@@ -569,32 +587,41 @@
%-----------------------------------------------------------------------------%
:- pred handle_diagnoser_exception(diagnoser_exception::in,
- diagnoser_response::out, diagnoser_state(R)::in,
+ diagnoser_response(R)::out, diagnoser_state(R)::in,
diagnoser_state(R)::out, io__state::di, io__state::uo) is det.
-handle_diagnoser_exception(internal_error(Loc, Msg), Response, D, D) -->
- io__stderr_stream(StdErr),
- io__write_strings(StdErr, [
- "An internal error has occurred; diagnosis will be aborted. Debugging\n",
- "message follows:\n",
- Loc, ": ", Msg, "\n",
- "Please report bugs to mercury-bugs at cs.mu.oz.au.\n"]),
- { Response = no_bug_found }.
-
-handle_diagnoser_exception(io_error(Loc, Msg), Response, D, D) -->
- io__stderr_stream(StdErr),
- io__write_strings(StdErr, [
- "I/O error: ", Loc, ": ", Msg, ".\n",
- "Diagnosis will be aborted.\n"]),
- { Response = no_bug_found }.
-
-handle_diagnoser_exception(unimplemented_feature(Feature), Response, D, D) -->
- io__write_strings([
- "Sorry, the diagnosis cannot continue because it requires support for\n",
- "the following: ", Feature, ".\n",
- "The debugger is a work in progress, and this is not supported in the\n",
- "current version.\n"]),
- { Response = no_bug_found }.
+handle_diagnoser_exception(internal_error(Loc, Msg), Response, !Diagnoser, !IO)
+ :-
+ io__stderr_stream(StdErr, !IO),
+ io__write_string(StdErr, "An internal error has occurred; "++
+ "diagnosis will be aborted. Debugging\n"++
+ "message follows:\n"++Loc++": "++Msg++"\n"++
+ "Please report bugs to mercury-bugs at cs.mu.oz.au.\n", !IO),
+ % Reset the analyser, in case it was left in an inconsistent state.
+ reset_analyser(!.Diagnoser ^ analyser_state, Analyser),
+ !:Diagnoser = !.Diagnoser ^ analyser_state := Analyser,
+ Response = no_bug_found.
+
+handle_diagnoser_exception(io_error(Loc, Msg), Response, !Diagnoser, !IO) :-
+ io__stderr_stream(StdErr, !IO),
+ io__write_string(StdErr, "I/O error: "++Loc++": "++Msg++".\n"++
+ "Diagnosis will be aborted.\n", !IO),
+ % Reset the analyser, in case it was left in an inconsistent state.
+ reset_analyser(!.Diagnoser ^ analyser_state, Analyser),
+ !:Diagnoser = !.Diagnoser ^ analyser_state := Analyser,
+ Response = no_bug_found.
+
+handle_diagnoser_exception(unimplemented_feature(Feature), Response,
+ !Diagnoser, !IO) :-
+ io__write_string("Sorry, the diagnosis cannot continue because "++
+ "it requires support for\n"++
+ "the following: "++Feature++".\n"++
+ "The debugger is a work in progress, and this is not "++
+ "supported in the\ncurrent version.\n", !IO),
+ % Reset the analyser, in case it was left in an inconsistent state.
+ reset_analyser(!.Diagnoser ^ analyser_state, Analyser),
+ !:Diagnoser = !.Diagnoser ^ analyser_state := Analyser,
+ Response = no_bug_found.
%-----------------------------------------------------------------------------%
Index: browser/declarative_edt.m
===================================================================
RCS file: browser/declarative_edt.m
diff -N browser/declarative_edt.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ browser/declarative_edt.m 28 Sep 2004 13:09:44 -0000
@@ -0,0 +1,1162 @@
+%-----------------------------------------------------------------------------%
+% Copyright (C) 1999-2003 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_edt.m
+% Authors: Ian MacLarty, Mark Brown
+%
+% This module defines Evaluation Dependency Trees (EDTs) which represent the
+% dependencies between calls made during the execution of a buggy program.
+% Search spaces are also defined as a layer on top of EDTs. A search space
+% records extra information that is used when searching for bugs in EDTs and
+% also provides a way to reference nodes in the EDT independent of whether
+% a node is represented implicitly or explicitly. By convention nodes in the
+% search space are referred to as `suspects', while nodes in the EDT are
+% referred to as `EDT nodes', or just `nodes'.
+%
+
+:- module mdb.declarative_edt.
+
+:- interface.
+
+:- import_module mdbcomp.program_representation.
+:- import_module mdb.io_action.
+:- import_module mdb.declarative_debugger.
+
+:- import_module list, std_util.
+
+ % This typeclass defines how EDTs may be accessed by this module.
+ % An EDT is a tree of nodes, each of which contains a question
+ % about the truth of an assertion. The children of a node may
+ % not be immediately accessible if the sub-tree beneath that
+ % node is represented implicitly. In this case, the analyser
+ % must request that it be made explicit before continuing.
+ %
+ % The first argument is intuitively a "store", which maps
+ % references to the things they reference. The second argument
+ % is the type of trees themselves. By convention, we use the
+ % names S and T for type variables which are constrained by
+ % mercury_edt.
+ %
+ % By convention, we also use the names S and T in type declarations
+ % where it is *intended* that the type variables be constrained by
+ % mercury_edt.
+ %
+ % (Compare with the similar conventions for annotated_trace/2.)
+ %
+:- typeclass mercury_edt(S, T) where [
+
+ % Returns the question corresponding to the given node.
+ %
+ pred edt_question(io_action_map::in, S::in, T::in,
+ decl_question(T)::out) is det,
+
+ % If this node is an e_bug, then find the bug.
+ %
+ pred edt_root_e_bug(io_action_map::in, S::in, T::in, decl_e_bug::out)
+ is det,
+
+ % edt_root_i_bug(Store, BugNode, InadmissibleChild, Bug)
+ % Get the I-bug corresponding to the give erroneous node
+ % (BugNode) and its inadmissible child.
+ %
+ pred edt_root_i_bug(S::in, T::in, T::in, decl_i_bug::out) is det,
+
+ % Gives the list of children of a tree. If the tree is
+ % represented implicitly, then the procedure fails.
+ %
+ pred edt_children(S::in, T::in, list(T)::out) is semidet,
+
+ % Given a subterm of a tree, find the mode of that subterm
+ % and the origin of it amongst the parent, siblings or
+ % children.
+ %
+ pred edt_dependency(S, T, arg_pos, term_path, subterm_mode,
+ subterm_origin(T)),
+ mode edt_dependency(in, in, in, in, out, out) is det,
+
+ % Just find the mode of the subterm.
+ %
+ pred edt_subterm_mode(S::in, T::in, arg_pos::in, term_path::in,
+ subterm_mode::out) is det,
+
+ % Succeeds if the Node is the root of an implicit subtree.
+ % Fails otherwise.
+ %
+ pred edt_implicit_root(S::in, T::in) is semidet
+].
+
+:- type subterm_mode
+ ---> subterm_in
+ ; subterm_out.
+
+:- type subterm_origin(T)
+
+ % Subterm came from an output of a child or sibling
+ % call. The first argument records the child or sibling
+ % edt node. The second and third arguments state which
+ % part of which argument is the origin.
+ ---> output(T, arg_pos, term_path)
+
+ % Subterm came from an input of the parent. The
+ % arguments identify which part of which argument of
+ % the clause head is the origin.
+ ; input(arg_pos, term_path)
+
+ % Subterm was constructed in the body. We record
+ % the filename and line number of the primitive
+ % operation (unification or inlined foreign_proc)
+ % that constructed it.
+ ; primitive_op(string, int)
+
+ % The origin could not be found due to missing
+ % information.
+ ; not_found.
+
+ % This type defines a search space in which the declarative debugger
+ % can look for bugs. The search space keeps track of which nodes in
+ % the EDT could contain a bug as well as skipped or ignored nodes.
+ % Each suspect in the search space has an identifier (suspect_id)
+ % that's independent of the EDT node id and independent of whether the
+ % EDT node is represented implicitly or explicitly.
+ %
+ % Information about each node that is relevant to the bug search is
+ % stored in the search space. For example information about the status
+ % of the node like whether it was skipped, ignored or marked erroneous,
+ % correct or inadmissible and the depth of each node in the EDT is
+ % stored here. In future information like the probability that a node
+ % contains a bug could also be stored here.
+ %
+:- type search_space(T).
+
+ % suspect_id is used to lookup suspects in the search space. Each
+ % suspect in the search space will have a unique suspect_id. When an
+ % explicit subtree is generated, a new EDT node is generated for the
+ % root of the explicit subtree, replacing the EDT node that represented
+ % the subtree implicitly. However the suspect_id will remain
+ % unchanged. Any search algorithms that needs to keep track of EDT
+ % nodes can use suspect_ids for this purpose and not have to worry
+ % about updating these when an explicit subtree is generated.
+ %
+:- type suspect_id.
+
+ % Succeeds if the given search space contains no suspects.
+ %
+:- pred empty_search_space(search_space(T)::out) is det.
+
+ % Creates a new search space containing just the one EDT node.
+ %
+:- pred initialise_search_space(T::in, search_space(T)::out) is det.
+
+ % The root of the search space is the root of the subtree of the EDT
+ % that we think contains a bug, based on information received so far.
+ % Normally the root will be marked erroneous, but it could also be
+ % marked unknown, skipped or ignored (for example when the search has
+ % just started and the oracle hasn't asserted any suspects are
+ % erroneous or when a bug search is being revised. This pred returns
+ % the root, or fails if the search space is empty.
+ %
+:- pred root(search_space(T)::in, suspect_id::out) is semidet.
+
+ % Returns the root but throws an exception if the search space is
+ % empty.
+ %
+:- pred root_det(search_space(T)::in, suspect_id::out) is det.
+
+ % no_more_questions(Store, !SearchSpace, CorrectDescendents,
+ % InadmissibleChildren).
+ % Succeeds if the root of the search space has only correct,
+ % inadmissible, pruned or ignored descendents. The direct children of
+ % the root who are inadmissible are placed in InadmissibleChildren.
+ % CorrectDescendents is all the correct and inadmissible
+ % descendents of the root.
+ %
+:- pred no_more_questions(S::in, search_space(T)::in, search_space(T)::out,
+ list(suspect_id)::out, list(suspect_id)::out)
+ is semidet <= mercury_edt(S, T).
+
+ % children(Store, SuspectId, !SearchSpace, Children).
+ % Children is the list of children of SuspectId in the SearchSpace. If
+ % the children were not in the search space then they are added. Fails
+ % if SuspectId is the root of an implicit subtree.
+ %
+:- pred children(S::in, suspect_id::in, search_space(T)::in,
+ search_space(T)::out, list(suspect_id)::out)
+ is semidet <= mercury_edt(S, T).
+
+ % Marks the suspect correct and alls its decendents as pruned.
+ %
+:- pred assert_suspect_is_correct(suspect_id::in, search_space(T)::in,
+ search_space(T)::out) is det.
+
+ % Marks the supect erroneous and marks the complement of the subtree
+ % rooted at the erroneous suspect as in_erroneous_subtree_complement.
+ %
+:- pred assert_suspect_is_erroneous(suspect_id::in, search_space(T)::in,
+ search_space(T)::out) is det.
+
+ % Marks the suspect inadmissible and alls its decendents as pruned.
+ %
+:- pred assert_suspect_is_inadmissible(suspect_id::in, search_space(T)::in,
+ search_space(T)::out) is det.
+
+ % Marks the suspect ignored.
+ %
+:- pred ignore_suspect(suspect_id::in, search_space(T)::in,
+ search_space(T)::out) is det.
+
+ % Marks the suspect as skipped.
+ %
+:- pred skip_suspect(suspect_id::in, search_space(T)::in, search_space(T)::out)
+ is det.
+
+ % find_subterm_origin(Store, SuspectId, ArgPos, TermPath, !SearchSpace,
+ % Response).
+ % Finds the origin of the subterm given by SuspectId, ArgPos and
+ % TermPath in its immediate neighbors. If the children of a suspect
+ % are required then they'll be added to the search space, unless an
+ % explicit subtree is required in which case the appropriate response
+ % is returned (see definition of find_origin_response type below).
+ %
+:- pred find_subterm_origin(S::in, suspect_id::in, arg_pos::in, term_path::in,
+ search_space(T)::in, search_space(T)::out, find_origin_response::out)
+ is det <= mercury_edt(S, T).
+
+:- type find_origin_response
+ % The origin couldn't be found because of insufficient
+ % tracing information.
+ ---> not_found
+
+ % The subterm originated from the suspect referenced by
+ % argument 1. The 2nd and 3rd arguments give the
+ % position of the subterm in the origin node.
+ ; origin(suspect_id, arg_pos, term_path)
+
+ % The subterm was bound by a primitive operation inside
+ % the suspect. The arguments are the filename and line
+ % number of primitive op that bound the subterm.
+ ; primitive_op(string, int)
+
+ % The suspect is the root of an implicit subtree and
+ % the origin lies in one of it's children.
+ ; require_explicit.
+
+ % Returns the depth of the suspect in the EDT.
+ %
+:- pred depth(suspect_id::in, search_space(T)::in, int::out) is det.
+
+ % travel_up(SearchSpace, SuspectId, N, AncestorId).
+ % True iff AncestorId is the Nth ancestor of SuspectId in SearchSpace.
+ %
+:- pred travel_up(search_space(_)::in, suspect_id::in, int::in,
+ suspect_id::out) is det.
+
+ % incorporate_explicit_subtree(SuspectId, Node, !SearchSpace).
+ % Replaces the EDT node referenced by SuspectId with Node.
+:- pred incorporate_explicit_subtree(suspect_id::in, T::in,
+ search_space(T)::in, search_space(T)::out) is det.
+
+ % Makes the given suspect the root of the search space and also changes
+ % it and all it's descendent's status to unknown (except for skipped
+ % and ignored nodes which are left as is).
+ %
+:- pred revise_suspect(suspect_id::in, search_space(T)::in,
+ search_space(T)::out) is det.
+
+ % Return the EDT node corresponding to the suspect_id.
+ %
+:- func get_edt_node(search_space(T), suspect_id) = T.
+
+ % Succeeds if the suspect has been marked correct or inadmissible
+ % or is the descendent of a suspect that was marked correct or
+ % inadmissible. Fails otherwise.
+ %
+:- pred suspect_in_excluded_subtree(search_space(T)::in, suspect_id::in)
+ is semidet.
+
+ % Succeeds if the suspect has been marked erroneous or is in the
+ % complement of a subtree with an erroneous root. Fails otherwise.
+ %
+:- pred suspect_in_excluded_complement(search_space(T)::in, suspect_id::in)
+ is semidet.
+
+ % Succeeds if the suspect's status is unknown.
+ %
+:- pred suspect_unknown(search_space(T)::in, suspect_id::in) is semidet.
+
+ % Succeeds if the suspect's status is erroneous.
+ %
+:- pred suspect_erroneous(search_space(T)::in, suspect_id::in) is semidet.
+
+ % Succeeds if the suspect's status is skipped.
+ %
+:- pred suspect_skipped(search_space(T)::in, suspect_id::in) is semidet.
+
+ % Succeeds if the suspect's status is ignored.
+ %
+:- pred suspect_ignored(search_space(T)::in, suspect_id::in) is semidet.
+
+ % first_unknown_descendent_breadth(Store, SuspectId, !SearchSpace,
+ % MaybeDescendent).
+ % Search the search space for a suspect with status = unknown in a
+ % breadth first fashion, starting with SuspectId. If no unknown
+ % suspect is found then MaybeDescendent will be no. If there are no
+ % unknown suspects in the explicit part of the search space and a
+ % skipped, ignored or erroneous suspect is the root of an implicit
+ % subtree, then the call will fail.
+ %
+:- pred first_unknown_descendent_breadth(S::in, suspect_id::in,
+ search_space(T)::in, search_space(T)::out, maybe(suspect_id)::out)
+ is semidet <= mercury_edt(S, T).
+
+ % choose_skipped_suspect(SearchSpace, Skipped) True iff Skipped is the
+ % skipped suspect in SearchSpace with the lowest skip order (i.e. was
+ % skipped the longest time ago). Fails if there are no skipped
+ % suspects in SearchSpace.
+ %
+:- pred choose_skipped_suspect(search_space(T)::in, suspect_id::out)
+ is semidet.
+
+ % pick_implicit_root(Store, SearchSpace, ImplicitRoot) succeeds if
+ % ImplicitRoot is the root of an implicit subtree and the status of
+ % ImplicitRoot is unknown, skipped or ignored. If there are multiple
+ % such roots then one is committed to. XXX currently the ImplicitRoot
+ % is chosen naively, but in future better methods could be used to pick
+ % an implicit root (such as the implicit root whos subtree is most
+ % lightly to contain a bug according to some heuristic(s)).
+ %
+:- pred pick_implicit_root(S::in, search_space(T)::in, suspect_id::out)
+ is semidet <= mercury_edt(S, T).
+
+ % get_path(SearchSpace, FromId, ToId, InitialPath, Path).
+ % Path is InitialPath appended to the list of suspect_id's between
+ % FromId and ToId (inclusive). ToId should be an ancestor of FromId.
+ % If it isn't then the call will fail.
+ %
+:- pred get_path(search_space(T)::in, suspect_id::in, suspect_id::in,
+ list(suspect_id)::in, list(suspect_id)::out) is semidet.
+
+ % Succeeds if the suspect has been marked correct or
+ % inadmissible.
+ %
+:- pred suspect_correct_or_inadmissible(search_space(T)::in, suspect_id::in)
+ is semidet.
+
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- import_module exception, map, int, counter, std_util, string, bool.
+
+ % A suspect is an edt node with some additional information relevant
+ % to the bug search.
+ %
+:- type suspect(T)
+ ---> suspect(
+ % The suspect's parent id in the search space.
+ % no if the suspect is at the root of the
+ % search space.
+ parent :: maybe(suspect_id),
+
+ % The EDT node.
+ edt_node :: T,
+
+ % What is the status of this node with
+ % respect to the bug search.
+ status :: suspect_status,
+
+ % The depth of the suspect in the EDT.
+ depth :: int,
+
+ % The children of the suspect. If this is
+ % no then the children have not yet been
+ % explored. Children are only added to the
+ % search space when they are required.
+ children :: maybe(list(suspect_id))
+ ).
+
+:- type suspect_status
+ ---> ignored
+ ; skipped(int) % We record the order nodes were skipped in.
+ ; correct
+ ; erroneous
+ ; inadmissible
+
+ % The suspect is in a subtree with a correct or
+ % inadmissible root.
+ ; pruned
+
+ % The suspect was in the complement of a subtree with
+ % an erroneous root.
+ ; in_erroneous_subtree_complement
+ ; unknown.
+
+:- type suspect_id == int.
+
+:- type search_space(T)
+ ---> search_space(
+ % The root of the (potentially) buggy subtree
+ % in the search space. The search space root
+ % will be the last suspect marked erroneous,
+ % except for when the search first starts and
+ % the oracle hasn't asserted any suspects are
+ % erroneous, or when the root of the EDT is
+ % revised (so its erroneous status is reset).
+ root :: maybe(suspect_id),
+
+ % Counter for generating suspect_ids.
+ suspect_id_counter :: counter,
+
+ % So we can keep the skipped nodes in some
+ % kind of order to avoid asking about
+ % the same skipped node twice in a row.
+ skip_counter :: counter,
+
+ % The collection of suspects in the search
+ % space.
+ store :: map(suspect_id, suspect(T)),
+
+ % A map of roots of implicit subtrees in the
+ % EDT to explicit subtrees.
+ implicit_roots_to_explicit_roots :: map(T, T)
+ ).
+
+empty_search_space(search_space(no, counter.init(0), counter.init(0),
+ map.init, map.init)).
+
+root(SearchSpace, RootId) :- SearchSpace ^ root = yes(RootId).
+
+root_det(SearchSpace, RootId) :-
+ (
+ SearchSpace ^ root = yes(Id),
+ RootId = Id
+ ;
+ SearchSpace ^ root = no,
+ throw(internal_error("root_det", "search space empty"))
+ ).
+
+no_more_questions(Store, !SearchSpace, CorrectDescendents,
+ InadmissibleChildren) :-
+ root_det(!.SearchSpace, RootId),
+ !.SearchSpace ^ root = yes(RootId),
+ \+ suspect_is_questionable(!.SearchSpace, RootId),
+ (
+ suspect_in_buggy_subtree(!.SearchSpace, RootId)
+ ->
+ children(Store, RootId, !SearchSpace, Children),
+ non_ignored_descendents(Store, Children, !SearchSpace,
+ Descendents),
+ filter(suspect_correct_or_inadmissible(!.SearchSpace),
+ Descendents, CorrectDescendents, []),
+ filter(suspect_inadmissible(!.SearchSpace), Children,
+ InadmissibleChildren)
+ ;
+ CorrectDescendents = [],
+ InadmissibleChildren = []
+ ).
+
+suspect_correct_or_inadmissible(SearchSpace, SuspectId) :-
+ lookup_suspect(SearchSpace, SuspectId, Suspect),
+ Status = Suspect ^ status,
+ ( Status = correct ; Status = inadmissible ).
+
+ % Succeeds if the suspect is in a part of the search space that could
+ % contain a bug.
+ %
+:- pred suspect_in_buggy_subtree(search_space(T)::in,
+ suspect_id::in) is semidet.
+
+suspect_in_buggy_subtree(SearchSpace, SuspectId) :-
+ in_buggy_subtree(get_status(SearchSpace, SuspectId), yes).
+
+:- pred suspect_inadmissible(search_space(T)::in, suspect_id::in) is semidet.
+
+suspect_inadmissible(SearchSpace, SuspectId) :-
+ lookup_suspect(SearchSpace, SuspectId, Suspect),
+ Suspect ^ status = inadmissible.
+
+suspect_unknown(SearchSpace, SuspectId) :-
+ lookup_suspect(SearchSpace, SuspectId, Suspect),
+ Suspect ^ status = unknown.
+
+suspect_erroneous(SearchSpace, SuspectId) :-
+ lookup_suspect(SearchSpace, SuspectId, Suspect),
+ Suspect ^ status = erroneous.
+
+suspect_skipped(SearchSpace, SuspectId) :-
+ lookup_suspect(SearchSpace, SuspectId, Suspect),
+ Suspect ^ status = skipped(_).
+
+suspect_ignored(SearchSpace, SuspectId) :-
+ lookup_suspect(SearchSpace, SuspectId, Suspect),
+ Suspect ^ status = ignored.
+
+suspect_in_excluded_subtree(SearchSpace, SuspectId) :-
+ lookup_suspect(SearchSpace, SuspectId, Suspect),
+ excluded_subtree(Suspect ^ status, yes).
+
+ % Succeeds if we haven't got an answer from the oracle about this
+ % suspect, and haven't been able to infer anything about this suspect
+ % from other oracle answers?
+ %
+:- pred suspect_is_questionable(search_space(T)::in, suspect_id::in)
+ is semidet.
+
+suspect_is_questionable(SearchSpace, SuspectId) :-
+ questionable(get_status(SearchSpace, SuspectId), yes).
+
+ % Does the given status mean the suspect is in a subtree that was
+ % excluded from the bug search (because it was marked correct or
+ % inadmissible or is the descedent of such a suspect)?
+ %
+:- pred excluded_subtree(suspect_status::in, bool::out) is det.
+
+excluded_subtree(ignored, no).
+excluded_subtree(skipped(_), no).
+excluded_subtree(correct, yes).
+excluded_subtree(erroneous, no).
+excluded_subtree(inadmissible, yes).
+excluded_subtree(pruned, yes).
+excluded_subtree(in_erroneous_subtree_complement, no).
+excluded_subtree(unknown, no).
+
+ % Does the status mean we haven't got an answer from the oracle, or
+ % haven't been able to infer anything about this suspect from other
+ % oracle answers?
+ %
+:- pred questionable(suspect_status::in, bool::out) is det.
+
+questionable(ignored, no).
+questionable(skipped(_), yes).
+questionable(correct, no).
+questionable(erroneous, no).
+questionable(inadmissible, no).
+questionable(pruned, no).
+questionable(in_erroneous_subtree_complement, no).
+questionable(unknown, yes).
+
+suspect_in_excluded_complement(SearchSpace, SuspectId) :-
+ lookup_suspect(SearchSpace, SuspectId, Suspect),
+ excluded_complement(Suspect ^ status, yes).
+
+ % Does the given status mean the suspect is in the complement of
+ % a subtree whos root was marked erroneous or is erroneous itself.
+ %
+:- pred excluded_complement(suspect_status::in, bool::out) is det.
+
+excluded_complement(ignored, no).
+excluded_complement(skipped(_), no).
+excluded_complement(correct, no).
+excluded_complement(erroneous, yes).
+excluded_complement(inadmissible, no).
+excluded_complement(pruned, no).
+excluded_complement(in_erroneous_subtree_complement, yes).
+excluded_complement(unknown, no).
+
+ % Does the given status mean the suspect is in a subtree that could
+ % contain a bug.
+ %
+:- pred in_buggy_subtree(suspect_status::in, bool::out) is det.
+
+in_buggy_subtree(ignored, yes).
+in_buggy_subtree(skipped(_), yes).
+in_buggy_subtree(correct, no).
+in_buggy_subtree(erroneous, yes).
+in_buggy_subtree(inadmissible, no).
+in_buggy_subtree(pruned, no).
+in_buggy_subtree(in_erroneous_subtree_complement, no).
+in_buggy_subtree(unknown, yes).
+
+
+ % Should the suspect's status be propogated to it's children when the
+ % children are added to the search space?
+ %
+:- pred propogate_status_to_children(suspect_status::in, bool::out) is det.
+
+propogate_status_to_children(ignored, no).
+propogate_status_to_children(skipped(_), no).
+propogate_status_to_children(correct, no).
+propogate_status_to_children(erroneous, no).
+propogate_status_to_children(inadmissible, no).
+propogate_status_to_children(pruned, yes).
+propogate_status_to_children(in_erroneous_subtree_complement, yes).
+propogate_status_to_children(unknown, no).
+
+assert_suspect_is_correct(SuspectId, !SearchSpace) :-
+ lookup_suspect(!.SearchSpace, SuspectId, Suspect),
+ map.set(!.SearchSpace ^ store, SuspectId, Suspect ^ status :=
+ correct, Store),
+ !:SearchSpace = !.SearchSpace ^ store := Store,
+ (
+ Suspect ^ children = yes(Children),
+ list.foldl(trickle_status(pruned), Children,
+ !SearchSpace)
+ ;
+ Suspect ^ children = no
+ ).
+
+assert_suspect_is_erroneous(SuspectId, !SearchSpace) :-
+ lookup_suspect(!.SearchSpace, SuspectId, Suspect),
+ map.set(!.SearchSpace ^ store, SuspectId, Suspect ^ status :=
+ erroneous, Store),
+ !:SearchSpace = !.SearchSpace ^ store := Store,
+ exclude_complement(SuspectId, !SearchSpace),
+ !:SearchSpace = !.SearchSpace ^ root := yes(SuspectId).
+
+assert_suspect_is_inadmissible(SuspectId, !SearchSpace) :-
+ lookup_suspect(!.SearchSpace, SuspectId, Suspect),
+ map.set(!.SearchSpace ^ store, SuspectId, Suspect ^ status :=
+ inadmissible, Store),
+ !:SearchSpace = !.SearchSpace ^ store := Store,
+ (
+ Suspect ^ children = yes(Children),
+ list.foldl(trickle_status(pruned), Children,
+ !SearchSpace)
+ ;
+ Suspect ^ children = no
+ ).
+
+ignore_suspect(SuspectId, !SearchSpace) :-
+ lookup_suspect(!.SearchSpace, SuspectId, Suspect),
+ map.set(!.SearchSpace ^ store, SuspectId, Suspect ^ status :=
+ ignored, Store),
+ !:SearchSpace = !.SearchSpace ^ store := Store.
+
+skip_suspect(SuspectId, !SearchSpace) :-
+ lookup_suspect(!.SearchSpace, SuspectId, Suspect),
+ counter.allocate(N, !.SearchSpace ^ skip_counter, SkipCounter),
+ !:SearchSpace = !.SearchSpace ^ skip_counter := SkipCounter,
+ map.set(!.SearchSpace ^ store, SuspectId, Suspect ^ status :=
+ skipped(N), Store),
+ !:SearchSpace = !.SearchSpace ^ store := Store.
+
+depth(SuspectId, SearchSpace, Depth) :-
+ lookup_suspect(SearchSpace, SuspectId, Suspect),
+ Suspect ^ depth = Depth.
+
+travel_up(SearchSpace, StartId, Distance, FinishId) :-
+ (
+ Distance > 0,
+ lookup_suspect(SearchSpace, StartId, Suspect),
+ Suspect ^ parent = yes(ParentId)
+ ->
+ travel_up(SearchSpace, ParentId, Distance - 1, FinishId)
+ ;
+ FinishId = StartId
+ ).
+
+find_subterm_origin(Store, SuspectId, ArgPos, TermPath, !SearchSpace,
+ Response) :-
+ lookup_suspect(!.SearchSpace, SuspectId, Suspect),
+ Node = Suspect ^ edt_node,
+ edt_dependency(Store, Node, ArgPos, TermPath, Mode, Origin),
+ (
+ Origin = primitive_op(FileName, LineNo),
+ Response = primitive_op(FileName, LineNo)
+ ;
+ Origin = not_found,
+ Response = not_found
+ ;
+ Origin = input(InputArgPos, InputTermPath),
+ (
+ Mode = subterm_in,
+ (
+ Suspect ^ parent = yes(ParentId),
+ Response = origin(ParentId, InputArgPos,
+ InputTermPath)
+ ;
+ Suspect ^ parent = no,
+ % Origin lies above the root of the search
+ % space, so return not_found.
+ Response = not_found
+ )
+ ;
+ Mode = subterm_out,
+ Response = origin(SuspectId, InputArgPos,
+ InputTermPath)
+ )
+ ;
+ Origin = output(OriginNode, OutputArgPos, OutputTermPath),
+ (
+ map.search(
+ !.SearchSpace^implicit_roots_to_explicit_roots,
+ OriginNode, ExplicitNode)
+ ->
+ ExplicitOrigin = ExplicitNode
+ ;
+ ExplicitOrigin = OriginNode
+ ),
+ (
+ Mode = subterm_in,
+ get_siblings(!.SearchSpace, SuspectId, Siblings),
+ (
+ find_edt_node_in_suspect_list(Siblings,
+ ExplicitOrigin, !.SearchSpace,
+ OriginId)
+ ->
+ Response = origin(OriginId, OutputArgPos,
+ OutputTermPath)
+ ;
+ throw(internal_error("find_subterm_origin",
+ "output origin for input subterm "++
+ "not in siblings"))
+ )
+ ;
+ Mode = subterm_out,
+ (
+ children(Store, SuspectId, !.SearchSpace,
+ SearchSpace1, Children)
+ ->
+ !:SearchSpace = SearchSpace1,
+ (
+ find_edt_node_in_suspect_list(Children,
+ ExplicitOrigin, !.SearchSpace,
+ OriginId)
+ ->
+ Response = origin(OriginId,
+ OutputArgPos, OutputTermPath)
+ ;
+ throw(internal_error(
+ "find_subterm_origin",
+ "output origin for output "++
+ "subterm not in children"))
+ )
+ ;
+ Response = require_explicit
+ )
+ )
+ ).
+
+ % Returns the suspect id in the given list that refers to the given edt
+ % node or fails if it can't find such a suspect in the list.
+ %
+:- pred find_edt_node_in_suspect_list(list(suspect_id)::in, T::in,
+ search_space(T)::in, suspect_id::out) is semidet.
+
+find_edt_node_in_suspect_list([SuspectId | SuspectIds], Node, SearchSpace,
+ FoundId) :-
+ (
+ map.search(SearchSpace ^ store, SuspectId, Suspect),
+ Node = Suspect ^ edt_node
+ ->
+ FoundId = SuspectId
+ ;
+ find_edt_node_in_suspect_list(SuspectIds, Node, SearchSpace,
+ FoundId)
+ ).
+
+ % Looks up the suspect in the search space and throws an exception if
+ % it can't find the suspect.
+ %
+:- pred lookup_suspect(search_space(T)::in, suspect_id::in, suspect(T)::out)
+ is det.
+
+lookup_suspect(SearchSpace, SuspectId, Suspect) :-
+ (
+ map.search(SearchSpace ^ store, SuspectId, FoundSuspect)
+ ->
+ Suspect = FoundSuspect
+ ;
+ throw(internal_error("lookup_suspect",
+ "couldn't find suspect"))
+ ).
+
+ % Sets the status of a node and all it's descendents to the given
+ % status. If a descendent already has the status then trickle_status
+ % assumes all it's descendents already have the same status and won't
+ % bother updating them.
+ %
+:- pred trickle_status(suspect_status::in, suspect_id::in, search_space(T)::in,
+ search_space(T)::out) is det.
+
+trickle_status(Status, SuspectId, !SearchSpace) :-
+ lookup_suspect(!.SearchSpace, SuspectId, Suspect),
+ (
+ Suspect ^ status \= Status
+ ->
+ map.set(!.SearchSpace ^ store, SuspectId,
+ Suspect ^ status := Status, Store),
+ !:SearchSpace = !.SearchSpace ^ store := Store,
+ (
+ Suspect ^ children = yes(Children),
+ list.foldl(trickle_status(Status), Children,
+ !SearchSpace)
+ ;
+ Suspect ^ children = no
+ )
+ ;
+ true
+ ).
+
+ % Marks all suspects not in the subtree with the given suspect
+ % as the root as in_erroneous_subtree_complement.
+ %
+:- pred exclude_complement(suspect_id::in, search_space(T)::in,
+ search_space(T)::out) is det.
+
+exclude_complement(SuspectId, !SearchSpace) :-
+ lookup_suspect(!.SearchSpace, SuspectId, Suspect),
+ Status = get_status(!.SearchSpace, SuspectId),
+ (
+ Status \= in_erroneous_subtree_complement
+ ->
+ (
+ Suspect ^ parent = yes(ParentId)
+ ->
+ get_siblings(!.SearchSpace, SuspectId, Siblings),
+ list.foldl(trickle_status(
+ in_erroneous_subtree_complement),
+ Siblings, !SearchSpace),
+ exclude_complement(ParentId, !SearchSpace),
+ lookup_suspect(!.SearchSpace, ParentId, Parent),
+ map.set(!.SearchSpace ^ store, ParentId,
+ Parent ^ status :=
+ in_erroneous_subtree_complement, Store),
+ !:SearchSpace = !.SearchSpace ^ store := Store,
+ !:SearchSpace = !.SearchSpace ^ root := yes(SuspectId)
+ ;
+ true
+ )
+ ;
+ true
+ ).
+
+ % Find the siblings of a suspect in the search space. This does not
+ % include the suspect itself.
+ %
+:- pred get_siblings(search_space(T)::in, suspect_id::in,
+ list(suspect_id)::out) is det.
+
+get_siblings(SearchSpace, SuspectId, Siblings) :-
+ lookup_suspect(SearchSpace, SuspectId, Suspect),
+ (
+ Suspect ^ parent = yes(ParentId),
+ lookup_suspect(SearchSpace, ParentId, Parent),
+ (
+ Parent ^ children = yes(Children),
+ (
+ Children = [_ | _],
+ list.filter(unify(SuspectId), Children, _,
+ Siblings)
+ ;
+ Children = [],
+ throw(internal_error("get_siblings",
+ "parent has no children"))
+ )
+ ;
+ Parent ^ children = no,
+ throw(internal_error("get_siblings",
+ "parent's children unexplored"))
+ )
+ ;
+ Suspect ^ parent = no,
+ Siblings = []
+ ).
+
+ % Add the list of EDT nodes to the search space as children to
+ % the given suspect. The suspect_ids for the new suspects will
+ % also be returned.
+ %
+:- pred add_children(list(T)::in, suspect_id::in, suspect_status::in,
+ search_space(T)::in, search_space(T)::out, list(suspect_id)::out)
+ is det.
+
+add_children(EDTChildren, SuspectId, Status, !SearchSpace, Children) :-
+ Counter0 = !.SearchSpace ^ suspect_id_counter,
+ lookup_suspect(!.SearchSpace, SuspectId, Suspect),
+ add_children_2(EDTChildren, SuspectId, Status, Suspect ^ depth + 1,
+ !SearchSpace, Counter0, Counter, Children),
+ !:SearchSpace = !.SearchSpace ^ suspect_id_counter := Counter,
+ map.set(!.SearchSpace ^ store, SuspectId,
+ Suspect ^ children := yes(Children), Store),
+ !:SearchSpace = !.SearchSpace ^ store := Store.
+
+:- pred add_children_2(list(T)::in, suspect_id::in, suspect_status::in,
+ int::in, search_space(T)::in, search_space(T)::out, counter::in,
+ counter::out, list(suspect_id)::out) is det.
+
+add_children_2([], _, _, _, SearchSpace, SearchSpace, Counter, Counter, []).
+
+add_children_2([EDTChild | EDTChildren], SuspectId, Status, Depth,
+ !SearchSpace, !Counter, Children) :-
+ (
+ allocate(NextId, !Counter),
+ map.det_insert(!.SearchSpace ^ store, NextId,
+ suspect(yes(SuspectId), EDTChild, Status, Depth,
+ no), Store),
+ !:SearchSpace = !.SearchSpace ^ store := Store,
+ add_children_2(EDTChildren, SuspectId, Status, Depth,
+ !SearchSpace, !Counter, OtherChildren),
+ Children = [NextId | OtherChildren]
+ ).
+
+initialise_search_space(Node, SearchSpace) :-
+ map.set(init, 0, suspect(no, Node, unknown, 0, no), SuspectStore),
+ SearchSpace = search_space(yes(0), counter.init(1),
+ counter.init(0), SuspectStore, map.init).
+
+incorporate_explicit_subtree(SuspectId, Node, !SearchSpace) :-
+ lookup_suspect(!.SearchSpace, SuspectId, Suspect),
+ map.set(!.SearchSpace ^ store, SuspectId, Suspect ^ edt_node := Node,
+ Store),
+ !:SearchSpace = !.SearchSpace ^ store := Store,
+ map.set(!.SearchSpace ^ implicit_roots_to_explicit_roots,
+ Suspect ^ edt_node, Node, ImplicitToExplicit),
+ !:SearchSpace =
+ !.SearchSpace ^ implicit_roots_to_explicit_roots :=
+ ImplicitToExplicit.
+
+revise_suspect(SuspectId, !SearchSpace) :-
+ !:SearchSpace = !.SearchSpace ^ root := yes(SuspectId),
+ revise_suspects(SuspectId, !SearchSpace).
+
+:- pred revise_suspects(suspect_id::in, search_space(T)::in,
+ search_space(T)::out) is det.
+
+revise_suspects(SuspectId, !SearchSpace) :-
+ lookup_suspect(!.SearchSpace, SuspectId, Suspect),
+ Status = Suspect ^ status,
+ (
+ ( Status = ignored ; Status = skipped(_) ; Status = unknown )
+ ->
+ true
+ ;
+ map.set(!.SearchSpace ^ store, SuspectId,
+ Suspect ^ status := unknown, Store),
+ !:SearchSpace = !.SearchSpace ^ store := Store
+ ),
+ (
+ Suspect ^ children = yes(Children),
+ foldl(revise_suspects, Children, !SearchSpace)
+ ;
+ Suspect ^ children = no
+ ).
+
+get_edt_node(SearchSpace, SuspectId) = Node :-
+ lookup_suspect(SearchSpace, SuspectId, Suspect),
+ Node = Suspect ^ edt_node.
+
+ % Return the status of the suspect.
+:- func get_status(search_space(T), suspect_id) = suspect_status.
+
+get_status(SearchSpace, SuspectId) = Status :-
+ lookup_suspect(SearchSpace, SuspectId, Suspect),
+ Status = Suspect ^ status.
+
+children(Store, SuspectId, !SearchSpace, Children) :-
+ lookup_suspect(!.SearchSpace, SuspectId, Suspect),
+ (
+ Suspect ^ children = yes(Children)
+ ;
+ Suspect ^ children = no,
+ edt_children(Store, Suspect ^ edt_node, EDTChildren),
+ (
+ propogate_status_to_children(Suspect ^ status, yes)
+ ->
+ add_children(EDTChildren, SuspectId, Suspect ^ status,
+ !SearchSpace, Children)
+ ;
+ add_children(EDTChildren, SuspectId, unknown,
+ !SearchSpace, Children)
+ )
+ ).
+
+ % non_ignored_descendents(Store, SuspectIds, !SearchSpace,
+ % Descendents).
+ % Descendents is the non-ignored children of the suspects in
+ % SuspectIds appended together. If a child is ignored then it's
+ % non-ignored children are added to the list. This is done
+ % recursively. Fails if an explicit subtree is required to find
+ % the children of an ignored suspect.
+ %
+:- pred non_ignored_descendents(S::in, list(suspect_id)::in,
+ search_space(T)::in, search_space(T)::out, list(suspect_id)::out)
+ is semidet <= mercury_edt(S, T).
+
+non_ignored_descendents(_, [], !SearchSpace, []).
+non_ignored_descendents(Store, [SuspectId | SuspectIds], !SearchSpace,
+ Descendents) :-
+ lookup_suspect(!.SearchSpace, SuspectId, Suspect),
+ (
+ Suspect ^ status = ignored
+ ->
+ children(Store, SuspectId, !SearchSpace, Children),
+ non_ignored_descendents(Store, Children, !SearchSpace,
+ Descendents1)
+ ;
+ Descendents1 = [SuspectId]
+ ),
+ non_ignored_descendents(Store, SuspectIds, !SearchSpace, Descendents2),
+ append(Descendents1, Descendents2, Descendents).
+
+choose_skipped_suspect(SearchSpace, Skipped) :-
+ SearchSpace ^ root = yes(RootId),
+ % XXX This can be done more efficiently, but I don't think this
+ % predicate will be called too often.
+ map.foldl(least_skipped(SearchSpace), SearchSpace ^ store, RootId,
+ Skipped),
+ (
+ RootId = Skipped
+ =>
+ skipped(_) = get_status(SearchSpace, RootId)
+ ).
+
+ % least_skipped(SearchSpace, SuspectId1, Suspect1, SuspectId2,
+ % LeastSkipped) :-
+ % LeastSkipped is whichever of SuspectId1 and SuspectId2 has the lowest
+ % skip order? If neither has been skipped then LeastSuspect =
+ % SuspectId1. Suspect1 is the suspect referenced by SuspectId1 and is
+ % present so we can use this predicate with map.foldl.
+ %
+:- pred least_skipped(search_space(T)::in, suspect_id::in, suspect(T)::in,
+ suspect_id::in, suspect_id::out) is det.
+
+least_skipped(SearchSpace, SuspectId1, Suspect1, SuspectId2, LeastSkipped) :-
+ Status1 = Suspect1 ^ status,
+ Status2 = get_status(SearchSpace, SuspectId2),
+ (
+ Status1 = skipped(N), Status2 = skipped(M)
+ ->
+ (
+ N > M
+ ->
+ LeastSkipped = SuspectId2
+ ;
+ LeastSkipped = SuspectId1
+ )
+ ;
+ Status2 = skipped(_)
+ ->
+ LeastSkipped = SuspectId2
+ ;
+ LeastSkipped = SuspectId1
+ ).
+
+first_unknown_descendent_breadth(Store, SuspectId, !SearchSpace,
+ MaybeDescendent) :-
+ first_unknown_descendent_list(Store, [SuspectId], !SearchSpace,
+ MaybeDescendent).
+
+ % first_unknown_descendent_list(Store, List, !SearchSpace,
+ % MaybeDescendent).
+ % Find the first unknown suspect in List. If one is found then
+ % it is returned through MaybeDescendent. Otherwise if there are
+ % any skipped, ignored or erroneous suspects in List then look in the
+ % list of all the children of the skipped, ignored or erroneous nodes
+ % in List, recursively. Fails if an explicit subtree is required to
+ % get the children of an explicit subtree and there are no other
+ % unknown suspects. MaybeDescendent will be no if there are no
+ % unknown descendents and no explicit subtree's are required.
+ %
+:- pred first_unknown_descendent_list(S::in, list(suspect_id)::in,
+ search_space(T)::in, search_space(T)::out, maybe(suspect_id)::out)
+ is semidet <= mercury_edt(S, T).
+
+first_unknown_descendent_list(Store, SuspectList, !SearchSpace,
+ MaybeDescendent) :-
+ list.filter(suspect_unknown(!.SearchSpace), SuspectList, UnknownList,
+ Others),
+ (
+ UnknownList = [Unknown | _],
+ MaybeDescendent = yes(Unknown)
+ ;
+ UnknownList = [],
+ list.filter(suspect_in_buggy_subtree(
+ !.SearchSpace), Others, InBuggySubtree),
+ get_children_list(Store, InBuggySubtree, !SearchSpace,
+ ExplicitRequired, Children),
+ (
+ Children = [],
+ ExplicitRequired = no,
+ MaybeDescendent = no
+ ;
+ Children = [_ | _],
+ first_unknown_descendent_list(Store, Children,
+ !SearchSpace, MaybeDescendentChildren),
+ (
+ MaybeDescendentChildren = no,
+ ExplicitRequired = no,
+ MaybeDescendent = no
+ ;
+ MaybeDescendentChildren = yes(Unknown),
+ MaybeDescendent = yes(Unknown)
+ )
+ )
+ ).
+
+ % get_children_list(Store, SuspectIds, !SearchSpace, ExplicitRequired,
+ % Children).
+ % Children is the children of all the suspects in SuspectIds appended
+ % together. If an explicit subtree is required to find the children
+ % of at least one element of SuspectIds, then ExplicitRequired will be
+ % yes, otherwise it'll be no. If an explicit subtree is required for
+ % a suspect then it's children are not included in Children.
+ %
+:- pred get_children_list(S::in, list(suspect_id)::in, search_space(T)::in,
+ search_space(T)::out, bool::out, list(suspect_id)::out) is det
+ <= mercury_edt(S, T).
+
+get_children_list(_, [], SearchSpace, SearchSpace, no, []).
+get_children_list(Store, [SuspectId | SuspectIds], !SearchSpace,
+ ExplicitRequired, ChildrenList) :-
+ get_children_list(Store, SuspectIds, !SearchSpace,
+ ExplicitRequired0, ChildrenList0),
+ (
+ children(Store, SuspectId, !SearchSpace, Children)
+ ->
+ append(Children, ChildrenList0, ChildrenList),
+ ExplicitRequired = ExplicitRequired0
+ ;
+ ChildrenList = ChildrenList0,
+ ExplicitRequired = yes
+ ).
+
+pick_implicit_root(Store, SearchSpace, ImplicitRoot) :-
+ root(SearchSpace, RootId),
+ find_first_implicit_root(Store, SearchSpace, [RootId], ImplicitRoot).
+
+ % Look for an implicit root in the descendents of each suspect in
+ % the list in a depth first fashion.
+ %
+:- pred find_first_implicit_root(S::in, search_space(T)::in,
+ list(suspect_id)::in, suspect_id::out) is semidet <= mercury_edt(S, T).
+
+find_first_implicit_root(Store, SearchSpace, [SuspectId | SuspectIds],
+ ImplicitRoot) :-
+ lookup_suspect(SearchSpace, SuspectId, Suspect),
+ Status = Suspect ^ status,
+ (
+ %
+ % Check that it might be worth our while building an explicit
+ % subtree here.
+ %
+ in_buggy_subtree(Status, yes),
+ edt_implicit_root(Store, Suspect ^ edt_node)
+ ->
+ ImplicitRoot = SuspectId
+ ;
+ (
+ in_buggy_subtree(Status, yes),
+ Suspect ^ children = yes(Children),
+ find_first_implicit_root(Store, SearchSpace,
+ Children, ImplicitRootInChildren)
+ ->
+ ImplicitRoot = ImplicitRootInChildren
+ ;
+ find_first_implicit_root(Store, SearchSpace,
+ SuspectIds, ImplicitRoot)
+ )
+ ).
+
+get_path(SearchSpace, FromId, ToId, PathSoFar, Path) :-
+ (
+ FromId = ToId
+ ->
+ Path = [FromId | PathSoFar]
+ ;
+ lookup_suspect(SearchSpace, FromId, From),
+ From ^ parent = yes(ParentId),
+ get_path(SearchSpace, ParentId, ToId, [FromId | PathSoFar],
+ Path)
+ ).
Index: browser/declarative_execution.m
===================================================================
RCS file: /home/mercury1/repository/mercury/browser/declarative_execution.m,v
retrieving revision 1.27
diff -u -r1.27 declarative_execution.m
--- browser/declarative_execution.m 2 Aug 2004 08:30:02 -0000 1.27
+++ browser/declarative_execution.m 28 Sep 2004 06:47:56 -0000
@@ -227,6 +227,13 @@
:- func get_all_modes_for_layout(proc_layout) = list(proc_layout).
+ % get_pred_attributes(ProcId, Module, Name, Arity, PredOrFunc).
+ % Return the predicate/function attributes common to both UCI and
+ % regular predicates/functions.
+ %
+:- pred get_pred_attributes(proc_id::in, string::out, string::out, int::out,
+ pred_or_func::out) is det.
+
%-----------------------------------------------------------------------------%
% If the following type is modified, some of the macros in
@@ -565,6 +572,28 @@
Layouts = list;
").
+:- func get_special_pred_id_name(special_pred_id) = string.
+
+get_special_pred_id_name(unify) = "__Unify__".
+get_special_pred_id_name(index) = "__Index__".
+get_special_pred_id_name(compare) = "__Compare__".
+
+:- func get_special_pred_id_arity(special_pred_id) = int.
+
+get_special_pred_id_arity(unify) = 2.
+get_special_pred_id_arity(index) = 2.
+get_special_pred_id_arity(compare) = 3.
+
+get_pred_attributes(ProcId, Module, Name, Arity, PredOrFunc) :-
+ (
+ ProcId = proc(Module, PredOrFunc, _, Name, Arity, _)
+ ;
+ ProcId = uci_proc(Module, SpecialId, _, _, _, _),
+ PredOrFunc = predicate,
+ Arity = get_special_pred_id_arity(SpecialId),
+ Name = get_special_pred_id_name(SpecialId)
+ ).
+
%-----------------------------------------------------------------------------%
step_left_in_contour(Store, exit(_, Call, _, _, _, _)) = Prec :-
@@ -974,9 +1003,8 @@
SeqNo = CallNode ^ call_seq
).
-:- pred trace_node_call(trace_node_store, trace_node(trace_node_id),
- trace_node_id).
-:- mode trace_node_call(in, in, out) is semidet.
+:- pred trace_node_call(trace_node_store::in, trace_node(trace_node_id)::in,
+ trace_node_id::out) is semidet.
:- pragma export(trace_node_call(in, in, out), "MR_DD_trace_node_call").
@@ -1376,6 +1404,10 @@
;
ArgPos = any_head_var(N),
Which = all_headvars
+ ;
+ ArgPos = any_head_var_from_back(M),
+ N = length(Args0) - M + 1,
+ Which = all_headvars
),
maybe_filter_headvars(Which, Args0, Args),
list__index1_det(Args, N, Arg).
@@ -1383,6 +1415,7 @@
absolute_arg_num(any_head_var(ArgNum), _, ArgNum).
absolute_arg_num(user_head_var(N), atom(_, Args), ArgNum) :-
head_var_num_to_arg_num(Args, N, 1, ArgNum).
+absolute_arg_num(any_head_var_from_back(M), atom(_, Args), length(Args)-M+1).
:- pred head_var_num_to_arg_num(list(trace_atom_arg)::in, int::in, int::in,
int::out) is det.
Index: browser/declarative_oracle.m
===================================================================
RCS file: /home/mercury1/repository/mercury/browser/declarative_oracle.m,v
retrieving revision 1.26
diff -u -r1.26 declarative_oracle.m
--- browser/declarative_oracle.m 20 Sep 2004 07:43:37 -0000 1.26
+++ browser/declarative_oracle.m 28 Sep 2004 03:13:13 -0000
@@ -29,14 +29,13 @@
:- import_module mdb__declarative_debugger.
:- import_module mdb__declarative_execution.
-:- import_module list, io, bool, string.
+:- import_module io, bool, string.
% A response that the oracle gives to a query about the
% truth of an EDT node.
%
:- type oracle_response(T)
- ---> oracle_answers(list(decl_answer(T)))
- ; no_oracle_answers
+ ---> oracle_answer(decl_answer(T))
; exit_diagnosis(T)
; abort_diagnosis.
@@ -79,12 +78,11 @@
:- pred get_trusted_list(oracle_state::in, bool::in, string::out) is det.
% Query the oracle about the program being debugged. The first
- % argument is a queue of nodes in the evaluation tree, the second
- % argument is the oracle response to any of these. The oracle
- % state is threaded through so its contents can be updated after
- % user responses.
+ % argument is a node in the evaluation tree, the second argument is the
+ % oracle response. The oracle state is threaded through so its
+ % contents can be updated after user responses.
%
-:- pred query_oracle(list(decl_question(T))::in, oracle_response(T)::out,
+:- pred query_oracle(decl_question(T)::in, oracle_response(T)::out,
oracle_state::in, oracle_state::out, io__state::di, io__state::uo)
is cc_multi.
@@ -96,6 +94,12 @@
decl_confirmation::out, oracle_state::in, oracle_state::out,
io__state::di, io__state::uo) is cc_multi.
+ % Revise a question in the oracle's knowledge base so that the oracle
+ % will get an answer to the question from the user.
+ %
+:- pred revise_oracle(decl_question(T)::in, oracle_state::in, oracle_state::out)
+ is cc_multi.
+
%-----------------------------------------------------------------------------%
:- implementation.
@@ -105,19 +109,18 @@
:- import_module mdb__set_cc.
:- import_module mdb__util.
-:- import_module bool, std_util, set, int.
+:- import_module bool, std_util, set, int, exception, list.
-query_oracle(Questions, Response, Oracle0, Oracle) -->
- { query_oracle_list(Oracle0, Questions, Answers) },
+query_oracle(Question, Response, !Oracle, !IO) :-
+ answer_known(!.Oracle, Question, MaybeAnswer),
(
- { Answers = [] }
+ MaybeAnswer = yes(Answer)
->
- { list__map(make_user_question(Oracle0 ^ kb_revised),
- Questions, UserQuestions) },
- query_oracle_user(UserQuestions, Response, Oracle0, Oracle)
+ Response = oracle_answer(Answer)
;
- { Response = oracle_answers(Answers) },
- { Oracle = Oracle0 }
+ make_user_question(!.Oracle ^ kb_revised, Question,
+ UserQuestion),
+ query_oracle_user(UserQuestion, Response, !Oracle, !IO)
).
:- pred make_user_question(oracle_kb::in, decl_question(T)::in,
@@ -133,67 +136,58 @@
UserQuestion = plain_question(DeclQuestion)
).
-:- pred query_oracle_user(list(user_question(T))::in, oracle_response(T)::out,
+:- pred query_oracle_user(user_question(T)::in, oracle_response(T)::out,
oracle_state::in, oracle_state::out, io__state::di, io__state::uo)
is cc_multi.
-query_oracle_user(Questions, OracleResponse, Oracle0, Oracle) -->
- { User0 = Oracle0 ^ user_state },
- query_user(Questions, UserResponse, User0, User),
- {
+query_oracle_user(UserQuestion, OracleResponse, !Oracle, !IO) :-
+ User0 = !.Oracle ^ user_state,
+ query_user(UserQuestion, UserResponse, User0, User, !IO),
+ (
UserResponse = user_answer(Question, Answer),
- OracleResponse = oracle_answers([Answer]),
- Current0 = Oracle0 ^ kb_current,
- Revised0 = Oracle0 ^ kb_revised,
+ OracleResponse = oracle_answer(Answer),
+ Current0 = !.Oracle ^ kb_current,
+ Revised0 = !.Oracle ^ kb_revised,
retract_oracle_kb(Question, Revised0, Revised),
assert_oracle_kb(Question, Answer, Current0, Current),
- Oracle1 = (Oracle0
+ !:Oracle = (!.Oracle
^ kb_current := Current)
^ kb_revised := Revised
;
- UserResponse = no_user_answer,
- OracleResponse = no_oracle_answers,
- Oracle1 = Oracle0
- ;
UserResponse = exit_diagnosis(Node),
- OracleResponse = exit_diagnosis(Node),
- Oracle1 = Oracle0
+ OracleResponse = exit_diagnosis(Node)
;
UserResponse = abort_diagnosis,
- OracleResponse = abort_diagnosis,
- Oracle1 = Oracle0
- },
- { Oracle = Oracle1 ^ user_state := User }.
-
-oracle_confirm_bug(Bug, Evidence, Confirmation, Oracle0, Oracle) -->
- { User0 = Oracle0 ^ user_state },
- user_confirm_bug(Bug, Confirmation, User0, User),
- { Oracle1 = Oracle0 ^ user_state := User },
- {
+ OracleResponse = abort_diagnosis
+ ),
+ !:Oracle = !.Oracle ^ user_state := User.
+
+oracle_confirm_bug(Bug, Evidence, Confirmation, Oracle0, Oracle, !IO) :-
+ User0 = Oracle0 ^ user_state,
+ user_confirm_bug(Bug, Confirmation, User0, User, !IO),
+ Oracle1 = Oracle0 ^ user_state := User,
+ (
Confirmation = overrule_bug
->
list__foldl(revise_oracle, Evidence, Oracle1, Oracle)
;
Oracle = Oracle1
- }.
-
-:- pred revise_oracle(decl_question(T)::in, oracle_state::in, oracle_state::out)
- is cc_multi.
+ ).
-revise_oracle(Question, Oracle0, Oracle) :-
- Current0 = Oracle0 ^ kb_current,
+revise_oracle(Question, !Oracle) :-
+ Current0 = !.Oracle ^ kb_current,
query_oracle_kb(Current0, Question, MaybeAnswer),
(
- MaybeAnswer = yes(Answer),
+ MaybeAnswer = yes(Answer)
+ ->
retract_oracle_kb(Question, Current0, Current),
- Revised0 = Oracle0 ^ kb_revised,
+ Revised0 = !.Oracle ^ kb_revised,
assert_oracle_kb(Question, Answer, Revised0, Revised),
- Oracle = (Oracle0
+ !:Oracle = (!.Oracle
^ kb_revised := Revised)
^ kb_current := Current
;
- MaybeAnswer = no,
- Oracle = Oracle0
+ true
).
%-----------------------------------------------------------------------------%
@@ -356,8 +350,12 @@
:- type known_exceptions
---> known_excp(
- set_cc(decl_exception), % Possible exceptions.
- set_cc(decl_exception) % Impossible exceptions.
+ % Possible exceptions
+ possible :: set_cc(decl_exception),
+ % Impossible exceptions
+ impossible :: set_cc(decl_exception),
+ % Exceptions from inadmissible calls
+ inadmissible :: set_cc(decl_exception)
).
:- pred oracle_kb_init(oracle_kb).
@@ -405,26 +403,21 @@
%-----------------------------------------------------------------------------%
-:- pred query_oracle_list(oracle_state::in, list(decl_question(T))::in,
- list(decl_answer(T))::out) is cc_multi.
+:- pred answer_known(oracle_state::in, decl_question(T)::in,
+ maybe(decl_answer(T))::out) is cc_multi.
-query_oracle_list(_, [], []).
-query_oracle_list(OS, [Q | Qs0], As) :-
- query_oracle_list(OS, Qs0, As0),
- Atom = get_decl_question_atom(Q),
+answer_known(Oracle, Question, MaybeAnswer) :-
+ Atom = get_decl_question_atom(Question),
(
- trusted(Atom ^ proc_layout, OS)
+ trusted(Atom ^ proc_layout, Oracle)
->
- As = [truth_value(get_decl_question_node(Q), yes) | As0]
+ % We tell the analyser that this node doesn't contain a bug,
+ % however it's children may still contain bugs, since
+ % trusted procs may call untrusted procs (for example
+ % when an untrusted closure is passed to a trusted predicate).
+ MaybeAnswer = yes(ignore(get_decl_question_node(Question)))
;
- query_oracle_kb(OS ^ kb_current, Q, MaybeA),
- (
- MaybeA = yes(A),
- As = [A | As0]
- ;
- MaybeA = no,
- As = As0
- )
+ query_oracle_kb(Oracle ^ kb_current, Question, MaybeAnswer)
).
:- pred trusted(proc_layout::in, oracle_state::in) is semidet.
@@ -478,20 +471,29 @@
MaybeX = no,
Result = no
;
- MaybeX = yes(known_excp(Possible, Impossible)),
- set_cc__member(Exception, Possible, PossibleBool),
+ MaybeX = yes(known_excp(Possible, Impossible, Inadmissible)),
+ member(Exception, Possible, PossibleBool),
(
PossibleBool = yes,
- Result = yes(truth_value(Node, yes))
+ Result = yes(truth_value(Node, correct))
;
PossibleBool = no,
- set_cc__member(Exception, Impossible, ImpossibleBool),
+ member(Exception, Impossible, ImpossibleBool),
(
ImpossibleBool = yes,
- Result = yes(truth_value(Node, no))
+ Result = yes(truth_value(Node, erroneous))
;
ImpossibleBool = no,
- Result = no
+ member(Exception, Inadmissible,
+ InadmissibleBool),
+ (
+ InadmissibleBool = yes,
+ Result = yes(truth_value(Node,
+ inadmissible))
+ ;
+ InadmissibleBool = no,
+ Result = no
+ )
)
)
).
@@ -507,6 +509,10 @@
assert_oracle_kb(_, suspicious_subterm(_, _, _), KB, KB).
+assert_oracle_kb(_, ignore(_), KB, KB).
+
+assert_oracle_kb(_, skip(_), KB, KB).
+
assert_oracle_kb(wrong_answer(_, Atom), truth_value(_, Truth), KB0, KB) :-
get_kb_ground_map(KB0, Map0),
% insert all modes of the predicate/function
@@ -515,15 +521,6 @@
Map0, Map),
set_kb_ground_map(KB0, Map, KB).
-:- pred add_atom_to_ground_map(decl_truth::in, final_decl_atom::in,
- proc_layout::in, map_cc(final_decl_atom, decl_truth)::in,
- map_cc(final_decl_atom, decl_truth)::out) is cc_multi.
-
-add_atom_to_ground_map(Truth, FinalAtom, ProcLayout, Map0, Map) :-
- tree234_cc.set(Map0, final_decl_atom(
- atom(ProcLayout, FinalAtom ^ final_atom ^ atom_args),
- FinalAtom ^ final_io_actions), Truth, Map).
-
assert_oracle_kb(missing_answer(_, Call, _), truth_value(_, Truth), KB0, KB) :-
get_kb_complete_map(KB0, Map0),
tree234_cc__set(Map0, Call, Truth, Map),
@@ -534,30 +531,44 @@
get_kb_exceptions_map(KB0, Map0),
tree234_cc__search(Map0, Call, MaybeX),
(
- MaybeX = yes(known_excp(Possible0, Impossible0))
+ MaybeX = yes(KnownExceptions0)
;
MaybeX = no,
- set_cc__init(Possible0),
- set_cc__init(Impossible0)
+ set_cc.init(Possible0),
+ set_cc.init(Impossible0),
+ set_cc.init(Inadmissible0),
+ KnownExceptions0 = known_excp(Possible0, Impossible0,
+ Inadmissible0)
),
(
- Truth = yes,
- set_cc__insert(Possible0, Exception, Possible),
- Impossible = Impossible0
- ;
- Truth = no,
- Possible = Possible0,
- set_cc__insert(Impossible0, Exception, Impossible)
+ Truth = correct,
+ insert(KnownExceptions0 ^ possible, Exception,
+ Possible),
+ KnownExceptions = KnownExceptions0 ^ possible := Possible
+ ;
+ Truth = erroneous,
+ insert(KnownExceptions0 ^ impossible, Exception,
+ Impossible),
+ KnownExceptions = KnownExceptions0 ^ impossible := Impossible
+ ;
+ Truth = inadmissible,
+ insert(KnownExceptions0 ^ inadmissible, Exception,
+ Inadmissible),
+ KnownExceptions = KnownExceptions0 ^ inadmissible :=
+ Inadmissible
),
- tree234_cc__set(Map0, Call, known_excp(Possible, Impossible), Map),
+ tree234_cc__set(Map0, Call, KnownExceptions, Map),
set_kb_exceptions_map(KB0, Map, KB).
:- pred retract_oracle_kb(decl_question(T), oracle_kb, oracle_kb).
:- mode retract_oracle_kb(in, in, out) is cc_multi.
-retract_oracle_kb(wrong_answer(_, FinalAtom), KB0, KB) :-
+retract_oracle_kb(wrong_answer(_, Atom), KB0, KB) :-
Map0 = KB0 ^ kb_ground_map,
- tree234_cc__delete(Map0, FinalAtom, Map),
+ % delete all modes of the predicate/function
+ foldl(remove_atom_from_ground_map(Atom),
+ get_all_modes_for_layout(Atom ^ final_atom ^ proc_layout),
+ Map0, Map),
KB = KB0 ^ kb_ground_map := Map.
retract_oracle_kb(missing_answer(_, InitAtom, _), KB0, KB) :-
@@ -569,15 +580,36 @@
ExceptionsMap0 = KB0 ^ kb_exceptions_map,
tree234_cc__search(ExceptionsMap0, InitAtom, MaybeKnownExceptions0),
(
- MaybeKnownExceptions0 = yes(known_excp(Possible0, Impossible0))
+ MaybeKnownExceptions0 = yes(known_excp(Possible0, Impossible0,
+ Inadmissible0))
->
set_cc__delete(Possible0, Exception, Possible),
set_cc__delete(Impossible0, Exception, Impossible),
- KnownExceptions = known_excp(Possible, Impossible),
+ set_cc__delete(Inadmissible0, Exception, Inadmissible),
+ KnownExceptions = known_excp(Possible, Impossible,
+ Inadmissible),
tree234_cc__set(ExceptionsMap0, InitAtom, KnownExceptions,
ExceptionsMap)
;
ExceptionsMap = ExceptionsMap0
),
KB = KB0 ^ kb_exceptions_map := ExceptionsMap.
+
+:- pred add_atom_to_ground_map(decl_truth::in, final_decl_atom::in,
+ proc_layout::in, map_cc(final_decl_atom, decl_truth)::in,
+ map_cc(final_decl_atom, decl_truth)::out) is cc_multi.
+
+add_atom_to_ground_map(Truth, FinalAtom, ProcLayout, Map0, Map) :-
+ tree234_cc.set(Map0, final_decl_atom(
+ atom(ProcLayout, FinalAtom ^ final_atom ^ atom_args),
+ FinalAtom ^ final_io_actions), Truth, Map).
+
+:- pred remove_atom_from_ground_map(final_decl_atom::in,
+ proc_layout::in, map_cc(final_decl_atom, decl_truth)::in,
+ map_cc(final_decl_atom, decl_truth)::out) is cc_multi.
+
+remove_atom_from_ground_map(FinalAtom, ProcLayout, Map0, Map) :-
+ tree234_cc.delete(Map0, final_decl_atom(
+ atom(ProcLayout, FinalAtom ^ final_atom ^ atom_args),
+ FinalAtom ^ final_io_actions), Map).
Index: browser/declarative_tree.m
===================================================================
RCS file: /home/mercury1/repository/mercury/browser/declarative_tree.m,v
retrieving revision 1.7
diff -u -r1.7 declarative_tree.m
--- browser/declarative_tree.m 21 Jul 2004 07:25:11 -0000 1.7
+++ browser/declarative_tree.m 28 Sep 2004 15:37:20 -0000
@@ -1,5 +1,5 @@
%-----------------------------------------------------------------------------%
-% Copyright (C) 2002-2004 The University of Melbourne.
+% Copyright (C) 2002-2003 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.
%-----------------------------------------------------------------------------%
@@ -14,7 +14,7 @@
:- interface.
-:- import_module mdb__declarative_analyser.
+:- import_module mdb.declarative_edt.
:- import_module mdb__declarative_execution.
% The type of nodes in our implementation of EDTs. The parameter
@@ -33,9 +33,9 @@
%
:- type wrap(S) ---> wrap(S).
-:- pred edt_subtree_details(S, edt_node(R), event_number, sequence_number)
- <= annotated_trace(S, R).
-:- mode edt_subtree_details(in, in, out, out) is det.
+:- pred edt_subtree_details(S, edt_node(R), event_number, sequence_number, R)
+ <= annotated_trace(S, R).
+:- mode edt_subtree_details(in, in, out, out, out) is det.
%-----------------------------------------------------------------------------%
@@ -44,15 +44,20 @@
:- import_module mdb__declarative_debugger.
:- import_module mdb__io_action.
:- import_module mdbcomp__program_representation.
+:- import_module mdb__util.
-:- import_module assoc_list, bool, exception, int, list, map, std_util.
+:- import_module assoc_list, bool, exception, int, list, map, std_util, string.
+:- import_module io.
:- instance mercury_edt(wrap(S), edt_node(R)) <= annotated_trace(S, R)
where [
- pred(edt_root_question/4) is trace_root_question,
+ pred(edt_question/4) is trace_question,
pred(edt_root_e_bug/4) is trace_root_e_bug,
+ pred(edt_root_i_bug/4) is trace_root_i_bug,
pred(edt_children/3) is trace_children,
- pred(edt_dependency/6) is trace_dependency
+ pred(edt_dependency/6) is trace_dependency,
+ pred(edt_subterm_mode/5) is trace_subterm_mode,
+ pred(edt_implicit_root/2) is trace_implicit_root
].
%-----------------------------------------------------------------------------%
@@ -87,12 +92,41 @@
make_io_actions(IoActionMap, InitIoSeq + 1, ExitIoSeq)]
).
+:- pred get_edt_node_initial_atom(S::in, R::in, init_decl_atom::out)
+ is det <= annotated_trace(S, R).
+
+get_edt_node_initial_atom(Store, Ref, Atom) :-
+ det_edt_return_node_from_id(Store, Ref, Node),
+ (
+ Node = exit(_, CallId, _, _, _, _),
+ Atom = call_node_decl_atom(Store, CallId)
+ ;
+ Node = fail(_, CallId, _, _),
+ Atom = call_node_decl_atom(Store, CallId)
+ ;
+ Node = excp(_, CallId, _, _, _),
+ Atom = call_node_decl_atom(Store, CallId)
+ ).
+
+:- pred get_edt_node_event_number(S::in, R::in, event_number::out)
+ is det <= annotated_trace(S, R).
+
+get_edt_node_event_number(Store, Ref, Event) :-
+ det_edt_return_node_from_id(Store, Ref, Node),
+ (
+ Node = exit(_, _, _, _, Event, _)
+ ;
+ Node = fail(_, _, _, Event)
+ ;
+ Node = excp(_, _, _, _, Event)
+ ).
+
%-----------------------------------------------------------------------------%
-:- pred trace_root_question(io_action_map::in, wrap(S)::in, edt_node(R)::in,
+:- pred trace_question(io_action_map::in, wrap(S)::in, edt_node(R)::in,
decl_question(edt_node(R))::out) is det <= annotated_trace(S, R).
-trace_root_question(IoActionMap, wrap(Store), dynamic(Ref), Root) :-
+trace_question(IoActionMap, wrap(Store), dynamic(Ref), Root) :-
det_edt_return_node_from_id(Store, Ref, Node),
(
Node = fail(_, CallId, RedoId, _),
@@ -145,9 +179,18 @@
Bug = unhandled_exception(DeclAtom, Exception, Event)
).
-:- pred trace_children(wrap(S), edt_node(R), list(edt_node(R)))
- <= annotated_trace(S, R).
-:- mode trace_children(in, in, out) is semidet.
+:- pred trace_root_i_bug(wrap(S)::in, edt_node(R)::in,
+ edt_node(R)::in, decl_i_bug::out) is det <= annotated_trace(S, R).
+
+trace_root_i_bug(wrap(Store), dynamic(BugRef),
+ dynamic(InadmissibleRef), inadmissible_call(BugAtom, unit,
+ InadmissibleAtom, Event)) :-
+ get_edt_node_initial_atom(Store, BugRef, BugAtom),
+ get_edt_node_initial_atom(Store, InadmissibleRef, InadmissibleAtom),
+ get_edt_node_event_number(Store, BugRef, Event).
+
+:- pred trace_children(wrap(S)::in, edt_node(R)::in, list(edt_node(R))::out)
+ is semidet <= annotated_trace(S, R).
trace_children(wrap(Store), dynamic(Ref), Children) :-
det_edt_return_node_from_id(Store, Ref, Node),
@@ -156,9 +199,17 @@
not_at_depth_limit(Store, CallId),
missing_answer_children(Store, PrecId, CallId, [], Children)
;
- Node = exit(PrecId, CallId, _, _, _, _),
+ Node = exit(PrecId, CallId, _, Atom, _, _),
not_at_depth_limit(Store, CallId),
- wrong_answer_children(Store, PrecId, CallId, [], Children)
+ (
+ missing_answer_special_case(Atom)
+ ->
+ missing_answer_children(Store, PrecId, CallId, [],
+ Children)
+ ;
+ wrong_answer_children(Store, PrecId, CallId, [],
+ Children)
+ )
;
Node = excp(PrecId, CallId, _, _, _),
not_at_depth_limit(Store, CallId),
@@ -166,6 +217,20 @@
Children)
).
+:- pred trace_implicit_root(wrap(S)::in, edt_node(R)::in) is semidet
+ <= annotated_trace(S, R).
+
+trace_implicit_root(wrap(Store), dynamic(Ref)) :-
+ get_edt_call_node(Store, Ref, CallId),
+ \+ not_at_depth_limit(Store, CallId).
+
+:- pred missing_answer_special_case(trace_atom::in) is semidet.
+
+missing_answer_special_case(Atom) :-
+ ProcId = get_proc_id_from_layout(Atom ^ proc_layout),
+ ProcId = proc("std_util", predicate, "std_util", "builtin_aggregate",
+ 4, _).
+
:- pred not_at_depth_limit(S, R) <= annotated_trace(S, R).
:- mode not_at_depth_limit(in, in) is semidet.
@@ -478,10 +543,15 @@
:- type dependency_chain_start(R)
---> chain_start(
start_loc(R),
- int, % The argument number of the selected
+ % The argument number of the selected
% position in the full list of
% arguments, including the
- % compiler-generated ones.
+ % compiler-generated ones.
+ int,
+ % The total number of arguments
+ % including the compiler generated
+ % ones.
+ int,
R, % The id of the node preceding the exit
% node, if start_loc is cur_goal
% and the id of the node preceding the
@@ -492,7 +562,8 @@
% and yes wrapped around the goal path
% of the call in the parent procedure
% if start_loc is parent_goal.
- maybe(proc_rep) % The body of the procedure indicated
+ maybe(proc_rep)
+ % The body of the procedure indicated
% by start_loc.
).
@@ -516,14 +587,22 @@
% the id of the call's exit event
).
-:- pred trace_dependency(wrap(S)::in, edt_node(R)::in,
- arg_pos::in, term_path::in, subterm_mode::out,
- subterm_origin(edt_node(R))::out) is det <= annotated_trace(S, R).
+:- pred trace_subterm_mode(wrap(S)::in, edt_node(R)::in, arg_pos::in,
+ term_path::in, subterm_mode::out) is det <= annotated_trace(S, R).
+
+trace_subterm_mode(wrap(Store), dynamic(Ref), ArgPos, TermPath, Mode) :-
+ find_chain_start(Store, Ref, ArgPos, TermPath, ChainStart),
+ ChainStart = chain_start(StartLoc, _, _, _, _, _),
+ Mode = start_loc_to_subterm_mode(StartLoc).
+
+:- pred trace_dependency(wrap(S)::in, edt_node(R)::in, arg_pos::in,
+ term_path::in, subterm_mode::out, subterm_origin(edt_node(R))::out)
+ is det <= annotated_trace(S, R).
trace_dependency(wrap(Store), dynamic(Ref), ArgPos, TermPath, Mode, Origin) :-
find_chain_start(Store, Ref, ArgPos, TermPath, ChainStart),
- ChainStart = chain_start(StartLoc, ArgNum, NodeId, StartPath,
- MaybeProcRep),
+ ChainStart = chain_start(StartLoc, ArgNum, TotalArgs, NodeId,
+ StartPath, MaybeProcRep),
Mode = start_loc_to_subterm_mode(StartLoc),
(
MaybeProcRep = no,
@@ -540,11 +619,39 @@
Contour = Contour0
),
ProcRep = proc_rep(HeadVars, GoalRep),
- make_primitive_list(Store, [goal_and_path(GoalRep, [])],
- Contour, StartPath, ArgNum, HeadVars, Var,
- [], Primitives),
- traverse_primitives(Primitives, Var, TermPath,
- Store, ProcRep, Origin)
+ is_traced_grade(AllTraced),
+ MaybePrims = make_primitive_list(Store,
+ [goal_and_path(GoalRep, [])],
+ Contour, StartPath, ArgNum, TotalArgs,
+ HeadVars, AllTraced, []),
+ (
+ MaybePrims = yes(primitive_list_and_var(Primitives,
+ Var, MaybeClosure)),
+ %
+ % If the subterm is in a closure argument (i.e. an
+ % argument passed to the predicate that originally
+ % formed the closure), then the argument number of the
+ % closure argument is prefixed to the term path, since
+ % the closure is itself a term. This is done because
+ % at the time of the closure call it's not easy (XXX or
+ % is it?) to decide if the call is higher order or not,
+ % without repeating all the work done in
+ % make_primitive_list, so the original TermPath doesn't
+ % reflect the closure argument position.
+ %
+ (
+ MaybeClosure = yes,
+ AdjustedTermPath = [ArgNum | TermPath]
+ ;
+ MaybeClosure = no,
+ AdjustedTermPath = TermPath
+ ),
+ traverse_primitives(Primitives, Var, AdjustedTermPath,
+ Store, ProcRep, Origin)
+ ;
+ MaybePrims = no,
+ Origin = not_found
+ )
).
:- pred find_chain_start(S::in, R::in, arg_pos::in, term_path::in,
@@ -604,11 +711,12 @@
path_from_string_det(CallPathStr, CallPath),
StartLoc = parent_goal(CallId, CallNode),
absolute_arg_num(ArgPos, CallAtom, ArgNum),
+ TotalArgs = length(CallAtom ^ atom_args),
StartId = CallPrecId,
StartPath = yes(CallPath),
parent_proc_rep(Store, CallId, StartRep),
- ChainStart = chain_start(StartLoc, ArgNum, StartId, StartPath,
- StartRep).
+ ChainStart = chain_start(StartLoc, ArgNum, TotalArgs, StartId,
+ StartPath, StartRep).
:- pred find_chain_start_outside(trace_node(R)::in(trace_node_call),
trace_node(R)::in(trace_node_exit), arg_pos::in,
@@ -618,10 +726,11 @@
StartLoc = cur_goal,
ExitAtom = ExitNode ^ exit_atom,
absolute_arg_num(ArgPos, ExitAtom, ArgNum),
+ TotalArgs = length(ExitAtom ^ atom_args),
StartId = ExitNode ^ exit_preceding,
StartPath = no,
StartRep = CallNode ^ call_proc_rep,
- ChainStart = chain_start(StartLoc, ArgNum, StartId,
+ ChainStart = chain_start(StartLoc, ArgNum, TotalArgs, StartId,
StartPath, StartRep).
:- pred parent_proc_rep(S::in, R::in, maybe(proc_rep)::out)
@@ -630,28 +739,39 @@
parent_proc_rep(Store, CallId, ProcRep) :-
call_node_from_id(Store, CallId, Call),
CallPrecId = Call ^ call_preceding,
- ( trace_node_from_id(Store, CallPrecId, CallPrecNode) ->
- step_left_to_call(Store, CallPrecNode, ParentCallNode),
+ (
+ step_left_to_call(Store, CallPrecId, ParentCallNode)
+ ->
ProcRep = ParentCallNode ^ call_proc_rep
;
- % The parent call is outside the annotated trace.
ProcRep = no
).
+
+ %
+ % Finds the call node of the parent of the given node. Fails if
+ % the call node cannot be found because it was not included in the
+ % annotated trace.
+ %
+:- pred step_left_to_call(S::in, R::in, trace_node(R)::out(trace_node_call))
+ is semidet <= annotated_trace(S, R).
-:- pred step_left_to_call(S::in, trace_node(R)::in,
- trace_node(R)::out(trace_node_call)) is det <= annotated_trace(S, R).
-
-step_left_to_call(Store, Node, ParentCallNode) :-
+step_left_to_call(Store, NodeId, ParentCallNode) :-
+ trace_node_from_id(Store, NodeId, Node),
( Node = call(_, _, _, _, _, _, _, _, _) ->
ParentCallNode = Node
;
- ( Node = neg(NegPrec, _, _) ->
+ (
+ Node = neg(NegPrec, _, _)
+ ->
PrevNodeId = NegPrec
;
+ Node = cond(CondPrec, _, failed)
+ ->
+ PrevNodeId = CondPrec
+ ;
PrevNodeId = step_left_in_contour(Store, Node)
),
- det_trace_node_from_id(Store, PrevNodeId, PrevNode),
- step_left_to_call(Store, PrevNode, ParentCallNode)
+ step_left_to_call(Store, PrevNodeId, ParentCallNode)
).
:- pred materialize_contour(S::in, R::in, trace_node(R)::in,
@@ -660,6 +780,7 @@
materialize_contour(Store, NodeId, Node, Nodes0, Nodes) :-
( Node = call(_, _, _, _, _, _, _, _, _) ->
+
Nodes = Nodes0
;
( Node = neg(NegPrec, _, _) ->
@@ -680,27 +801,172 @@
Nodes1, Nodes)
).
-:- pred make_primitive_list(S::in, goal_and_path_list::in,
- assoc_list(R, trace_node(R))::in, maybe(goal_path)::in,
- int::in, list(var_rep)::in, var_rep::out,
- list(annotated_primitive(R))::in, list(annotated_primitive(R))::out)
- is det <= annotated_trace(S, R).
+:- type primitive_list_and_var(R)
+ ---> primitive_list_and_var(
+ primitives :: list(annotated_primitive(R)),
+ %
+ % The var_rep for the argument which holds the
+ % subterm we are trying to find the origin of.
+ % If the subterm is in one of the arguments
+ % that were passed to a closure when the
+ % closure was created, then this will be the
+ % var_rep for the variable containing the
+ % closure.
+ %
+ var :: var_rep,
+ %
+ % Was the subterm inside a closure argument
+ % that was passed in when the closure was
+ % created?
+ %
+ closure :: bool
+ ).
-make_primitive_list(Store, [goal_and_path(Goal, Path) | GoalPaths],
- Contour, MaybeEnd, ArgNum, HeadVars, Var,
- Primitives0, Primitives) :-
+ % Constructs a list of the primitive goals along the given contour if
+ % it can. It might not be able to construct the list in the case where
+ % there are higher order calls and we're not sure if everything is
+ % traced, then there might be extra/missing events on the contour and
+ % we need to make sure the primitive atomic goals match up with the
+ % contour events, but in the case of higher order calls this is not
+ % easily done as the name/module of the higher order call is not
+ % available in the goal_rep. If it cannot construct the primitive list
+ % reliably then `no' is returned. MaybeEnd is the goal path of the
+ % call event that should be at the end of the contour for input
+ % subterms.
+ %
+:- func make_primitive_list(S, goal_and_path_list,
+ assoc_list(R, trace_node(R)), maybe(goal_path), int, int,
+ list(var_rep), bool, list(annotated_primitive(R)))
+ = maybe(primitive_list_and_var(R)) <= annotated_trace(S, R).
+
+make_primitive_list(Store, GoalPaths, Contour, MaybeEnd, ArgNum, TotalArgs,
+ HeadVars, AllTraced, Primitives0) = MaybePrims :-
+ (
+ AllTraced = no,
+ (
+ next_goal_generates_internal_event(GoalPaths)
+ ;
+ GoalPaths = []
+ )
+ ->
+ % There may be extra exit and fail events in the
+ % contour if a call to an untraced module was made, but
+ % then something in the untraced module called
+ % something in a traced module.
+ remove_leading_exit_fail_events(Contour,
+ AdjustedContour)
+ ;
+ AdjustedContour = Contour
+ ),
+ (
+ AllTraced = no,
+ contour_at_end_path(AdjustedContour, MaybeEnd),
+ (
+ next_goal_generates_internal_event(GoalPaths)
+ ;
+ GoalPaths = []
+ )
+ ->
+ % We were unable to identify the goal corresponding to this
+ % call (it might have been a higher order call) so we return no
+ % to indicate this. This is the safest thing to do when we're
+ % not sure what has/hasn't been traced.
+ MaybePrims = no
+ ;
+ (
+ GoalPaths = [goal_and_path(Goal, Path) | Tail],
+ MaybePrims = match_goal_to_contour_event(Store, Goal,
+ Path, Tail, AdjustedContour, MaybeEnd,
+ ArgNum, TotalArgs, HeadVars, AllTraced,
+ Primitives0)
+ ;
+ GoalPaths = [],
+ decl_require(unify(AdjustedContour, []),
+ "make_primitive_list",
+ "nonempty contour at end"),
+ decl_require(unify(MaybeEnd, no),
+ "make_primitive_list",
+ "found end when looking for call"),
+ find_variable_in_args(HeadVars, ArgNum, TotalArgs,
+ Var),
+ MaybePrims = yes(primitive_list_and_var(
+ Primitives0, Var, no))
+ )
+ ).
+
+:- pred contour_at_end_path(assoc_list(R, trace_node(R))::in,
+ maybe(goal_path)::in) is semidet.
+
+contour_at_end_path([_ - call(_,_,_,_,_,_,_, CallPathStr, _)], yes(EndPath)) :-
+ path_from_string_det(CallPathStr, CallPath),
+ CallPath = EndPath.
+
+:- pred next_goal_generates_internal_event(list(goal_and_path)::in) is semidet.
+
+next_goal_generates_internal_event([goal_and_path(NextGoal, _) | _]) :-
+ goal_generates_internal_event(NextGoal) = yes.
+
+ % match_goal_to_contour_event(Store, Goal, Path, GoalPaths,
+ % Contour, MaybeEnd, ArgNum, TotalArgs, HeadVars, AllTraced,
+ % Primitives) = MaybePrims
+ % Matches the given goal_rep to the first event in the contour for
+ % all goal_reps except atomic goal reps which need to be handled
+ % differently depending on whether everything is traced (AllTraced).
+ % Returns the list of Primitives appended to the list of
+ % primitive goals along the remaining contour. If it cannot match
+ % a higher order call to a contour event and AllTraced is no, then
+ % no is returned.
+ %
+:- func match_goal_to_contour_event(S, goal_rep, goal_path, goal_and_path_list,
+ assoc_list(R, trace_node(R)), maybe(goal_path), int, int,
+ list(var_rep), bool, list(annotated_primitive(R)))
+ = maybe(primitive_list_and_var(R)) <= annotated_trace(S, R).
+
+match_goal_to_contour_event(Store, Goal, Path, GoalPaths,
+ Contour, MaybeEnd, ArgNum, TotalArgs, HeadVars, AllTraced,
+ Primitives0) = MaybePrims :-
(
Goal = conj_rep(Conjs),
add_paths_to_conjuncts(Conjs, Path, 1, ConjPaths),
- make_primitive_list(Store, list__append(ConjPaths, GoalPaths),
- Contour, MaybeEnd, ArgNum, HeadVars, Var,
- Primitives0, Primitives)
+ MaybePrims = make_primitive_list(Store,
+ list__append(ConjPaths, GoalPaths),
+ Contour, MaybeEnd, ArgNum, TotalArgs, HeadVars,
+ AllTraced, Primitives0)
+ ;
+ Goal = some_rep(InnerGoal, MaybeCut),
+ InnerPath = list__append(Path, [exist(MaybeCut)]),
+ InnerAndPath = goal_and_path(InnerGoal, InnerPath),
+ MaybePrims = make_primitive_list(Store,
+ [InnerAndPath | GoalPaths],
+ Contour, MaybeEnd, ArgNum, TotalArgs, HeadVars,
+ AllTraced, Primitives0)
+ ;
+ Goal = atomic_goal_rep(_, File, Line, BoundVars, AtomicGoal),
+ GeneratesEvent = atomic_goal_generates_event(AtomicGoal),
+ (
+ GeneratesEvent = yes(AtomicGoalArgs),
+ MaybePrims = match_atomic_goal_to_contour_event(Store,
+ File, Line, BoundVars, AtomicGoal,
+ AtomicGoalArgs, Path, GoalPaths, Contour,
+ MaybeEnd, ArgNum, TotalArgs, HeadVars,
+ AllTraced, Primitives0)
+ ;
+ GeneratesEvent = no,
+ Primitive = primitive(File, Line, BoundVars,
+ AtomicGoal, Path, no),
+ Primitives1 = [Primitive | Primitives0],
+ MaybePrims = make_primitive_list(Store, GoalPaths,
+ Contour, MaybeEnd, ArgNum, TotalArgs, HeadVars,
+ AllTraced, Primitives1)
+ )
;
Goal = disj_rep(Disjs),
(
Contour = [_ - ContourHeadNode | ContourTail],
- ( ContourHeadNode = first_disj(_, DisjPathStr)
- ; ContourHeadNode = later_disj(_, DisjPathStr, _)
+ (
+ ContourHeadNode = first_disj(_, DisjPathStr)
+ ;
+ ContourHeadNode = later_disj(_, DisjPathStr, _)
),
path_from_string_det(DisjPathStr, DisjPath),
list__append(Path, PathTail, DisjPath),
@@ -708,11 +974,11 @@
->
list__index1_det(Disjs, N, Disj),
DisjAndPath = goal_and_path(Disj, DisjPath),
- make_primitive_list(Store, [DisjAndPath | GoalPaths],
- ContourTail, MaybeEnd, ArgNum, HeadVars, Var,
- Primitives0, Primitives)
+ MaybePrims = make_primitive_list(Store, [DisjAndPath |
+ GoalPaths], ContourTail, MaybeEnd, ArgNum,
+ TotalArgs, HeadVars, AllTraced, Primitives0)
;
- throw(internal_error("make_primitive_list",
+ throw(internal_error("match_goal_to_contour_event",
"mismatch on disj"))
)
;
@@ -726,11 +992,11 @@
->
list__index1_det(Arms, N, Arm),
ArmAndPath = goal_and_path(Arm, ArmPath),
- make_primitive_list(Store, [ArmAndPath | GoalPaths],
- ContourTail, MaybeEnd, ArgNum, HeadVars, Var,
- Primitives0, Primitives)
+ MaybePrims = make_primitive_list(Store, [ArmAndPath |
+ GoalPaths], ContourTail, MaybeEnd, ArgNum,
+ TotalArgs, HeadVars, AllTraced, Primitives0)
;
- throw(internal_error("make_primitive_list",
+ throw(internal_error("match_goal_to_contour_event",
"mismatch on switch"))
)
;
@@ -745,10 +1011,10 @@
ThenPath = list__append(Path, [ite_then]),
CondAndPath = goal_and_path(Cond, CondPath),
ThenAndPath = goal_and_path(Then, ThenPath),
- make_primitive_list(Store,
- [CondAndPath, ThenAndPath | GoalPaths],
- ContourTail, MaybeEnd, ArgNum, HeadVars, Var,
- Primitives0, Primitives)
+ MaybePrims = make_primitive_list(Store, [CondAndPath,
+ ThenAndPath | GoalPaths], ContourTail,
+ MaybeEnd, ArgNum, TotalArgs, HeadVars,
+ AllTraced, Primitives0)
;
Contour = [_ - ContourHeadNode | ContourTail],
ContourHeadNode = else(_, ElseCondId),
@@ -760,11 +1026,11 @@
->
ElsePath = list__append(Path, [ite_else]),
ElseAndPath = goal_and_path(Else, ElsePath),
- make_primitive_list(Store, [ElseAndPath | GoalPaths],
- ContourTail, MaybeEnd, ArgNum, HeadVars, Var,
- Primitives0, Primitives)
+ MaybePrims = make_primitive_list(Store, [ElseAndPath |
+ GoalPaths], ContourTail, MaybeEnd, ArgNum,
+ TotalArgs, HeadVars, AllTraced, Primitives0)
;
- throw(internal_error("make_primitive_list",
+ throw(internal_error("match_goal_to_contour_event",
"mismatch on if-then-else"))
)
;
@@ -774,9 +1040,9 @@
ContourHeadNode = neg_succ(_, _)
->
% The negated goal cannot contribute any bindings.
- make_primitive_list(Store, GoalPaths,
- ContourTail, MaybeEnd, ArgNum, HeadVars, Var,
- Primitives0, Primitives)
+ MaybePrims = make_primitive_list(Store, GoalPaths,
+ ContourTail, MaybeEnd, ArgNum, TotalArgs,
+ HeadVars, AllTraced, Primitives0)
;
Contour = [_ - ContourHeadNode | ContourTail],
ContourHeadNode = neg(_, _, _)
@@ -785,75 +1051,234 @@
% NegGoal.
NegPath = list__append(Path, [neg]),
NegAndPath = goal_and_path(NegGoal, NegPath),
- make_primitive_list(Store, [NegAndPath],
- ContourTail, MaybeEnd, ArgNum, HeadVars, Var,
- Primitives0, Primitives)
+ MaybePrims = make_primitive_list(Store, [NegAndPath],
+ ContourTail, MaybeEnd, ArgNum, TotalArgs,
+ HeadVars, AllTraced, Primitives0)
;
- throw(internal_error("make_primitive_list",
+ throw(internal_error("match_goal_to_contour_event",
"mismatch on negation"))
)
+ ).
+
+:- pred remove_leading_exit_fail_events(
+ assoc_list(R, trace_node(R))::in,
+ assoc_list(R, trace_node(R))::out) is det.
+
+remove_leading_exit_fail_events([], []).
+remove_leading_exit_fail_events(Contour0, Contour) :-
+ Contour0 = [_ - ContourHeadNode | ContourTail],
+ (
+ (
+ ContourHeadNode = exit(_, _, _, _, _, _)
+ ;
+ ContourHeadNode = fail(_, _, _, _)
+ )
+ ->
+ remove_leading_exit_fail_events(ContourTail,
+ Contour)
;
- Goal = some_rep(InnerGoal, MaybeCut),
- InnerPath = list__append(Path, [exist(MaybeCut)]),
- InnerAndPath = goal_and_path(InnerGoal, InnerPath),
- make_primitive_list(Store, [InnerAndPath | GoalPaths],
- Contour, MaybeEnd, ArgNum, HeadVars, Var,
- Primitives0, Primitives)
- ;
- Goal = atomic_goal_rep(_, File, Line, BoundVars, AtomicGoal),
- GeneratesEvent = atomic_goal_generates_event(AtomicGoal),
+ Contour = Contour0
+ ).
+
+ % Trys to match an atomic goal to the first event on the contour.
+ % These should match if AllTraced = yes. If AllTraced = no, then
+ % if the goal doesn't match the contour event (i.e. they are for
+ % different predicates), then the goal will be treated as a primitive
+ % operation with no children. The next atomic goal will then be tried
+ % as a match for the first event on the contour. This will
+ % continue until a non-atomic goal is reached, at which point all
+ % events that could match atomic goals (exit and fail events) are
+ % removed from the top of the contour. This strategy will work
+ % best when untraced calls do not call traced modules (which seems
+ % more likely for the majority of untraced calls).
+ %
+:- func match_atomic_goal_to_contour_event(S, string, int,
+ list(var_rep), atomic_goal_rep, list(var_rep), goal_path,
+ list(goal_and_path), assoc_list(R, trace_node(R)), maybe(goal_path),
+ int, int, list(var_rep), bool, list(annotated_primitive(R))) =
+ maybe(primitive_list_and_var(R)) <= annotated_trace(S, R).
+
+match_atomic_goal_to_contour_event(Store, File, Line, BoundVars, AtomicGoal,
+ AtomicGoalArgs, Path, GoalPaths, Contour, MaybeEnd, ArgNum,
+ TotalArgs, HeadVars, AllTraced, Primitives0) = MaybePrims :-
+ (
+ Contour = [_ - ContourHeadNode],
+ MaybeEnd = yes(EndPath)
+ ->
(
- GeneratesEvent = yes(Args),
+ ContourHeadNode =
+ call(_, _, Atom, _, _, _, _, CallPathStr, _),
+ path_from_string_det(CallPathStr, CallPath),
+ CallPath = EndPath
+ ->
(
- Contour = [ContourHeadId - ContourHeadNode
- | ContourTail],
- CallId = ContourHeadNode ^ exit_call,
- call_node_from_id(Store, CallId, CallNode),
- CallPathStr = CallNode ^ call_goal_path,
- path_from_string_det(CallPathStr, CallPath),
- CallPath = Path,
- \+ (
- MaybeEnd = yes(EndPath),
- EndPath = Path
+ (
+ atomic_goal_identifiable(AtomicGoal) =
+ yes(AtomicGoalId)
+ ->
+ atomic_goal_matches_atom(AtomicGoalId,
+ Atom)
+ ;
+ AllTraced = yes
)
->
- Primitive = primitive(File, Line, BoundVars,
- AtomicGoal, Path, yes(ContourHeadId)),
- Primitives1 = [Primitive | Primitives0],
- make_primitive_list(Store, GoalPaths,
- ContourTail, MaybeEnd, ArgNum,
- HeadVars, Var, Primitives1, Primitives)
- ;
- Contour = [_ContourHeadId - ContourHeadNode],
- CallPathStr = ContourHeadNode ^ call_goal_path,
- path_from_string_det(CallPathStr, CallPath),
- CallPath = Path,
- MaybeEnd = yes(EndPath),
- EndPath = Path
- ->
- list__index1_det(Args, ArgNum, Var),
- Primitives = Primitives0
+ (
+ % Test to see that the argument is not
+ % a closure argument (passed in when
+ % the closure was created)
+ ArgNum > TotalArgs -
+ length(AtomicGoalArgs)
+ ->
+ find_variable_in_args(AtomicGoalArgs,
+ ArgNum, TotalArgs, Var),
+ MaybePrims = yes(
+ primitive_list_and_var(
+ Primitives0, Var, no))
+
+ ;
+ % Perhaps this is a closure and the
+ % argument was passed in when the
+ % closure was created.
+ (
+ AtomicGoal =
+ higher_order_call_rep(
+ Closure, _)
+ ->
+ Var = Closure,
+ MaybePrims = yes(
+ primitive_list_and_var(
+ Primitives0, Var, yes))
+ ;
+ throw(internal_error(
+ "make_primitive_list",
+ "argument number "++
+ "mismatch"))
+ )
+ )
;
- throw(internal_error("make_primitive_list",
- "mismatch on call"))
+ (
+ AllTraced = yes,
+ throw(internal_error(
+ "match_atomic_goal_to_conto"++
+ "ur_event",
+ "name mismatch on call"))
+ ;
+ AllTraced = no,
+ Primitive = primitive(File, Line,
+ BoundVars, AtomicGoal, Path,
+ no),
+ Primitives1 = [Primitive|Primitives0],
+ MaybePrims = make_primitive_list(Store,
+ GoalPaths, Contour, MaybeEnd,
+ ArgNum, TotalArgs, HeadVars,
+ AllTraced, Primitives1)
+ )
)
;
- GeneratesEvent = no,
+ throw(internal_error(
+ "match_atomic_goal_to_contour_event",
+ "goalpath mismatch on call"))
+ )
+ ;
+ (
+ Contour = [ContourHeadId - ContourHeadNode |
+ ContourTail],
+ (
+ ContourHeadNode = exit(_, _, _, Atom, _, _)
+ ->
+ (
+ (
+ atomic_goal_identifiable(
+ AtomicGoal) =
+ yes(AtomicGoalId)
+ ->
+ atomic_goal_matches_atom(
+ AtomicGoalId, Atom)
+ ;
+ AllTraced = yes
+ )
+ ->
+ CallInfo = yes(ContourHeadId),
+ NewContour = ContourTail
+ ;
+ (
+ AllTraced = yes,
+ throw(internal_error(
+ "match_atomic_goal_"++
+ "to_contour_event",
+ "atomic goal doesn't"++
+ " match exit event\n"))
+ ;
+ AllTraced = no,
+ CallInfo = no,
+ NewContour = Contour
+ )
+ )
+ ;
+ (
+ AllTraced = yes,
+ throw(internal_error(
+ "match_atomic_goal_to_contour_event",
+ "atomic goal with no exit event "++
+ "when assuming all traced"))
+ ;
+ AllTraced = no,
+ CallInfo = no,
+ NewContour = Contour
+ )
+ ),
Primitive = primitive(File, Line, BoundVars,
- AtomicGoal, Path, no),
+ AtomicGoal, Path, CallInfo),
Primitives1 = [Primitive | Primitives0],
- make_primitive_list(Store, GoalPaths,
- Contour, MaybeEnd, ArgNum, HeadVars, Var,
- Primitives1, Primitives)
+ MaybePrims = make_primitive_list(Store, GoalPaths,
+ NewContour, MaybeEnd, ArgNum, TotalArgs,
+ HeadVars, AllTraced, Primitives1)
+ ;
+ Contour = [],
+ (
+ AllTraced = no,
+ MaybeEnd = no
+ ->
+ Primitive = primitive(File, Line, BoundVars,
+ AtomicGoal, Path, no),
+ Primitives1 = [Primitive | Primitives0],
+ MaybePrims = make_primitive_list(Store,
+ GoalPaths, [], MaybeEnd, ArgNum,
+ TotalArgs, HeadVars, AllTraced,
+ Primitives1)
+ ;
+ throw(internal_error(
+ "match_atomic_goal_to_contour_event",
+ "premature contour end"))
+ )
)
).
-make_primitive_list(_, [], Contour, MaybeEnd, ArgNum, HeadVars, Var,
- Primitives, Primitives) :-
- decl_require(unify(Contour, []),
- "make_primitive_list", "nonempty contour at end"),
- decl_require(unify(MaybeEnd, no),
- "make_primitive_list", "found end when looking for call"),
- list__index1_det(HeadVars, ArgNum, Var).
+
+:- pred atomic_goal_matches_atom(atomic_goal_id::in, trace_atom::in)
+ is semidet.
+
+atomic_goal_matches_atom(AtomicGoalId, Atom) :-
+ AtomicGoalId = atomic_goal_id(GoalModule, GoalName, GoalArity),
+ ProcId = get_proc_id_from_layout(Atom ^ proc_layout),
+ get_pred_attributes(ProcId, EventModule, EventName, _, _),
+ EventArity = length(Atom ^ atom_args),
+ EventModule = GoalModule,
+ EventName = GoalName,
+ EventArity = GoalArity.
+
+:- pred find_variable_in_args(list(var_rep)::in, int::in, int::in,
+ var_rep::out) is det.
+
+find_variable_in_args(Args, ArgNum, TotalArgs, Var) :-
+ % We reverse the arg list in case this is an argument of a closure call
+ % that is passed in at the time of the call.
+ (
+ index1(reverse(Args), TotalArgs - ArgNum + 1, FoundVar)
+ ->
+ Var = FoundVar
+ ;
+ throw(internal_error("find_variable_in_args", "arg not found"))
+ ).
:- pred traverse_primitives(list(annotated_primitive(R))::in,
var_rep::in, term_path::in, S::in, proc_rep::in,
@@ -941,18 +1366,24 @@
)
;
AtomicGoal = higher_order_call_rep(_, Args),
- traverse_call(BoundVars, no, Args, MaybeNodeId, Prims,
+ traverse_call(BoundVars, File, Line, Args, MaybeNodeId, Prims,
Var0, TermPath0, Store, ProcRep, Origin)
;
AtomicGoal = method_call_rep(_, _, Args),
- traverse_call(BoundVars, no, Args, MaybeNodeId, Prims,
+ traverse_call(BoundVars, File, Line, Args, MaybeNodeId, Prims,
Var0, TermPath0, Store, ProcRep, Origin)
;
- AtomicGoal = plain_call_rep(ModuleName, PredName, Args),
- PlainCallInfo = plain_call_info(File, Line,
- ModuleName, PredName),
- traverse_call(BoundVars, yes(PlainCallInfo), Args, MaybeNodeId,
+ AtomicGoal = plain_call_rep(_, _, Args),
+ traverse_call(BoundVars, File, Line, Args, MaybeNodeId,
Prims, Var0, TermPath0, Store, ProcRep, Origin)
+ ;
+ AtomicGoal = builtin_call_rep(_, _, _),
+ ( list__member(Var0, BoundVars) ->
+ Origin = primitive_op(File, Line)
+ ;
+ traverse_primitives(Prims, Var0, TermPath0,
+ Store, ProcRep, Origin)
+ )
).
:- type plain_call_info
@@ -963,13 +1394,12 @@
pred_name :: string
).
-:- pred traverse_call(list(var_rep)::in, maybe(plain_call_info)::in,
- list(var_rep)::in, maybe(R)::in,
- list(annotated_primitive(R))::in, var_rep::in, term_path::in,
- S::in, proc_rep::in, subterm_origin(edt_node(R))::out) is det
- <= annotated_trace(S, R).
+:- pred traverse_call(list(var_rep)::in, string::in, int::in,
+ list(var_rep)::in, maybe(R)::in, list(annotated_primitive(R))::in,
+ var_rep::in, term_path::in, S::in, proc_rep::in,
+ subterm_origin(edt_node(R))::out) is det <= annotated_trace(S, R).
-traverse_call(BoundVars, MaybePlainCallInfo, Args, MaybeNodeId,
+traverse_call(BoundVars, File, Line, Args, MaybeNodeId,
Prims, Var, TermPath, Store, ProcRep, Origin) :-
( list__member(Var, BoundVars) ->
Pos = find_arg_pos(Args, Var),
@@ -978,17 +1408,7 @@
Origin = output(dynamic(NodeId), Pos, TermPath)
;
MaybeNodeId = no,
- (
- MaybePlainCallInfo = yes(PlainCallInfo),
- PlainCallInfo = plain_call_info(File, Line,
- ModuleName, PredName),
- call_is_primitive(ModuleName, PredName)
- ->
- Origin = primitive_op(File, Line)
- ;
- throw(internal_error("traverse_call",
- "no node id"))
- )
+ Origin = primitive_op(File, Line)
)
;
traverse_primitives(Prims, Var, TermPath, Store, ProcRep,
@@ -1008,6 +1428,21 @@
%-----------------------------------------------------------------------------%
+:- pred is_traced_grade(bool::out) is det.
+
+:- pragma foreign_proc("C", is_traced_grade(TracingOn::out),
+ [promise_pure, will_not_call_mercury, thread_safe],
+"
+ #ifdef MR_EXEC_TRACE
+ TracingOn = ML_bool_return_yes();
+ #else
+ TracingOn = ML_bool_return_no();
+ #endif
+").
+
+
+%-----------------------------------------------------------------------------%
+
:- func start_loc_to_subterm_mode(start_loc(R)) = subterm_mode.
start_loc_to_subterm_mode(cur_goal) = subterm_out.
@@ -1018,23 +1453,23 @@
:- func find_arg_pos(list(var_rep), var_rep) = arg_pos.
find_arg_pos(HeadVars, Var) = ArgPos :-
- find_arg_pos_2(HeadVars, Var, 1, ArgPos).
+ find_arg_pos_from_back(HeadVars, Var, length(HeadVars), ArgPos).
-:- pred find_arg_pos_2(list(var_rep)::in, var_rep::in, int::in, arg_pos::out)
- is det.
+:- pred find_arg_pos_from_back(list(var_rep)::in, var_rep::in, int::in,
+ arg_pos::out) is det.
-find_arg_pos_2([], _, _, _) :-
+find_arg_pos_from_back([], _, _, _) :-
throw(internal_error("find_arg_pos_2", "empty list")).
-find_arg_pos_2([HeadVar | HeadVars], Var, Pos, ArgPos) :-
+find_arg_pos_from_back([HeadVar | HeadVars], Var, Pos, ArgPos) :-
( HeadVar = Var ->
- ArgPos = any_head_var(Pos)
+ ArgPos = any_head_var_from_back(Pos)
;
- find_arg_pos_2(HeadVars, Var, Pos + 1, ArgPos)
+ find_arg_pos_from_back(HeadVars, Var, Pos - 1, ArgPos)
).
%-----------------------------------------------------------------------------%
-edt_subtree_details(Store, dynamic(Ref), Event, SeqNo) :-
+edt_subtree_details(Store, dynamic(Ref), Event, SeqNo, CallPreceding) :-
det_edt_return_node_from_id(Store, Ref, Node),
(
Node = exit(_, Call, _, _, Event, _)
@@ -1044,12 +1479,13 @@
Node = excp(_, Call, _, _, Event)
),
call_node_from_id(Store, Call, CallNode),
- SeqNo = CallNode ^ call_seq.
+ SeqNo = CallNode ^ call_seq,
+ CallPreceding = CallNode ^ call_preceding.
-:- inst edt_return_node
- ---> exit(ground, ground, ground, ground, ground, ground)
- ; fail(ground, ground, ground, ground)
- ; excp(ground, ground, ground, ground, ground).
+:- inst edt_return_node =
+ bound( exit(ground, ground, ground, ground, ground, ground)
+ ; fail(ground, ground, ground, ground)
+ ; excp(ground, ground, ground, ground, ground)).
:- pred det_edt_return_node_from_id(S::in, R::in,
trace_node(R)::out(edt_return_node)) is det <= annotated_trace(S, R).
@@ -1071,6 +1507,26 @@
"not a return node"))
).
+:- pred get_edt_call_node(S::in, R::in, R::out)
+ is det <= annotated_trace(S, R).
+
+get_edt_call_node(Store, Ref, CallId) :-
+ (
+ trace_node_from_id(Store, Ref, Node0),
+ (
+ Node0 = exit(_, CallId0, _, _, _, _)
+ ;
+ Node0 = fail(_, CallId0, _, _)
+ ;
+ Node0 = excp(_, CallId0, _, _, _)
+ )
+ ->
+ CallId = CallId0
+ ;
+ throw(internal_error("get_edt_call_node",
+ "not a return node"))
+ ).
+
%-----------------------------------------------------------------------------%
:- pred trace_atom_subterm_is_ground(trace_atom, arg_pos, term_path).
@@ -1094,4 +1550,3 @@
;
throw(internal_error(Loc, Msg))
).
-
Index: browser/declarative_user.m
===================================================================
RCS file: /home/mercury1/repository/mercury/browser/declarative_user.m,v
retrieving revision 1.29
diff -u -r1.29 declarative_user.m
--- browser/declarative_user.m 9 Aug 2004 03:05:20 -0000 1.29
+++ browser/declarative_user.m 20 Sep 2004 07:48:03 -0000
@@ -18,7 +18,7 @@
:- import_module mdb__declarative_debugger.
-:- import_module list, io.
+:- import_module io.
:- type user_question(T)
---> plain_question(decl_question(T))
@@ -26,7 +26,6 @@
:- type user_response(T)
---> user_answer(decl_question(T), decl_answer(T))
- ; no_user_answer
; exit_diagnosis(T)
; abort_diagnosis.
@@ -40,7 +39,7 @@
% possibly with a default answer, and is asked to respond about the
% truth of it in the intended interpretation.
%
-:- pred query_user(list(user_question(T))::in, user_response(T)::out,
+:- pred query_user(user_question(T)::in, user_response(T)::out,
user_state::in, user_state::out, io__state::di, io__state::uo)
is cc_multi.
@@ -62,7 +61,7 @@
:- import_module mdb__declarative_execution.
:- import_module mdbcomp__program_representation.
-:- import_module std_util, char, string, bool, int, deconstruct.
+:- import_module std_util, char, string, bool, int, deconstruct, list.
:- type user_state
---> user(
@@ -77,142 +76,152 @@
%-----------------------------------------------------------------------------%
-query_user(Questions, Response, User0, User) -->
- query_user_2(Questions, [], Response, User0, User).
-
-:- pred query_user_2(list(user_question(T))::in, list(user_question(T))::in,
- user_response(T)::out, user_state::in, user_state::out,
- io__state::di, io__state::uo) is cc_multi.
-
-query_user_2([], _, no_user_answer, User, User) -->
- [].
-query_user_2([UserQuestion | UserQuestions], Skipped, Response, User0, User) -->
- { Question = get_decl_question(UserQuestion) },
- write_decl_question(Question, User0),
- { user_question_prompt(UserQuestion, Prompt) },
- get_command(Prompt, Command, User0, User1),
- handle_command(Command, UserQuestion, UserQuestions, Skipped, Response,
- User1, User).
+query_user(UserQuestion, Response, !User, !IO) :-
+ Question = get_decl_question(UserQuestion),
+ write_decl_question(Question, !.User, !IO),
+ user_question_prompt(UserQuestion, Prompt),
+ get_command(Prompt, Command, !User, !IO),
+ handle_command(Command, UserQuestion, Response, !User,
+ !IO).
:- pred handle_command(user_command::in, user_question(T)::in,
- list(user_question(T))::in, list(user_question(T))::in,
- user_response(T)::out, user_state::in, user_state::out,
- io__state::di, io__state::uo) is cc_multi.
+ user_response(T)::out, user_state::in, user_state::out, io__state::di,
+ io__state::uo) is cc_multi.
-handle_command(yes, UserQuestion, _, _, Response, User, User) -->
- { Question = get_decl_question(UserQuestion) },
- { Node = get_decl_question_node(Question) },
- { Response = user_answer(Question, truth_value(Node, yes)) }.
-
-handle_command(no, UserQuestion, _, _, Response, User, User) -->
- { Question = get_decl_question(UserQuestion) },
- { Node = get_decl_question_node(Question) },
- { Response = user_answer(Question, truth_value(Node, no)) }.
-
-handle_command(inadmissible, UserQuestion, UserQuestions, Skipped, Response,
- User0, User) -->
- io__write_string("Sorry, not implemented,\n"),
- query_user_2([UserQuestion | UserQuestions], Skipped, Response, User0,
- User).
-
-handle_command(skip, UserQuestion, UserQuestions, Skipped, Response,
- User0, User) -->
- query_user_2(UserQuestions, [UserQuestion | Skipped], Response, User0,
- User).
-
-handle_command(restart, UserQuestion, UserQuestions, Skipped, Response,
- User0, User) -->
- { reverse_and_append(Skipped, [UserQuestion | UserQuestions],
- RestartedQuestions) },
- query_user(RestartedQuestions, Response, User0, User).
-
-handle_command(browse_arg(ArgNum), UserQuestion, UserQuestions, Skipped,
- Response, User0, User) -->
- { Question = get_decl_question(UserQuestion) },
- { edt_node_trace_atom(Question, TraceAtom) },
- browse_atom_argument(TraceAtom, ArgNum, MaybeMark, User0, User1),
+handle_command(yes, UserQuestion, Response, !User, !IO) :-
+ Question = get_decl_question(UserQuestion),
+ Node = get_decl_question_node(Question),
+ Response = user_answer(Question, truth_value(Node, correct)).
+
+handle_command(no, UserQuestion, Response, !User, !IO) :-
+ Question = get_decl_question(UserQuestion),
+ Node = get_decl_question_node(Question),
+ Response = user_answer(Question, truth_value(Node, erroneous)).
+
+handle_command(inadmissible, UserQuestion, Response, !User, !IO) :-
+ Question = get_decl_question(UserQuestion),
+ Node = get_decl_question_node(Question),
+ Response = user_answer(Question, truth_value(Node, inadmissible)).
+
+handle_command(skip, UserQuestion, Response, !User, !IO) :-
+ Question = get_decl_question(UserQuestion),
+ Node = get_decl_question_node(Question),
+ Response = user_answer(Question, skip(Node)).
+
+handle_command(browse_arg(MaybeArgNum), UserQuestion, Response,
+ !User, !IO) :-
+ Question = get_decl_question(UserQuestion),
+ edt_node_trace_atom(Question, TraceAtom),
(
- { MaybeMark = no },
- query_user_2([UserQuestion | UserQuestions], Skipped, Response,
- User1, User)
+ MaybeArgNum = yes(ArgNum),
+ browse_atom_argument(TraceAtom, ArgNum, MaybeMark, !User, !IO),
+ (
+ MaybeMark = no,
+ query_user(UserQuestion, Response,
+ !User, !IO)
+ ;
+ MaybeMark = yes(Mark),
+ Which = chosen_head_vars_presentation,
+ (
+ Which = only_user_headvars,
+ ArgPos = user_head_var(ArgNum)
+ ;
+ Which = all_headvars,
+ ArgPos = any_head_var(ArgNum)
+ ),
+ Node = get_decl_question_node(Question),
+ Answer = suspicious_subterm(Node, ArgPos, Mark),
+ Response = user_answer(Question, Answer)
+ )
;
- { MaybeMark = yes(Mark) },
- { Which = chosen_head_vars_presentation },
- {
- Which = only_user_headvars,
- ArgPos = user_head_var(ArgNum)
+ MaybeArgNum = no,
+ browse_atom(TraceAtom, MaybeMark, !User, !IO),
+ (
+ MaybeMark = no,
+ query_user(UserQuestion, Response,
+ !User, !IO)
+ ;
+ % If the user marks the predicate or function,
+ % we make the call invalid.
+ MaybeMark = yes([]),
+ Node = get_decl_question_node(Question),
+ Answer = truth_value(Node, erroneous),
+ Response = user_answer(Question, Answer)
;
- Which = all_headvars,
- ArgPos = any_head_var(ArgNum)
- },
- { Node = get_decl_question_node(Question) },
- { Answer = suspicious_subterm(Node, ArgPos, Mark) },
- { Response = user_answer(Question, Answer) },
- { User = User1 }
- ).
-
-handle_command(print_arg(From, To), UserQuestion, UserQuestions, Skipped,
- Response, User0, User) -->
- { Question = get_decl_question(UserQuestion) },
- { edt_node_trace_atom(Question, TraceAtom) },
- print_atom_arguments(TraceAtom, From, To, User0),
- query_user_2([UserQuestion | UserQuestions], Skipped, Response,
- User0, User).
-
-handle_command(browse_io(ActionNum), UserQuestion, UserQuestions, Skipped,
- Response, User0, User) -->
- { Question = get_decl_question(UserQuestion) },
- { edt_node_io_actions(Question, IoActions) },
+ MaybeMark = yes([ArgNum | Mark]),
+ Which = chosen_head_vars_presentation,
+ (
+ Which = only_user_headvars,
+ ArgPos = user_head_var(ArgNum)
+ ;
+ Which = all_headvars,
+ ArgPos = any_head_var(ArgNum)
+ ),
+ Node = get_decl_question_node(Question),
+ Answer = suspicious_subterm(Node, ArgPos, Mark),
+ Response = user_answer(Question, Answer)
+ )
+ ).
+
+handle_command(print_arg(From, To), UserQuestion, Response,
+ !User, !IO) :-
+ Question = get_decl_question(UserQuestion),
+ edt_node_trace_atom(Question, TraceAtom),
+ print_atom_arguments(TraceAtom, From, To, !.User, !IO),
+ query_user(UserQuestion, Response, !User, !IO).
+
+handle_command(browse_io(ActionNum), UserQuestion, Response,
+ !User, !IO) :-
+ Question = get_decl_question(UserQuestion),
+ edt_node_io_actions(Question, IoActions),
% We don't have code yet to trace a marked I/O action.
- browse_chosen_io_action(IoActions, ActionNum, _MaybeMark, User0, User1),
- query_user_2([UserQuestion | UserQuestions], Skipped, Response,
- User1, User).
-
-handle_command(print_io(From, To), UserQuestion, UserQuestions, Skipped,
- Response, User0, User) -->
- { Question = get_decl_question(UserQuestion) },
- { edt_node_io_actions(Question, IoActions) },
- print_chosen_io_actions(IoActions, From, To, User0),
- query_user_2([UserQuestion | UserQuestions], Skipped, Response,
- User0, User).
-
-handle_command(pd, UserQuestion, _, _, Response, User, User) -->
- { Question = get_decl_question(UserQuestion) },
- { Node = get_decl_question_node(Question) },
- { Response = exit_diagnosis(Node) }.
-
-handle_command(abort, _, _, _, Response, User, User) -->
- { Response = abort_diagnosis }.
-
-handle_command(help, UserQuestion, UserQuestions, Skipped, Response,
- User0, User) -->
- user_help_message(User0),
- query_user_2([UserQuestion | UserQuestions], Skipped, Response,
- User0, User).
-
-handle_command(empty_command, UserQuestion, UserQuestions, Skipped, Response,
- User0, User) -->
- {
+ browse_chosen_io_action(IoActions, ActionNum, _MaybeMark, !User, !IO),
+ query_user(UserQuestion, Response, !User, !IO).
+
+handle_command(print_io(From, To), UserQuestion, Response,
+ !User, !IO) :-
+ Question = get_decl_question(UserQuestion),
+ edt_node_io_actions(Question, IoActions),
+ print_chosen_io_actions(IoActions, From, To, !.User, !IO),
+ query_user(UserQuestion, Response, !User, !IO).
+
+handle_command(pd, UserQuestion, Response, !User, !IO) :-
+ Question = get_decl_question(UserQuestion),
+ Node = get_decl_question_node(Question),
+ Response = exit_diagnosis(Node).
+
+handle_command(abort, _, Response, !User, !IO) :-
+ Response = abort_diagnosis.
+
+handle_command(help, UserQuestion, Response, !User, !IO) :-
+ user_help_message(!.User, !IO),
+ query_user(UserQuestion, Response, !User, !IO).
+
+handle_command(empty_command, UserQuestion, Response, !User,
+ !IO) :-
+ (
UserQuestion = plain_question(_),
Command = skip
;
UserQuestion = question_with_default(_, Truth),
(
- Truth = yes,
+ Truth = correct,
Command = yes
;
- Truth = no,
+ Truth = erroneous,
Command = no
+ ;
+ Truth = inadmissible,
+ Command = inadmissible
)
- },
- handle_command(Command, UserQuestion, UserQuestions, Skipped, Response,
- User0, User).
-
-handle_command(illegal_command, UserQuestion, UserQuestions, Skipped, Response,
- User0, User) -->
- io__write_string("Unknown command, 'h' for help.\n"),
- query_user_2([UserQuestion | UserQuestions], Skipped, Response,
- User0, User).
+ ),
+ handle_command(Command, UserQuestion, Response, !User,
+ !IO).
+
+handle_command(illegal_command, UserQuestion, Response, !User,
+ !IO) :-
+ io__write_string("Unknown command, 'h' for help.\n", !IO),
+ query_user(UserQuestion, Response, !User, !IO).
:- func get_decl_question(user_question(T)) = decl_question(T).
@@ -240,8 +249,9 @@
:- pred default_prompt(decl_truth, string).
:- mode default_prompt(in, out) is det.
-default_prompt(yes, "[yes] ").
-default_prompt(no, "[no] ").
+default_prompt(correct, "[yes] ").
+default_prompt(erroneous, "[no] ").
+default_prompt(inadmissible, "[inadmissible] ").
:- pred edt_node_trace_atom(decl_question(T)::in, trace_atom::out) is det.
@@ -325,13 +335,19 @@
maybe_convert_dirs_to_path(MaybeDirs, MaybeMark),
!:User = !.User ^ browser := Browser.
-:- pred browse_decl_bug_arg(decl_bug::in, int::in,
+:- pred browse_decl_bug(decl_bug::in, maybe(int)::in,
user_state::in, user_state::out, io__state::di, io__state::uo)
is cc_multi.
-browse_decl_bug_arg(Bug, ArgNum, !User, !IO) :-
+browse_decl_bug(Bug, MaybeArgNum, !User, !IO) :-
decl_bug_trace_atom(Bug, Atom),
- browse_atom_argument(Atom, ArgNum, _, !User, !IO).
+ (
+ MaybeArgNum = yes(ArgNum),
+ browse_atom_argument(Atom, ArgNum, _, !User, !IO)
+ ;
+ MaybeArgNum = no,
+ browse_atom(Atom, _, !User, !IO)
+ ).
:- pred browse_atom_argument(trace_atom::in, int::in, maybe(term_path)::out,
user_state::in, user_state::out, io__state::di, io__state::uo)
@@ -356,6 +372,42 @@
MaybeMark = no
).
+:- pred browse_atom(trace_atom::in, maybe(term_path)::out,
+ user_state::in, user_state::out, io__state::di, io__state::uo)
+ is cc_multi.
+
+browse_atom(Atom, MaybeMark, !User, !IO) :-
+ Atom = atom(ProcLayout, Args),
+ ProcId = get_proc_id_from_layout(ProcLayout),
+ get_user_arg_values(Args, ArgValues),
+ get_pred_attributes(ProcId, Module, Name, _, PredOrFunc),
+ Function = pred_to_bool(unify(PredOrFunc,function)),
+ BrowserTerm = synthetic_term_to_browser_term(Module++"."++Name,
+ ArgValues, Function),
+ browse_browser_term(BrowserTerm, !.User ^ instr, !.User ^ outstr,
+ MaybeDirs, !.User ^ browser, Browser, !IO),
+ maybe_convert_dirs_to_path(MaybeDirs, MaybeMark),
+ !:User = !.User ^ browser := Browser.
+
+:- pred get_user_arg_values(list(trace_atom_arg)::in, list(univ)::out) is det.
+
+get_user_arg_values([], []).
+get_user_arg_values([arg_info(UserVisible, _, MaybeValue) | Args], Values) :-
+ get_user_arg_values(Args, Values0),
+ (
+ UserVisible = yes
+ ->
+ (
+ MaybeValue = yes(Value)
+ ;
+ MaybeValue = no,
+ Value = univ('_'`with_type`unbound)
+ ),
+ Values = [Value | Values0]
+ ;
+ Values = Values0
+ ).
+
:- pred print_atom_arguments(trace_atom::in, int::in, int::in, user_state::in,
io__state::di, io__state::uo) is cc_multi.
@@ -413,9 +465,10 @@
; no % The node is incorrect.
; inadmissible % The node is inadmissible.
; skip % The user has no answer.
- ; restart % Ask the skipped questions again.
- ; browse_arg(int) % Browse the nth argument before
- % answering.
+ ; browse_arg(maybe(int)) % Browse the nth argument before
+ % answering. Or browse the whole
+ % predicate/function if the maybe is
+ % no.
; browse_io(int) % Browse the nth IO action before
% answering.
; print_arg(int, int) % Print the nth to the mth arguments
@@ -438,10 +491,9 @@
" answer one of:\n",
"\ty\tyes\t\tthe node is correct\n",
"\tn\tno\t\tthe node is incorrect\n",
-% "\ti\tinadmissible\tthe input arguments are out of range\n",
+ "\ti\tinadmissible\tthe input arguments are out of range\n",
"\ts\tskip\t\tskip this question\n",
- "\tr\trestart\t\task the skipped questions again\n",
- "\tb <n>\tbrowse <n>\tbrowse the nth argument of the atom\n",
+ "\tb [<n>]\tbrowse [<n>]\tbrowse the atom, or its nth argument\n",
"\tb io <n>\tbrowse io <n>\tbrowse the atom's nth I/O action\n",
"\tp <n>\tprint <n>\tprint the nth argument of the atom\n",
"\tp <n-m>\tprint <n-m>\tprint the nth to the mth arguments of the atom\n",
@@ -508,12 +560,10 @@
cmd_handler("yes", one_word_cmd(yes)).
cmd_handler("n", one_word_cmd(no)).
cmd_handler("no", one_word_cmd(no)).
-cmd_handler("in", one_word_cmd(inadmissible)).
+cmd_handler("i", one_word_cmd(inadmissible)).
cmd_handler("inadmissible", one_word_cmd(inadmissible)).
cmd_handler("s", one_word_cmd(skip)).
cmd_handler("skip", one_word_cmd(skip)).
-cmd_handler("r", one_word_cmd(restart)).
-cmd_handler("restart", one_word_cmd(restart)).
cmd_handler("pd", one_word_cmd(pd)).
cmd_handler("a", one_word_cmd(abort)).
cmd_handler("abort", one_word_cmd(abort)).
@@ -532,8 +582,9 @@
:- func browse_arg_cmd(list(string)::in) = (user_command::out) is semidet.
-browse_arg_cmd([Arg]) = browse_arg(ArgNum) :-
+browse_arg_cmd([Arg]) = browse_arg(yes(ArgNum)) :-
string__to_int(Arg, ArgNum).
+browse_arg_cmd([]) = browse_arg(no).
browse_arg_cmd(["io", Arg]) = browse_io(ArgNum) :-
string__to_int(Arg, ArgNum).
@@ -569,39 +620,36 @@
%-----------------------------------------------------------------------------%
-user_confirm_bug(Bug, Response, User0, User) -->
- write_decl_bug(Bug, User0),
- get_command("Is this a bug? ", Command, User0, User1),
+user_confirm_bug(Bug, Response, !User, !IO) :-
+ write_decl_bug(Bug, !.User, !IO),
+ get_command("Is this a bug? ", Command, !User, !IO),
(
- { Command = yes }
+ Command = yes
->
- { Response = confirm_bug },
- { User = User1 }
+ Response = confirm_bug
;
- { Command = no }
+ Command = no
->
- { Response = overrule_bug },
- { User = User1 }
+ Response = overrule_bug
;
- { Command = abort }
+ Command = abort
->
- { Response = abort_diagnosis },
- { User = User1 }
+ Response = abort_diagnosis
;
- { Command = browse_arg(ArgNum) }
+ Command = browse_arg(MaybeArgNum)
->
- browse_decl_bug_arg(Bug, ArgNum, User1, User2),
- user_confirm_bug(Bug, Response, User2, User)
+ browse_decl_bug(Bug, MaybeArgNum, !User, !IO),
+ user_confirm_bug(Bug, Response, !User, !IO)
;
- { Command = browse_io(ActionNum) }
+ Command = browse_io(ActionNum)
->
- { decl_bug_io_actions(Bug, IoActions) },
+ decl_bug_io_actions(Bug, IoActions),
browse_chosen_io_action(IoActions, ActionNum, _MaybeMark,
- User1, User2),
- user_confirm_bug(Bug, Response, User2, User)
+ !User, !IO),
+ user_confirm_bug(Bug, Response, !User, !IO)
;
- user_confirm_bug_help(User1),
- user_confirm_bug(Bug, Response, User1, User)
+ user_confirm_bug_help(!.User, !IO),
+ user_confirm_bug(Bug, Response, !User, !IO)
).
%-----------------------------------------------------------------------------%
@@ -687,12 +735,7 @@
unravel_decl_atom(DeclAtom, TraceAtom, IoActions),
TraceAtom = atom(ProcLabel, Args0),
ProcId = get_proc_id_from_layout(ProcLabel),
- (
- ProcId = proc(_, PredOrFunc, _, Functor, _, _)
- ;
- ProcId = uci_proc(_, _, _, Functor, _, _),
- PredOrFunc = predicate
- ),
+ get_pred_attributes(ProcId, _, Functor, _, PredOrFunc),
Which = chosen_head_vars_presentation,
maybe_filter_headvars(Which, Args0, Args1),
list__map(trace_atom_arg_to_univ, Args1, Args),
--------------------------------------------------------------------------
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