mercurylang/mercury
1
0
Fork 0
mirror of https://github.com/Mercury-Language/mercury.git synced 2025-12-09 02:43:21 +00:00
Code Issues Projects Releases Wiki Activity
Files
026148c907be6be23f45cf69862d1fcfc2b7e947
mercury/browser/declarative_tree.m
Mark Brown d465fa53cb Update the COPYING.LIB file and references to it. 
Discussion of these changes can be found on the Mercury developers
mailing list archives from June 2018.

COPYING.LIB:
    Add a special linking exception to the LGPL.

*:
    Update references to COPYING.LIB.

    Clean up some minor errors that have accumulated in copyright
    messages.
2018-06-09 17:43:12 +10:00

1909 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.
% Copyright (C) 2014-2015, 2017-2018 The Mercury team.
% This file is distributed under the terms specified in COPYING.LIB.
%---------------------------------------------------------------------------%
%
% 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.
:- 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 trace_implicit_tree_info(wrap(S)::in, edt_node(R)::in,
implicit_tree_info::out) is semidet <= annotated_trace(S, R).
:- 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.
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
:- 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 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 for trace_node/1
---> 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