mercurylang/mercury
1
0
Fork 0
mirror of https://github.com/Mercury-Language/mercury.git synced 2025-12-18 07:15:19 +00:00
Code Issues Projects Releases Wiki Activity
Files
ed3ca2ffe0463ec4e0646e6324d59c99299b2326
mercury/browser/declarative_tree.m
Zoltan Somogyi 62ec97d443 Report imports shadowed by other imports. 
If a module has two or more import_module or use_module declarations
for the same module, (typically, but not always, one being in its interface
and one in its implementation), generate an informational message about
each redundant declaration if --warn-unused-imports is enabled.

compiler/hlds_module.m:
    We used to record the set of imported/used modules, and the set of
    modules imported/used in the interface of the current module. However,
    these sets

    - did not record the distinction between imports and uses;
    - did not allow distinction between single and multiple imports/uses;
    - did not record the locations of the imports/uses.

    The first distinction was needed only by module_qual.m, which *did*
    pay attention to it; the other two were not needed at all.

    To generate messages for imports/uses shadowing other imports/uses,
    we need all three, so change the data structure storing such information
    for *direct* imports to one that records all three of the above kinds
    of information. (For imports made by read-in interface and optimization
    files, the old set of modules approach is fine, and this diff leaves
    the set of thus *indirectly* imported module names alone.)

compiler/unused_imports.m:
    Use the extra information now available to generate a
    severity_informational message about any import or use that is made
    redundant by an earlier, more general import or use.

    Fix two bugs in the code that generated warnings for just plain unused
    modules.

    (1) It did not consider that a use of the builtin type char justified
    an import of char.m, but without that import, the type is not visible.

    (2) It scanned cons_ids in goals in procedure bodies, but did not scan
    cons_ids that have been put into the const_struct_db. (I did not update
    the code here when I added the const_struct_db.)

    Also, add a (hopefully temporary) workaround for a bug in
    make_hlds_passes.m, which is noted below.

    However, there are at least three problems that prevent us from enabling
    --warn-unused-imports by default.

    (1) In some places, the import of a module is used only by clauses for
    a predicate that also has foreign procs. When compiled in a grade that
    selects one of those foreign_procs as the implementation of the predicate,
    the clauses are discarded *without* being added to the HLDS at all.
    This leads unused_imports.m to generate an uncalled-for warning in such
    cases. To fix this, we would need to preserve the Mercury clauses for
    *all* predicates, even those with foreign procs, and do all the semantic
    checks on them before throwing them away. (I tried to do this once, and
    failed, but the task should be easier after the item list change.)

    (2) We have two pieces of code to generate import warnings. The one in
    unused_imports.m operates on the HLDS after type and mode checking,
    while module_qual.m operates on the parse tree before the creation of
    the HLDS. The former is more powerful, since it knows e.g. what types and
    modes are used in the bodies of predicates, and hence can generate warnings
    about an import being unused *anywhere* in a module, as opposed to just
    unused in its interface.

    If --warn-unused-imports is enabled, we will get two separate set of
    reports about an interface import being unused in the interface,
    *unless* we get a type or mode error, in which case unused_imports.m
    won't be invoked. But in case we do get such errors, we don't want to
    throw away the warnings from module_qual.m. We could store them and
    throw them away only after we know we won't need them, or just get
    the two modules to generate identical error_specs for each warning,
    so that the sort_and_remove_dups of the error specs will do the
    throwing away for us for free, if we get that far.

    (3) The valid/bug100.m test case was added as a regression test for a bug
    that was fixed in module_qual.m. However the bug is still present in
    unused_imports.m.

compiler/make_hlds_passes.m:
    Give hlds_module.m the extra information it now needs for each item_avail.

    Add an XXX for a bug that cannot be fixed right now: the setting of
    the status of abstract instances to abstract_imported. (The "abstract"
    part is correct; the "imported" part may not be.)

compiler/intermod.m:
compiler/try_expand.m:
compiler/xml_documentation.m:
    Conform to the change in hlds_module.m.

compiler/module_qual.m:
    Update the documentation of the relationship of this module
    with unused_imports.m.

compiler/hlds_data.m:
    Document a problem with the status of instance definitions.

compiler/hlds_out_module.m:
    Update the code that prints out the module_info to conform to the change
    to hlds_module.m.

    Print status information about instances, which was needed to diagnose
    one of the bugs in unused_imports.m. Format the output for instances
    nicer.

compiler/prog_item.m:
    Add a convenience predicate.

compiler/prog_data.m:
    Remove a type synonym that makes things harder to understand, not easier.

compiler/modules.m:
    Delete an XXX that asks for the feature this diff implements.
    Add another XXX about how that feature could be improved.

compiler/Mercury.options.m:
    Add some more modules to the list of modules on which the compiler
    should be invoked with --no-warn-unused-imports.

compiler/*.m:
library/*.m:
mdbcomp/*.m:
browser/*.m:
deep_profiler/*.m:
mfilterjavac/*.m:
    Delete unneeded imports. Many of these shadow other imports, and some
    are just plain unneeded, as shown by --warn-unused-imports. In a few
    modules, there were a *lot* of unneeded imports, but most had just
    one or two.

    In a few cases, removing an import from a module, because it *itself*
    does not need it, required adding that same import to those of its
    submodules which *do* need it.

    In a few cases, conform to other changes above.

tests/invalid/Mercury.options:
    Test the generation of messages about import shadowing on the existing
    import_in_parent.m test case (although it was also tested very thoroughly
    when giving me the information needed for the deletion of all the
    unneeded imports above).

tests/*/*.{m,*exp}:
    Delete unneeded imports, and update any expected error messages
    to expect the now-smaller line numbers.
2015-08-25 00:38:49 +10:00

1908 lines
75 KiB
Mathematica
Raw Blame History

%-----------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------%
% Copyright (C) 2002-2008, 2010-2011 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_tree.m
% Author: Mark Brown
%
% This module defines an instance of mercury_edt/2, the debugging tree.
%
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- module mdb.declarative_tree.
:- interface.
:- import_module mdb.declarative_edt.
:- import_module mdb.declarative_execution.
:- import_module mdbcomp.program_representation.
%-----------------------------------------------------------------------------%
% The type of nodes in our implementation of EDTs. The parameter is meant
% to be the type of references to trace nodes. In particular, the
% references should be to trace nodes that could be considered nodes
% in the EDT, namely those for exit, fail and exception events.
%
:- type edt_node(R)
---> dynamic(R).
:- instance mercury_edt(wrap(S), edt_node(R)) <= annotated_trace(S, R).
% The wrap/1 around the first argument of the instance is
% required by the language.
%
:- type wrap(S)
---> wrap(S).
:- pred edt_subtree_details(S::in, edt_node(R)::in, event_number::out,
sequence_number::out, R::out) is det <= annotated_trace(S, R).
:- pred trace_atom_subterm_is_ground(trace_atom::in, arg_pos::in,
term_path::in) is semidet.
:- pred trace_implicit_tree_info(wrap(S)::in, edt_node(R)::in,
implicit_tree_info::out) is semidet <= annotated_trace(S, R).
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- implementation.
:- import_module mdb.declarative_debugger.
:- import_module mdb.io_action.
:- import_module mdb.term_rep.
:- import_module mdbcomp.goal_path.
:- import_module mdbcomp.prim_data.
:- import_module mdbcomp.rtti_access.
:- import_module mdbcomp.sym_name.
:- import_module assoc_list.
:- import_module bool.
:- import_module deconstruct.
:- import_module exception.
:- import_module int.
:- import_module list.
:- import_module maybe.
:- import_module pair.
:- import_module string.
:- import_module unit.
:- import_module univ.
%-----------------------------------------------------------------------------%
:- instance mercury_edt(wrap(S), edt_node(R)) <= annotated_trace(S, R)
where [
pred(edt_question/3) is trace_question,
pred(edt_get_e_bug/3) is trace_get_e_bug,
pred(edt_get_i_bug/4) is trace_get_i_bug,
pred(edt_children/3) is trace_children,
pred(edt_parent/3) is trace_last_parent,
pred(edt_dependency/6) is trace_dependency,
pred(edt_subterm_mode/5) is trace_subterm_mode,
pred(edt_is_implicit_root/2) is trace_is_implicit_root,
pred(edt_same_nodes/3) is trace_same_event_numbers,
pred(edt_topmost_node/2) is trace_topmost_node,
pred(edt_number_of_events/4) is trace_number_of_events,
pred(edt_subtree_suspicion/4) is trace_subtree_suspicion,
pred(edt_context/4) is trace_context,
func(edt_proc_label/2) is trace_node_proc_label,
func(edt_arg_pos_to_user_arg_num/3) is trace_arg_pos_to_user_arg_num
].
%-----------------------------------------------------------------------------%
:- func exit_node_decl_atom(S::in,
trace_node(R)::in(trace_node_exit)) = (final_decl_atom::out) is det
<= annotated_trace(S, R).
exit_node_decl_atom(Store, ExitNode) = DeclAtom :-
ExitAtom = get_trace_exit_atom(ExitNode),
CallId = ExitNode ^ exit_call,
call_node_from_id(Store, CallId, Call),
CallIoSeq = Call ^ call_io_seq_num,
ExitIoSeq = ExitNode ^ exit_io_seq_num,
( if CallIoSeq = ExitIoSeq then
DeclAtom = final_decl_atom(ExitAtom, no)
else
DeclAtom = final_decl_atom(ExitAtom,
yes(io_action_range(CallIoSeq, ExitIoSeq)))
).
:- func call_node_decl_atom(S, R) = init_decl_atom <= annotated_trace(S, R).
call_node_decl_atom(Store, CallId) = DeclAtom :-
call_node_from_id(Store, CallId, CallNode),
CallAtom = get_trace_call_atom(CallNode),
DeclAtom = init_decl_atom(CallAtom).
:- 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 = node_exit(_, CallId, _, _, _, _, _, _),
Atom = call_node_decl_atom(Store, CallId)
;
Node = node_fail(_, CallId, _, _, _, _),
Atom = call_node_decl_atom(Store, CallId)
;
Node = 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 = node_exit(_, _, _, _, Event, _, _, _)
;
Node = node_fail(_, _, _, Event, _, _)
;
Node = node_excp(_, _, _, _, Event, _, _)
).
%-----------------------------------------------------------------------------%
:- pred trace_question(wrap(S)::in, edt_node(R)::in,
decl_question(edt_node(R))::out) is det <= annotated_trace(S, R).
trace_question(wrap(Store), dynamic(Ref), Root) :-
det_edt_return_node_from_id(Store, Ref, Node),
(
Node = node_fail(_, CallId, RedoId, _, _, _),
DeclAtom = call_node_decl_atom(Store, CallId),
get_answers(Store, RedoId, [], Answers),
Root = missing_answer(dynamic(Ref), DeclAtom, Answers)
;
Node = node_exit(_, CallId, _, _, _, _, _, _),
InitDeclAtom = call_node_decl_atom(Store, CallId),
FinalDeclAtom = exit_node_decl_atom(Store, Node),
Root = wrong_answer(dynamic(Ref), InitDeclAtom, FinalDeclAtom)
;
Node = node_excp(_, CallId, _, Exception, _, _, _),
DeclAtom = call_node_decl_atom(Store, CallId),
Root = unexpected_exception(dynamic(Ref), DeclAtom, Exception)
).
:- pred get_answers(S::in, R::in,
list(final_decl_atom)::in, list(final_decl_atom)::out) is det
<= annotated_trace(S, R).
get_answers(Store, RedoId, DeclAtoms0, DeclAtoms) :-
( if
maybe_redo_node_from_id(Store, RedoId, node_redo(_, ExitId, _, _, _))
then
exit_node_from_id(Store, ExitId, ExitNode),
NextId = ExitNode ^ exit_prev_redo,
DeclAtom = exit_node_decl_atom(Store, ExitNode),
get_answers(Store, NextId, [DeclAtom | DeclAtoms0], DeclAtoms)
else
DeclAtoms = DeclAtoms0
).
:- pred trace_get_e_bug(wrap(S)::in, edt_node(R)::in,
decl_e_bug::out) is det <= annotated_trace(S, R).
trace_get_e_bug(wrap(Store), dynamic(Ref), Bug) :-
det_edt_return_node_from_id(Store, Ref, Node),
(
Node = node_exit(_, CallId, _, _, Event, _, _, _),
InitDeclAtom = call_node_decl_atom(Store, CallId),
FinalDeclAtom = exit_node_decl_atom(Store, Node),
get_exit_atoms_in_contour(Store, Node, Contour),
Bug = incorrect_contour(InitDeclAtom, FinalDeclAtom, Contour, Event)
;
Node = node_fail(_, CallId, _, Event, _, _),
DeclAtom = call_node_decl_atom(Store, CallId),
Bug = partially_uncovered_atom(DeclAtom, Event)
;
Node = node_excp(_, CallId, _, Exception, Event, _, _),
DeclAtom = call_node_decl_atom(Store, CallId),
Bug = unhandled_exception(DeclAtom, Exception, Event)
).
:- pred trace_get_i_bug(wrap(S)::in, edt_node(R)::in,
edt_node(R)::in, decl_i_bug::out) is det <= annotated_trace(S, R).
trace_get_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).
% Finding the parent of a node in the EDT from an EXIT event is in fact
% not deterministic in the presence of backtracking, since one EXIT event
% could belong to multiple children if it is in a call which is backtracked
% over and each of these children could have different parents. We return
% the last interface event of the parent CALL event as the parent. This is
% OK since trace_last_parent is only used when an explicit subtree
% is generated which is above the previous subtree, so it doesn't
% really matter which parent we pick.
%
:- pred trace_last_parent(wrap(S)::in, edt_node(R)::in, edt_node(R)::out)
is semidet <= annotated_trace(S, R).
trace_last_parent(wrap(Store), dynamic(Ref), dynamic(Parent)) :-
det_edt_return_node_from_id(Store, Ref, Node),
( Node = node_fail(_, CallId, _, _, _, _)
; Node = node_exit(_, CallId, _, _, _, _, _, _)
; Node = node_excp(_, CallId, _, _, _, _, _)
),
call_node_from_id(Store, CallId, Call),
CallPrecId = Call ^ call_preceding,
step_left_to_call(Store, CallPrecId, ParentCallNode),
Parent = ParentCallNode ^ call_last_interface.
:- pred trace_same_event_numbers(wrap(S)::in, edt_node(R)::in,
edt_node(R)::in) is semidet <= annotated_trace(S, R).
trace_same_event_numbers(wrap(Store), dynamic(Ref1), dynamic(Ref2)) :-
det_edt_return_node_from_id(Store, Ref1, Node1),
det_edt_return_node_from_id(Store, Ref2, Node2),
(
Node1 = node_exit(_, _, _, _, Event, _, _, _),
Node2 = node_exit(_, _, _, _, Event, _, _, _)
;
Node1 = node_fail(_, _, _, Event, _, _),
Node2 = node_fail(_, _, _, Event, _, _)
;
Node1 = node_excp(_, _, _, _, Event, _, _),
Node2 = node_excp(_, _, _, _, Event, _, _)
).
:- pred trace_topmost_node(wrap(S)::in, edt_node(R)::in) is semidet
<= annotated_trace(S, R).
trace_topmost_node(wrap(Store), dynamic(Ref)) :-
det_edt_return_node_from_id(Store, Ref, Node),
( Node = node_exit(_, CallId, _, _, _, _, _, _)
; Node = node_fail(_, CallId, _, _, _, _)
; Node = node_excp(_, CallId, _, _, _, _, _)
),
% XXX This is buggy: see the io_read_bug test case.
% The node is topmost if the call sequence number is 1.
call_node_from_id(Store, CallId, node_call(_, _, _, 1, _, _, _, _, _, _)).
:- 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),
(
Node = node_fail(PrecId, CallId, _, _, _, _),
not_at_depth_limit(Store, CallId),
stratum_children(Store, PrecId, CallId, [], Children)
;
Node = node_exit(PrecId, CallId, _, _, _, _, _, _),
Atom = get_trace_exit_atom(Node),
not_at_depth_limit(Store, CallId),
( if missing_answer_special_case(Atom) then
stratum_children(Store, PrecId, CallId, [], Children)
else
contour_children(normal, Store, PrecId, CallId, [], Children)
)
;
Node = node_excp(PrecId, CallId, _, _, _, _, _),
not_at_depth_limit(Store, CallId),
contour_children(exception, Store, PrecId, CallId, [], Children)
).
:- pred trace_is_implicit_root(wrap(S)::in, edt_node(R)::in) is semidet
<= annotated_trace(S, R).
trace_is_implicit_root(wrap(Store), dynamic(Ref)) :-
get_edt_call_node(Store, Ref, CallId),
\+ not_at_depth_limit(Store, CallId).
trace_implicit_tree_info(wrap(Store), dynamic(Ref), ImplicitTreeInfo) :-
get_edt_call_node(Store, Ref, CallId),
call_node_from_id(Store, CallId, CallNode),
CallNode ^ call_at_max_depth = yes(ImplicitTreeInfo).
:- pred trace_number_of_events(wrap(S)::in, edt_node(R)::in, int::out,
int::out) is det <= annotated_trace(S, R).
trace_number_of_events(Store, NodeId, Events, DuplicatedEvents) :-
trace_weight(number_of_events, Store, NodeId, 0, Events, no, 0, 0,
DuplicatedEvents).
:- pred trace_subtree_suspicion(wrap(S)::in, edt_node(R)::in, int::out,
int::out) is det <= annotated_trace(S, R).
trace_subtree_suspicion(Store, NodeId, Suspicion, Excess) :-
trace_weight(suspicion, Store, NodeId, 0, Suspicion, no, 0, 0, Excess).
% trace_weight(Weighting, Store, Node, PrevWeight, Weight, RecordDups,
% DupFactor, PrevDupWeight, Excess):
%
% Calculate the difference between the value of a field in an EXIT,
% FAIL or EXCP node and the same field in the corresponding CALL node
% (the field that is used depends on the value of Weighting).
% If Node is a FAIL or EXCP, then sum the differences between the first
% CALL and the first EXIT, subsequent REDOs and EXITs and the final
% REDO and FAIL/EXCP. If Node is a FAIL or EXCP then all the previous
% EXITs will be included in the EDT and the subtrees rooted at these
% EXITs will have common annotated trace nodes. Excess is the total
% weight of all duplicated nodes. PrevWeight and PrevDupWeight are
% accumulators which should initially be zero. RecordDups keeps track
% of whether the final node was a FAIL or EXCP. This should be `no'
% initially. DupFactor keeps track of how many times the nodes before
% the last REDO could have been duplicated, and should initially be zero.
%
:- pred trace_weight(weighting_heuristic::in, wrap(S)::in, edt_node(R)::in,
int::in, int::out, bool::in, int::in, int::in, int::out)
is det <= annotated_trace(S, R).
trace_weight(Weighting, wrap(Store), dynamic(Ref), PrevWeight, Weight,
RecordDups, DupFactor, PrevDupWeight, Excess) :-
det_trace_node_from_id(Store, Ref, Final),
( if
(
Final = node_exit(_, CallId, RedoId, _, FinalEvent, _, _,
FinalSuspicion),
NewRecordDups = RecordDups
;
Final = node_fail(_, CallId, RedoId, FinalEvent, _,
FinalSuspicion),
NewRecordDups = yes
;
Final = node_excp(_, CallId, RedoId, _, FinalEvent, _,
FinalSuspicion),
NewRecordDups = yes
)
then
( if
maybe_redo_node_from_id(Store, RedoId, Redo),
Redo = node_redo(_, ExitId, RedoEvent, _, RedoSuspicion)
then
(
NewRecordDups = yes,
(
Weighting = number_of_events,
NewPrevDupWeight = PrevDupWeight +
DupFactor * (FinalEvent - RedoEvent + 1)
;
Weighting = suspicion,
NewPrevDupWeight = PrevDupWeight +
DupFactor * (FinalSuspicion - RedoSuspicion)
)
;
NewRecordDups = no,
NewPrevDupWeight = 0
),
(
Weighting = number_of_events,
NewPrevWeight = PrevWeight + FinalEvent - RedoEvent + 1
;
Weighting = suspicion,
NewPrevWeight = PrevWeight + FinalSuspicion - RedoSuspicion
),
trace_weight(Weighting, wrap(Store), dynamic(ExitId),
NewPrevWeight, Weight, NewRecordDups,
DupFactor + 1, NewPrevDupWeight, Excess)
else
call_node_from_id(Store, CallId, Call),
CallEvent = Call ^ call_event,
CallSuspicion = Call ^ call_suspicion,
(
Weighting = number_of_events,
Weight = PrevWeight + FinalEvent - CallEvent + 1
;
Weighting = suspicion,
Weight = PrevWeight + FinalSuspicion - CallSuspicion
),
(
NewRecordDups = yes,
(
Weighting = number_of_events,
Excess = PrevDupWeight + DupFactor *
(FinalEvent - CallEvent + 1)
;
Weighting = suspicion,
Excess = PrevDupWeight + DupFactor *
(FinalSuspicion - CallSuspicion)
)
;
NewRecordDups = no,
Excess = 0
)
)
else
throw(internal_error($pred, "not a final event"))
).
:- pred trace_context(wrap(S)::in, edt_node(R)::in, pair(string, int)::out,
maybe(pair(string, int))::out) is semidet <= annotated_trace(S, R).
trace_context(wrap(Store), dynamic(Ref), FileName - LineNo,
MaybeReturnContext) :-
det_trace_node_from_id(Store, Ref, Final),
(
Final = node_exit(_, CallId, _, _, _, Label, _, _)
;
Final = node_fail(_, CallId, _, _, Label, _)
;
Final = node_excp(_, CallId, _, _, _, Label, _)
),
get_context_from_label_layout(Label, FileName, LineNo),
call_node_from_id(Store, CallId, Call),
(
Call ^ call_return_label = yes(ReturnLabel),
get_context_from_label_layout(ReturnLabel, ReturnFileName,
ReturnLineNo),
MaybeReturnContext = yes(ReturnFileName - ReturnLineNo)
;
Call ^ call_return_label = no,
MaybeReturnContext = no
).
:- pred missing_answer_special_case(trace_atom::in) is semidet.
missing_answer_special_case(Atom) :-
ProcLabel = get_proc_label_from_layout(Atom ^ proc_layout),
(
ProcLabel = ordinary_proc_label(StdUtilModule1, pf_predicate,
StdUtilModule2, "builtin_aggregate", 4, _)
;
ProcLabel = ordinary_proc_label(StdUtilModule1, pf_predicate,
StdUtilModule2, "builtin_aggregate2", 6, _)
),
possible_sym_library_module_name("solutions", StdUtilModule1),
possible_sym_library_module_name("solutions", StdUtilModule2).
:- pred possible_sym_library_module_name(string::in, module_name::out)
is multi.
possible_sym_library_module_name(ModuleStr, unqualified(ModuleStr)).
possible_sym_library_module_name(ModuleStr, qualified(unqualified("library"),
ModuleStr)).
:- pred not_at_depth_limit(S::in, R::in) is semidet <= annotated_trace(S, R).
not_at_depth_limit(Store, Ref) :-
call_node_from_id(Store, Ref, CallNode),
CallNode ^ call_at_max_depth = no.
:- func trace_node_proc_label(wrap(S), edt_node(R)) = proc_label
<= annotated_trace(S, R).
trace_node_proc_label(wrap(Store), dynamic(Ref)) = ProcLabel :-
det_edt_return_node_from_id(Store, Ref, Node),
( Node = node_fail(_, _, _, _, Label, _)
; Node = node_exit(_, _, _, _, _, Label, _, _)
; Node = node_excp(_, _, _, _, _, Label, _)
),
ProcLayout = get_proc_layout_from_label_layout(Label),
ProcLabel = get_proc_label_from_layout(ProcLayout).
:- type contour_type
---> normal
% The contour ends with an EXIT event.
; exception.
% The contour ends with an EXCP event.
:- pred contour_children(contour_type::in, S::in, R::in, R::in,
list(edt_node(R))::in, list(edt_node(R))::out) is det
<= annotated_trace(S, R).
contour_children(ContourType, Store, NodeId, StartId, Ns0, Ns) :-
( if NodeId = StartId then
Ns = Ns0
else
contour_children_2(ContourType, Store, NodeId, StartId, Ns0, Ns)
).
:- pred contour_children_2(contour_type::in, S::in, R::in, R::in,
list(edt_node(R))::in, list(edt_node(R))::out) is det
<= annotated_trace(S, R).
contour_children_2(ContourType, Store, NodeId, StartId, Ns0, Ns) :-
det_trace_node_from_id(Store, NodeId, Node),
(
Node = node_call(_, _, _, _, _, _, _, _, _, _),
throw(internal_error($pred, "unexpected start of contour"))
;
Node = node_exit(_, _, _, _, _, _, _, _),
% Add a child for this node.
Ns1 = [dynamic(NodeId) | Ns0]
;
Node = node_fail(_, CallId, _, _, _, _),
% Fail events can be reached here if there were events missing
% due to a parent being shallow traced. In this case, we can't tell
% whether the call was in a negated context or backtracked over,
% so we have to assume the former.
%
% Fail events can also be reached here if the parent was a variant
% of solutions/2.
%
% If this really is in a negated context, the start of the context
% would be just before the entry to this failed call, modulo
% any det/semidet code which succeeded.
call_node_from_id(Store, CallId, Call),
NestedStartId = Call ^ call_preceding,
stratum_children(Store, NodeId, NestedStartId, Ns0, Ns1)
;
Node = node_neg_fail(Prec, NestedStartId, _),
% There is a nested context. Neg_fail events can be reached here
% if there were events missing due to a parent being shallow traced.
% In this case, we can't tell whether the call was in a negated context
% or backtracked over, so we have to assume the former.
contour_children(ContourType, Store, Prec, NestedStartId, Ns0, Ns1)
;
( Node = node_else(Prec, NestedStartId, _)
; Node = node_neg_succ(Prec, NestedStartId, _)
),
% There is a nested context.
stratum_children(Store, Prec, NestedStartId, Ns0, Ns1)
;
Node = node_excp(_, CallId, _, _, _, _, _),
% If the contour ends in an exception, then add this exception
% to the list of contour children and continue along the contour,
% since in this case we are only interested in nodes that caused
% the exception to be thrown.
%
% If the contour ends with an exit then the exception must have been
% caught by a try/2 or try_all/3 or similar. In this case we want to
% add all the exits of the call that threw the exception to the list
% of children since one of the generated solutions may be incorrect.
(
ContourType = exception,
Ns1 = [dynamic(NodeId) | Ns0]
;
ContourType = normal,
call_node_from_id(Store, CallId, Call),
NestedStartId = Call ^ call_preceding,
stratum_children(Store, NodeId, NestedStartId, Ns0, Ns1)
)
;
( Node = node_redo(_, _, _, _, _)
; Node = node_switch(_, _)
; Node = node_first_disj(_, _)
; Node = node_later_disj(_, _, _)
; Node = node_then(_, _, _)
),
% We skip neg_succ nodes for the same reason that we skip exit nodes
% This handles the following cases: redo, switch, first_disj,
% later_disj, and then. Also handles cond when the status is anything
% other than failed.
%
% Redo events can be reached here if there were missing events
% due to a shallow tracing. In this case, we have to scan over
% the entire previous contour, since there is no way to tell
% how much of it was backtracked over.
Ns1 = Ns0
;
Node = node_cond(_, _, CondStatus),
(
CondStatus = failed,
throw(internal_error($pred, "unexpected start of contour"))
;
( CondStatus = succeeded
; CondStatus = undecided
),
Ns1 = Ns0
)
;
Node = node_neg(_, _, NegStatus),
(
ContourType = normal,
throw(internal_error($pred, "unexpected start of contour"))
;
ContourType = exception,
(
NegStatus = failed,
throw(internal_error($pred, "unexpected start of contour"))
;
( NegStatus = succeeded
; NegStatus = undecided
),
% A non-failed NEGE could be encountered when gathering
% the children of an exception node, since the exception
% may have been thrown inside the negation.
Ns1 = Ns0
)
)
),
Next = step_left_in_contour(Store, Node),
contour_children(ContourType, Store, Next, StartId, Ns1, Ns).
:- pred stratum_children(S::in, R::in, R::in, list(edt_node(R))::in,
list(edt_node(R))::out) is det <= annotated_trace(S, R).
stratum_children(Store, NodeId, StartId, Ns0, Ns) :-
( if NodeId = StartId then
Ns = Ns0
else
stratum_children_2(Store, NodeId, StartId, Ns0, Ns)
).
:- pred stratum_children_2(S::in, R::in, R::in, list(edt_node(R))::in,
list(edt_node(R))::out) is det <= annotated_trace(S, R).
stratum_children_2(Store, NodeId, StartId, Ns0, Ns) :-
det_trace_node_from_id(Store, NodeId, Node),
(
( Node = node_call(_, _, _, _, _, _, _, _, _, _)
; Node = node_neg(_, _, _)
),
throw(internal_error($pred, "unexpected start of contour"))
;
( Node = node_fail(_, _, _, _, _, _)
; Node = node_excp(_, _, _, _, _, _, _)
),
% Add a child for this node.
Ns1 = [dynamic(NodeId) | Ns0]
;
Node = node_neg_fail(Prec, NestedStartId, _),
% There is a nested successful context.
contour_children(normal, Store, Prec, NestedStartId, Ns0, Ns1)
;
Node = node_else(Prec, NestedStartId, _),
% There is a nested failed context.
stratum_children(Store, Prec, NestedStartId, Ns0, Ns1)
;
Node = node_exit(_, CallId, _, _, _, _, _, _),
% Only include an exit node as a missing answer child if it
% produces output. If the exit event doesn't produce output,
% then the only way the call could have behaved differently
% is by failing, which won't change the fail, negs or else event
% anchoring the end of the current stratum, since the rest of the goal
% failed anyway.
( if calls_arguments_are_all_ground(Store, CallId) then
Ns1 = Ns0
else
Ns1 = [dynamic(NodeId) | Ns0]
)
;
( Node = node_redo(_, _, _, _, _)
; Node = node_switch(_, _)
; Node = node_first_disj(_, _)
; Node = node_later_disj(_, _, _)
; Node = node_then(_, _, _)
; Node = node_neg_succ(_, _, _)
),
% We skip neg_succ nodes for the same reason that we skip exit nodes
% where there are no outputs (see above).
Ns1 = Ns0
;
Node = node_cond(_, _, CondStatus),
(
( CondStatus = succeeded
; CondStatus = undecided
),
Ns1 = Ns0
;
CondStatus = failed,
throw(internal_error($pred, "unexpected start of contour"))
)
),
Next = step_in_stratum(Store, Node),
stratum_children(Store, Next, StartId, Ns1, Ns).
%-----------------------------------------------------------------------------%
%
% Tracking a subterm dependency.
%
% We are given an EDT node, an argument position, and a path to the selected
% subterm. We wish to find the origin of that subterm within the body of the
% given node, or within the body of its parent. We can figure out the mode of
% the top of the selected subterm.
%
% If the mode is `in', the origin could be:
% - a primitive (unification or foreign_proc) within the body of the
% parent,
% - an output subterm in a sibling node, or
% - an input subterm of the parent node.
% In this case we look at the contour leading up to the call event associated
% with the given node. This contour will be wholly within the parent call.
%
% If the mode is `out', the origin could be:
% - a primitive (unification or foreign_proc) within the body of the
% call,
% - an output subterm of a child of the node, or
% - an input subterm of the node itself.
% In this case we look at the contour leading up to the exit or exception event
% associated with the given node. This contour will be wholly within the
% current call.
%
% Our algorithm for finding the origin has three phases.
%
% In the first phase, we materialize a list of the nodes in the contour.
%
% In the second phase, we use this list of nodes to construct a list of the
% primitive goals along that contour in the body of the relevant procedure,
% leading up to either the call event (if subterm_mode is `in') or the exit
% event (if subterm_mode is `out').
%
% In the third phase, we traverse the list of primitive goals backwards, from
% the most recently executed primitive to the earliest one, keeping track of
% the variable which contains the selected subterm, and the location within
% this variable.
:- type dependency_chain_start(R)
---> chain_start(
% The argument number of the selected position in the full list
% of arguments, including the compiler-generated ones.
start_loc(R),
% The total number of arguments including the compiler
% generated ones.
int,
int,
% The id of the node preceding the exit node if start_loc
% is cur_goal, and the id of the node preceding the call node
% if start_loc is parent_goal.
R,
% No if start_loc is cur_goal; and yes wrapped around the
% goal path of the call in the parent procedure if start_loc
% is parent_goal.
maybe(reverse_goal_path),
% The body of the procedure indicated by start_loc.
maybe(proc_defn_rep)
)
; require_explicit_subtree.
% An explicit subtree is required before the
% chain start can be calculated.
:- type start_loc(R)
---> cur_goal
; parent_goal(R, trace_node(R)).
:- type goal_and_path
---> goal_and_path(goal_rep, reverse_goal_path).
:- type goal_and_path_list == list(goal_and_path).
:- type annotated_primitive(R)
---> primitive(
string, % filename
int, % line number
list(var_rep), % vars bound by the atomic goal
atomic_goal_rep, % the atomic goal itself
reverse_goal_path, % its goal path
maybe(R) % if the atomic goal is a call,
% the id of the call's exit event
).
:- 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)
;
ChainStart = require_explicit_subtree,
% The only time a subtree will be required is if the
% mode of the subterm is output.
Mode = subterm_out
).
:- 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, TotalArgs, NodeId,
StartPath, MaybeProcDefnRep),
Mode = start_loc_to_subterm_mode(StartLoc),
(
MaybeProcDefnRep = no,
Origin = origin_not_found
;
MaybeProcDefnRep = yes(ProcDefnRep),
( if
trace_dependency_special_case(Store, ProcDefnRep, Ref,
StartLoc, ArgNum, TermPath, NodeId, Origin0)
then
Origin = Origin0
else
trace_dependency_in_proc_defn_rep(Store, TermPath, StartLoc,
ArgNum, TotalArgs, NodeId, StartPath, ProcDefnRep, Origin)
)
)
;
ChainStart = require_explicit_subtree,
Origin = origin_require_explicit_subtree,
% The only time a subtree will be required is if the subterm is output.
Mode = subterm_out
).
% trace_dependency_special_case handles special cases not handled
% by the usual subterm dependency tracking algorithm. At the moment
% it handles tracking of subterms through catch_impl.
%
:- pred trace_dependency_special_case(S::in, proc_defn_rep::in, R::in,
start_loc(R)::in, int::in, term_path::in, R::in,
subterm_origin(edt_node(R))::out) is semidet <= annotated_trace(S, R).
trace_dependency_special_case(Store, ProcDefnRep, Ref, StartLoc,
ArgNum, TermPath, NodeId, Origin) :-
% Catch_impl's body is a single call to builtin_catch. Builtin_catch
% doesn't generate any events, so we need to handle catch_impl specially.
proc_defn_rep_is_catch_impl(ProcDefnRep),
(
StartLoc = parent_goal(_, _),
% The subterm being tracked is an input to builtin_catch so we know
% the origin will be in the first argument of catch_impl, because
% builtin_catch is only called from catch_impl.
Origin = origin_input(user_head_var(1), [ArgNum | TermPath])
;
StartLoc = cur_goal,
% The subterm being tracked is an output of catch_impl so we know
% its origin will be the output of the closure passed to try.
% If the closure succeeded, then we continue to track the subterm
% in the child call to exception.wrap_success_or_failure, otherwise
% we stop tracking at the catch_impl.
% XXX In future we should track exception values to the throw
% that created them.
exit_node_from_id(Store, Ref, ExitNode),
ExitAtom = get_trace_exit_atom(ExitNode),
ExitAtom = atom(_, Args),
list.det_index1(Args, ArgNum, TryResultArgInfo),
TryResultArgInfo = arg_info(_, _, yes(TryResultRep)),
rep_to_univ(TryResultRep, TryResultUniv),
univ_value(TryResultUniv) = TryResult,
deconstruct(TryResult, canonicalize, Functor, _, _),
( if Functor = "succeeded" then
Origin = origin_output(dynamic(NodeId), any_head_var_from_back(1),
TermPath)
else
Origin = origin_primitive_op("exception.m", 0, primop_builtin_call)
)
).
:- pred trace_dependency_in_proc_defn_rep(S::in, term_path::in,
start_loc(R)::in, int::in, int::in, R::in, maybe(reverse_goal_path)::in,
proc_defn_rep::in, subterm_origin(edt_node(R))::out) is det
<= annotated_trace(S, R).
trace_dependency_in_proc_defn_rep(Store, TermPath, StartLoc, ArgNum,
TotalArgs, NodeId, StartPath, ProcDefnRep, Origin) :-
det_trace_node_from_id(Store, NodeId, Node),
materialize_contour(Store, NodeId, Node, [], Contour0),
(
StartLoc = parent_goal(CallId, CallNode),
Contour = list.append(Contour0, [CallId - CallNode])
;
StartLoc = cur_goal,
Contour = Contour0
),
HeadVars = list.map(head_var_to_var, ProcDefnRep ^ pdr_head_vars),
GoalRep = ProcDefnRep ^ pdr_goal,
is_traced_grade(AllTraced),
MaybePrims = make_primitive_list(Store,
[goal_and_path(GoalRep, rgp_nil)], Contour, StartPath, ArgNum,
TotalArgs, HeadVars, AllTraced, []),
(
MaybePrims = yes(primitive_list_and_var(Primitives, Var,
MaybeClosure)),
% If the subterm is in a closure argument then the argument number
% of the closure argument is prefixed to the term path, since the
% closure is itself a term. This is done here because at the time
% of the closure call it is not easy to decide if the call is higher
% order or not, without repeating all the work done in
% make_primitive_list.
(
MaybeClosure = yes,
AdjustedTermPath = [ArgNum | TermPath]
;
MaybeClosure = no,
AdjustedTermPath = TermPath
),
traverse_primitives(Primitives, Var, AdjustedTermPath, Store,
ProcDefnRep, Origin)
;
MaybePrims = no,
Origin = origin_not_found
).
% proc_defn_rep_is_catch_impl(ProcDefnRep) is true if ProcDefnRep
% is a representation of exception.catch_impl (the converse is true
% assuming exception.builtin_catch is only called from
% exception.catch_impl).
%
:- pred proc_defn_rep_is_catch_impl(proc_defn_rep::in) is semidet.
proc_defn_rep_is_catch_impl(ProcDefnRep) :-
GoalRep = ProcDefnRep ^ pdr_goal,
HeadVars = list.map(head_var_to_var, ProcDefnRep ^ pdr_head_vars),
GoalExprRep = GoalRep ^ goal_expr_rep,
HeadVars = [A, B, C, D],
GoalExprRep = atomic_goal_rep("exception.m", _, [D],
plain_call_rep("exception", "builtin_catch", [A, B, C, D])).
:- pred find_chain_start(S::in, R::in, arg_pos::in, term_path::in,
dependency_chain_start(R)::out) is det <= annotated_trace(S, R).
find_chain_start(Store, Ref, ArgPos, TermPath, ChainStart) :-
det_edt_return_node_from_id(Store, Ref, Node),
(
Node = node_exit(_, CallId, _, _, _, _, _, _),
ExitAtom = get_trace_exit_atom(Node),
call_node_from_id(Store, CallId, CallNode),
CallAtom = get_trace_call_atom(CallNode),
( if trace_atom_subterm_is_ground(CallAtom, ArgPos, TermPath) then
find_chain_start_inside(Store, CallId, CallNode,
ArgPos, ChainStart)
else if trace_atom_subterm_is_ground(ExitAtom, ArgPos, TermPath) then
( if not_at_depth_limit(Store, CallId) then
find_chain_start_outside(CallNode, Node, ArgPos, ChainStart)
else
ChainStart = require_explicit_subtree
)
else
throw(internal_error($pred, "unbound wrong answer term"))
)
;
Node = node_fail(_, CallId, _, _, _, _),
call_node_from_id(Store, CallId, CallNode),
CallAtom = get_trace_call_atom(CallNode),
( if trace_atom_subterm_is_ground(CallAtom, ArgPos, TermPath) then
find_chain_start_inside(Store, CallId, CallNode,
ArgPos, ChainStart)
else
throw(internal_error($pred, "unbound missing answer term"))
)
;
Node = node_excp(_, CallId, _, _, _, _, _),
call_node_from_id(Store, CallId, CallNode),
CallAtom = get_trace_call_atom(CallNode),
% XXX We don't yet handle tracking of the exception value.
( if trace_atom_subterm_is_ground(CallAtom, ArgPos, TermPath) then
find_chain_start_inside(Store, CallId, CallNode,
ArgPos, ChainStart)
else
throw(internal_error($pred, "unbound exception term"))
)
).
:- pred find_chain_start_inside(S::in, R::in,
trace_node(R)::in(trace_node_call), arg_pos::in,
dependency_chain_start(R)::out) is det <= annotated_trace(S, R).
find_chain_start_inside(Store, CallId, CallNode, ArgPos, ChainStart) :-
CallPrecId = CallNode ^ call_preceding,
CallAtom = get_trace_call_atom(CallNode),
CallPathStr = get_goal_path_from_maybe_label(CallNode ^ call_return_label),
rev_goal_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_defn_rep(Store, CallId, 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,
dependency_chain_start(R)::out) is det.
find_chain_start_outside(CallNode, ExitNode, ArgPos, ChainStart) :-
StartLoc = cur_goal,
ExitAtom = get_trace_exit_atom(ExitNode),
absolute_arg_num(ArgPos, ExitAtom, ArgNum),
TotalArgs = length(ExitAtom ^ atom_args),
StartId = ExitNode ^ exit_preceding,
StartPath = no,
call_node_maybe_proc_defn_rep(CallNode, StartRep),
ChainStart = chain_start(StartLoc, ArgNum, TotalArgs, StartId,
StartPath, StartRep).
:- pred parent_proc_defn_rep(S::in, R::in, maybe(proc_defn_rep)::out)
is det <= annotated_trace(S, R).
parent_proc_defn_rep(Store, CallId, ProcDefnRep) :-
call_node_from_id(Store, CallId, Call),
CallPrecId = Call ^ call_preceding,
( if step_left_to_call(Store, CallPrecId, ParentCallNode) then
call_node_maybe_proc_defn_rep(ParentCallNode, ProcDefnRep)
else
ProcDefnRep = 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).
step_left_to_call(Store, NodeId, ParentCallNode) :-
trace_node_from_id(Store, NodeId, Node),
( if Node = node_call(_, _, _, _, _, _, _, _, _, _) then
ParentCallNode = Node
else
% We wish to step through negated contexts, so we handle NEGE
% and COND events separately, since step_left_in_contour/2
% will throw an exception if it reaches the boundary of a
% negated context.
( if Node = node_neg(NegPrec, _, _) then
PrevNodeId = NegPrec
else if Node = node_cond(CondPrec, _, _) then
PrevNodeId = CondPrec
else
PrevNodeId = step_left_in_contour(Store, Node)
),
step_left_to_call(Store, PrevNodeId, ParentCallNode)
).
:- pred materialize_contour(S::in, R::in, trace_node(R)::in,
assoc_list(R, trace_node(R))::in, assoc_list(R, trace_node(R))::out)
is det <= annotated_trace(S, R).
materialize_contour(Store, NodeId, Node, Nodes0, Nodes) :-
( if Node = node_call(_, _, _, _, _, _, _, _, _, _) then
Nodes = Nodes0
else
% We include NEGE and (possibly failed) COND events in the contour
% so we can track input sub-terms through negated contexts.
( if Node = node_neg(NegPrec, _, _) then
PrevNodeId = NegPrec
else if Node = node_cond(CondPrec, _, _) then
PrevNodeId = CondPrec
else
PrevNodeId = step_left_in_contour(Store, Node)
),
det_trace_node_from_id(Store, PrevNodeId, PrevNode),
( if Node = node_then(_, _, _) then
% The cond node is enough to tell us which way the if-then-else
% went; the then node would just complicate the job of
% make_primitive_list.
Nodes1 = Nodes0
else
Nodes1 = [NodeId - Node | Nodes0]
),
materialize_contour(Store, PrevNodeId, PrevNode, Nodes1, Nodes)
).
:- pred get_exit_atoms_in_contour(S::in,
trace_node(R)::in(trace_node_exit),
list(final_decl_atom)::out) is det <= annotated_trace(S, R).
get_exit_atoms_in_contour(Store, ExitNode, ExitAtoms) :-
ExitPrecId = ExitNode ^ exit_preceding,
det_trace_node_from_id(Store, ExitPrecId, ExitPrec),
materialize_contour(Store, ExitPrecId, ExitPrec, [], Contour),
list.filter_map(get_exit_atom(Store), Contour, ExitAtoms).
:- pred get_exit_atom(S::in, pair(R, trace_node(R))::in,
final_decl_atom::out) is semidet <= annotated_trace(S, R).
get_exit_atom(Store, _ - Exit, FinalAtom) :-
Exit = node_exit(_, _, _, _, _, _, _, _),
FinalAtom = exit_node_decl_atom(Store, Exit).
:- 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
).
% 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(reverse_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 :-
( if
AllTraced = no,
(
next_goal_generates_internal_event(GoalPaths)
;
GoalPaths = []
)
then
% 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)
else
AdjustedContour = Contour
),
( if
AllTraced = no,
contour_at_end_path(AdjustedContour, MaybeEnd),
(
next_goal_generates_internal_event(GoalPaths)
;
GoalPaths = []
)
then
% 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
else
(
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(reverse_goal_path)::in) is semidet.
contour_at_end_path([_ - Node], yes(EndPath)) :-
Node = node_call(_, _, _, _, _, _, MaybeReturnLabel, _, _, _),
CallPathStr = get_goal_path_from_maybe_label(MaybeReturnLabel),
rev_goal_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, Primitives0)
% = 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 Primitives0 appended to the end of 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 it returns "no".
%
:- func match_goal_to_contour_event(S, goal_rep, reverse_goal_path,
goal_and_path_list, assoc_list(R, trace_node(R)), maybe(reverse_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 = goal_rep(GoalExpr, _, _),
(
GoalExpr = conj_rep(Conjs),
add_paths_to_conjuncts(Conjs, Path, 1, ConjPaths),
MaybePrims = make_primitive_list(Store, ConjPaths ++ GoalPaths,
Contour, MaybeEnd, ArgNum, TotalArgs, HeadVars, AllTraced,
Primitives0)
;
GoalExpr = scope_rep(InnerGoal, MaybeCut),
InnerPath = rev_goal_path_add_at_end(Path, step_scope(MaybeCut)),
InnerAndPath = goal_and_path(InnerGoal, InnerPath),
MaybePrims = make_primitive_list(Store, [InnerAndPath | GoalPaths],
Contour, MaybeEnd, ArgNum, TotalArgs, HeadVars, AllTraced,
Primitives0)
;
GoalExpr = atomic_goal_rep(File, Line, BoundVars, AtomicGoal),
GeneratesEvent = atomic_goal_generates_event_like_call(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)
)
;
GoalExpr = disj_rep(Disjs),
( if
Contour = [_ - ContourHeadNode | ContourTail],
( ContourHeadNode = node_first_disj(_, Label)
; ContourHeadNode = node_later_disj(_, Label, _)
),
DisjPathStr = get_goal_path_from_label_layout(Label),
rev_goal_path_from_string_det(DisjPathStr, DisjPath),
rev_goal_path_remove_last(DisjPath, DisjInitialPath, DisjLastStep),
DisjInitialPath = Path,
DisjLastStep = step_disj(N)
then
list.det_index1(Disjs, N, Disj),
DisjAndPath = goal_and_path(Disj, DisjPath),
MaybePrims = make_primitive_list(Store, [DisjAndPath | GoalPaths],
ContourTail, MaybeEnd, ArgNum, TotalArgs, HeadVars, AllTraced,
Primitives0)
else
throw(internal_error($pred, "mismatch on disj"))
)
;
GoalExpr = switch_rep(_SwitchVar, _SwitchCanFail, Cases),
( if
Contour = [_ - ContourHeadNode | ContourTail],
ContourHeadNode = node_switch(_, Label),
ArmPathStr = get_goal_path_from_label_layout(Label),
rev_goal_path_from_string_det(ArmPathStr, ArmPath),
rev_goal_path_remove_last(ArmPath, ArmInitialPath, ArmLastStep),
ArmInitialPath = Path,
ArmLastStep = step_switch(N, _)
then
list.det_index1(Cases, N, Case),
Case = case_rep(_ConsId, _ConsIdArity, Arm),
ArmAndPath = goal_and_path(Arm, ArmPath),
MaybePrims = make_primitive_list(Store, [ArmAndPath | GoalPaths],
ContourTail, MaybeEnd, ArgNum, TotalArgs, HeadVars, AllTraced,
Primitives0)
else
throw(internal_error($pred, "mismatch on switch"))
)
;
GoalExpr = ite_rep(Cond, Then, Else),
( if
Contour = [_ - ContourHeadNode | ContourTail],
ContourHeadNode = node_cond(_, Label, _),
CondPathStr = get_goal_path_from_label_layout(Label),
rev_goal_path_from_string_det(CondPathStr, CondPath),
rev_goal_path_remove_last(CondPath, CondInitialPath, CondLastStep),
CondInitialPath = Path,
CondLastStep = step_ite_cond
then
ThenPath = rev_goal_path_add_at_end(Path, step_ite_then),
CondAndPath = goal_and_path(Cond, CondPath),
ThenAndPath = goal_and_path(Then, ThenPath),
MaybePrims = make_primitive_list(Store,
[CondAndPath, ThenAndPath | GoalPaths], ContourTail,
MaybeEnd, ArgNum, TotalArgs, HeadVars, AllTraced, Primitives0)
else if
Contour = [_ - ContourHeadNode | ContourTail],
ContourHeadNode = node_else(_, ElseCondId, _),
cond_node_from_id(Store, ElseCondId, CondNode),
CondNode = node_cond(_, Label, _),
CondPathStr = get_goal_path_from_label_layout(Label),
rev_goal_path_from_string_det(CondPathStr, CondPath),
rev_goal_path_remove_last(CondPath, CondInitialPath, CondLastStep),
CondInitialPath = Path,
CondLastStep = step_ite_cond
then
ElsePath = rev_goal_path_add_at_end(Path, step_ite_else),
ElseAndPath = goal_and_path(Else, ElsePath),
MaybePrims = make_primitive_list(Store, [ElseAndPath | GoalPaths],
ContourTail, MaybeEnd, ArgNum, TotalArgs, HeadVars, AllTraced,
Primitives0)
else
throw(internal_error($pred, "mismatch on if-then-else"))
)
;
GoalExpr = negation_rep(NegGoal),
( if
Contour = [_ - ContourHeadNode | ContourTail],
ContourHeadNode = node_neg_succ(_, _, _)
then
% The negated goal cannot contribute any bindings.
MaybePrims = make_primitive_list(Store, GoalPaths, ContourTail,
MaybeEnd, ArgNum, TotalArgs, HeadVars, AllTraced, Primitives0)
else if
Contour = [_ - ContourHeadNode | ContourTail],
ContourHeadNode = node_neg(_, _, _)
then
% The end of the primitive list is somewhere inside
% NegGoal.
NegPath = rev_goal_path_add_at_end(Path, step_neg),
NegAndPath = goal_and_path(NegGoal, NegPath),
MaybePrims = make_primitive_list(Store, [NegAndPath], ContourTail,
MaybeEnd, ArgNum, TotalArgs, HeadVars, AllTraced, Primitives0)
else
throw(internal_error($pred, "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],
( if
( ContourHeadNode = node_exit(_, _, _, _, _, _, _, _)
; ContourHeadNode = node_fail(_, _, _, _, _, _)
)
then
remove_leading_exit_fail_events(ContourTail, Contour)
else
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), reverse_goal_path,
list(goal_and_path), assoc_list(R, trace_node(R)), maybe(reverse_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 :-
( if
Contour = [_ - ContourHeadNode],
MaybeEnd = yes(EndPath)
then
( if
ContourHeadNode = node_call(_, _, _, _, _, _,
MaybeReturnLabel, _, _, _),
Atom = get_trace_call_atom(ContourHeadNode),
CallPathStr = get_goal_path_from_maybe_label( MaybeReturnLabel),
rev_goal_path_from_string_det(CallPathStr, CallPath),
CallPath = EndPath
then
( if
( if
atomic_goal_identifiable(AtomicGoal) = yes(AtomicGoalId)
then
atomic_goal_matches_atom(AtomicGoalId, Atom)
else
AllTraced = yes
)
then
( if
% Test to see that the argument is not a closure argument
% (passed in when the closure was created).
ArgNum > TotalArgs - length(AtomicGoalArgs)
then
find_variable_in_args(AtomicGoalArgs, ArgNum, TotalArgs,
Var),
MaybePrims = yes(
primitive_list_and_var(Primitives0, Var, no))
else
% 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))
;
( AtomicGoal = unify_construct_rep(_, _, _)
; AtomicGoal = unify_deconstruct_rep(_, _, _)
; AtomicGoal = partial_deconstruct_rep(_, _, _)
; AtomicGoal = partial_construct_rep(_, _, _)
; AtomicGoal = unify_assign_rep(_, _)
; AtomicGoal = cast_rep(_, _)
; AtomicGoal = unify_simple_test_rep(_, _)
; AtomicGoal = pragma_foreign_code_rep(_)
; AtomicGoal = method_call_rep(_, _, _)
; AtomicGoal = plain_call_rep(_, _, _)
; AtomicGoal = builtin_call_rep(_, _, _)
; AtomicGoal = event_call_rep(_, _)
),
throw(internal_error($pred,
"argument number mismatch"))
)
)
else
(
AllTraced = yes,
throw(internal_error($pred, "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)
)
)
else
throw(internal_error($pred, "goalpath mismatch on call"))
)
else
(
Contour = [ContourHeadId - ContourHeadNode | ContourTail],
( if Atom = get_trace_exit_atom(ContourHeadNode) then
( if
( if
atomic_goal_identifiable(AtomicGoal) =
yes(AtomicGoalId)
then
atomic_goal_matches_atom(AtomicGoalId, Atom)
else
AllTraced = yes
)
then
CallInfo = yes(ContourHeadId),
NewContour = ContourTail
else
(
AllTraced = yes,
throw(internal_error($pred,
"atomic goal doesn't match exit event\n"))
;
AllTraced = no,
CallInfo = no,
NewContour = Contour
)
)
else
(
AllTraced = yes,
throw(internal_error($pred,
"atomic goal with no exit event "
++ "when assuming all traced"))
;
AllTraced = no,
CallInfo = no,
NewContour = Contour
)
),
Primitive = primitive(File, Line, BoundVars, AtomicGoal, Path,
CallInfo),
Primitives1 = [Primitive | Primitives0],
MaybePrims = make_primitive_list(Store, GoalPaths, NewContour,
MaybeEnd, ArgNum, TotalArgs, HeadVars, AllTraced, Primitives1)
;
Contour = [],
( if
MaybeEnd = no,
AllTraced = no
then
Primitive = primitive(File, Line, BoundVars, AtomicGoal, Path,
no),
Primitives1 = [Primitive | Primitives0],
MaybePrims = make_primitive_list(Store, GoalPaths, [],
MaybeEnd, ArgNum, TotalArgs, HeadVars, AllTraced,
Primitives1)
else
throw(internal_error($pred, "premature contour end"))
)
)
).
:- 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),
ProcLabel = get_proc_label_from_layout(Atom ^ proc_layout),
get_pred_attributes(ProcLabel, EventModule, EventName, _, _),
EventArity = length(Atom ^ atom_args),
GoalModule = sym_name_to_string(EventModule),
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.
( if list.index1(reverse(Args), TotalArgs - ArgNum + 1, FoundVar) then
Var = FoundVar
else
throw(internal_error($pred, "arg not found"))
).
:- pred traverse_primitives(list(annotated_primitive(R))::in,
var_rep::in, term_path::in, S::in, proc_defn_rep::in,
subterm_origin(edt_node(R))::out) is det <= annotated_trace(S, R).
traverse_primitives([], Var0, TermPath0, _, ProcDefnRep, Origin) :-
HeadVars = list.map(head_var_to_var, ProcDefnRep ^ pdr_head_vars),
ArgPos = find_arg_pos(HeadVars, Var0),
Origin = origin_input(ArgPos, TermPath0).
traverse_primitives([Prim | Prims], Var0, TermPath0, Store, ProcDefnRep,
Origin) :-
Prim = primitive(File, Line, BoundVars, AtomicGoal, _GoalPath,
MaybeNodeId),
(
AtomicGoal = unify_construct_rep(_CellVar, _Cons, FieldVars),
( if list.member(Var0, BoundVars) then
(
TermPath0 = [],
Origin = origin_primitive_op(File, Line, primop_unification)
;
TermPath0 = [TermPathStep0 | TermPath],
list.det_index1(FieldVars, TermPathStep0, Var),
traverse_primitives(Prims, Var, TermPath, Store, ProcDefnRep,
Origin)
)
else
traverse_primitives(Prims, Var0, TermPath0, Store, ProcDefnRep,
Origin)
)
;
AtomicGoal = unify_deconstruct_rep(CellVar, _Cons, FieldVars),
( if list.member(Var0, BoundVars) then
( if list.index1_of_first_occurrence(FieldVars, Var0, Pos) then
traverse_primitives(Prims, CellVar, [Pos | TermPath0],
Store, ProcDefnRep, Origin)
else
throw(internal_error($pred, "bad deconstruct"))
)
else
traverse_primitives(Prims, Var0, TermPath0, Store, ProcDefnRep,
Origin)
)
;
AtomicGoal = partial_deconstruct_rep(_, _, MaybeFieldVars),
( if
list.member(Var0, BoundVars),
TermPath0 = [TermPathStep0 | TermPath]
then
list.det_index1(MaybeFieldVars, TermPathStep0, MaybeVar),
(
MaybeVar = yes(Var),
% This partial deconstruction bound the TermPathStep0'th
% argument of Var0.
traverse_primitives(Prims, Var, TermPath, Store, ProcDefnRep,
Origin)
;
MaybeVar = no,
% This partial deconstruction did not bind the TermPathStep0'th
% argument, so continue looking for the unification which did.
traverse_primitives(Prims, Var0, TermPath0, Store, ProcDefnRep,
Origin)
)
else
traverse_primitives(Prims, Var0, TermPath0, Store, ProcDefnRep,
Origin)
)
;
AtomicGoal = partial_construct_rep(_, _, MaybeFieldVars),
( if list.member(Var0, BoundVars) then
(
TermPath0 = [],
Origin = origin_primitive_op(File, Line, primop_unification)
;
TermPath0 = [TermPathStep0 | TermPath],
list.det_index1(MaybeFieldVars, TermPathStep0, MaybeVar),
(
MaybeVar = yes(Var),
% The partial construction bound the TermPathStep0'th
% argument of Var0.
traverse_primitives(Prims, Var, TermPath, Store,
ProcDefnRep, Origin)
;
MaybeVar = no,
% We got to the construction which bound the outermost
% functor of Var0 without finding the unification which
% bound the TermPathStep0'th argument of that functor.
% So something has gone wrong.
throw(internal_error($pred, "input argument not found"))
)
)
else
traverse_primitives(Prims, Var0, TermPath0, Store, ProcDefnRep,
Origin)
)
;
AtomicGoal = unify_assign_rep(ToVar, FromVar),
% We handle assigns the same as we handle unsafe casts.
( if list.member(Var0, BoundVars) then
decl_require(unify(Var0, ToVar), "traverse_primitives",
"bad assign"),
traverse_primitives(Prims, FromVar, TermPath0, Store, ProcDefnRep,
Origin)
else
traverse_primitives(Prims, Var0, TermPath0, Store, ProcDefnRep,
Origin)
)
;
AtomicGoal = cast_rep(ToVar, FromVar),
% We handle casts the same as we handle assigns.
( if list.member(Var0, BoundVars) then
decl_require(unify(Var0, ToVar), $pred, "bad unsafe_cast"),
traverse_primitives(Prims, FromVar, TermPath0, Store, ProcDefnRep,
Origin)
else
traverse_primitives(Prims, Var0, TermPath0, Store, ProcDefnRep,
Origin)
)
;
AtomicGoal = pragma_foreign_code_rep(_Args),
( if list.member(Var0, BoundVars) then
Origin = origin_primitive_op(File, Line, primop_foreign_proc)
else
traverse_primitives(Prims, Var0, TermPath0, Store, ProcDefnRep,
Origin)
)
;
AtomicGoal = unify_simple_test_rep(_LVar, _RVar),
( if list.member(Var0, BoundVars) then
throw(internal_error($pred, "bad test"))
else
traverse_primitives(Prims, Var0, TermPath0, Store, ProcDefnRep,
Origin)
)
;
AtomicGoal = higher_order_call_rep(_, Args),
traverse_call(BoundVars, File, Line, Args, MaybeNodeId, Prims,
Var0, TermPath0, Store, ProcDefnRep, Origin)
;
AtomicGoal = method_call_rep(_, _, Args),
traverse_call(BoundVars, File, Line, Args, MaybeNodeId, Prims,
Var0, TermPath0, Store, ProcDefnRep, Origin)
;
AtomicGoal = plain_call_rep(Module, Name, Args),
( if
list.member(Var0, BoundVars),
plain_call_is_special_case(Module, Name, Args, NewVar)
then
traverse_primitives(Prims, NewVar, TermPath0, Store, ProcDefnRep,
Origin)
else
traverse_call(BoundVars, File, Line, Args, MaybeNodeId,
Prims, Var0, TermPath0, Store, ProcDefnRep, Origin)
)
;
AtomicGoal = builtin_call_rep(_, _, _),
( if list.member(Var0, BoundVars) then
Origin = origin_primitive_op(File, Line, primop_builtin_call)
else
traverse_primitives(Prims, Var0, TermPath0, Store, ProcDefnRep,
Origin)
)
;
AtomicGoal = event_call_rep(_, _),
( if list.member(Var0, BoundVars) then
throw(internal_error($pred, "bad event"))
else
traverse_primitives(Prims, Var0, TermPath0, Store, ProcDefnRep,
Origin)
)
).
% Some foreign calls, such as casts, are handled specially
% to improve the accuracy of the subterm dependency tracking algorithm.
%
:- pred plain_call_is_special_case(string::in, string::in, list(var_rep)::in,
var_rep::out) is semidet.
plain_call_is_special_case(Module, Name, Args, NewVar) :-
% builtin.cc_multi_equal is the same as a unification for the
% purposes of subterm dependency tracking.
Module = "builtin",
Name = "cc_multi_equal",
list.length(Args, 3),
list.det_index1(Args, 2) = NewVar.
:- type plain_call_info
---> plain_call_info(
file_name :: string,
line_number :: int,
flat_module_name :: string,
pred_name :: string
).
:- 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_defn_rep::in,
subterm_origin(edt_node(R))::out) is det <= annotated_trace(S, R).
traverse_call(BoundVars, File, Line, Args, MaybeNodeId,
Prims, Var, TermPath, Store, ProcDefnRep, Origin) :-
( if list.member(Var, BoundVars) then
Pos = find_arg_pos(Args, Var),
(
MaybeNodeId = yes(NodeId),
Origin = origin_output(dynamic(NodeId), Pos, TermPath)
;
MaybeNodeId = no,
Origin = origin_primitive_op(File, Line, primop_untraced_call)
)
else
traverse_primitives(Prims, Var, TermPath, Store, ProcDefnRep, Origin)
).
%-----------------------------------------------------------------------------%
:- pred add_paths_to_conjuncts(list(goal_rep)::in, reverse_goal_path::in,
int::in, goal_and_path_list::out) is det.
add_paths_to_conjuncts([], _, _, []).
add_paths_to_conjuncts([Goal | Goals], ParentPath, N,
[goal_and_path(Goal, Path) | GoalAndPaths]) :-
Path = rev_goal_path_add_at_end(ParentPath, step_conj(N)),
add_paths_to_conjuncts(Goals, ParentPath, N + 1, GoalAndPaths).
%-----------------------------------------------------------------------------%
:- 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 = MR_YES;
#else
TracingOn = MR_NO;
#endif
").
%-----------------------------------------------------------------------------%
:- func start_loc_to_subterm_mode(start_loc(R)) = subterm_mode.
start_loc_to_subterm_mode(cur_goal) = subterm_out.
start_loc_to_subterm_mode(parent_goal(_, _)) = subterm_in.
%-----------------------------------------------------------------------------%
:- func find_arg_pos(list(var_rep), var_rep) = arg_pos.
find_arg_pos(HeadVars, Var) = ArgPos :-
find_arg_pos_from_back(HeadVars, Var, length(HeadVars), ArgPos).
:- pred find_arg_pos_from_back(list(var_rep)::in, var_rep::in, int::in,
arg_pos::out) is det.
find_arg_pos_from_back([], _, _, _) :-
throw(internal_error($pred, "empty list")).
find_arg_pos_from_back([HeadVar | HeadVars], Var, Pos, ArgPos) :-
( if HeadVar = Var then
ArgPos = any_head_var_from_back(Pos)
else
find_arg_pos_from_back(HeadVars, Var, Pos - 1, ArgPos)
).
%-----------------------------------------------------------------------------%
edt_subtree_details(Store, dynamic(Ref), Event, SeqNo, CallPreceding) :-
det_edt_return_node_from_id(Store, Ref, Node),
( Node = node_exit(_, Call, _, _, Event, _, _, _)
; Node = node_fail(_, Call, _, Event, _, _)
; Node = node_excp(_, Call, _, _, Event, _, _)
),
call_node_from_id(Store, Call, CallNode),
SeqNo = CallNode ^ call_seq,
CallPreceding = CallNode ^ call_preceding.
:- inst edt_return_node
---> node_exit(ground, ground, ground, ground, ground, ground, ground,
ground)
; node_fail(ground, ground, ground, ground, ground, ground)
; node_excp(ground, ground, 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).
det_edt_return_node_from_id(Store, Ref, Node) :-
( if
trace_node_from_id(Store, Ref, Node0),
( Node0 = node_exit(_, _, _, _, _, _, _, _)
; Node0 = node_fail(_, _, _, _, _, _)
; Node0 = node_excp(_, _, _, _, _, _, _)
)
then
Node = Node0
else
throw(internal_error($pred, "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) :-
( if
trace_node_from_id(Store, Ref, Node0),
( Node0 = node_exit(_, CallId0, _, _, _, _, _, _)
; Node0 = node_fail(_, CallId0, _, _, _, _)
; Node0 = node_excp(_, CallId0, _, _, _, _, _)
)
then
CallId = CallId0
else
throw(internal_error($pred, "not a return node"))
).
%-----------------------------------------------------------------------------%
trace_atom_subterm_is_ground(atom(_, Args), ArgPos, _) :-
select_arg_at_pos(ArgPos, Args, ArgInfo),
ArgInfo = arg_info(_, _, MaybeArg),
MaybeArg = yes(_).
:- func trace_arg_pos_to_user_arg_num(wrap(S), edt_node(R), arg_pos) = int
<= annotated_trace(S, R).
trace_arg_pos_to_user_arg_num(wrap(Store), dynamic(Ref), ArgPos) = ArgNum :-
get_edt_call_node(Store, Ref, CallId),
call_node_from_id(Store, CallId, Call),
Atom = get_trace_call_atom(Call),
user_arg_num(ArgPos, Atom, ArgNum).
:- pred calls_arguments_are_all_ground(S::in, R::in) is semidet
<= annotated_trace(S, R).
calls_arguments_are_all_ground(Store, CallId) :-
call_node_from_id(Store, CallId, Call),
Args = Call ^ call_atom_args,
% XXX The following won't work for partially instantiated arguments.
all [Arg] (
list.member(Arg, Args)
=>
Arg = arg_info(_, _, yes(_))
).
%-----------------------------------------------------------------------------%
:- pred decl_require((pred)::in((pred) is semidet), string::in, string::in)
is det.
decl_require(Goal, Loc, Msg) :-
( if call(Goal) then
true
else
throw(internal_error(Loc, Msg))
).
Reference in New Issue View Git Blame Copy Permalink