1% BEGIN LICENSE BLOCK
2% Version: CMPL 1.1
3%
4% The contents of this file are subject to the Cisco-style Mozilla Public
5% License Version 1.1 (the "License"); you may not use this file except
6% in compliance with the License.  You may obtain a copy of the License
7% at www.eclipse-clp.org/license.
8%
9% Software distributed under the License is distributed on an "AS IS"
10% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied.  See
11% the License for the specific language governing rights and limitations
12% under the License.
13%
14% The Original Code is  The ECLiPSe Constraint Logic Programming System.
15% The Initial Developer of the Original Code is  Cisco Systems, Inc.
16% Portions created by the Initial Developer are
17% Copyright (C) 1994-2006 Cisco Systems, Inc.  All Rights Reserved.
18%
19% Contributor(s): ECRC GmbH.
20%
21% END LICENSE BLOCK
22
23%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
24%
25%	Predicates to trace and display
26%	the propagation between labeling steps.
27%
28%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
29
30:- begin_module(grace).
31:- call(lib(fd)).
32
33%
34% Deamon on the labelled variable
35%
36start_stepw_deamon(Inst) :-
37    nonvar(Inst).
38start_stepw_deamon(Var) :-
39    (getval(mode, stepw) ->
40	copy_term(Var, CVar),
41	make_suspension(stepw_deamon(Var, CVar), 1, Susp),
42	insert_suspension(Var, Susp, constrained of suspend, suspend)
43    ;
44	true
45    ).
46
47stepw_deamon(Val, Var) :-
48    get_depth(D),
49    record(label, [label(Val, D)|Var]),
50    %trace
51    init_propagation_trace(label(Val, D)).
52
53%
54% Recording the information
55%
56trace_suspension(_, _, _, grace) :- !.
57trace_suspension(Port, Goal, Mark, _) :-
58    %printf("%s %w %GDmVw\n%b", [Port, Mark, Goal]),
59    handle_suspension_trace(Port, Goal, Mark).
60
61handle_suspension_trace('CALL', Goal, Mark) :-
62    copy_term(Goal, Copy),
63    record(call, [Mark|Copy]).
64handle_suspension_trace('EXIT', Goal, Mark) :-
65    copy_term(Goal, Copy),
66    record(exit, [Mark|Copy]).
67handle_suspension_trace('REC_WAKE', Goal, Mark) :-
68    copy_term(Goal, Copy),
69    record(exit, [Mark|Copy]).
70handle_suspension_trace('FAIL', _Goal, Mark) :-
71    (getval(first_fail, 1) ->
72	record(fail, Mark),
73	setval(first_fail, 0)
74    ;
75	true
76    ).
77
78%
79% We can only record goals, no suspensions, because of bug #731, otherwise
80% we would duplicate them
81trace_propagation(Mark, Woken, Delayed, First) :-
82    %printf("+%w (%d) %VDw %VDw\n", [Mark, First, Woken, Delayed]),
83    record_propagation(Mark, Woken, Delayed, First).
84
85record_propagation(Mark, Woken, Delayed, First) :-
86    woken_goals(Woken, First, WokenList),
87    delayed_list(Delayed, 16'7fffffff, DelayedList),	% always new
88    (WokenList = [] ->
89	true
90    ;
91	record(wake, [Mark|WokenList])
92    ),
93    (DelayedList = [] ->
94	true
95    ;
96	record(delay, [Mark|DelayedList])
97    ).
98
99%
100% filter our local goals and create a list of marks
101%
102woken_goals(L, First, W) :-
103    (woken_goals(L, First, W, -1)).
104
105woken_goals([], _, [], _).
106woken_goals([Susp|S], First, L, Last) :-
107    (suspension_to_goal(Susp, _, grace) ->
108	woken_goals(S, First, L, Last)
109    ;
110    %printf("in woken: %Vw\n", [Susp]),
111    suspension_mark(Susp, First, Mark),
112    Mark > 0,
113    Mark \== Last ->
114	L = [Mark|L1],
115	woken_goals(S, First, L1, Mark)
116    ;
117	woken_goals(S, First, L, Last)
118    ).
119
120%
121% New suspensions. Filter out our goals and mark the rest.
122%
123delayed_list([], _, []).
124delayed_list([Susp|S], New, L) :-
125    suspension_to_goal(Susp, Goal, Module),
126    (Module = grace ->
127	L1 = L
128    ;
129	(suspension_mark(Susp, New, Mark) ->
130	    copy_term(Goal, Copy),
131	    record(delay_goal, [Mark|Copy]),
132	    L = [Mark|L1]
133	;
134	    L1 = L
135	)
136    ),
137    delayed_list(S, New, L1).
138
139
140init_propagation_trace(Label) :-
141    get_parent(p(_, _, LS, _)),
142    garbage_collect,
143    new_scheduled(LS, Woken),
144    get_suspension_counter(SC),
145    (tcl_eval('set .tc.reg.var', 0) ->
146	% Replace
147	set_first_suspension(SC)
148    ;
149	% Add
150	set_first_suspension(SC)
151    ),
152    %printf("----init: label %w, first counter %d\n%b", [Label, SC]),
153    %printf("\twoken: %Vw\n", [Woken]),
154    %printf("\tlast scheduled: %w\n", [LS]),
155    %trace
156    record_propagation(Label, Woken, [], SC),
157    setval(first_fail, 1),
158    last_scheduled(LS1),
159    last_suspension(LD1),
160    set_parent(p(Label, [], LS1, LD1)).
161
162reset_propagation_trace :-
163    erase_all(call),
164    erase_all(exit),
165    erase_all(fail),
166    erase_all(wake),
167    erase_all(delay),
168    erase_all(delay_goal),
169    erase_all(label),
170    (current_array(goals(_, _), _) ->
171	erase_array(goals/2)
172    ;
173	true
174    ).
175
176:- global pp/0.
177pp :-
178    recorded_list(call, CL),
179    recorded_list(exit, EL),
180    recorded_list(delay, DL),
181    recorded_list(wake, WL),
182    recorded_list(fail, FL),
183    printf("\ncall=", []),
184    print_array(0, CL),
185    printf("\nexit=", []),
186    print_array(1, EL),
187    printf("\ndelay=", []),
188    print_list(DL),
189    printf("\nwake=", []),
190    print_list(WL),
191    printf("\nfail=", []),
192    print_list(FL).
193
194pl(Key) :-
195    recorded_list(Key, L),
196    printf("\n%s=", [Key]),
197    print_list(L).
198
199print_array(I, []) :-
200    current_array(goals(N, _), _),
201    N1 is N - 1,
202    between(0, N1, 1, C),
203    getval(goals(C, I), Goal),
204    (var(Goal) ->
205	true
206    ;
207	printf("%d\t%w\n%b", [C, Goal])
208    ),
209    fail; true.
210print_array(_, [H|T]) :-
211    print_list([H|T]).
212
213%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
214%
215%	Displaying the propagation tree
216%
217%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
218
219%
220% Display the whole propagation. Since we don't have a good graph
221% package, display it as a tree.
222%
223make_graph(1) :-
224    woken_graph(1).
225make_graph(3) :-
226    simple_graph(1).
227
228woken_graph(Eager) :-
229    make_tree('.t', "Propagation Tree", 30, horizontal, Tree, 1),
230    recorded_list(wake, WL),
231    goal_graph(Tree, WL, Eager).
232
233simple_graph(Eager) :-
234    tcl_eval('make_simple_tree .st', Tree),
235    recorded_list(wake, WL),
236    simple_tree(Tree, WL, Eager).
237
238delayed_graph(Eager) :-
239    make_tree('.t', "Propagation Tree", 30, horizontal, Tree, 1),
240    recorded_list(delay, DL),
241    goal_graph(Tree, DL, Eager).
242
243%
244% Display the sequence of updates of a specified variable
245%
246display_var_updates(Id) :-
247    current_array(goals(Max, _), _),
248    make_list_of_var_nodes(0, Max, Id, List),
249    (List = [] ->
250	true
251    ;
252	failed_nodes_list(FL, List),
253	sort(2, =<, FL, FL1),	% to get I-fail after I-Node
254	label_nodes_list(LL, FL1, MD),
255	keysort(LL, Sorted),
256	make_tree('.tv', "Variable Updates", 10, vertical, Tree, 0),
257	display_var_nodes(Tree, Sorted, MD),
258	colour_failed_nodes(Tree)
259    ).
260
261make_tree(Top, Title, ParDistance, Layout, Tree, Replace) :-
262    tcl_eval(['make_tree ', Top, ' "', Title, '" ',
263	ParDistance, ' ', Layout, ' ', Replace], Tree).
264
265%
266% Make a list of all nodes which have modified the given variable
267make_list_of_var_nodes(I, Max, Id, List) :-
268    I < Max,
269    !,
270    I1 is I + 1,
271    goal_format(I, Call, Exit),
272    (var_in_term(Id, Call, CVar) ->
273	(var_in_term(Id, Exit, EVar),
274	same_domain(CVar, EVar),
275	not(recorded(fail, I)) ->
276	    make_list_of_var_nodes(I1, Max, Id, List)
277	;
278	    % different or not there - must be instantiated
279	    getval(goals(I, 2), Order),
280	    List = [Order-I|L],
281	    make_list_of_var_nodes(I1, Max, Id, L)
282	)
283    ;
284	make_list_of_var_nodes(I1, Max, Id, List)
285    ).
286make_list_of_var_nodes(_, _, _, []).
287
288failed_nodes_list(List, Link) :-
289    recorded_list(fail, FL),
290    failed_nodes_list(FL, List, Link).
291
292failed_nodes_list([], L, L).
293failed_nodes_list([H|T], [O-fail|List], Link) :-
294    getval(goals(H, 2), O),
295    failed_nodes_list(T, List, Link).
296
297label_nodes_list(List, Link, MD) :-
298    recorded_list(wake, WL),
299    label_nodes_list(WL, List, Link, 0, MD).
300
301label_nodes_list([], L, L, M, M).
302label_nodes_list([[label(_, D), H|_]|T], [O1-l(D)|List], Link, M, MD) :-
303    !,
304    getval(goals(H, 2), O),
305    O1 is O,
306    (D > M ->
307	M1 = D
308    ;
309	M1 = M
310    ),
311    label_nodes_list(T, List, Link, M1, MD).
312label_nodes_list([_|T], List, Link, M, MD) :-
313    label_nodes_list(T, List, Link, M, MD).
314
315display_var_nodes(Tree, [_-P|L], _MD) :-
316    (L = [] ->
317	add_successors(Tree, P, [], 1, 0)
318    ;
319	display_var_nodes(Tree, P, L, []),
320	fail; true
321    ).
322
323display_var_nodes(_, _, [], _).
324display_var_nodes(Tree, P, [_-C|L], Lab) :-
325    (P = fail ->
326	display_var_nodes(Tree, C, L, Lab)
327    ;
328    C = fail ->
329	display_var_nodes(Tree, P, L, Lab)
330    ;
331    C = l(D) ->
332	(find_stack_depth(Lab, D, LN, NewLab) ->
333	    display_var_nodes(Tree, C, L, NewLab)
334	;
335	    display_var_nodes(Tree, C, L, [D-P|Lab])
336	)
337    ;
338    P = l(D) ->
339	(find_stack_depth(Lab, D, LN, NewLab) ->
340	    true
341	;
342	    LN = start,
343	    NewLab = [D-start|Lab]
344	),
345	add_successors(Tree, LN, [C], 0, 0),
346	display_var_nodes(Tree, C, L, NewLab)
347    ;
348	add_successors(Tree, P, [C], 0, 0),
349	display_var_nodes(Tree, C, L, Lab)
350    ).
351
352find_stack_depth(L, D, LN, L) :-
353    L = [D-LN|_],
354    !.
355find_stack_depth([H-_|T], D, LN, L) :-
356    H > D,
357    find_stack_depth(T, D, LN, L).
358
359/*
360display_var_nodes(Tree, [_-P|L]) :-
361    (L = [] ->
362	add_successors(Tree, P, [], 1, 0)
363    ;
364	display_var_nodes(Tree, P, L, 0)
365    ).
366
367display_var_nodes(_, _, [], _).
368display_var_nodes(Tree, P, [_-C|L], Fail) :-
369    (P = fail ->
370	display_var_nodes(Tree, C, L, Fail)
371    ;
372    C = fail ->
373	display_var_nodes(Tree, P, L, 1)
374    ;
375	add_successors(Tree, P, [C], 1, Fail),
376	display_var_nodes(Tree, C, L, 0)
377    ).
378*/
379
380goal_graph(Tree, [], _) :-
381    colour_failed_nodes(Tree).
382goal_graph(Tree, [[Parent|Woken]|List], Eager) :-
383    sort(Woken, Sorted),
384    add_successors(Tree, Parent, Sorted, Eager, 0),
385    goal_graph(Tree, List, Eager).
386
387add_successors(Tree, Parent, Children, Eager, Fail) :-
388    goals_list(Children, WList),
389    list_to_tcl(WList, TclList),
390    (Parent = label(V, D) ->
391	concat_string(['label(', V, ',', D, ')'], ParT)
392    ;
393	ParT = Parent
394    ),
395    ((integer(Parent); Parent = label(_, _)) ->
396	goal_to_node(Parent, PNode)
397    ;
398	PNode = Parent
399    ),
400    tcl_eval(['add_successors ', Tree, ' ', ParT, ' ', PNode,
401			TclList, Eager, ' ', Fail]).
402
403colour_failed_nodes(Tree) :-
404    recorded_list(fail, FL),
405    list_to_tcl(FL, FTcl),
406    tcl_eval(['tree_failed_nodes ', Tree, ' ', FTcl]).
407
408simple_tree(_, [], _).
409simple_tree(Tree, [[Parent|Woken]|List], Eager) :-
410    sort(Woken, Sorted),
411    add_simple_successors(Tree, Parent, Sorted, Eager, 0),
412    simple_tree(Tree, List, Eager).
413
414add_simple_successors(Tree, Parent, Children, Eager, _Fail) :-
415    simple_goal_list(Children, CL),
416    list_to_tcl(CL, TclList),
417    (Parent = label(V, D) ->
418	concat_string(['label(', V, ',', D, ')'], ParT)
419    ;
420	ParT = Parent
421    ),
422    tcl_eval(['add_simple_successors ', Tree, ' ', ParT, ' ',
423			TclList, Eager]).
424
425simple_goal_list([], []).
426simple_goal_list([G|L], [C|T]) :-
427    (goal_modified(G) ->
428	list_to_tcl([G, red], C)
429    ;
430	list_to_tcl([G, black], C)
431    ),
432    simple_goal_list(L, T).
433
434
435goals_list([], []).
436goals_list([G|T], [W|L]) :-
437    goal_to_node(G, GoalS),
438    !,
439    concat_string(['{', G, GoalS, '}'], W),
440    goals_list(T, L).
441goals_list([_|T], L) :-
442    goals_list(T, L).
443
444% Fake GC to get rid of the long list
445call_number(_) :-
446    recorded_list(call, CList),
447    length(CList, Length),
448    setval(nodes, Length),
449    fail.
450call_number(X) :-
451    getval(nodes, X).
452
453goal_format(label(V, D), Var, V) :-
454    !,
455    recorded(label, [label(V, D)|Var]).
456goal_format(Index, Goal, Exit) :-
457    getval(goals(Index, 0), Goal),
458    getval(goals(Index, 1), Exit),
459    (var(Exit) ->
460	Exit = Goal
461    ;
462	true
463    ).
464
465%
466% Process the recorded data, move records to arrays where direct
467% access is necessary
468%
469end_propagation :-
470    get_suspension_counter(SC),
471    (SC > 1 ->
472	(call_number(CN),
473	CN > 0 ->
474	    prop_register(CN, 1),
475	    % Move the data from records to arrays, because we need
476	    % direct access
477	    goals_array(SC),
478	    findall((Lab,D)-L, (recorded(delay, [label(Lab, D)|L], Ref), erase(Ref)), DL),
479	    prune_delays(DL)
480	;
481	recorded(wake, _) ->
482	    recorded_list(wake, WL),
483	    flatten(WL, WLF),
484	    sort(WLF, WLFS),
485	    length(WLFS, N),
486	    prop_register(N, 0)
487	)
488    ;
489	tcl_eval('tc_register .tc {}')
490    ).
491
492prop_register(CN, Calls) :-
493    (CN = 1 -> G = " goal"; G = " goals"),
494    concat_string([CN, G, " registered"], Text),
495    tcl_eval(['tc_register .tc "', Text, '" ', Calls]).
496
497prune_delays([(Lab,D)-DL|L]) :-
498    filter_delays(DL, CDL),
499    (CDL = [] ->
500	true
501    ;
502	recorda(delay, [label(Lab, D)|CDL])
503    ),
504    prune_delays(L).
505prune_delays([]).
506
507goals_array(C) :-
508    C1 is C + 1,
509    (current_array(goals(_, _), _) ->
510	erase_array(goals/2)
511    ;
512	true
513    ),
514    make_local_array(goals(C1, 3)),
515    recorded_list(call, CList),
516    insert_calls(CList, 0),
517    erase_all(call),
518    recorded_list(exit, EList),
519    insert_exits(EList),
520    erase_all(exit),
521    recorded_list(delay_goal, DG),
522    insert_delay_goals(DG, 0),
523    erase_all(delay_goal),
524    true.
525
526insert_calls([], _).
527insert_calls([[M|Goal]|List], I) :-
528    setval(goals(M, 0), Goal),
529    setval(goals(M, 2), I),
530    I1 is I + 1,
531    insert_calls(List, I1).
532
533insert_exits([]).
534insert_exits([[M|Goal]|List]) :-
535    setval(goals(M, 1), Goal),
536    insert_exits(List).
537
538insert_delay_goals([], _).
539insert_delay_goals([[M|Goal]|List], I) :-
540    getval(goals(M, I), G),
541    (var(G) ->
542	setval(goals(M, I), Goal)
543    ;
544	true
545    ),
546    insert_delay_goals(List, I).
547
548filter_delays([], []).
549filter_delays([D|DL], [D|CL]) :-
550    recorded(delay, [D|_]),
551    !,
552    filter_delays(DL, CL).
553filter_delays([_|DL], CL) :-
554    filter_delays(DL, CL).
555
556var_in_term(Id, Var{grace:(grace with id:I)}, V) :-
557    -?->
558    I = Id,
559    !,
560    V = Var.
561var_in_term(Id, Term, Var) :-
562    compound(Term),
563    Term = [_|_],
564    !,
565    var_in_term_list(Id, Term, Var).
566var_in_term(Id, Term, Var) :-
567    compound(Term),
568    Term =.. [_|Args],
569    var_in_term_list(Id, Args, Var).
570
571var_in_term_list(Id, [Term|_], Var) :-
572    var_in_term(Id, Term, Var),
573    !.
574var_in_term_list(Id, [_|L], Var) :-
575    var_in_term_list(Id, L, Var).
576
577same_domain(V1, V2) :-
578    dvar_domain(V1, D),
579    dvar_domain(V2, D).
580