1 | % (c) 2009-2015 Lehrstuhl fuer Softwaretechnik und Programmiersprachen, | |
2 | % Heinrich Heine Universitaet Duesseldorf | |
3 | % This software is licenced under EPL 1.0 (http://www.eclipse.org/org/documents/epl-v10.html) | |
4 | ||
5 | /* | |
6 | * This module allows to register predicates as "debugging predicates". | |
7 | * When such a predicate is marked by the prefix operator ~~, | |
8 | * during term expansion, the term is replaced by: | |
9 | * - if remove_debug_calls is true: | |
10 | * one of the term's arguments, namely the one that is marked | |
11 | * by a star (*) during registration | |
12 | * - if remove_debug_calls is false: | |
13 | * only the prefix operator ~~ is removed, leaving the rest | |
14 | * of the term unchanged. | |
15 | * | |
16 | * Example: | |
17 | * | |
18 | * :- register_debugging_call log(-,*). | |
19 | * log(Info,X) :- | |
20 | * print(Info),print(' enter: '),print(X),nl, | |
21 | * call(X), | |
22 | * print(Info),print(' leave: '),print(X),nl. | |
23 | * | |
24 | * :- enable_debugging_calls. | |
25 | * p1 :- ~~log(p1, member(X,[a])). | |
26 | * :- disable_debugging_calls. | |
27 | * p2 :- ~~log(p2, member(X,[a])). | |
28 | * | |
29 | * a call of p1 prints: | |
30 | * p1 enter: member(_123,[a]) | |
31 | * p1 leave: member(a,[a]) | |
32 | * while a call to p2 prints nothing | |
33 | * | |
34 | */ | |
35 | ||
36 | :- module(debugging_calls,[register_debugging_call/1, | |
37 | enable_debugging_calls/0, | |
38 | disable_debugging_calls/0, | |
39 | remove_debugging_calls/4 % called by term expander | |
40 | ]). | |
41 | ||
42 | :- use_module(library(lists)). | |
43 | :- use_module(library(codesio)). | |
44 | ||
45 | :- use_module(module_information,[module_info/2]). | |
46 | ||
47 | :- module_info(group,infrastructure). | |
48 | :- module_info(description,'This module provides functionality to specify meta-calls that (like a must-not-fail call) that are short-circuited when compiling production code.'). | |
49 | ||
50 | :- op(1150, fx, register_debugging_call). | |
51 | :- op(300, fy, ~~). | |
52 | ||
53 | :- dynamic remove_debug_calls/0. | |
54 | % remove_debug_calls. | |
55 | ||
56 | :- dynamic is_debug_call/3. | |
57 | ||
58 | safe_atom_codes(A,C) :- | |
59 | on_exception(error(representation_error(max_atom_length),_),atom_codes(A,C), | |
60 | (print(exception(max_atom_length)),nl,A='???')). | |
61 | ||
62 | %avl_term(X) :- var(X),!,fail. | |
63 | %avl_term(avl_set(_)). | |
64 | %avl_term((A,B)):- (avl_term(A) -> true ; avl_term(B)). | |
65 | %avl_term([H|_]) :- avl_term(H). | |
66 | ||
67 | remove_debugging_calls(Layout,Term,Layout,Term) :- var(Term),!. | |
68 | %remove_debugging_calls(Layout,nl,Layout,format(' line:~w~n',[Layout])) :- !. | |
69 | % comment in to see nl (newline term_expansion) info with :- prolog_flag(source_info,_,on). | |
70 | remove_debugging_calls(LayoutIn,when(Cond,Body),LayoutOut,ResTerm) :- !, | |
71 | ResTerm = when(Cond,NewBody), % do not expand inside condition | |
72 | (LayoutIn = [] | |
73 | -> LayoutBody = [], | |
74 | LayoutOut = [] | |
75 | ; LayoutIn = [LayoutWhen,LayoutCond,LayoutBody], | |
76 | LayoutOut = [LayoutWhen,LayoutCond,LayoutBodyOut]), | |
77 | remove_debugging_calls(LayoutBody,Body,LayoutBodyOut,NewBody). | |
78 | %remove_debugging_calls(Layout,ground(Term),Layout,Term2) :- !, Term2 = (nonvar(Term),(debugging_calls:avl_term(Term) -> print(ground_check(Term)),nl, trace ; true),ground(Term)). %% comment in to observe ground checks | |
79 | remove_debugging_calls(LayoutIn,Term,Layout2,Term2) :- | |
80 | functor(Term, ~~, 1), | |
81 | arg(1,Term,Term1), | |
82 | nonvar(Term1),!,functor(Term1,Functor,Arity), | |
83 | ( LayoutIn = [] -> Layout1 = [] | |
84 | ; LayoutIn = [_,Layout1]), | |
85 | ( is_debug_call(Functor,Arity,CallPos) -> | |
86 | ( remove_debug_calls -> | |
87 | safe_arg(CallPos,Term1,TermI), | |
88 | ( Layout1 = [] -> LayoutI = [] | |
89 | ; Layout1 = [_|ArgLayout] -> | |
90 | nth1(CallPos,ArgLayout,LayoutI)), | |
91 | remove_debugging_calls(LayoutI,TermI,Layout2,Term2) | |
92 | ; otherwise -> | |
93 | remove_debugging_calls(Layout1,Term1,Layout2,Term2)) | |
94 | ; otherwise -> | |
95 | write_to_codes(Functor/Arity,M1), | |
96 | append(["encountered unregistered ",M1, | |
97 | " tagged for debugging removal"],M3), | |
98 | safe_atom_codes(Msg1,M3), | |
99 | print_message(error,Msg1), | |
100 | Term2 = Term1 | |
101 | ). | |
102 | %remove_debugging_calls(LayoutIn,on_exception(E,Call,Code),LayoutOut,Term2) :- !, | |
103 | % LayoutOut = LayoutIn, | |
104 | % print(on_exception(E,Call,Code)),nl, | |
105 | % Term2 = on_exception(E,Call,(format('~n**EXCEPTION = ~w~n~n',[E]),Code)). | |
106 | %remove_debugging_calls(LayoutIn,time_out(Call,TO,Res),LayoutOut,Term2) :- !, | |
107 | % LayoutOut = LayoutIn, | |
108 | % print(time_out(Call,TO,Res)),nl, | |
109 | % Term2 = ((Call = _:C -> true ; Call=C), | |
110 | % functor(C,F,N),format('**TIMEOUT CALL ~w/~w = ~w ms~n',[F,N,TO]), | |
111 | % time_out(Call,TO,Res), | |
112 | % (Res=time_out -> format('**TIMEOUT OCCURED ~w/~w after ~w ms~n',[F,N,TO]) ; true)). | |
113 | remove_debugging_calls(LayoutIn,Term1,LayoutOut,Term2) :- | |
114 | !,functor(Term1,Functor,Arity), | |
115 | functor(Term2,Functor,Arity), | |
116 | ( LayoutIn = [] -> | |
117 | LayoutOut = [], | |
118 | remove_debugging_calls_args_nl(1,Arity,Term1,Term2) | |
119 | ; LayoutIn = [Pos|Layout1] -> | |
120 | LayoutOut = [Pos|Layout2], | |
121 | remove_debugging_calls_args(Layout1,Term1,Layout2,Term2,1) | |
122 | ; otherwise -> | |
123 | LayoutIn = LayoutOut, | |
124 | Term1 = Term2). | |
125 | ||
126 | remove_debugging_calls_args([],_,[],_,_). | |
127 | remove_debugging_calls_args([L1|Layout1],Term1,[L2|Layout2],Term2,N) :- | |
128 | safe_arg(N,Term1,In), safe_arg(N,Term2,Out), | |
129 | remove_debugging_calls(L1,In,L2,Out), | |
130 | N2 is N+1, | |
131 | remove_debugging_calls_args(Layout1,Term1,Layout2,Term2,N2). | |
132 | ||
133 | safe_arg(N,Term,Arg) :- compound(Term), arg(N,Term,Arg). | |
134 | ||
135 | remove_debugging_calls_args_nl(N,Max,_,_) :- N > Max,!. | |
136 | remove_debugging_calls_args_nl(N,Max,Term1,Term2) :- | |
137 | N =< Max, | |
138 | safe_arg(N,Term1,In), safe_arg(N,Term2,Out), | |
139 | remove_debugging_calls([],In,_,Out), | |
140 | N2 is N+1, | |
141 | remove_debugging_calls_args_nl(N2,Max,Term1,Term2). | |
142 | ||
143 | register_debugging_call((Call1,Call2)) :- | |
144 | !,register_debugging_call(Call1), | |
145 | register_debugging_call(Call2). | |
146 | register_debugging_call(Call) :- | |
147 | functor(Call,Functor,Arity), | |
148 | Call =.. [_|Args], | |
149 | ? | ( nth1(Pos,Args,*) -> |
150 | ? | ( nth1(NPos,Args,*), NPos \= Pos -> |
151 | register_error_msg(Call) | |
152 | ; otherwise -> | |
153 | retractall(is_debug_call(Functor,Arity,_)), | |
154 | assert(is_debug_call(Functor,Arity,Pos))) | |
155 | ; otherwise -> | |
156 | register_error_msg(Call)). | |
157 | register_error_msg(Call) :- | |
158 | write_to_codes(Call,M), | |
159 | append("register_debug_call has wrong argument: ", M, Codes), | |
160 | safe_atom_codes(Msg,Codes), | |
161 | print_message(error,Msg). | |
162 | ||
163 | ||
164 | enable_debugging_calls :- | |
165 | retractall(remove_debug_calls). | |
166 | disable_debugging_calls :- | |
167 | (remove_debug_calls -> true; assert(remove_debug_calls)). | |
168 | ||
169 | /* | |
170 | * This code uses the term_expansion/6 hook, wich | |
171 | * is a multifile-predicate. Due to a bug in SICStus Prolog, | |
172 | * it is not possible to mix uncompiled and compiled code | |
173 | * for such a predicate. | |
174 | * So we always compile the term_expansion hook | |
175 | */ | |
176 | :- prolog_flag(compiling,Pre,compactcode), | |
177 | compile(debugging_calls_te), | |
178 | prolog_flag(compiling,_,Pre). |