1/*  Part of Extended Libraries for SWI-Prolog
    2
    3    Author:        Edison Mera
    4    E-mail:        efmera@gmail.com
    5    WWW:           https://github.com/edisonm/xlibrary
    6    Copyright (C): 2015, Process Design Center, Breda, The Netherlands.
    7    All rights reserved.
    8
    9    Redistribution and use in source and binary forms, with or without
   10    modification, are permitted provided that the following conditions
   11    are met:
   12
   13    1. Redistributions of source code must retain the above copyright
   14       notice, this list of conditions and the following disclaimer.
   15
   16    2. Redistributions in binary form must reproduce the above copyright
   17       notice, this list of conditions and the following disclaimer in
   18       the documentation and/or other materials provided with the
   19       distribution.
   20
   21    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   22    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   23    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
   24    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
   25    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
   26    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
   27    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
   28    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   29    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
   30    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
   31    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
   32    POSSIBILITY OF SUCH DAMAGE.
   33*/
   34
   35:- module(ontrace, [ontrace/3,
   36                    clause_pc_location/3,
   37		    cleanup_trace/1]).   38
   39:- use_module(library(apply)).   40:- use_module(library(edinburgh)).   41:- use_module(library(lists)).   42:- use_module(library(option)).   43:- use_module(library(ntabling)).   44:- use_module(library(prolog_clause), []).   45:- use_module(library(prolog_codewalk), []).   46:- use_module(library(prolog_source)).   47:- use_module(library(clambda)).   48:- use_module(library(call_inoutex)).   49:- init_expansors.   50
   51:- meta_predicate ontrace(0,6,:).   52
   53ontrace(Goal, OnTrace, Options) :-
   54    State=state(_, _, _),       % Allow destructive assignment
   55    call_inoutex(Goal,
   56        setup_trace(State, OnTrace, Options),
   57        cleanup_trace(State)).
   58
   59:- public true_1/1.   60true_1(_).
   61
   62is_meta(goal).
   63is_meta(file).
   64
   65:- multifile
   66        user:prolog_trace_interception/4.   67:- dynamic
   68        user:prolog_trace_interception/4.   69
   70:- thread_local
   71    ontrace_enabled/4.   72
   73user:prolog_trace_interception(Port, Frame, PC, Action) :-
   74    ontrace_enabled(M, OnTrace, ValidGoal, ValidFile),
   75    !,
   76    trace_port(Port, Frame, PC, M:OnTrace, M:ValidGoal, M:ValidFile, Action).
   77
   78% disable this hook, to avoid problems with library(threadutil), since it
   79% will try to trigger xterm --EMM
   80user:message_hook(trace_mode(on), _, _) :-
   81    ontrace_enabled(_, _, _, _),
   82    !,
   83    fail.

 setup_trace(!State, :OnTrace, :OptL) is det

   87setup_trace(State, M:OnTrace, MOptL) :-
   88    meta_options(is_meta, MOptL, OptL),
   89    select_option(goal(ValidGoal), OptL,  OptL1, ontrace:true_1),
   90    select_option(file(ValidFile), OptL1, OptL2, ontrace:true_1),
   91    % redo port has weird bugs, ignoring it for now:
   92    select_option(ports(Ports), OptL2, _,
   93                  [+call, +exit, +fail, +unify, +exception]),
   94    % it is safer to use asserta here, in case this hook was already defined while debugging
   95    asserta(ontrace_enabled(M, OnTrace, ValidGoal, ValidFile), Ref),
   96    once('$syspreds':map_bits(port_name, Ports, 0, Mask)),
   97    '$visible'(Visible, Mask),
   98    '$leash'(Leash, Mask),
   99    nb_setarg(1, State, Visible),
  100    nb_setarg(2, State, Leash),
  101    nb_setarg(3, State, Ref),
  102    trace.

 cleanup_state(+State) is det

  106cleanup_trace(state(Visible, Leash, Ref)) :-
  107    nodebug,
  108    '$visible'(_, Visible),
  109    '$leash'(_, Leash),
  110    erase(Ref),
  111    !.
  112cleanup_trace(State) :-
  113    print_message(error, format('Failed when saving tracer data', [State])),
  114    fail.
  115
  116user_defined_module(M) :-
  117    module_property(M, class(user)),
  118    M \= ontrace.
  119
  120:- public trace_port/7.  121:- meta_predicate trace_port(+,+,+,5,1,1,-).  122
  123trace_port(Port, Frame, PC, OnTrace, ValidGoal, ValidFile, Action) :-
  124    prolog_frame_attribute(Frame,  goal, M:H), % M:H to skip local predicates
  125    \+ \+ call(ValidGoal, M:H),
  126    ignore(( Port = (exit),
  127             prolog_frame_attribute(Frame, clause, ExCl),
  128             % Trace exit at clause level:
  129             check_and_call(exitcl, Frame, PC, OnTrace, ValidGoal, ValidFile,
  130                            _, [], Frame, ExCl, clause(ExCl))
  131           )),
  132    find_parents(Port, Frame, ParentL, RFrame, Cl, SubLoc),
  133    check_and_call(Port, Frame, PC, OnTrace, ValidGoal, ValidFile, Action,
  134                   ParentL, RFrame, Cl, SubLoc),
  135    !.
  136trace_port(_, _, _, _, _, _, continue).
  137
  138check_and_call(Port, Frame, PC, OnTrace, ValidGoal, ValidFile, Action,
  139               ParentL, RFrame, Cl, SubLoc) :-
  140    prolog_frame_attribute(RFrame, goal, CM:CH),
  141    ( ( clause_property(Cl, file(File))
  142      ; module_property(CM, file(File))
  143      )
  144    -> \+ \+ call(ValidFile, File)
  145    ; true
  146    ),
  147    \+ \+ call(ValidGoal, CM:CH),
  148    \+ \+ ( member(F, [Frame|ParentL]),
  149            prolog_frame_attribute(F, goal, PM:_),
  150            user_defined_module(PM)
  151          ),
  152    call(OnTrace, Port, Frame, PC, ParentL, SubLoc, Action).
  153
  154find_parents(Port, Frame, ParentL, RFrame, Cl, Loc) :-
  155    ( member(Port, [unify, redo(_)])
  156    ->ParentL = [],
  157      prolog_frame_attribute(Frame, clause, Cl),
  158      RFrame = Frame,
  159      Loc = clause(Cl)
  160    ; find_parent_with_pc(Frame, PC, [], ParentL),
  161      [Parent|_] = ParentL,
  162      prolog_frame_attribute(Parent, clause, Cl),
  163      RFrame = Parent,
  164      Loc = clause_pc(Cl, PC)
  165    ).
  166
  167find_parent_with_pc(Frame, PC, List1, List) :-
  168    prolog_frame_attribute(Frame, parent, Parent),
  169    ( prolog_frame_attribute(Frame, pc, PC)
  170    ->List = [Parent|List1]
  171    ; find_parent_with_pc(Parent, PC, [Parent|List1], List)
  172    ).
  173
  174:- multifile
  175    prolog:message_location//1.  176
  177:- table
  178    clause_pc_location/3.  179
  180clause_pc_location(Clause, PC, Loc) :-
  181    ( '$clause_term_position'(Clause, PC, List)
  182    ->clause_subloc(Clause, List, Loc)
  183    ; Loc = clause(Clause)
  184    ).
  185
  186prolog:message_location(clause_pc(Clause, PC)) -->
  187    {clause_pc_location(Clause, PC, Loc)},
  188    '$messages':swi_location(Loc).

 clause_subloc(+ClauseRef, +List, -SubLoc) is det

  192clause_subloc(Cl, List, SubLoc) :-
  193    ( clause_property(Cl, file(File)),
  194      clause_property(Cl, line_count(Line)),
  195      clause_property(Cl, module(Module))
  196    ->file_line_module_subloc(Cl, List, File, Line, Module, SubLoc)
  197    ; SubLoc = clause(Cl)
  198    ).
  199
  200read_term_at_line(File, Line, Module, Clause, TermPos) :-
  201    setup_call_cleanup(
  202        ( '$push_input_context'(ontrace_info),
  203          catch(open(File, read, In), _, fail),
  204          set_stream(In, newline(detect))
  205        ),
  206        read_source_term_at_location(
  207            In, Clause,
  208            [ line(Line),
  209              module(Module),
  210              subterm_positions(TermPos)
  211            ]),
  212        ( close(In),
  213          '$pop_input_context'
  214        )).
  215
  216file_line_module_subloc(Cl, List, File, Line, Module, SubLoc) :-
  217    ( read_term_at_line(File, Line, Module, Term, TermPos)
  218    % Usage of term positions has priority
  219    ->( prolog_clause:ci_expand(Term, ClauseL, Module, TermPos, CPosL),
  220        match_clause(Cl, ClauseL, Module, CPosL, ClausePos, List2, List),
  221        nonvar(ClausePos)
  222      ->foldl(find_subgoal, List2, ClausePos, SubPos) % Expensive
  223      ; SubPos = TermPos
  224      ),
  225      SubLoc = file_term_position(File, SubPos)
  226    ; SubLoc = file(File, Line, -1, _)
  227    ).
  228
  229list_pos(term_position(_, _, _, _, PosL), PosL).
  230list_pos(list_position(_, _, PosL, _), PosL).
  231list_pos(parentheses_term_position(_, _, Pos1), Pos) :-
  232    nonvar(Pos1),
  233    list_pos(Pos1, Pos).
  234list_pos(F-T, [F-T]).
  235
  236find_subgoal(A, TermPos, Pos) :-
  237    list_pos(TermPos, PosL),
  238    is_list(PosL),
  239    nth1(A, PosL, Pos),
  240    nonvar(Pos), !.
  241find_subgoal(_, Pos, Pos).
  242
  243match_clause(Ref, ClauseL, Module, CPosL, CPos, List, Tail) :-
  244    % format(user_error, '~N~w',[match_clause(Ref, ClauseL, Module, List, Tail)]),
  245    ( is_list(ClauseL)
  246    ->clause(Head, Body, Ref),
  247      nth1(Pos, ClauseL, Clause),
  248      ( ( is_list(CPosL),
  249          TermPosL = CPosL
  250        ; CPosL = list_position(_,_, TermPosL, _),
  251          is_list(TermPosL)
  252        )
  253      ->nth1(Pos, TermPosL, CPos)
  254      ),
  255      % format(user_error, '~N~w',[normalize_cl(Clause, Module, Module, NClause)]),
  256      normalize_cl(Clause, Module, Module, NClause),
  257      NClause =@= (Head :- Body)
  258    ->List = [Pos|Tail]
  259    ; List = Tail,
  260      CPos = CPosL
  261    ).
  262
  263normalize_cl(M:Clause, _, CM, NClause) :- !,
  264    normalize_cl(Clause, M, CM, NClause).
  265normalize_cl((Head :- Body), M, CM, (MHead :- NBody)) :- !,
  266    strip_mod(Head, M, MHead),
  267    strip_mod(Body, CM, MBody),
  268    ( MBody = M:Body
  269    ->NBody = Body
  270    ; NBody = MBody
  271    ).
  272normalize_cl(Head, M, CM, NClause) :-
  273    normalize_cl((Head :- true), M, CM, NClause).
  274
  275strip_mod(M:Term, _, MTerm) :-
  276    strip_mod(Term, M, MTerm).
  277strip_mod(Term, M, M:Term)