This repository has been archived on 2023-08-20. You can view files and clone it, but cannot push or open issues or pull requests.
yap-6.3/CHR/chr/trace.yap
vsc 5143aebb01 try to reduce overheads when running with goal expansion enabled.
CLPBN fixes
Handle overflows when allocating big clauses properly.


git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@1193 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
2004-12-05 05:01:45 +00:00

594 lines
15 KiB
Prolog

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Constraint Handling Rules version 2.2 %
% %
% (c) Copyright 1998 %
% LMU, Muenchen %
% %
% File: trace.pl %
% Author: Christian Holzbaur christian@ai.univie.ac.at %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
/*
2 Mechanisms: trace+leash, debug+spy
Debugger integration issue:
We could use conditional spypoints of the Prolog debugger
to get hooked, but then we depend a lot on it ...
:- spypoint_condition( debug_event(E), P, chr:de(P,E)).
Todo:
-) module_wrap/3 for all terms (M as arg to debug_event)
-) guard-fail = rule-delay reason?
*/
:- dynamic spy_rule/2.
:- dynamic spy_constraint/2.
:- initialization
getval( debug, _) -> true ; setval( debug, off).
:- initialization
retractall( spy_rule(_,_)).
:- initialization
retractall( spy_constraint(_,_)).
chr_trace :-
setval( debug, trace),
what_is_on( informational).
chr_notrace :-
setval( debug, off),
what_is_on( informational).
chr_debug :-
setval( debug, debug),
what_is_on( informational).
chr_nodebug :-
chr_notrace.
chr_spy( constraints(Cs)) :-
parse_spy_constraints( Cs, L, []),
member( N/A, L),
assert( spy_constraint(N,A)),
fail.
chr_spy( rules(Rs)) :-
parse_spy_rules( Rs, L, []),
member( Handler:Rule, L),
assert( spy_rule(Rule,Handler)),
fail.
chr_spy( _) :- getval( debug, trace), !.
chr_spy( _) :- chr_debug.
chr_nospy( rules(Rs)) :-
parse_spy_rules( Rs, L1, []),
member( Handler:Rule, L1),
retract( spy_rule(Rule,Handler)),
fail.
chr_nospy( constraints(Cs)) :-
parse_spy_constraints( Cs, L, []),
member( N/A, L),
retract( spy_constraint(N,A)),
fail.
chr_nospy( _).
parse_spy_constraints( C) --> {var(C)}, !, [ _ ].
parse_spy_constraints( (C,Cs)) -->
parse_spy_constraints( C),
parse_spy_constraints( Cs).
parse_spy_constraints( N) --> {atom(N)}, [ N/_ ].
parse_spy_constraints( N/A) --> {atom(N),integer(A),A>0}, [ N/A ].
parse_spy_rules( R) --> {var(R)}, !, [ _ ].
parse_spy_rules( (R,Rs)) --> !,
parse_spy_rules( R),
parse_spy_rules( Rs).
parse_spy_rules( H:R) --> !, [ H:R ].
parse_spy_rules( R) --> [ _:R ]. % any handler
chr_leash( Spec) :-
nonvar( Spec),
chr_leash( Spec, I),
setval( leashing, I),
what_is_leashed( informational).
chr_leash( none, 0) :- !.
chr_leash( off, 0) :- !.
chr_leash( all, -1) :- !.
chr_leash( default, I) :- !, chr_leash( 0, I, [call,wake,apply,exit,fail], []).
chr_leash( L, I) :- chr_leash( 0, I, L, []), !.
chr_leash( X, I) :- chr_leash( 0, I, [X], []).
chr_leash( I, K) --> [call], {J is I\/2'100000000}, chr_leash( J, K).
chr_leash( I, K) --> [wake], {J is I\/2'010000000}, chr_leash( J, K).
chr_leash( I, K) --> [try], {J is I\/2'001000000}, chr_leash( J, K).
chr_leash( I, K) --> [apply], {J is I\/2'000100000}, chr_leash( J, K).
chr_leash( I, K) --> [exit], {J is I\/2'000010000}, chr_leash( J, K).
chr_leash( I, K) --> [redo], {J is I\/2'000001000}, chr_leash( J, K).
chr_leash( I, K) --> [fail], {J is I\/2'000000100}, chr_leash( J, K).
%
chr_leash( I, K) --> [insert], {J is I\/2'000000010}, chr_leash( J, K).
chr_leash( I, K) --> [remove], {J is I\/2'000000001}, chr_leash( J, K).
chr_leash( I, I) --> [].
:- initialization
chr_leash( default, I), setval( leashing, I).
debug_stop( call(S), L, Why) :-
( L/\2'100000000 > 0 -> true
; spypoint_susp( S, Why)
).
debug_stop( wake(S), L, Why) :-
( L/\2'010000000 > 0 -> true
; spypoint_susp( S, Why)
).
debug_stop( exit(S), L, Why) :-
( L/\2'000010000 > 0 -> true
; spypoint_susp( S, Why)
).
debug_stop( redo(S), L, Why) :-
( L/\2'000001000 > 0 -> true
; spypoint_susp( S, Why)
).
debug_stop( fail(S), L, Why) :-
( L/\2'000000100 > 0 -> true
; spypoint_susp( S, Why)
).
%
debug_stop( insert(S), L, Why) :-
( L/\2'000000010 > 0 -> true
; spypoint_susp( S, Why)
).
debug_stop( remove(S), L, Why) :-
( L/\2'000000001 > 0 -> true
; spypoint_susp( S, Why)
).
%
debug_stop( try(H,R,_,Hs,_,_), L, Why) :-
( L/\2'001000000 > 0 -> true
; spy_rule(R,H) -> Why = r
; spypoint_head( Hs, Why)
).
debug_stop( apply(H,R,_,Hs,_,_), L, Why) :-
( L/\2'000100000 > 0 -> true
; spy_rule(R,H) -> Why = r
; spypoint_head( Hs, Why)
).
spypoint_susp( S, c) :-
S =.. [suspension,_,_,_,_,_,N|Args],
length( Args, A),
spy_constraint( N, A).
spypoint_head( Hs, c) :-
member( H, Hs),
arg( 1, H, Term),
functor( Term, N, A),
spy_constraint( N, A).
debug_stop_reason( Why, _) :- nonvar( Why).
debug_stop_reason( Why, Event) :- var( Why),
( debug_stop( Event, 0, Why) ->
true
;
Why = ' '
).
chr_debugging :-
what_is_on( help),
what_is_leashed( help),
what_spypoints( help).
what_is_on( Type) :-
getval( debug, Mode),
print_message( Type, debug(Mode)).
what_is_leashed( Type) :-
getval( leashing, Leash),
findall( P, (chr_leash(0,K,[P],[]),K/\Leash>0), L),
print_message( Type, leash(L)).
what_spypoints( Type) :-
findall( rules(E), (spy_rule(R,H),(var(H)->E=R;E=H:R)), L0, L1),
findall( constraints(E), (spy_constraint(N,A),(var(A)->E=N;E=N/A)), L1, []),
sort( L0, Ls),
print_message( Type, spypoints(Ls)).
% -----------------------------------------------------------------
debug_event( Event) :-
getval( debug, State),
( State == off ->
true
;
debug_event( State, Event),
debug_stack( Event)
).
debug_event( trace, Event) :-
getval( leashing, L),
( debug_stop( Event, L, SpyInd) ->
debug_stop_reason( SpyInd, Event),
debug_show( SpyInd, Event),
get_command( Cmd),
debug_do( Cmd, Event, trace)
;
debug_stop_reason( SpyInd, Event),
debug_show( SpyInd, Event),
errnl
).
debug_event( debug, Event) :-
( debug_stop( Event, 0, SpyInd) ->
debug_show( SpyInd, Event),
get_command( Cmd),
debug_do( Cmd, Event, debug)
;
true
).
debug_event( skip(N,S), Event) :-
stack_depth( M),
( M =< N, member( Event, [exit(_),fail(_)]) ->
setval( debug, S),
debug_event( S, Event)
;
true
).
debug_event( off, _).
debug_stack( Event) :- Event = call(_), !, stack_push( Event).
debug_stack( Event) :- Event = wake(_), !, stack_push( Event).
%
debug_stack( Event) :- Event = apply(_,_,_,_,_,_), !,
stack_pop,
stack_push( Event).
%
debug_stack( exit(_)) :- !, stack_pop.
%
debug_stack( _).
stack_push( S) :-
get_dbg_state( Ref),
get_mutable( Stack, Ref),
update_mutable( [S|Stack], Ref).
stack_pop :-
get_dbg_state( Ref),
get_mutable( [_|Stack], Ref),
update_mutable( Stack, Ref).
stack_depth( Depth) :-
get_dbg_state( Ref),
get_mutable( Stack, Ref),
length( Stack, Depth).
show_stack :-
get_dbg_state( Ref),
get_mutable( Stack, Ref),
length( Stack, N),
errwrite('Ancestors:'), errnl,
show_stack( Stack, N), errnl.
show_stack( [], _).
show_stack( [S|Ss], N) :-
M is N-1,
show_stack( Ss, M),
Spy = ' ',
( arg( 3, S, Hp) -> true ; Hp = '-' ),
functor( S, Port, _),
errformat( ' ~w ~|~t~d~4+ ~|~t~w~3+ ~|~p~t~7+', [Spy,N,Hp,Port]),
debug_show_event( S),
errnl.
debug_show( Spy, Event) :-
functor( Event, Port, _),
( arg( 3, Event, Hp) -> true ; Hp = '-' ),
stack_depth( Depth),
errformat( ' ~w ~|~t~d~4+ ~|~t~w~3+ ~|~p~t~7+', [Spy,Depth,Hp,Port]),
debug_show_event( Event).
debug_show_event( call(S)) :-
debug_susp_term( S, Term), errtab( 1), errprint( Term).
debug_show_event( wake(S)) :-
debug_susp_term( S, Term), errtab( 1), errprint( Term).
debug_show_event( exit(S)) :-
debug_susp_term( S, Term), errtab( 1), errprint( Term).
debug_show_event( redo(S)) :-
debug_susp_term( S, Term), errtab( 1), errprint( Term).
debug_show_event( fail(S)) :-
debug_susp_term( S, Term), errtab( 1), errprint( Term).
debug_show_event( remove(S)) :-
debug_susp_term( S, Term), errtab( 1), errprint( Term).
debug_show_event( insert(C)) :-
errtab( 1), errprint( C).
debug_show_event( try(Handler,Rule,_,Heads,_,_)) :-
errformat( ' ~p:~p @ ', [Handler,Rule]),
show_heads( Heads, 0, 0, _).
debug_show_event( apply(Handler,Rule,_,Heads,_,_)) :-
errformat( ' ~p:~p @ ', [Handler,Rule]),
show_heads( Heads, 0, 0, _).
debug_susp_term( S, Term#S) :-
S =.. [suspension,_,_,_,_,_,F|Args],
Term =.. [F|Args].
debug_do( 0'a, _, _) :- !, abort.
debug_do( 0'n, _, _) :- !, chr_notrace.
debug_do( 0'&, E, S) :- !, show_store( 0), debug_event( S, E).
debug_do( [0'&|_], E, S) :- !, show_store( 1), debug_event( S, E).
debug_do( 0'g, E, S) :- !, show_stack, debug_event( S, E).
debug_do( 0'., E, S) :-
dbg_at_rule( E, _, _),
!,
show_rule( E),
debug_event( S, E).
debug_do( 0'+, E, S) :- !,
( dbg_at_rule( E, Handler, Rule) ->
chr_spy( rules( Handler:Rule))
; dbg_at_constraint( E, N, A) ->
chr_spy( constraints( N/A))
),
debug_event( S, E).
debug_do( 0'-, E, S) :- !,
( dbg_at_rule( E, Handler, Rule) ->
chr_nospy( rules( Handler:Rule))
; dbg_at_constraint( E, N, A) ->
chr_nospy( constraints( N/A))
),
debug_event( S, E).
debug_do( 0'b, E, S) :- !,
setval( debug, off),
break,
setval( debug, S),
debug_event( S, E).
debug_do( 0'
, _, _) :- !, setval( debug, trace). % CR = creep
debug_do( 0'c, _, _) :- !, setval( debug, trace). % creep
debug_do( 0'l, _, _) :- !, setval( debug, debug). % leap
debug_do( 0's, E, S) :- chr_skip( E, S, _), !. % skip
debug_do( [0's,N], E, S) :- chr_skip( E, S, N), !. % skip
debug_do( 0'<, E, S) :- !, set_pd(10), debug_event( S, E).
debug_do( [0'<,N], E, S) :- !, set_pd(N), debug_event( S, E).
debug_do( 0'=, E, S) :- !, chr_debugging, debug_event( S, E).
debug_do( 0'?, E, S) :- !, dbg_help, debug_event( S, E).
debug_do( 0'h, E, S) :- !, dbg_help, debug_event( S, E).
debug_do( _, E, S) :-
print_message( informational, wrong_option),
debug_event( S, E).
chr_skip( E, S, K) :- E = exit(_), stack_depth( K), !, debug_event( S, E).
chr_skip( E, S, K) :- E = fail(_), stack_depth( K), !, debug_event( S, E).
chr_skip( _, S, K) :-
stack_depth( Depth),
( var(K) ->
N is Depth+1
;
1 =< K, K =< Depth,
N = K
),
setval( debug, skip(N,S)).
dbg_at_rule( try(Handler,Rule,_,_,_,_), Handler, Rule).
dbg_at_rule( apply(Handler,Rule,_,_,_,_), Handler, Rule).
dbg_at_constraint( E, N, A) :-
dbg_at_constraint( E, S),
S =.. [suspension,_,_,_,_,_,N|Args],
length( Args, A).
dbg_at_constraint( call(S), S).
dbg_at_constraint( wake(S), S).
dbg_at_constraint( exit(S), S).
dbg_at_constraint( redo(S), S).
dbg_at_constraint( fail(S), S).
dbg_at_constraint( insert(S), S).
dbg_at_constraint( remove(S), S).
%
% numbervars binds variables ...
%
show_rule( Event) :-
Event =.. [Which,Handler,Rule,_,Heads,Guard,Body],
member( Which, [try,apply]),
current_handler( Handler, _),
!,
show_rule( Rule, Heads, Guard, Body).
show_rule( _).
show_rule :-
chrcmp:rule( _, _, Name, Heads, Guard, Body, _),
numbervars( Heads/Name/Guard/Body, 0, _),
show_rule( Name, Heads, Guard, Body),
fail.
show_rule.
show_rule( Name, Heads, Guard, Body) :-
errformat( '~n ~p @', [Name]),
show_heads( Heads, 2, 2, Ident),
( member( k(_,_), Heads) ->
errformat( ' <=>~n~n', [])
;
errformat( ' ==>~n~n', [])
),
( Guard==true ->
show_body( Body, Ident)
;
show_body( Guard, Ident), errnl,
errtab( Ident), errwrite( '|'), errnl,
show_body( Body, Ident)
),
errput( 0'.), errnl, errnl.
show_body( (A,B), Tab) :- !,
show_body( A, Tab),
errwrite( ','), errnl,
show_body( B, Tab).
show_body( (A->B;C), Tab) :- !,
errtab( Tab), errwrite( '('), errnl,
NTab1 is Tab+2,
NTab2 is Tab+5,
show_body( A, NTab1),
errwrite( ' ->'), errnl,
show_body( B, NTab2), errnl,
errtab( Tab), errwrite( ';'), errnl,
show_body( C, NTab2), errnl,
errtab( Tab), errwrite( ')').
show_body( (A->B), Tab) :- !,
errtab( Tab), errwrite( '('), errnl,
NTab1 is Tab+2,
NTab2 is Tab+5,
show_body( A, NTab1),
errwrite( ' ->'), errnl,
show_body( B, NTab2), errnl,
errtab( Tab), errwrite( ')').
show_body( (A;B), Tab) :- !,
errtab( Tab), errwrite( '('), errnl,
NTab is Tab+5,
show_body( A, NTab), errnl,
errtab( Tab), errwrite( ';'), errnl,
show_body( B, NTab), errnl,
errtab( Tab), errwrite( ')').
show_body( A, Tab) :-
errtab( Tab),
errwriteq( A).
show_heads( [], I, _, I).
show_heads( [H|Hs], I, D, If) :-
arg( 1, H, C),
arg( 2, H, T),
( I>0 -> errnl ; true ),
errtab( I), errprint( C#T),
( Hs=[] ->
If = I
; H=r(_,_), Hs=[k(_,_)|_] ->
errput(0' ), errput(0'\\ ), errput(0' ),
J is I+D,
show_heads( Hs, J, D, If)
;
errput(0',), errput(0' ),
J is I+D,
show_heads( Hs, J, D, If)
).
show_store( 0) :-
errnl,
global_term_ref_1( Global),
find_constraint_internal( Global, Term, S, active, Module),
module_wrap( Term, Module, Wrapped),
errprint( Wrapped#S), errnl,
fail.
show_store( 1) :-
prolog_flag( debugger_print_options, Options),
errnl,
global_term_ref_1( Global),
find_constraint_internal( Global, Term, S, State, Module),
S =.. [suspension,Id,_,_Closure,Gref,Href|_],
get_mutable( Generation, Gref),
get_mutable( Hist, Href),
assoc_to_list( Hist, History),
module_wrap( Term, Module, Wrapped),
errformat( '~|~t~p~5+ ~|~t~d~3+ ~|~p~t~10+ ~|~@~t~50+ ',
[Id,Generation,State,write_term(Wrapped,Options)]),
show_history( History),
errnl,
fail.
show_store( _) :- errnl.
show_history( []).
show_history( [K-_|Hs]) :-
errprint( K),
( Hs==[] -> true ; errput(0',) ),
show_history( Hs).
set_pd( N) :-
prolog_flag( debugger_print_options, Old),
( select( max_depth(_), Old, Rest) ->
true
;
Rest = Old
),
( N < 0 -> D = 0 ; D = N ),
prolog_flag( debugger_print_options, _, [max_depth(D)|Rest]).
dbg_help :-
errnl,
errwrite('CHR debugging options:'), errnl,
errwrite(' <cr> creep c creep'), errnl,
errwrite(' l leap '), errnl,
errwrite(' s skip s <i> skip i'), errnl,
errwrite(' g ancestors '), errnl,
errwrite(' & constraints & <i> constraints (details)'), errnl,
errwrite(' n nodebug = debugging'), errnl,
errwrite(' + spy this '), errnl,
errwrite(' - nospy this . show rule'), errnl,
errwrite(' < reset printdepth < <n> set printdepth'), errnl,
errwrite(' a abort b break'), errnl,
errwrite(' ? help h help'), errnl,
errnl.
errnl :- nl( user_error).
errput( X) :- put( user_error, X).
errtab( X) :- tab( user_error, X).
errwrite( X) :- write( user_error, X).
errwriteq( X) :- writeq( user_error, X).
errprint( X) :-
prolog_flag( debugger_print_options, Options),
write_term( user_error, X, Options).
errformat( F, A) :- format( user_error, F, A).
% ----------------------------------------------------------
%
% code from the Bips/trace.pl
%
get_command(Command) :-
errwrite(' ? '),
ttyflush,
ttyget0(C1),
get_command(C1, Command).
get_command(0'
, 0'
) :- !.
get_command(C1, Command) :-
ttyget0(C2),
get_args(C2, Args),
( Args = [] -> Command = C1
; Command = [C1|Args]
).
get_args(0'
, []) :- !.
get_args(C1, [Arg|Args]) :-
C1 >= 0'0, C1 =< 0'9, !,
get_arg(C1, 0, Arg, C2),
get_args(C2, Args).
get_args(0'-, [Arg|Args]) :- !,
ttyget0(C2),
get_arg(C2, 0, Arg1, C3),
Arg is -Arg1,
get_args(C3, Args).
get_args(_, Args) :-
ttyget0(C2),
get_args(C2, Args).
get_arg(C1, Arg0, Arg, C) :-
C1 >= 0'0, C1 =< 0'9, !,
Arg1 is Arg0*10 + C1 - 0'0,
ttyget0(C2),
get_arg(C2, Arg1, Arg, C).
get_arg(C1, Arg, Arg, C1).