1		% (c) 2009-2024 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		register_debugging_calls/1,
38		enable_debugging_calls/0,
39		disable_debugging_calls/0,
40		remove_debugging_calls/4 % called by term expander
41		]).
42
43		:- use_module(library(lists)).
44		:- use_module(library(codesio)).
45
46		:- use_module(module_information,[module_info/2]).
47
48		:- module_info(group,infrastructure).
49		:- 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.').
50
51		:- set_prolog_flag(double_quotes, codes).
52
53		:- op(300, fy, ~~).
54
55		:- dynamic remove_debug_calls/0.
56		% remove_debug_calls.
57
58		:- dynamic is_debug_call/3.
59
60		safe_atom_codes(A,C) :-
61		catch(atom_codes(A,C),
62		error(representation_error(max_atom_length),_),
63		(print(exception(max_atom_length)),nl,A='???')).
64
65		%avl_term(X) :- var(X),!,fail.
66		%avl_term(avl_set(_)).
67		%avl_term((A,B)):- (avl_term(A) -> true ; avl_term(B)).
68		%avl_term([H|_]) :- avl_term(H).
69
70		get_current_position(Line,Col,Module,File) :-
71		prolog_load_context(module, Module),
72		prolog_load_context(file, File),
73		prolog_load_context(term_position,TPos), % gives something like $stream_position(18031,18031,340,21)
74		!,
75		(TPos= '$stream_position'(_,_,Line,Col) -> true ; Line='?', Col='?').
76		get_current_position('?','?',Module,'?') :-
77		prolog_load_context(module, Module),!.
78		get_current_position('?','?','?','?').
79
80		safe_functor(Var,F,N) :- var(Var),!, F='$VAR', N=0.
81		safe_functor(X,F,N) :- functor(X,F,N).
82
83		% built-ins to observe before their execution where we observe one argument
84		observe_built_in(assert(P),assert,P).
85		observe_built_in(asserta(P),asserta,P).
86		observe_built_in(assertz(P),assertz,P).
87		observe_built_in(ground(P),ground,P).
88		observe_built_in(copy_term(P,_),copy_term,P).
89		observe_built_in(copy_term(P,_,_),copy_term,P).
90		observe_built_in(term_variables(P,_),term_variables,P).
91		observe_built_in(term_hash(P,_),term_hash,P).
92		observe_built_in(term_hash(P,_,_),term_hash,P).
93		observe_built_in(number_vars(P,_,_),term_variables,P).
94		observe_built_in(acyclic_term(P),acyclic_term,P).
95
96		% operators with two arguments which must both be large and which compare the arguments
97		observe_built_in2('/=='(P,Q),'/==',P,Q) :- \+ atom(Q), \+ atom(P).
98		observe_built_in2('/='(P,Q),'/=',P,Q) :- \+ atom(Q), \+ atom(P), Q \== term(undefined).
99		observe_built_in2('=='(P,Q),'==',P,Q) :- \+ atom(Q), \+ atom(P), Q \== term(undefined).
100		observe_built_in2('@<'(P,Q),'@<',P,Q) :- \+ atom(Q), \+ atom(P), Q \== term(undefined).
101		observe_built_in2('@>'(P,Q),'@>',P,Q) :- \+ atom(Q), \+ atom(P), Q \== term(undefined).
102		observe_built_in2(dif(P,Q),dif,P,Q) :- \+ atom(Q), \+ atom(P).
103		observe_built_in2(unify_with_occurs_check(P,Q),unify_with_occurs_check,P,Q) :- \+ atom(Q), \+ atom(P).
104		observe_built_in2(subsumes_term(P,Q),subsumes_term,P,Q) :- \+ atom(Q), \+ atom(P).
105
106
107		% built-ins to observe after their execution
108		observe_built_in_post(frozen(_,P),frozen,P).
109		observe_built_in_post(retract(P),retract,P).
110
111
112		ignore_module(aggregate).
113		ignore_module(assoc).
114		ignore_module(avl).
115		ignore_module(a_star).
116		ignore_module(binomialheap).
117		ignore_module(builtins).
118		ignore_module(chr). % prevent inserting observation code into some library modules
119		ignore_module(chr_compiler_utility).
120		ignore_module(chr_hashtable_store).
121		ignore_module(chr_runtime).
122		ignore_module(chr_translate).
123		ignore_module(clpfd).
124		ignore_module(fastrw).
125		ignore_module(guard_entailment).
126		ignore_module(heaps).
127		ignore_module(hpattvars).
128		ignore_module(hprolog).
129		ignore_module(listmap).
130		ignore_module(lists).
131		ignore_module(mutdict).
132		ignore_module(pairlist).
133		ignore_module(plunit).
134		ignore_module(random).
135		ignore_module(samsort).
136		ignore_module(system).
137		ignore_module(terms).
138		ignore_module(xml).
139
140		ignore_module(chr_integer_inequality).
141
142
143
144		:- load_files(library(system), [when(compile_time), imports([environ/2])]).
145
146		remove_debugging_calls(Layout,Term,Layout,Term) :- var(Term),!.
147		% comment in to see nl (newline term_expansion) info with :- set_prolog_flag(source_info,on).
148		% and be sure to enable user:term_expansion in debugging_calls_te.pl
149		%remove_debugging_calls(Layout,nl,Layout,format(' line:~w col:~w in ~w (~w)~n',[L,C,CM,CF])) :- !, get_current_position(L,C,CM,CF).
150		:- if(environ(prob_debug_flag,true)).
151
152
153		remove_debugging_calls(_,_Call,_,_) :-
154		prolog_load_context(module, CurModule),
155		ignore_module(CurModule),!,
156		%get_current_position(L,C,CM,CF),format(' ignoring >> ~w at line:~w col:~w in ~w (~w)~n',[CurModule,L,C,CM,CF]),
157		fail.
158		remove_debugging_calls(Layout,Call,Layout,
159		(debugging_calls:safe_functor(P,F,N),terms:term_size(P,Sze),
160		(Sze>100 -> (Sze>10000 -> LRG=' ***LARGE***' ; LRG=''),
161		format(' ~w(~w/~w - sze:~w~w) line:~w col:~w in ~w (~w)~n',[BI,F,N,Sze,LRG,L,C,CM,CF]) ; true),
162		Call) ) :-
163		observe_built_in(Call,BI,P), !, get_current_position(L,C,CM,CF).
164		remove_debugging_calls(Layout,Call,Layout,
165		(debugging_calls:safe_functor(P,F,N),terms:term_size(P,Sze),
166		debugging_calls:safe_functor(Q,F2,N2),terms:term_size(Q,Sze2),
167		(Sze>100,Sze2>100,
168		(F,N)=(F2,N2) % otherwise the terms are obviously different and the calls cannot be expensive
169		-> format(' ~w(~w/~w - ~w <-> ~w/~w - ~w) line:~w col:~w in ~w (~w)~n',[BI,F,N,Sze,F2,N2,Sze2,L,C,CM,CF])
170		; true), Call) ) :-
171		observe_built_in2(Call,BI,P,Q), !, get_current_position(L,C,CM,CF).
172		remove_debugging_calls(Layout,Call,Layout,
173		(Call,debugging_calls:safe_functor(P,F,N),terms:term_size(P,Sze),
174		(Sze>100 -> format(' ~w(~w/~w - ~w) line:~w col:~w in ~w (~w)~n',[BI,F,N,Sze,L,C,CM,CF]) ; true)) ) :-
175		observe_built_in_post(Call,BI,P), !, get_current_position(L,C,CM,CF).
176		remove_debugging_calls(Layout,time_out(P,TO,Res),Layout,
177		(print(time_out(P)),nl,functor(P,F,N),
178		format(' time_out(~w/~w,~w) line:~w col:~w in ~w (~w)~n', [F,N,TO,L,C,CM,CF]),
179		time_out(P,TO,Res))) :- !,
180		get_current_position(L,C,CM,CF).
181		% comment in lines below to see retracts; be sure to enable user:term_expansion in debugging_calls_te.pl
182		%remove_debugging_calls(Layout,retractall(P),Layout,
183		% (retractall(P),functor(P,F,N),format(' retractall(~w/~w) line:~w col:~w in ~w (~w)~n',[F,N,L,C,CM,CF]))) :- !, get_current_position(L,C,CM,CF). % for some reason retractall is sometimes expensive
184		% a few other calls to observe
185		%remove_debugging_calls(Layout,arg(Nr,T,A),Layout,(format(' line:~w col:~w in ~w (~w)~n',[L,C,CM,CF]),arg(Nr,T,A))) :- !, get_current_position(L,C,CM,CF).
186		%remove_debugging_calls(Layout,call_cleanup(P,P2),Layout,(functor(P,F,N),format(' call_cleanup(~w/~w) line:~w col:~w in ~w (~w)~n',[F,N,L,C,CM,CF]),call_cleanup(P,P2))) :- !, get_current_position(L,C,CM,CF).
187		%remove_debugging_calls(Layout,on_exception(Exc,P,P2),Layout,(functor(P,F,N),format(' on_exception(~w/~w) line:~w col:~w in ~w (~w)~n',[F,N,L,C,CM,CF]),on_exception(Exc,P,P2))) :- !, get_current_position(L,C,CM,CF).
188		% comment in next clause to see nesting of call_cleanup calls:
189		%remove_debugging_calls(Layout,call_cleanup(P,P2),Layout,
190		% (debugging_calls:get_functor(P,F,N),debugging_calls:inc_indent,write(enter),FCall,
191		% call_cleanup(P,(P2,debugging_calls:dec_indent,write(exit),FCall)))) :- !,
192		% FCall = format('_call_cleanup(~w/~w) line:~w col:~w in ~w (~w)~n',[F,N,L,C,CM,CF]), get_current_position(L,C,CM,CF).
193		:- endif.
194		remove_debugging_calls(LayoutIn,when(Cond,Body),LayoutOut,ResTerm) :- !,
195		ResTerm = when(Cond,NewBody), % do not expand inside condition
196		(LayoutIn = []
197		-> LayoutBody = [],
198		LayoutOut = []
199		; LayoutIn = [LayoutWhen,LayoutCond,LayoutBody],
200		LayoutOut = [LayoutWhen,LayoutCond,LayoutBodyOut]),
201		remove_debugging_calls(LayoutBody,Body,LayoutBodyOut,NewBody).
202		%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
203		remove_debugging_calls(LayoutIn,Term,Layout2,Term2) :-
204		functor(Term, ~~, 1),
205		arg(1,Term,Term1),
206		nonvar(Term1),!,functor(Term1,Functor,Arity),
207		( LayoutIn = [] -> Layout1 = []
208		; LayoutIn = [_,Layout1]),
209		( is_debug_call(Functor,Arity,CallPos) ->
210		( remove_debug_calls ->
211		safe_arg(CallPos,Term1,TermI),
212		( Layout1 = [] -> LayoutI = []
213		; Layout1 = [_|ArgLayout] ->
214		nth1(CallPos,ArgLayout,LayoutI)),
215		remove_debugging_calls(LayoutI,TermI,Layout2,Term2)
216		;
217		remove_debugging_calls(Layout1,Term1,Layout2,Term2))
218		;
219		write_to_codes(Functor/Arity,M1),
220		append(["encountered unregistered ",M1,
221		" tagged for debugging removal"],M3),
222		safe_atom_codes(Msg1,M3),
223		print_message(error,Msg1),
224		Term2 = Term1
225		).
226		%remove_debugging_calls(LayoutIn,on_exception(E,Call,Code),LayoutOut,Term2) :- !,
227		% LayoutOut = LayoutIn,
228		% print(on_exception(E,Call,Code)),nl,
229		% Term2 = on_exception(E,Call,(format('~n**EXCEPTION = ~w~n~n',[E]),Code)).
230		%remove_debugging_calls(LayoutIn,time_out(Call,TO,Res),LayoutOut,Term2) :- !,
231		% LayoutOut = LayoutIn,
232		% print(time_out(Call,TO,Res)),nl,
233		% Term2 = ((Call = _:C -> true ; Call=C),
234		% functor(C,F,N),format('**TIMEOUT CALL ~w/~w = ~w ms~n',[F,N,TO]),
235		% time_out(Call,TO,Res),
236		% (Res=time_out -> format('**TIMEOUT OCCURED ~w/~w after ~w ms~n',[F,N,TO]) ; true)).
237		remove_debugging_calls(LayoutIn,Term1,LayoutOut,Term2) :-
238		!,functor(Term1,Functor,Arity),
239		functor(Term2,Functor,Arity),
240		( LayoutIn = [] ->
241		LayoutOut = [],
242		remove_debugging_calls_args_nl(1,Arity,Term1,Term2)
243		; LayoutIn = [Pos|Layout1] ->
244		LayoutOut = [Pos|Layout2],
245		remove_debugging_calls_args(Layout1,Term1,Layout2,Term2,1)
246		;
247		LayoutIn = LayoutOut,
248		Term1 = Term2).
249
250
251		remove_debugging_calls_args([],_,[],_,_).
252		remove_debugging_calls_args([L1|Layout1],Term1,[L2|Layout2],Term2,N) :-
253		safe_arg(N,Term1,In), safe_arg(N,Term2,Out),
254		remove_debugging_calls(L1,In,L2,Out),
255		N2 is N+1,
256		remove_debugging_calls_args(Layout1,Term1,Layout2,Term2,N2).
257
258		safe_arg(N,Term,Arg) :- compound(Term), arg(N,Term,Arg).
259
260		remove_debugging_calls_args_nl(N,Max,_,_) :- N > Max,!.
261		remove_debugging_calls_args_nl(N,Max,Term1,Term2) :-
262		N =< Max,
263		safe_arg(N,Term1,In), safe_arg(N,Term2,Out),
264		remove_debugging_calls([],In,_,Out),
265		N2 is N+1,
266		remove_debugging_calls_args_nl(N2,Max,Term1,Term2).
267
268		register_debugging_calls([]).
269		register_debugging_calls([Call|Calls]) :-
270		register_debugging_call(Call),
271		register_debugging_calls(Calls).
272
273		register_debugging_call(Call) :-
274		functor(Call,Functor,Arity),
275		Call =.. [_|Args],
276	?	( nth1(Pos,Args,*) ->
277	?	( nth1(NPos,Args,*), NPos \= Pos ->
278		register_error_msg(Call)
279		;
280		retractall(is_debug_call(Functor,Arity,_)),
281		assertz(is_debug_call(Functor,Arity,Pos)))
282		;
283		register_error_msg(Call)).
284		register_error_msg(Call) :-
285		write_to_codes(Call,M),
286		append("register_debug_call has wrong argument: ", M, Codes),
287		safe_atom_codes(Msg,Codes),
288		print_message(error,Msg).
289
290
291		enable_debugging_calls :-
292		retractall(remove_debug_calls).
293		disable_debugging_calls :-
294		(remove_debug_calls -> true; assertz(remove_debug_calls)).
295
296		:- public inc_indent/0.
297		inc_indent :- (bb_get(debugging_indent_level,L) -> true ; L=0),
298		L1 is L+1,
299		bb_put(debugging_indent_level,L1),
300		indent(L).
301
302		indent(X) :- X<1,!.
303		indent(X) :- write('>'), X1 is X-1, indent(X1).
304
305		:- public dec_indent/0.
306		dec_indent :-
307		bb_get(debugging_indent_level,L), L>0,!,
308		L1 is L-1,
309		bb_put(debugging_indent_level,L1),
310		indent(L1).
311		dec_indent :- format('~n**** UNMATCHED decrease_indent~n',[]).
312
313		:- public get_functor/3.
314		get_functor(Var,F,N) :- var(Var), !, F='$VAR',N=0.
315		get_functor(Mod:E,Mod:F,N) :- !, get_functor(E,F,N).
316		get_functor(catch(E,_,_),catch:F,N) :- !, get_functor(E,F,N).
317		get_functor(if(E,_,_),if:F,N) :- !, get_functor(E,F,N).
318		get_functor(call(E),catch:F,N) :- !, get_functor(E,F,N).
319		get_functor(E,F,N) :- (E=true -> trace ; true), functor(E,F,N).
320
321		:- if(current_prolog_flag(dialect, sicstus)).
322		/*
323		* This code uses the term_expansion/6 hook, wich
324		* is a multifile-predicate. Due to a bug in SICStus Prolog,
325		* it is not possible to mix uncompiled and compiled code
326		* for such a predicate.
327		* So we always compile the term_expansion hook
328		*/
329		:- current_prolog_flag(compiling,Pre),
330		set_prolog_flag(compiling,compactcode),
331		compile(debugging_calls_te),
332		set_prolog_flag(compiling,Pre).
333		:- else.
334		:- load_files(debugging_calls_te).
335		:- endif.