1 /* Part of SWI-Prolog
2
3 Author: Jan Wielemaker
4 E-mail: J.Wielemaker@vu.nl
5 WWW: http://www.swi-prolog.org
6 Copyright (c) 1985-2015, University of Amsterdam
7 VU University Amsterdam
8 All rights reserved.
9
10 Redistribution and use in source and binary forms, with or without
11 modification, are permitted provided that the following conditions
12 are met:
13
14 1. Redistributions of source code must retain the above copyright
15 notice, this list of conditions and the following disclaimer.
16
17 2. Redistributions in binary form must reproduce the above copyright
18 notice, this list of conditions and the following disclaimer in
19 the documentation and/or other materials provided with the
20 distribution.
21
22 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
23 "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
24 LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
25 FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
26 COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
27 INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
28 BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
29 LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
30 CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
31 LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
32 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
33 POSSIBILITY OF SUCH DAMAGE.
34 */
35
36 #include "pl-incl.h"
37 #include "pl-comp.h"
38 #include "os/pl-ctype.h"
39 #include "os/pl-cstack.h"
40 #include "pl-inline.h"
41 #include "pl-dbref.h"
42 #include <stdio.h>
43
44 #define WFG_TRACING 0x02000
45 #define WFG_BACKTRACE 0x04000
46 #define WFG_CHOICE 0x08000
47
48 #define TRACE_FIND_NONE 0
49 #define TRACE_FIND_ANY 1
50 #define TRACE_FIND_NAME 2
51 #define TRACE_FIND_TERM 3
52
53 typedef struct find_data_tag
54 { int port; /* Port to find */
55 bool searching; /* Currently searching? */
56 int type; /* TRACE_FIND_* */
57 union
58 { atom_t name; /* Name of goal to find */
59 struct
60 { functor_t functor; /* functor of the goal */
61 Record term; /* Goal to find */
62 } term;
63 } goal;
64 } find_data;
65
66
67 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
68 Convert between integer frame reference and LocalFrame pointer.
69 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
70
71 static int
PL_unify_frame(term_t t,LocalFrame fr)72 PL_unify_frame(term_t t, LocalFrame fr)
73 { GET_LD
74
75 if ( fr )
76 { assert(fr >= lBase && fr < lTop);
77
78 return PL_unify_integer(t, (Word)fr - (Word)lBase);
79 } else
80 return PL_unify_atom(t, ATOM_none);
81 }
82
83
84 int
PL_put_frame(term_t t,LocalFrame fr)85 PL_put_frame(term_t t, LocalFrame fr)
86 { GET_LD
87
88 if ( fr )
89 { assert(fr >= lBase && fr < lTop);
90
91 return PL_put_intptr(t, (Word)fr - (Word)lBase);
92 } else
93 return PL_put_atom(t, ATOM_none);
94 }
95
96
97 static int
PL_get_frame(term_t r,LocalFrame * fr)98 PL_get_frame(term_t r, LocalFrame *fr)
99 { GET_LD
100 intptr_t i;
101 atom_t a;
102
103 if ( PL_get_intptr(r, &i) )
104 { LocalFrame f = ((LocalFrame)((Word)lBase + i));
105
106 if ( !(f >= lBase && f < lTop) )
107 fail;
108 *fr = f;
109
110 succeed;
111 } else if ( PL_get_atom(r, &a) && a == ATOM_none )
112 { *fr = NULL;
113
114 succeed;
115 }
116
117 fail;
118 }
119
120
121 void
PL_put_choice(term_t t,Choice ch)122 PL_put_choice(term_t t, Choice ch)
123 { GET_LD
124
125 if ( ch )
126 { assert(ch >= (Choice)lBase && ch < (Choice)lTop);
127
128 PL_put_intptr(t, (Word)ch - (Word)lBase);
129 } else
130 PL_put_atom(t, ATOM_none);
131 }
132
133
134 static int
PL_unify_choice(term_t t,Choice ch)135 PL_unify_choice(term_t t, Choice ch)
136 { GET_LD
137
138 if ( ch )
139 { assert(ch >= (Choice)lBase && ch < (Choice)lTop);
140
141 return PL_unify_integer(t, (Word)ch - (Word)lBase);
142 } else
143 return PL_unify_atom(t, ATOM_none);
144 }
145
146
147 static inline int
valid_choice(Choice ch ARG_LD)148 valid_choice(Choice ch ARG_LD)
149 { if ( (int)ch->type >= 0 && (int)ch->type <= CHP_DEBUG &&
150 onStack(local, ch->frame) )
151 return TRUE;
152
153 return FALSE;
154 }
155
156
157 static int
PL_get_choice(term_t r,Choice * chp)158 PL_get_choice(term_t r, Choice *chp)
159 { GET_LD
160 long i;
161
162 if ( PL_get_long(r, &i) )
163 { Choice ch = ((Choice)((Word)lBase + i));
164
165 if ( !(ch >= (Choice)lBase && ch < (Choice)lTop) ||
166 !valid_choice(ch PASS_LD) )
167 return PL_error(NULL, 0, NULL, ERR_EXISTENCE, ATOM_choice, r);
168 *chp = ch;
169
170 succeed;
171 } else
172 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_choice, r);
173 }
174
175
176 #ifdef O_DEBUGGER
177
178 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
179 isDebugFrame(LocalFrame FR) is true if this call must be visible in the
180 tracer. `No-debug' code has HIDE_CHILDS. Calls to it must be visible if
181 the parent is a debug frame.
182 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
183
184 int
isDebugFrame(LocalFrame FR)185 isDebugFrame(LocalFrame FR)
186 { if ( false(FR->predicate, TRACE_ME) )
187 return FALSE; /* hidden predicate */
188
189 if ( false(FR->predicate, HIDE_CHILDS) )
190 return TRUE; /* user pred */
191
192 if ( FR->parent )
193 { LocalFrame parent = FR->parent;
194
195 if ( levelFrame(FR) == levelFrame(parent)+1 )
196 { /* not last-call optimized */
197 if ( false(parent->predicate, HIDE_CHILDS) )
198 return TRUE; /* user calls system */
199 return FALSE; /* system calls system */
200 } else
201 { if ( false(parent, FR_HIDE_CHILDS) )
202 return TRUE;
203 return FALSE;
204 }
205 } else
206 { QueryFrame qf = queryOfFrame(FR);
207
208 return (qf->flags & PL_Q_NODEBUG) ? FALSE : TRUE;
209 }
210 }
211
212
213 static int
exitFromDebugger(const char * msg,int status)214 exitFromDebugger(const char *msg, int status)
215 { GET_LD
216
217 #ifdef O_PLMT
218 if ( PL_thread_self() > 1 )
219 { Sfprintf(Sdout, "%sexit session\n", msg);
220 LD->exit_requested = EXIT_REQ_THREAD;
221 return ACTION_ABORT;
222 }
223 #endif
224 Sfprintf(Sdout, "%sexit (status 4)\n", msg);
225 PL_halt(status);
226 return -1;
227 }
228
229 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
230 This module defines the tracer and interrupt handler that allows the
231 user to break the normal Prolog execution. The tracer is written in C,
232 but before taking action it calls Prolog. This mechanism allows the
233 user to intercept and redefine the tracer.
234 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
235
236 /* Frame <-> Prolog integer */
237 static void helpTrace(void);
238 #ifdef O_INTERRUPT
239 static void helpInterrupt(void);
240 #endif
241 static bool hasAlternativesFrame(LocalFrame);
242 static void alternatives(Choice);
243 static int exceptionDetails(void);
244 static int listGoal(LocalFrame frame);
245 static int traceInterception(LocalFrame, Choice, int, Code);
246 static int traceAction(char *cmd,
247 int port,
248 LocalFrame frame,
249 Choice bfr,
250 bool interactive);
251 static void interruptHandler(int sig);
252 static int writeFrameGoal(IOSTREAM *out, LocalFrame frame, Code PC,
253 unsigned int flags);
254
255 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
256 redoFrame() returns the latest skipped frame or NULL if no such frame
257 exists. This is used to give the redo port of the goal skipped rather
258 than the redo port of some subgoal of this port.
259 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
260
261 static LocalFrame
redoFrame(LocalFrame fr,Code * PC)262 redoFrame(LocalFrame fr, Code *PC)
263 { while( fr && false(fr, FR_SKIPPED))
264 { *PC = fr->programPointer;
265 fr = parentFrame(fr);
266 }
267
268 return fr;
269 }
270
271
272 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
273 canUnifyTermWithGoal() is used to check whether the given frame satisfies
274 the /search specification. This function cannot use the `neat' interface
275 as the record is not in the proper format.
276
277 This function fails if its execution would require a stack-shift of GC!
278 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
279
280 static int
canUnifyTermWithGoal(LocalFrame fr)281 canUnifyTermWithGoal(LocalFrame fr)
282 { GET_LD
283 find_data *find = LD->trace.find;
284
285 switch(find->type)
286 { case TRACE_FIND_ANY:
287 succeed;
288 case TRACE_FIND_NAME:
289 return find->goal.name == fr->predicate->functor->name;
290 case TRACE_FIND_TERM:
291 { if ( find->goal.term.functor == fr->predicate->functor->functor )
292 { fid_t cid;
293
294 if ( (cid=PL_open_foreign_frame()) )
295 { term_t t = PL_new_term_ref();
296 term_t frref = consTermRef(fr);
297 int i, arity = fr->predicate->functor->arity;
298 int rval = TRUE;
299
300 if ( copyRecordToGlobal(t, find->goal.term.term,
301 ALLOW_GC|ALLOW_SHIFT PASS_LD) < 0 )
302 fail;
303 for(i=0; i<arity; i++)
304 { Word a, b;
305
306 a = valTermRef(t);
307 deRef(a);
308 a = argFrameP(*a, i);
309 fr = (LocalFrame)valTermRef(frref);
310 b = argFrameP(fr, i);
311
312 if ( !can_unify(a++, b++, 0) )
313 { rval = FALSE;
314 break;
315 }
316 }
317
318 PL_discard_foreign_frame(cid);
319 return rval;
320 }
321 }
322
323 fail;
324 }
325 default:
326 assert(0);
327 fail;
328 }
329 }
330
331
332 static const char *
portPrompt(int port)333 portPrompt(int port)
334 { switch(port)
335 { case CALL_PORT: return " Call: ";
336 case REDO_PORT: return " Redo: ";
337 case FAIL_PORT: return " Fail: ";
338 case EXIT_PORT: return " Exit: ";
339 case UNIFY_PORT: return " Unify: ";
340 case EXCEPTION_PORT: return " Exception: ";
341 case CUT_CALL_PORT: return " Cut call: ";
342 case CUT_EXIT_PORT: return " Cut exit: ";
343 default: return "";
344 }
345 }
346
347
348 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
349 Toplevel of the tracer. This function is called from the WAM
350 interpreter. It can take care of most of the tracer actions itself,
351 except if the execution path is to be changed. For this reason it
352 returns to the WAM interpreter how to continue the execution:
353
354 ACTION_CONTINUE: Continue normal
355 ACTION_FAIL: Go to the fail port of this goal
356 ACTION_RETRY: Redo the current goal
357 ACTION_IGNORE: Go to the exit port of this goal
358 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
359
360 #define SAVE_PTRS() \
361 frameref = consTermRef(frame); \
362 chref = consTermRef(bfr); \
363 frref = (fr ? consTermRef(fr) : 0); \
364 pcref = (onStack(local, PC) ? consTermRef(PC) : 0);
365 #define RESTORE_PTRS() \
366 frame = (LocalFrame)valTermRef(frameref); \
367 bfr = (Choice)valTermRef(chref); \
368 fr = (frref ? (LocalFrame)valTermRef(frref) : NULL); \
369 PC = (pcref ? (Code)valTermRef(pcref) : PC);
370
371 int
tracePort(LocalFrame frame,Choice bfr,int port,Code PC ARG_LD)372 tracePort(LocalFrame frame, Choice bfr, int port, Code PC ARG_LD)
373 { int action = ACTION_CONTINUE;
374 wakeup_state wstate;
375 term_t frameref, chref, frref, pcref;
376 Definition def = frame->predicate;
377 LocalFrame fr = NULL;
378
379 if ( (!isDebugFrame(frame) && !SYSTEM_MODE) || /* hidden */
380 debugstatus.suspendTrace ) /* called back */
381 return ACTION_CONTINUE;
382
383 if ( port == EXCEPTION_PORT ) /* do not trace abort */
384 { Word p = valTermRef(LD->exception.pending);
385
386 deRef(p);
387 if ( *p == ATOM_aborted )
388 return ACTION_CONTINUE;
389 }
390
391 if ( !debugstatus.tracing &&
392 (false(def, SPY_ME) || (port & (CUT_PORT|REDO_PORT))) )
393 return ACTION_CONTINUE; /* not tracing and no spy-point */
394 if ( debugstatus.skiplevel < levelFrame(frame) )
395 return ACTION_CONTINUE; /* skipped */
396 if ( debugstatus.skiplevel == levelFrame(frame) &&
397 (port & (REDO_PORT|CUT_PORT|UNIFY_PORT)) )
398 return ACTION_CONTINUE; /* redo, unify or ! in skipped pred */
399 if ( false(def, TRACE_ME) )
400 return ACTION_CONTINUE; /* non-traced predicate */
401 if ( (!(debugstatus.visible & port)) )
402 return ACTION_CONTINUE; /* wrong port */
403 if ( (true(def, HIDE_CHILDS) && !SYSTEM_MODE) &&
404 (port & CUT_PORT) )
405 return ACTION_CONTINUE; /* redo or ! in system predicates */
406
407 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
408 Give a trace on the skipped goal for a redo.
409 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
410
411 { Code pc2 = NULL;
412
413 if ( port == REDO_PORT && debugstatus.skiplevel == SKIP_VERY_DEEP &&
414 (fr = redoFrame(frame, &pc2)) != NULL )
415 { int rc;
416
417 debugstatus.skiplevel = SKIP_REDO_IN_SKIP;
418 SAVE_PTRS();
419 rc = tracePort(fr, bfr, REDO_PORT, pc2 PASS_LD);
420 RESTORE_PTRS();
421 debugstatus.skiplevel = levelFrame(fr);
422 set(fr, FR_SKIPPED); /* cleared by "creep" */
423
424 return rc;
425 }
426 }
427
428 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
429 We are in searching mode; should we actually give this port?
430 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
431
432 if ( LD->trace.find && LD->trace.find->searching )
433 { DEBUG(2, Sdprintf("Searching\n"));
434
435 if ( (port & LD->trace.find->port) )
436 { int rc;
437
438 SAVE_PTRS();
439 rc = canUnifyTermWithGoal(frame);
440 RESTORE_PTRS()
441 if ( rc )
442 LD->trace.find->searching = FALSE; /* Got you */
443 return ACTION_CONTINUE; /* Continue the search */
444 } else
445 { return ACTION_CONTINUE; /* Continue the search */
446 }
447 }
448
449 if ( !saveWakeup(&wstate, FALSE PASS_LD) )
450 return action;
451
452 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
453 Do the Prolog trace interception.
454 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
455
456 SAVE_PTRS();
457 action = traceInterception(frame, bfr, port, PC);
458 RESTORE_PTRS();
459 if ( action >= 0 )
460 goto out;
461
462 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
463 All failed. Things now are upto the normal Prolog tracer.
464 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
465
466 action = ACTION_CONTINUE;
467
468 again:
469 SAVE_PTRS();
470 writeFrameGoal(Suser_error, frame, PC, port|WFG_TRACING);
471 RESTORE_PTRS();
472
473 if (debugstatus.leashing & port)
474 { char buf[LINESIZ];
475
476 debugstatus.skiplevel = SKIP_VERY_DEEP;
477 debugstatus.tracing = TRUE;
478
479 Sfprintf(Sdout, " ? ");
480 Sflush(Sdout);
481 if ( !truePrologFlag(PLFLAG_TTY_CONTROL) )
482 { buf[0] = EOS;
483 if ( !readLine(Sdin, Sdout, buf) )
484 { action = exitFromDebugger("EOF: ", 4);
485 goto out;
486 }
487 } else
488 { int c = getSingleChar(Sdin, FALSE);
489
490 if ( c == EOF )
491 { action = exitFromDebugger("EOF: ", 4);
492 goto out;
493 }
494 buf[0] = c;
495 buf[1] = EOS;
496 if ( isDigit(buf[0]) || buf[0] == '/' )
497 { Sfprintf(Sdout, buf);
498 readLine(Sdin, Sdout, buf);
499 }
500 }
501 SAVE_PTRS();
502 action = traceAction(buf, port, frame, bfr,
503 truePrologFlag(PLFLAG_TTY_CONTROL));
504 RESTORE_PTRS();
505 if ( action == ACTION_AGAIN )
506 goto again;
507 } else
508 Sfprintf(Sdout, "\n");
509
510 out:
511 restoreWakeup(&wstate PASS_LD);
512 if ( action == ACTION_ABORT )
513 abortProlog();
514
515 return action;
516 }
517
518
519 static int
setupFind(char * buf)520 setupFind(char *buf)
521 { GET_LD
522 char *s;
523 int port = 0;
524
525 for(s = buf; *s && isBlank(*s); s++) /* Skip blanks */
526 ;
527 if ( *s == EOS ) /* No specification: repeat */
528 { if ( !LD->trace.find || !LD->trace.find->port )
529 { Sfprintf(Sdout, "[No previous search]\n");
530 fail;
531 }
532 LD->trace.find->searching = TRUE;
533 succeed;
534 }
535 for( ; *s && !isBlank(*s); s++ ) /* Parse the port specification */
536 { switch( *s )
537 { case 'c': port |= CALL_PORT; continue;
538 case 'e': port |= EXIT_PORT; continue;
539 case 'r': port |= REDO_PORT; continue;
540 case 'f': port |= FAIL_PORT; continue;
541 case 'u': port |= UNIFY_PORT; continue;
542 case 'a': port |= CALL_PORT|REDO_PORT|FAIL_PORT|EXIT_PORT|UNIFY_PORT;
543 continue;
544 default: Sfprintf(Sdout, "[Illegal port specification]\n");
545 fail;
546 }
547 }
548 for( ; *s && isBlank(*s); s++) /* Skip blanks */
549 ;
550
551 if ( *s == EOS ) /* Nothing is a variable */
552 { s = buf;
553 buf[0] = '_',
554 buf[1] = EOS;
555 }
556
557 { fid_t cid = PL_open_foreign_frame();
558 term_t t = PL_new_term_ref();
559 FindData find;
560
561 if ( !(find = LD->trace.find) )
562 find = LD->trace.find = allocHeapOrHalt(sizeof(find_data));
563
564 if ( !PL_chars_to_term(s, t) )
565 { PL_discard_foreign_frame(cid);
566 fail;
567 }
568
569 if ( find->type == TRACE_FIND_TERM && find->goal.term.term )
570 freeRecord(find->goal.term.term);
571
572 if ( PL_is_variable(t) )
573 { find->type = TRACE_FIND_ANY;
574 } else if ( PL_get_atom(t, &find->goal.name) )
575 { find->type = TRACE_FIND_NAME;
576 } else if ( PL_get_functor(t, &find->goal.term.functor) )
577 { if ( (find->goal.term.term = compileTermToHeap(t, 0)) )
578 { find->type = TRACE_FIND_TERM;
579 } else
580 { Sfprintf(Sdout, "ERROR: no memory to safe find target\n");
581 fail;
582 }
583 } else
584 { Sfprintf(Sdout, "[Illegal goal specification]\n");
585 fail;
586 }
587
588 find->port = port;
589 find->searching = TRUE;
590
591 DEBUG(2,
592 Sdprintf("setup ok, port = 0x%x, goal = ", port);
593 PL_write_term(Serror, t, 1200, 0);
594 Sdprintf("\n") );
595
596 PL_discard_foreign_frame(cid);
597 }
598
599 succeed;
600 }
601
602
603 static void
setPrintOptions(word t)604 setPrintOptions(word t)
605 { GET_LD
606 fid_t fid;
607
608 if ( (fid=PL_open_foreign_frame()) )
609 { term_t av = PL_new_term_ref();
610 predicate_t pred = PL_predicate("$set_debugger_write_options", 1,
611 "system");
612
613 _PL_put_atomic(av, t);
614 PL_call_predicate(NULL, PL_Q_NODEBUG, pred, av);
615
616 PL_discard_foreign_frame(fid);
617 }
618 }
619
620
621 static int
traceAction(char * cmd,int port,LocalFrame frame,Choice bfr,bool interactive)622 traceAction(char *cmd, int port, LocalFrame frame, Choice bfr,
623 bool interactive)
624 { GET_LD
625 int num_arg; /* numeric argument */
626 char *s;
627
628 #define FeedBack(msg) { if (interactive) { if (cmd[1] != EOS) \
629 Sfprintf(Sdout, "\n"); \
630 else \
631 Sfprintf(Sdout, "%s", msg); } }
632 #define Warn(msg) { if (interactive) \
633 Sfprintf(Sdout, "%s", msg); \
634 else \
635 warning(msg); \
636 }
637 #define Default (-1)
638
639 for(s=cmd; *s && isBlank(*s); s++)
640 ;
641 if ( isDigit(*s) )
642 { num_arg = strtol(s, &s, 10);
643
644 while(isBlank(*s))
645 s++;
646 } else
647 num_arg = Default;
648
649 switch( *s )
650 { case 'a': FeedBack("abort\n");
651 return ACTION_ABORT;
652 case 'b': FeedBack("break\n");
653 pl_break();
654 return ACTION_AGAIN;
655 case '/': FeedBack("/");
656 Sflush(Sdout);
657 if ( setupFind(&s[1]) )
658 { clear(frame, FR_SKIPPED);
659 return ACTION_CONTINUE;
660 }
661 return ACTION_AGAIN;
662 case '.': if ( LD->trace.find &&
663 LD->trace.find->type != TRACE_FIND_NONE )
664 { FeedBack("repeat search\n");
665 LD->trace.find->searching = TRUE;
666 clear(frame, FR_SKIPPED);
667 return ACTION_CONTINUE;
668 } else
669 { Warn("No previous search\n");
670 }
671 return ACTION_AGAIN;
672 case EOS:
673 case ' ':
674 case '\n':
675 case '\r':
676 case 'c': FeedBack("creep\n");
677 if ( !(port & EXIT_PORT) )
678 clear(frame, FR_SKIPPED);
679 return ACTION_CONTINUE;
680 case '\04': FeedBack("EOF: ");
681 case 'e': return exitFromDebugger("", 4);
682 case 'f': FeedBack("fail\n");
683 return ACTION_FAIL;
684 case 'i': if (port & (CALL_PORT|REDO_PORT|FAIL_PORT))
685 { FeedBack("ignore\n");
686 return ACTION_IGNORE;
687 } else
688 Warn("Can't ignore goal at this port\n");
689 return ACTION_CONTINUE;
690 case 'r': if (port & (REDO_PORT|FAIL_PORT|EXIT_PORT|EXCEPTION_PORT))
691 { FeedBack("retry\n[retry]\n");
692 debugstatus.retryFrame = consTermRef(frame);
693 return ACTION_RETRY;
694 } else
695 Warn("Can't retry at this port\n");
696 return ACTION_CONTINUE;
697 case 's': if (port & (CALL_PORT|REDO_PORT))
698 { FeedBack("skip\n");
699 set(frame, FR_SKIPPED);
700 debugstatus.skiplevel = levelFrame(frame);
701 } else
702 { FeedBack("creep\n");
703 }
704 return ACTION_CONTINUE;
705 case 'u': FeedBack("up\n");
706 debugstatus.skiplevel = levelFrame(frame) - 1;
707 return ACTION_CONTINUE;
708 case 'd': FeedBack("depth\n");
709 setPrintOptions(consInt(num_arg));
710 return ACTION_AGAIN;
711 case 'w': FeedBack("write\n");
712 setPrintOptions(ATOM_write);
713 return ACTION_AGAIN;
714 case 'p': FeedBack("print\n");
715 setPrintOptions(ATOM_print);
716 return ACTION_AGAIN;
717 case 'l': FeedBack("leap\n");
718 tracemode(FALSE, NULL);
719 return ACTION_CONTINUE;
720 case 'n': FeedBack("no debug\n");
721 tracemode(FALSE, NULL);
722 debugmode(DBG_OFF, NULL);
723 return ACTION_CONTINUE;
724 case 'g': FeedBack("goals\n");
725 PL_backtrace(num_arg == Default ? 5 : num_arg, PL_BT_USER);
726 return ACTION_AGAIN;
727 case 'A': FeedBack("alternatives\n");
728 alternatives(bfr);
729 return ACTION_AGAIN;
730 case 'C': debugstatus.showContext = 1 - debugstatus.showContext;
731 if ( debugstatus.showContext == TRUE )
732 { FeedBack("Show context\n");
733 } else
734 { FeedBack("No show context\n");
735 }
736 return ACTION_AGAIN;
737 case 'm': FeedBack("Exception details");
738 if ( port & EXCEPTION_PORT )
739 { exceptionDetails();
740 } else
741 Warn("No exception\n");
742 return ACTION_AGAIN;
743 case 'L': FeedBack("Listing");
744 listGoal(frame);
745 return ACTION_AGAIN;
746 case '+': FeedBack("spy\n");
747 set(frame->predicate, SPY_ME);
748 return ACTION_AGAIN;
749 case '-': FeedBack("no spy\n");
750 clear(frame->predicate, SPY_ME);
751 return ACTION_AGAIN;
752 case '?':
753 case 'h': helpTrace();
754 return ACTION_AGAIN;
755 case 'D': GD->debug_level = num_arg;
756 FeedBack("Debug level\n");
757 return ACTION_AGAIN;
758 default: Warn("Unknown option (h for help)\n");
759 return ACTION_AGAIN;
760 }
761 }
762
763 static void
helpTrace(void)764 helpTrace(void)
765 { GET_LD
766
767 Sfprintf(Sdout,
768 "Options:\n"
769 "+: spy -: no spy\n"
770 "/c|e|r|f|u|a goal: find .: repeat find\n"
771 "a: abort A: alternatives\n"
772 "b: break c (ret, space): creep\n"
773 "[depth] d: depth e: exit\n"
774 "f: fail [ndepth] g: goals (backtrace)\n"
775 "h (?): help i: ignore\n"
776 "l: leap L: listing\n"
777 "n: no debug p: print\n"
778 "r: retry s: skip\n"
779 "u: up w: write\n"
780 "m: exception details\n"
781 "C: toggle show context\n"
782 #if O_DEBUG
783 "[level] D: set system debug level\n"
784 #endif
785 "");
786 }
787
788
789 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
790 Write goal of stack frame. First a term representing the goal of the
791 frame is constructed. Trail and global stack are marked and undone to
792 avoid garbage on the global stack.
793
794 Trick, trick, O big trick ... In order to print the goal we create a
795 term for it (otherwise we would have to write a special version of
796 write/1, etc. for stack frames). A small problem arises: if the frame
797 holds a variable we will make a reference to the new term, thus printing
798 the wrong variable: variables sharing in a clause does not seem to share
799 any longer in the tracer (Anjo Anjewierden discovered this ackward
800 feature of the tracer). The solution is simple: we make the reference
801 pointer the other way around. Normally references should never go from
802 the global to the local stack as the local stack frame might cease to
803 exists before the global frame. In this case this does not matter as
804 the local stack frame definitely survives the tracer (measuring does not
805 always mean influencing in computer science :-).
806
807 Unfortunately the garbage collector doesn't like this. It violates the
808 assumptions in offset_cell() where a local stack reference has
809 TAG_REFERENCE and storage STG_LOCAL. It also violates assumptions made
810 in mark_variable(). Hence we can only play this trick if GC is blocked
811 and the data is destroyed using PL_discard_foreign_frame().
812
813 For the above reason, the code below uses low-level manipulation rather
814 than normal unification, etc.
815 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
816
817 static int
put_frame_goal(term_t goal,LocalFrame frame)818 put_frame_goal(term_t goal, LocalFrame frame)
819 { GET_LD
820 Definition def = frame->predicate;
821 int argc = def->functor->arity;
822 Word argv = argFrameP(frame, 0);
823
824 if ( !PL_unify_functor(goal, def->functor->functor) )
825 return FALSE;
826
827 if ( argc > 0 )
828 { Word argp = valTermRef(goal);
829 int i;
830
831 deRef(argp);
832 argp = argTermP(*argp, 0);
833
834 for(i=0; i<argc; i++)
835 { Word a;
836
837 deRef2(argv+i, a);
838 *argp++ = (needsRef(*a) ? makeRef(a) : *a);
839 }
840 }
841
842 if ( def->module != MODULE_user &&
843 (false(def->module, M_SYSTEM) || SYSTEM_MODE))
844 { term_t a;
845
846 if ( !(a=PL_new_term_ref()) )
847 return FALSE;
848
849 PL_put_atom(a, def->module->name);
850 return PL_cons_functor(goal, FUNCTOR_colon2, a, goal);
851 }
852
853 return TRUE;
854 }
855
856
857 typedef struct
858 { unsigned int flags; /* flag mask */
859 atom_t name; /* name */
860 } portname;
861
862 static const portname portnames[] =
863 { { WFG_BACKTRACE, ATOM_backtrace },
864 { WFG_CHOICE, ATOM_choice },
865 { CALL_PORT, ATOM_call },
866 { EXIT_PORT, ATOM_exit },
867 { FAIL_PORT, ATOM_fail },
868 { REDO_PORT, ATOM_redo },
869 { UNIFY_PORT, ATOM_unify },
870 { CUT_CALL_PORT, ATOM_cut_call },
871 { CUT_EXIT_PORT, ATOM_cut_exit },
872 { EXCEPTION_PORT, ATOM_exception },
873 { 0, NULL_ATOM }
874 };
875
876
877 static int
writeFrameGoal(IOSTREAM * out,LocalFrame frame,Code PC,unsigned int flags)878 writeFrameGoal(IOSTREAM *out, LocalFrame frame, Code PC, unsigned int flags)
879 { GET_LD
880 wakeup_state wstate;
881 Definition def = frame->predicate;
882 int rc = TRUE;
883
884 if ( !saveWakeup(&wstate, TRUE PASS_LD) )
885 { rc = FALSE;
886 goto out;
887 }
888
889 if ( gc_status.active )
890 { Sfprintf(out, " (%d): %s\n",
891 levelFrame(frame), predicateName(frame->predicate));
892 } else if ( !GD->bootsession && GD->initialised && GD->debug_level == 0 )
893 { term_t fr = PL_new_term_ref();
894 term_t port = PL_new_term_ref();
895 term_t pc = PL_new_term_ref();
896 const portname *pn = portnames;
897
898 if ( true(def, P_FOREIGN) )
899 PL_put_atom(pc, ATOM_foreign);
900 else if ( PC && frame->clause )
901 rc = PL_put_intptr(pc, PC-frame->clause->value.clause->codes);
902 else
903 PL_put_nil(pc);
904
905 if ( rc )
906 PL_put_frame(fr, frame);
907
908 if ( rc )
909 { for(; pn->flags; pn++)
910 { if ( flags & pn->flags )
911 { PL_put_atom(port, pn->name);
912 break;
913 }
914 }
915 }
916
917 if ( rc )
918 { IOSTREAM *old = Suser_error;
919 Suser_error = out;
920 rc = printMessage(ATOM_debug,
921 PL_FUNCTOR, FUNCTOR_frame3,
922 PL_TERM, fr,
923 PL_TERM, port,
924 PL_TERM, pc);
925 Suser_error = old;
926 }
927 } else
928 { debug_type debugSave = debugstatus.debugging;
929 term_t goal = PL_new_term_ref();
930 term_t options = PL_new_term_ref();
931 term_t tmp = PL_new_term_ref();
932 char msg[3];
933 const char *pp = portPrompt(flags&PORT_MASK);
934 struct foreign_context ctx;
935
936 put_frame_goal(goal, frame);
937 debugstatus.debugging = DBG_OFF;
938 PL_put_atom(tmp, ATOM_debugger_write_options);
939 ctx.context = 0;
940 ctx.control = FRG_FIRST_CALL;
941 ctx.engine = LD;
942 if ( !pl_prolog_flag(tmp, options, &ctx) )
943 PL_put_nil(options);
944 PL_unify_stream_or_alias(tmp, out);
945
946 msg[0] = true(def, P_TRANSPARENT) ? '^' : ' ';
947 msg[1] = true(def, SPY_ME) ? '*' : ' ';
948 msg[2] = EOS;
949
950 Sfprintf(out, "%s%s(%d) ", msg, pp, levelFrame(frame));
951 if ( debugstatus.showContext )
952 Sfprintf(out, "[%s] ", stringAtom(contextModule(frame)->name));
953 #ifdef O_LIMIT_DEPTH
954 if ( levelFrame(frame) > depth_limit )
955 Sfprintf(out, "[depth-limit exceeded] ");
956 #endif
957
958 pl_write_term3(tmp, goal, options);
959 if ( flags & (WFG_BACKTRACE|WFG_CHOICE) )
960 Sfprintf(out, "\n");
961
962 debugstatus.debugging = debugSave;
963 }
964
965 out:
966 restoreWakeup(&wstate PASS_LD);
967 return rc;
968 }
969
970 /* Write those frames on the stack that have alternatives left.
971
972 ** Tue May 10 23:23:11 1988 jan@swivax.UUCP (Jan Wielemaker) */
973
974 static void
alternatives(Choice ch)975 alternatives(Choice ch)
976 { GET_LD
977
978 for(; ch; ch = ch->parent)
979 { if ( ch->type == CHP_DEBUG )
980 continue;
981 if ( (isDebugFrame(ch->frame) || SYSTEM_MODE) )
982 writeFrameGoal(Suser_error, ch->frame, NULL, WFG_CHOICE);
983 }
984 }
985
986
987 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
988 messageToString() is a wrapper around $messages:message_to_string/2,
989 translating a message-term as used for exceptions into a C-string.
990 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
991
992 static char *
messageToString(term_t msg)993 messageToString(term_t msg)
994 { GET_LD
995 fid_t fid;
996
997 if ( (fid=PL_open_foreign_frame()) )
998 { term_t av = PL_new_term_refs(2);
999 predicate_t pred = PL_predicate("message_to_string", 2, "$messages");
1000 int rc;
1001 char *s;
1002
1003 PL_put_term(av+0, msg);
1004 rc = (PL_call_predicate(MODULE_system, PL_Q_NODEBUG, pred, av) &&
1005 PL_get_chars(av+1, &s, CVT_ALL|BUF_STACK));
1006 PL_discard_foreign_frame(fid);
1007
1008 return rc ? s : (char*)NULL;
1009 }
1010
1011 return NULL;
1012 }
1013
1014
1015 static int
exceptionDetails()1016 exceptionDetails()
1017 { GET_LD
1018 term_t except = LD->exception.pending;
1019 fid_t cid;
1020
1021 if ( (cid = PL_open_foreign_frame()) )
1022 { int rc;
1023
1024 Sflush(Suser_output); /* make sure to stay in sync */
1025 Sfprintf(Sdout, "\n\tException term: ");
1026 rc = PL_write_term(Sdout, except, 1200, PL_WRT_QUOTED);
1027 Sfprintf(Sdout, "\n\t Message: %s\n", messageToString(except));
1028
1029 PL_discard_foreign_frame(cid);
1030 return rc;
1031 }
1032
1033 return FALSE;
1034 }
1035
1036
1037 static int
listGoal(LocalFrame frame)1038 listGoal(LocalFrame frame)
1039 { GET_LD
1040 fid_t cid;
1041
1042 if ( (cid=PL_open_foreign_frame()) )
1043 { term_t goal = PL_new_term_ref();
1044 predicate_t pred = PL_predicate("$prolog_list_goal", 1, "system");
1045 IOSTREAM *old = Scurout;
1046 int rc;
1047
1048 Scurout = Sdout;
1049 put_frame_goal(goal, frame);
1050 rc = PL_call_predicate(MODULE_system, PL_Q_NODEBUG, pred, goal);
1051 Scurout = old;
1052
1053 PL_discard_foreign_frame(cid);
1054 return rc;
1055 }
1056
1057 return FALSE;
1058 }
1059
1060
1061 static void
writeContextFrame(IOSTREAM * out,pl_context_t * ctx,int flags)1062 writeContextFrame(IOSTREAM *out, pl_context_t *ctx, int flags)
1063 { if ( (flags&PL_BT_SAFE) )
1064 { char buf[256];
1065
1066 PL_describe_context(ctx, buf, sizeof(buf));
1067 Sfprintf(out, " %s\n", buf);
1068 } else
1069 { writeFrameGoal(out, ctx->fr, ctx->pc, WFG_BACKTRACE);
1070 }
1071 }
1072
1073
1074 static void
_PL_backtrace(IOSTREAM * out,int depth,int flags)1075 _PL_backtrace(IOSTREAM *out, int depth, int flags)
1076 { pl_context_t ctx;
1077
1078 if ( PL_get_context(&ctx, 0) )
1079 { GET_LD
1080 Definition def = NULL;
1081 int same_proc = 0;
1082 pl_context_t rctx; /* recursive context */
1083
1084 if ( gc_status.active )
1085 { flags |= PL_BT_SAFE;
1086 flags &= ~PL_BT_USER;
1087 }
1088 if ( SYSTEM_MODE )
1089 flags &= ~PL_BT_USER;
1090
1091 for(; depth > 0; PL_step_context(&ctx))
1092 { LocalFrame frame;
1093
1094 if ( !(frame=ctx.fr) )
1095 return;
1096
1097 if ( frame->predicate == def )
1098 { if ( ++same_proc >= 10 )
1099 { if ( same_proc == 10 )
1100 Sfprintf(out, " ...\n ...\n", Sdout);
1101 rctx = ctx;
1102 continue;
1103 }
1104 } else
1105 { if ( same_proc >= 10 )
1106 { if ( isDebugFrame(rctx.fr) || !(flags&PL_BT_USER) )
1107 { writeContextFrame(out, &rctx, flags);
1108 depth--;
1109 }
1110 same_proc = 0;
1111 }
1112 def = frame->predicate;
1113 }
1114
1115 if ( isDebugFrame(frame) || !(flags&PL_BT_USER) )
1116 { writeContextFrame(out, &ctx, flags);
1117 depth--;
1118 }
1119 }
1120 } else
1121 { Sfprintf(out, "No stack??\n");
1122 }
1123 }
1124
1125
1126 void
PL_backtrace(int depth,int flags)1127 PL_backtrace(int depth, int flags)
1128 { GET_LD
1129
1130 _PL_backtrace(Suser_error, depth, flags);
1131 }
1132
1133
1134 char *
PL_backtrace_string(int depth,int flags)1135 PL_backtrace_string(int depth, int flags)
1136 { char *data = NULL;
1137 size_t len = 0;
1138 IOSTREAM *out;
1139
1140 if ( (out=Sopenmem(&data, &len, "w")) )
1141 { out->encoding = ENC_UTF8;
1142 out->newline = SIO_NL_POSIX;
1143
1144 _PL_backtrace(out, depth, flags);
1145 Sclose(out);
1146
1147 return data;
1148 }
1149
1150 return NULL;
1151 }
1152
1153
1154 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1155 Trace interception mechanism. Whenever the tracer wants to perform some
1156 action it will first call the users' Prolog predicate
1157 prolog_trace_interception/4, allowing the user to define his/her action.
1158 If this procedure succeeds the tracer assumes the trace action has been
1159 done and returns, otherwise the default C-defined trace actions are
1160 performed.
1161
1162 This predicate is supposed to return one of the following atoms:
1163
1164 continue simply continue (creep)
1165 fail fail this goal
1166 retry retry this goal
1167 ignore pretend this call succeeded
1168 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1169
1170 static int
traceInterception(LocalFrame frame,Choice bfr,int port,Code PC)1171 traceInterception(LocalFrame frame, Choice bfr, int port, Code PC)
1172 { GET_LD
1173 int rval = -1; /* Default C-action */
1174 predicate_t proc;
1175 term_t ex;
1176
1177 proc = _PL_predicate("prolog_trace_interception", 4, "user",
1178 &GD->procedures.prolog_trace_interception4);
1179 if ( !getProcDefinition(proc)->impl.any.defined )
1180 return rval;
1181
1182 if ( !GD->bootsession && GD->debug_level == 0 )
1183 { fid_t cid=0;
1184 qid_t qid=0;
1185 LocalFrame fr = NULL;
1186 term_t frameref, chref, frref, pcref;
1187 term_t argv, rarg;
1188 atom_t portname = NULL_ATOM;
1189 functor_t portfunc = 0;
1190 int nodebug = FALSE;
1191
1192 SAVE_PTRS();
1193 if ( !(cid=PL_open_foreign_frame()) )
1194 goto out;
1195 argv = PL_new_term_refs(4);
1196 rarg = argv+3;
1197
1198 switch(port)
1199 { case CALL_PORT: portname = ATOM_call; break;
1200 case REDO_PORT: portfunc = FUNCTOR_redo1; break;
1201 case EXIT_PORT: portname = ATOM_exit; break;
1202 case FAIL_PORT: portname = ATOM_fail; break;
1203 case UNIFY_PORT: portname = ATOM_unify; break;
1204 case EXCEPTION_PORT:
1205 if ( !PL_unify_term(argv,
1206 PL_FUNCTOR, FUNCTOR_exception1,
1207 PL_TERM, LD->exception.pending) )
1208 goto out;
1209 break;
1210 case CUT_CALL_PORT: portfunc = FUNCTOR_cut_call1; break;
1211 case CUT_EXIT_PORT: portfunc = FUNCTOR_cut_exit1; break;
1212 default:
1213 assert(0);
1214 goto out;
1215 }
1216 RESTORE_PTRS();
1217
1218 if ( portname )
1219 { PL_put_atom(argv, portname);
1220 } else if ( portfunc )
1221 { int pcn;
1222
1223 if ( PC && false(frame->predicate, P_FOREIGN) && frame->clause )
1224 pcn = (int)(PC - frame->clause->value.clause->codes);
1225 else
1226 pcn = 0;
1227
1228 if ( !PL_unify_term(argv,
1229 PL_FUNCTOR, portfunc,
1230 PL_INT, pcn) )
1231 goto out;
1232 }
1233
1234 RESTORE_PTRS();
1235 PL_put_frame(argv+1, frame);
1236 PL_put_choice(argv+2, bfr);
1237 if ( !(qid = PL_open_query(MODULE_user, PL_Q_NODEBUG|PL_Q_CATCH_EXCEPTION, proc, argv)) )
1238 goto out;
1239 if ( PL_next_solution(qid) )
1240 { atom_t a;
1241
1242 RESTORE_PTRS();
1243
1244 if ( PL_get_atom(rarg, &a) )
1245 { if ( a == ATOM_continue )
1246 { if ( !(port & EXIT_PORT) )
1247 clear(frame, FR_SKIPPED);
1248 rval = ACTION_CONTINUE;
1249 } else if ( a == ATOM_nodebug )
1250 { rval = ACTION_CONTINUE;
1251 nodebug = TRUE;
1252 } else if ( a == ATOM_fail )
1253 { rval = ACTION_FAIL;
1254 } else if ( a == ATOM_skip )
1255 { if ( (port & (CALL_PORT|REDO_PORT)) )
1256 { debugstatus.skiplevel = levelFrame(frame);
1257 set(frame, FR_SKIPPED);
1258 }
1259 rval = ACTION_CONTINUE;
1260 } else if ( a == ATOM_up )
1261 { debugstatus.skiplevel = levelFrame(frame) - 1;
1262 rval = ACTION_CONTINUE;
1263 } else if ( a == ATOM_retry )
1264 { debugstatus.retryFrame = consTermRef(frame);
1265 rval = ACTION_RETRY;
1266 } else if ( a == ATOM_ignore )
1267 { rval = ACTION_IGNORE;
1268 } else if ( a == ATOM_abort )
1269 { rval = ACTION_ABORT;
1270 } else
1271 PL_warning("Unknown trace action: %s", stringAtom(a));
1272 } else if ( PL_is_functor(rarg, FUNCTOR_retry1) )
1273 { LocalFrame fr;
1274 term_t arg = PL_new_term_ref();
1275
1276 if ( PL_get_arg(1, rarg, arg) && PL_get_frame(arg, &fr) )
1277 { debugstatus.retryFrame = consTermRef(fr);
1278 rval = ACTION_RETRY;
1279 } else
1280 PL_warning("prolog_trace_interception/4: bad argument to retry/1");
1281 }
1282 } else if ( (ex=PL_exception(qid)) )
1283 { if ( classify_exception(ex) == EXCEPT_ABORT )
1284 { rval = ACTION_ABORT;
1285 } else
1286 { if ( printMessage(ATOM_error, PL_TERM, ex) )
1287 { nodebug = TRUE;
1288 rval = ACTION_CONTINUE;
1289 } else if ( classify_exception(exception_term) >= EXCEPT_TIMEOUT )
1290 { PL_clear_exception();
1291 rval = ACTION_ABORT;
1292 } else
1293 { PL_clear_exception();
1294 nodebug = TRUE;
1295 rval = ACTION_CONTINUE;
1296 }
1297 }
1298 }
1299
1300 out:
1301 if ( qid ) PL_close_query(qid);
1302 if ( cid ) PL_discard_foreign_frame(cid);
1303
1304 if ( nodebug )
1305 { tracemode(FALSE, NULL);
1306 debugmode(DBG_OFF, NULL);
1307 }
1308 }
1309
1310 return rval;
1311 }
1312
1313
1314 /*******************************
1315 * SAFE STACK TRACE *
1316 *******************************/
1317
1318 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1319 PL_get_context(pl_context_t *ctx, int tid)
1320 PL_step_context(pl_context_t *ctx)
1321 PL_describe_context(pl_context_t *ctx, char *buf, size_t len)
1322
1323 These functions provide a public API to obtain a trace of the Prolog
1324 stack in a fairly safe manner.
1325
1326 static void
1327 dump_stack(void)
1328 { pl_context_t ctx;
1329
1330 if ( PL_get_context(&ctx, 0) )
1331 { int max = 5;
1332
1333 Sdprintf("Prolog stack:\n");
1334
1335 do
1336 { char buf[256];
1337
1338 PL_describe_context(&ctx, buf, sizeof(buf));
1339 Sdprintf(" %s\n", buf);
1340 } while ( max-- > 0 && PL_step_context(&ctx) );
1341 } else
1342 Sdprintf("No stack??\n");
1343 }
1344
1345 The second argument of PL_get_context() is a Prolog thread-id. Passing 0
1346 gets the context of the calling thread. The current implementation can
1347 only deal with extracting the stack for the calling thread, but the API
1348 is prepared to generalise this.
1349
1350 See also PL_backtrace() and os/pl-cstack.c.
1351 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1352
1353 int
PL_get_context(pl_context_t * c,int thread_id)1354 PL_get_context(pl_context_t *c, int thread_id)
1355 { GET_LD
1356 (void)thread_id;
1357
1358 if ( !HAS_LD )
1359 return FALSE;
1360
1361 c->ld = LD;
1362 c->qf = LD->query;
1363 if ( c->qf && c->qf->registers.fr )
1364 c->fr = c->qf->registers.fr;
1365 else
1366 c->fr = environment_frame;
1367 if ( c->qf && c->qf->registers.pc )
1368 c->pc = c->qf->registers.pc;
1369 else
1370 c->pc = NULL;
1371
1372 return TRUE;
1373 }
1374
1375
1376 int
PL_step_context(pl_context_t * c)1377 PL_step_context(pl_context_t *c)
1378 { if ( c->fr )
1379 { GET_LD
1380
1381 if ( !onStack(local, c->fr) )
1382 return FALSE;
1383
1384 if ( c->fr->parent )
1385 { c->pc = c->fr->programPointer;
1386 c->fr = c->fr->parent;
1387 } else
1388 { c->pc = NULL;
1389 c->qf = queryOfFrame(c->fr);
1390 c->fr = parentFrame(c->fr);
1391 }
1392 }
1393
1394 return c->fr ? TRUE : FALSE;
1395 }
1396
1397
1398 int
PL_describe_context(pl_context_t * c,char * buf,size_t len)1399 PL_describe_context(pl_context_t *c, char *buf, size_t len)
1400 { LocalFrame fr;
1401
1402 buf[0] = 0;
1403
1404 if ( (fr=c->fr) )
1405 { GET_LD
1406 long level;
1407 int printed;
1408
1409 if ( !onStack(local, fr) )
1410 return snprintf(buf, len, "<invalid frame reference %p>", fr);
1411
1412 level = levelFrame(fr);
1413 if ( !fr->predicate )
1414 return snprintf(buf, len, "[%ld] <no predicate>", level);
1415
1416 printed = snprintf(buf, len, "[%ld] %s ", level, predicateName(fr->predicate));
1417 len -= printed;
1418 buf += printed;
1419
1420 if ( c->pc >= fr->predicate->codes &&
1421 c->pc < &fr->predicate->codes[fr->predicate->codes[-1]] )
1422 { return printed+snprintf(buf, len, "[PC=%ld in supervisor]",
1423 (long)(c->pc - fr->predicate->codes));
1424 }
1425
1426 if ( false(fr->predicate, P_FOREIGN) )
1427 { int clause_no = 0;
1428 intptr_t pc = -1;
1429
1430 if ( fr->clause )
1431 { Clause cl = fr->clause->value.clause;
1432
1433 if ( c->pc >= cl->codes && c->pc < &cl->codes[cl->code_size] )
1434 pc = c->pc - cl->codes;
1435
1436 if ( fr->predicate == PROCEDURE_dc_call_prolog->definition )
1437 return printed+snprintf(buf, len, "[PC=%ld in top query clause]",
1438 (long)pc);
1439
1440 clause_no = clauseNo(cl, 0);
1441 return printed+snprintf(buf, len, "[PC=%ld in clause %d]",
1442 (long)pc,
1443 clause_no);
1444 }
1445 return printed+snprintf(buf, len, "<no clause>");
1446 } else
1447 { return printed+snprintf(buf, len, "<foreign>");
1448 }
1449 }
1450
1451 return 0;
1452 }
1453
1454
1455 #endif /*O_DEBUGGER*/
1456
1457 #ifndef offset
1458 #define offset(s, f) ((size_t)(&((struct s *)NULL)->f))
1459 #endif
1460
1461 static QueryFrame
findQuery(LocalFrame fr)1462 findQuery(LocalFrame fr)
1463 { while(fr && fr->parent)
1464 fr = fr->parent;
1465
1466 if ( fr )
1467 return queryOfFrame(fr);
1468 return NULL;
1469 }
1470
1471
1472 static bool
hasAlternativesFrame(LocalFrame frame)1473 hasAlternativesFrame(LocalFrame frame)
1474 { GET_LD
1475 QueryFrame qf;
1476 LocalFrame fr = environment_frame;
1477 Choice ch = LD->choicepoints;
1478
1479 for(;;)
1480 { for( ; ch; ch = ch->parent )
1481 { if ( (void *)ch < (void *)frame )
1482 return FALSE;
1483
1484 if ( ch->frame == frame )
1485 { switch( ch->type )
1486 { case CHP_CLAUSE:
1487 case CHP_JUMP:
1488 return TRUE;
1489 case CHP_TOP: /* no default to get warning */
1490 case CHP_CATCH:
1491 case CHP_DEBUG:
1492 continue;
1493 }
1494 }
1495 }
1496 if ( (qf = findQuery(fr)) )
1497 { fr = qf->saved_environment;
1498 ch = qf->saved_bfr;
1499 } else
1500 return FALSE;
1501 }
1502 }
1503
1504
1505 #ifdef O_DEBUG
1506 static intptr_t
loffset(void * p)1507 loffset(void *p)
1508 { GET_LD
1509 if ( p == NULL )
1510 return 0;
1511
1512 assert((intptr_t)p % sizeof(word) == 0);
1513 return (Word)p-(Word)lBase;
1514 }
1515
1516 extern char *chp_chars(Choice ch);
1517 #endif
1518
1519 static LocalFrame
alternativeFrame(LocalFrame frame)1520 alternativeFrame(LocalFrame frame)
1521 { GET_LD
1522 QueryFrame qf;
1523 LocalFrame fr = environment_frame;
1524 Choice ch = LD->choicepoints;
1525
1526 DEBUG(3, Sdprintf("Looking for choice of #%d\n", loffset(frame)));
1527
1528 for(;;)
1529 { for( ; ch; ch = ch->parent )
1530 { if ( (void *)ch < (void *)frame )
1531 return NULL;
1532
1533 if ( ch->frame == frame )
1534 { DEBUG(3, Sdprintf("First: %s\n", chp_chars(ch)));
1535
1536 for(ch = ch->parent; ch; ch = ch->parent )
1537 { if ( ch->frame == frame )
1538 { DEBUG(3, Sdprintf("\tSkipped: %s\n", chp_chars(ch)));
1539 continue;
1540 }
1541
1542 switch( ch->type )
1543 { case CHP_CLAUSE:
1544 case CHP_JUMP:
1545 DEBUG(3, Sdprintf("\tReturning: %s\n", chp_chars(ch)));
1546 return ch->frame;
1547 default:
1548 break;
1549 }
1550 }
1551
1552 return NULL;
1553 }
1554 }
1555
1556 if ( (qf = findQuery(fr)) )
1557 { fr = qf->saved_environment;
1558 ch = qf->saved_bfr;
1559 } else
1560 return NULL;
1561 }
1562 }
1563
1564
1565 void
resetTracer(void)1566 resetTracer(void)
1567 { GET_LD
1568
1569 debugstatus.tracing = FALSE;
1570 debugstatus.debugging = DBG_OFF;
1571 debugstatus.suspendTrace = 0;
1572 debugstatus.skiplevel = 0;
1573 debugstatus.retryFrame = 0;
1574
1575 setPrologFlagMask(PLFLAG_LASTCALL);
1576 }
1577
1578
1579 #ifdef O_INTERRUPT
1580
1581 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1582 Handling interrupts. We know we are not in critical code (see
1583 startCritical() and endCritical(), so the heap is consistent. The only
1584 problem can be that we are currently writing the arguments of the next
1585 goal above the local stack top pointer. To avoid problems we just
1586 increment the top pointer to point above the furthest argument.
1587 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1588
1589 static void
helpInterrupt(void)1590 helpInterrupt(void)
1591 { GET_LD
1592
1593 Sfprintf(Sdout,
1594 "Options:\n"
1595 "a: abort b: break\n"
1596 "c: continue e: exit\n"
1597 "g: goals s: C-backtrace\n"
1598 "t: trace p: Show PID\n"
1599 "h (?): help\n");
1600 }
1601
1602 static void
interruptHandler(int sig)1603 interruptHandler(int sig)
1604 { GET_LD
1605 int c;
1606 int safe;
1607 int first = TRUE;
1608
1609 if ( !GD->initialised )
1610 { Sfprintf(Serror, "Interrupt during startup. Cannot continue\n");
1611 PL_halt(1);
1612 }
1613
1614 #ifdef O_PLMT
1615 if ( !LD ) /* we can't handle this; main thread */
1616 { PL_thread_raise(1, sig); /* should try to do this */
1617 return;
1618 }
1619
1620 if ( LD->exit_requested )
1621 { term_t rval = PL_new_term_ref();
1622 PL_put_atom(rval, ATOM_true);
1623 pl_thread_exit(rval);
1624 assert(0); /* should not return */
1625 }
1626 #endif
1627
1628 #if __unix__ /* actually, asynchronous signal handling */
1629 if ( !LD->signal.is_sync )
1630 { if ( PL_pending(sig) )
1631 { PL_clearsig(sig);
1632 safe = FALSE;
1633 } else
1634 { DEBUG(1, Sdprintf("Reposting as synchronous\n"));
1635 PL_raise(sig);
1636 return;
1637 }
1638 } else
1639 #endif /* no async signals; always safe */
1640 { safe = TRUE;
1641 }
1642
1643 Sreset();
1644 again:
1645 if ( safe )
1646 { if ( !printMessage(ATOM_debug, PL_FUNCTOR, FUNCTOR_interrupt1,
1647 PL_ATOM, ATOM_begin) )
1648 PL_clear_exception();
1649 } else
1650 { if ( first )
1651 { first = FALSE;
1652 Sfprintf(Sdout,
1653 "\n"
1654 "WARNING: By typing Control-C twice, you have forced an asynchronous\n"
1655 "WARNING: interrupt. Your only SAFE operations are: c(ontinue), p(id),\n"
1656 "WARNING: s(stack) and e(xit). Notably a(abort) often works, but\n"
1657 "WARNING: leaves the system in an UNSTABLE state\n\n");
1658 }
1659 Sfprintf(Sdout, "Action (h for help) ? ");
1660 }
1661 ResetTty(); /* clear pending input -- atoenne -- */
1662 c = getSingleChar(Sdin, FALSE);
1663
1664 switch(c)
1665 { case 'a': Sfprintf(Sdout, "abort\n");
1666 action_a:
1667 unblockSignal(sig);
1668 abortProlog();
1669 if ( !safe )
1670 PL_rethrow();
1671 break;
1672 case 'b': Sfprintf(Sdout, "break\n");
1673 if ( safe )
1674 { unblockSignal(sig); /* into pl_break() itself */
1675 pl_break();
1676 } else
1677 { Sfprintf(Sdout, "Cannot break from forced interrupt\n");
1678 }
1679 goto again;
1680 case 'c': if ( safe )
1681 { if ( !printMessage(ATOM_debug,
1682 PL_FUNCTOR, FUNCTOR_interrupt1,
1683 PL_ATOM, ATOM_end) )
1684 PL_clear_exception();
1685 } else
1686 { Sfprintf(Sdout, "continue\n");
1687 }
1688 break;
1689 case 04:
1690 case EOF: Sfprintf(Sdout, "EOF: ");
1691 case 'e': if ( exitFromDebugger("", 4) == ACTION_ABORT )
1692 goto action_a;
1693 break;
1694 #ifdef O_DEBUGGER
1695 case 'g': Sfprintf(Sdout, "goals\n");
1696 PL_backtrace(5, PL_BT_USER);
1697 goto again;
1698 #endif /*O_DEBUGGER*/
1699 case 's': save_backtrace("INT");
1700 print_backtrace_named("INT");
1701 goto again;
1702 case 'p': Sfprintf(Sdout, "PID: %d\n", getpid());
1703 goto again;
1704 case 'h':
1705 case '?': helpInterrupt();
1706 goto again;
1707 #ifdef O_DEBUGGER
1708 case 't': if ( safe )
1709 { Sfprintf(Sdout, "trace\n");
1710 if ( !printMessage(ATOM_debug,
1711 PL_FUNCTOR, FUNCTOR_interrupt1,
1712 PL_ATOM, ATOM_trace) )
1713 PL_clear_exception();
1714 pl_trace();
1715 break;
1716 } else
1717 { Sfprintf(Sdout, "Cannot start tracer from forced interrupt\n");
1718 goto again;
1719 }
1720 #endif /*O_DEBUGGER*/
1721 default: Sfprintf(Sdout, "Unknown option (h for help)\n");
1722 goto again;
1723 }
1724 }
1725
1726 #endif /*O_INTERRUPT*/
1727
1728
1729 void
PL_interrupt(int sig)1730 PL_interrupt(int sig)
1731 {
1732 #ifdef O_INTERRUPT
1733 interruptHandler(sig);
1734 #endif
1735 }
1736
1737
1738 void
initTracer(void)1739 initTracer(void)
1740 { GET_LD
1741
1742 debugstatus.visible =
1743 debugstatus.leashing = CALL_PORT|FAIL_PORT|REDO_PORT|EXIT_PORT|
1744 EXCEPTION_PORT;
1745 debugstatus.showContext = FALSE;
1746
1747 #if defined(O_INTERRUPT) && defined(SIGINT)
1748 if ( truePrologFlag(PLFLAG_SIGNALS) )
1749 PL_signal(SIGINT, PL_interrupt);
1750 #endif
1751
1752 resetTracer();
1753 }
1754
1755 /********************************
1756 * PROLOG PREDICATES *
1757 *********************************/
1758
1759 #if O_DEBUGGER
1760
1761 void
suspendTrace(int suspend)1762 suspendTrace(int suspend)
1763 { GET_LD
1764
1765 if ( suspend )
1766 debugstatus.suspendTrace++;
1767 else
1768 debugstatus.suspendTrace--;
1769 }
1770
1771
1772 int
tracemode(int doit,int * old)1773 tracemode(int doit, int *old)
1774 { GET_LD
1775
1776 if ( doit )
1777 { debugmode(DBG_ON, NULL);
1778 doit = TRUE;
1779 }
1780
1781 if ( old )
1782 *old = debugstatus.tracing;
1783
1784 if ( debugstatus.tracing != doit )
1785 { debugstatus.tracing = doit;
1786 return printMessage(ATOM_silent,
1787 PL_FUNCTOR_CHARS, "trace_mode", 1,
1788 PL_ATOM, doit ? ATOM_on : ATOM_off);
1789 }
1790 if ( doit ) /* make sure trace works inside skip */
1791 { debugstatus.skiplevel = SKIP_VERY_DEEP;
1792 if ( LD->trace.find )
1793 LD->trace.find->searching = FALSE;
1794 }
1795
1796 succeed;
1797 }
1798
1799
1800 static int
have_space_for_debugging(void)1801 have_space_for_debugging(void)
1802 { GET_LD
1803
1804 return ( usedStack(local) +
1805 usedStack(global) +
1806 usedStack(trail) +
1807 100000*sizeof(void*) < LD->stacks.limit );
1808 }
1809
1810
1811 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1812 Enable the tracer if we have a safe amount of available space. This is
1813 used to start tracing uncaught overflow exceptions.
1814 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1815
1816 int
trace_if_space(void)1817 trace_if_space(void)
1818 { int trace;
1819
1820 if ( have_space_for_debugging() )
1821 { trace = TRUE;
1822 tracemode(trace, NULL);
1823
1824 } else
1825 trace = FALSE;
1826
1827 return trace;
1828 }
1829
1830
1831 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1832 enlargeMinFreeStacks() sets the minimum free space of all stacks a bit
1833 higher to accomodate debugging. This causes less GC calls and thus less
1834 cases where debugging is harmed due to <garbage_collected> atoms.
1835 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1836
1837 static int
enlargeMinFreeStacks(size_t l,size_t g,size_t t ARG_LD)1838 enlargeMinFreeStacks(size_t l, size_t g, size_t t ARG_LD)
1839 { if ( LD->stacks.local.min_free < l )
1840 LD->stacks.local.min_free = l;
1841 if ( LD->stacks.global.min_free < g )
1842 LD->stacks.global.min_free = g;
1843 if ( LD->stacks.trail.min_free < l )
1844 LD->stacks.trail.min_free = t;
1845
1846 return shiftTightStacks(); /* no GC: we want to keep variables! */
1847 }
1848
1849
1850
1851 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1852 debugmode(debug_type new, debug_type *old)
1853
1854 Set the current debug mode. If DBG_ALL, debugging in switched on in all
1855 queries. This behaviour is intended to allow using spy and debug from
1856 PceEmacs that runs its Prolog work in non-debug mode.
1857 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1858
1859 int
debugmode(debug_type doit,debug_type * old)1860 debugmode(debug_type doit, debug_type *old)
1861 { GET_LD
1862
1863 if ( old )
1864 *old = debugstatus.debugging;
1865
1866 if ( debugstatus.debugging != doit )
1867 { if ( doit )
1868 { if ( have_space_for_debugging() &&
1869 !enlargeMinFreeStacks(8*1024*SIZEOF_VOIDP,
1870 8*1024*SIZEOF_VOIDP,
1871 8*1024*SIZEOF_VOIDP
1872 PASS_LD) )
1873 return FALSE;
1874
1875 debugstatus.skiplevel = SKIP_VERY_DEEP;
1876 clearPrologFlagMask(PLFLAG_LASTCALL);
1877 if ( doit == DBG_ALL )
1878 { QueryFrame qf;
1879
1880 for(qf = LD->query; qf; qf = qf->parent)
1881 qf->debugSave = DBG_ON;
1882
1883 doit = DBG_ON;
1884 }
1885 } else
1886 { setPrologFlagMask(PLFLAG_LASTCALL);
1887 }
1888 debugstatus.debugging = doit;
1889 updateAlerted(LD);
1890 return printMessage(ATOM_silent,
1891 PL_FUNCTOR_CHARS, "debug_mode", 1,
1892 PL_ATOM, doit ? ATOM_on : ATOM_off);
1893 }
1894
1895 return TRUE;
1896 }
1897
1898 #else /*O_DEBUGGER*/
1899
1900 int
tracemode(int doit,int * old)1901 tracemode(int doit, int *old)
1902 { succeed;
1903 }
1904
1905 int
debugmode(debug_type doit,debug_type * old)1906 debugmode(debug_type doit, debug_type *old)
1907 { succeed;
1908 }
1909
1910 #endif
1911
1912 word
pl_trace()1913 pl_trace()
1914 { return tracemode(TRUE, NULL);
1915 }
1916
1917 word
pl_notrace()1918 pl_notrace()
1919 { return tracemode(FALSE, NULL);
1920 }
1921
1922 word
pl_tracing()1923 pl_tracing()
1924 { GET_LD
1925
1926 return debugstatus.tracing;
1927 }
1928
1929 static
1930 PRED_IMPL("prolog_skip_level", 2, prolog_skip_level, PL_FA_NOTRACE)
1931 { GET_LD
1932 term_t old = A1;
1933 term_t new = A2;
1934 atom_t a;
1935 size_t sl;
1936
1937 if ( debugstatus.skiplevel == SKIP_VERY_DEEP )
1938 { TRY(PL_unify_atom(old, ATOM_very_deep));
1939 } else if ( debugstatus.skiplevel == SKIP_REDO_IN_SKIP )
1940 { TRY(PL_unify_atom(old, ATOM_redo_in_skip));
1941 } else
1942 { TRY(PL_unify_integer(old, debugstatus.skiplevel));
1943 }
1944
1945 if ( PL_compare(A1, A2) == 0 )
1946 return TRUE;
1947
1948 if ( PL_get_atom(new, &a) )
1949 { if ( a == ATOM_very_deep )
1950 { debugstatus.skiplevel = SKIP_VERY_DEEP;
1951 succeed;
1952 } else if ( a == ATOM_redo_in_skip )
1953 { debugstatus.skiplevel = SKIP_REDO_IN_SKIP;
1954 succeed;
1955 }
1956 }
1957
1958 if ( PL_get_size_ex(new, &sl) )
1959 { debugstatus.skiplevel = sl;
1960 succeed;
1961 }
1962
1963 fail;
1964 }
1965
1966
1967 static
1968 PRED_IMPL("prolog_skip_frame", 1, prolog_skip_frame, PL_FA_NOTRACE)
1969 { PRED_LD
1970 LocalFrame fr;
1971
1972 if ( !PL_get_frame(A1, &fr) || !fr )
1973 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_frame_reference, A1);
1974
1975 debugstatus.skiplevel = levelFrame(fr);
1976 set(fr, FR_SKIPPED);
1977
1978 return TRUE;
1979 }
1980
1981
1982 word
pl_spy(term_t p)1983 pl_spy(term_t p)
1984 { GET_LD
1985 Procedure proc;
1986
1987 if ( get_procedure(p, &proc, 0, GP_FIND) )
1988 { Definition def = getProcDefinition(proc);
1989
1990 if ( false(def, SPY_ME) )
1991 { LOCKDEF(def);
1992 set(def, SPY_ME);
1993 UNLOCKDEF(def);
1994 if ( !printMessage(ATOM_informational,
1995 PL_FUNCTOR_CHARS, "spy", 1,
1996 PL_TERM, p) )
1997 return FALSE;
1998 }
1999 return debugmode(DBG_ALL, NULL);
2000 }
2001
2002 return FALSE;
2003 }
2004
2005 word
pl_nospy(term_t p)2006 pl_nospy(term_t p)
2007 { GET_LD
2008 Procedure proc;
2009
2010 if ( get_procedure(p, &proc, 0, GP_FIND|GP_EXISTENCE_ERROR) )
2011 { Definition def = getProcDefinition(proc);
2012
2013 if ( true(def, SPY_ME) )
2014 { LOCKDEF(def);
2015 clear(def, SPY_ME);
2016 UNLOCKDEF(def);
2017 return printMessage(ATOM_informational,
2018 PL_FUNCTOR_CHARS, "nospy", 1,
2019 PL_TERM, p);
2020 }
2021 return TRUE;
2022 }
2023
2024 return FALSE;
2025 }
2026
2027 word
pl_leash(term_t old,term_t new)2028 pl_leash(term_t old, term_t new)
2029 { GET_LD
2030 return setInteger(&debugstatus.leashing, old, new);
2031 }
2032
2033 word
pl_visible(term_t old,term_t new)2034 pl_visible(term_t old, term_t new)
2035 { GET_LD
2036 return setInteger(&debugstatus.visible, old, new);
2037 }
2038
2039
2040 word
pl_debuglevel(term_t old,term_t new)2041 pl_debuglevel(term_t old, term_t new)
2042 { return setInteger(&GD->debug_level, old, new);
2043 }
2044
2045
2046 word
pl_prolog_current_frame(term_t frame)2047 pl_prolog_current_frame(term_t frame)
2048 { GET_LD
2049 LocalFrame fr = environment_frame;
2050
2051 if ( fr->predicate->impl.foreign.function == pl_prolog_current_frame )
2052 fr = parentFrame(fr); /* thats me! */
2053
2054 return PL_unify_frame(frame, fr);
2055 }
2056
2057
2058 /** prolog_current_choice(-Choice) is semidet.
2059
2060 True when Choice refers to the most recent choice-point.
2061 */
2062
2063 static
2064 PRED_IMPL("prolog_current_choice", 1, prolog_current_choice, 0)
2065 { PRED_LD
2066 Choice ch = LD->choicepoints;
2067
2068 while(ch && ch->type == CHP_DEBUG)
2069 ch = ch->parent;
2070 if ( ch )
2071 return PL_unify_choice(A1, ch);
2072
2073 return FALSE;
2074 }
2075
2076
2077 static int
prolog_frame_attribute(term_t frame,term_t what,term_t value)2078 prolog_frame_attribute(term_t frame, term_t what, term_t value)
2079 { GET_LD
2080 LocalFrame fr;
2081 atom_t key;
2082 size_t arity;
2083 term_t result = PL_new_term_ref();
2084 Module m = NULL;
2085
2086 if ( !PL_get_frame(frame, &fr) )
2087 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_frame_reference, frame);
2088 if ( !fr )
2089 return FALSE; /* frame == 'none' */
2090 if ( !PL_get_name_arity(what, &key, &arity) )
2091 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_callable, what);
2092 if ( !PL_strip_module(value, &m, value) )
2093 return FALSE;
2094
2095 set(fr, FR_DEBUG); /* explicit call to do this? */
2096
2097 if ( key == ATOM_argument && arity == 1 )
2098 { term_t arg = PL_new_term_ref();
2099 size_t argn;
2100
2101 if ( !PL_get_arg_ex(1, what, arg) || !PL_get_size_ex(arg, &argn) )
2102 fail;
2103 if ( argn < 1 )
2104 return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_natural, arg);
2105
2106 if ( true(fr->predicate, P_FOREIGN) || !fr->clause )
2107 { if ( argn > fr->predicate->functor->arity )
2108 fail;
2109 } else
2110 { if ( argn > fr->clause->value.clause->prolog_vars )
2111 fail;
2112 }
2113
2114 #ifdef O_DEBUGLOCAL /* see pl-wam.c */
2115 assert( *argFrameP(fr, argn-1) != (word)(((char*)ATOM_nil) + 1) );
2116 checkData(argFrameP(fr, argn-1));
2117 #endif
2118
2119 if ( !hasGlobalSpace(0) )
2120 { int rc;
2121
2122 if ( (rc=ensureGlobalSpace(0, ALLOW_GC)) != TRUE )
2123 return raiseStackOverflow(rc);
2124 PL_get_frame(frame, &fr);
2125 }
2126
2127 return PL_unify(value, consTermRef(argFrameP(fr, argn-1)));
2128 }
2129
2130 if ( !(arity == 0 || (arity == 1 && key == ATOM_parent_goal)) )
2131 { unknown_key:
2132 return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_frame_attribute, what);
2133 }
2134
2135 if ( key == ATOM_level)
2136 { PL_put_integer(result, levelFrame(fr));
2137 } else if (key == ATOM_has_alternatives)
2138 { PL_put_atom(result, hasAlternativesFrame(fr) ? ATOM_true : ATOM_false);
2139 } else if (key == ATOM_skipped)
2140 { PL_put_atom(result, true(fr, FR_SKIPPED) ? ATOM_true : ATOM_false);
2141 } else if (key == ATOM_alternative)
2142 { LocalFrame alt;
2143
2144 if ( (alt = alternativeFrame(fr)) )
2145 PL_put_frame(result, alt);
2146 else
2147 fail;
2148 } else if (key == ATOM_parent)
2149 { LocalFrame parent;
2150
2151 if ( fr->parent )
2152 clearUninitialisedVarsFrame(fr->parent, fr->programPointer);
2153
2154 if ( (parent = parentFrame(fr)) )
2155 PL_put_frame(result, parent);
2156 else
2157 fail;
2158 } else if (key == ATOM_top)
2159 { PL_put_atom(result, fr->parent ? ATOM_false : ATOM_true);
2160 } else if (key == ATOM_context_module)
2161 { PL_put_atom(result, contextModule(fr)->name);
2162 } else if (key == ATOM_clause)
2163 { if ( false(fr->predicate, P_FOREIGN) &&
2164 fr->clause && fr->clause->value.clause &&
2165 fr->predicate != PROCEDURE_dc_call_prolog->definition &&
2166 fr->predicate != PROCEDURE_dcall1->definition )
2167 { if ( !PL_unify_clref(result, fr->clause->value.clause) )
2168 return FALSE;
2169 } else
2170 { return FALSE;
2171 }
2172 } else if (key == ATOM_goal)
2173 { int arity, n;
2174 term_t arg = PL_new_term_ref();
2175 Definition def = fr->predicate;
2176
2177 if ( def->module != m )
2178 { if ( !PL_put_functor(result, FUNCTOR_colon2) )
2179 return FALSE;
2180 _PL_get_arg(1, result, arg);
2181 if ( !PL_unify_atom(arg, def->module->name) )
2182 return FALSE;
2183 _PL_get_arg(2, result, arg);
2184 } else
2185 PL_put_term(arg, result);
2186
2187 if ((arity = def->functor->arity) == 0)
2188 { PL_unify_atom(arg, def->functor->name);
2189 } else /* see put_frame_goal(); must be merged */
2190 { Word argv;
2191 Word argp;
2192
2193 if ( !PL_unify_functor(arg, def->functor->functor) )
2194 return FALSE;
2195 if ( tTop+arity > tMax )
2196 { int rc;
2197
2198 if ( (rc=ensureTrailSpace(arity)) != TRUE )
2199 return raiseStackOverflow(rc);
2200 }
2201
2202 PL_get_frame(frame, &fr); /* can be shifted */
2203 argv = argFrameP(fr, 0);
2204 argp = valTermRef(arg);
2205 deRef(argp);
2206 argp = argTermP(*argp, 0);
2207
2208 for(n=0; n < arity; n++, argp++)
2209 { Word a;
2210
2211 deRef2(argv+n, a);
2212 if ( isVar(*a) && onStack(local, a) )
2213 { LTrail(a);
2214 *a = makeRef(argp);
2215 } else
2216 { GTrail(argp);
2217 *argp = (needsRef(*a) ? makeRef(a) : *a);
2218 }
2219 }
2220 }
2221 } else if ( key == ATOM_predicate_indicator )
2222 { if ( !unify_definition(m, result, fr->predicate, 0, GP_NAMEARITY) )
2223 return FALSE;
2224 } else if ( key == ATOM_parent_goal )
2225 { Procedure proc;
2226 term_t head = PL_new_term_ref();
2227 term_t a = PL_new_term_ref();
2228 fid_t fid;
2229
2230 if ( !get_procedure(value, &proc, head, GP_FIND) )
2231 fail;
2232
2233 if ( (fid = PL_open_foreign_frame()) )
2234 { while( fr )
2235 { while(fr && fr->predicate != proc->definition)
2236 fr = parentFrame(fr);
2237
2238 if ( fr )
2239 { int i, garity = fr->predicate->functor->arity;
2240 term_t fref = consTermRef(fr);
2241
2242 for(i=0; i<garity; i++)
2243 { term_t fa;
2244
2245 fa = consTermRef(argFrameP(fr, i));
2246
2247 _PL_get_arg(i+1, head, a);
2248 if ( !PL_unify(a, fa) )
2249 break;
2250 fr = (LocalFrame)valTermRef(fref); /* deal with possible shift */
2251 }
2252 if ( i == garity )
2253 { if ( arity == 1 )
2254 { LocalFrame parent;
2255 term_t arg = PL_new_term_ref();
2256
2257 _PL_get_arg(1, what, arg);
2258 if ( (parent = parentFrame(fr)) )
2259 { if ( PL_unify_frame(arg, parent) )
2260 return TRUE;
2261 } else
2262 { if ( PL_unify_atom(arg, ATOM_none) )
2263 return TRUE;
2264 }
2265 } else
2266 { return TRUE;
2267 }
2268 }
2269
2270 if ( PL_exception(0) )
2271 { return FALSE;
2272 } else
2273 { PL_rewind_foreign_frame(fid);
2274
2275 fr = (LocalFrame)valTermRef(fref); /* deal with possible shift */
2276 fr = parentFrame(fr);
2277 }
2278 } else
2279 { PL_close_foreign_frame(fid);
2280 return FALSE;
2281 }
2282 }
2283 }
2284 } else if ( key == ATOM_pc )
2285 { if ( fr->programPointer &&
2286 fr->parent &&
2287 false(fr->parent->predicate, P_FOREIGN) &&
2288 fr->parent->clause &&
2289 fr->parent->predicate != PROCEDURE_dcall1->definition )
2290 { intptr_t pc = fr->programPointer - fr->parent->clause->value.clause->codes;
2291
2292 PL_put_intptr(result, pc);
2293 } else
2294 { fail;
2295 }
2296 } else if ( key == ATOM_hidden )
2297 { atom_t a;
2298
2299 if ( SYSTEM_MODE )
2300 { a = ATOM_true;
2301 } else
2302 { if ( isDebugFrame(fr) )
2303 a = ATOM_false;
2304 else
2305 a = ATOM_true;
2306 }
2307
2308 PL_put_atom(result, a);
2309 } else if ( key == ATOM_depth_limit_exceeded )
2310 { atom_t a; /* get limit from saved query */
2311
2312 #ifdef O_LIMIT_DEPTH
2313 QueryFrame qf = findQuery(environment_frame);
2314
2315 if ( qf && (uintptr_t)levelFrame(fr) > qf->saved_depth_limit )
2316 a = ATOM_true;
2317 else
2318 #endif
2319 a = ATOM_false;
2320
2321 PL_put_atom(result, a);
2322 } else
2323 goto unknown_key;
2324
2325 return PL_unify(value, result);
2326 }
2327
2328
2329 /** prolog_frame_attribute(+Frame, +Key, -Value) is semidet.
2330
2331 */
2332
2333 static
2334 PRED_IMPL("prolog_frame_attribute", 3, prolog_frame_attribute, PL_FA_TRANSPARENT)
2335 { int rc = prolog_frame_attribute(A1, A2, A3);
2336
2337 DEBUG(CHK_SECURE, scan_global(0));
2338
2339 return rc;
2340 }
2341
2342 /*******************************
2343 * CHOICEPOINT STACK *
2344 *******************************/
2345
2346 /** prolog_choice_attribute(+Choice, +Key, -Value) is semidet.
2347
2348 */
2349
2350 static size_t
in_clause_jump(Choice ch)2351 in_clause_jump(Choice ch)
2352 { Clause cl;
2353
2354 if ( ch->type == CHP_JUMP &&
2355 false(ch->frame->predicate, P_FOREIGN) &&
2356 ch->frame->clause &&
2357 (cl=ch->frame->clause->value.clause) &&
2358 ch->value.PC >= cl->codes &&
2359 ch->value.PC < &cl->codes[cl->code_size] )
2360 return ch->value.PC - cl->codes;
2361
2362 return (size_t)-1;
2363 }
2364
2365
2366 static
2367 PRED_IMPL("prolog_choice_attribute", 3, prolog_choice_attribute, 0)
2368 { PRED_LD
2369 Choice ch = NULL;
2370 atom_t key;
2371
2372 if ( !PL_get_choice(A1, &ch) ||
2373 !PL_get_atom_ex(A2, &key) )
2374 fail;
2375
2376 if ( key == ATOM_parent )
2377 { do
2378 { ch = ch->parent;
2379 } while(ch && ch->type == CHP_DEBUG);
2380
2381 if ( ch )
2382 return PL_unify_choice(A3, ch);
2383 fail;
2384 } else if ( key == ATOM_frame )
2385 { return PL_unify_frame(A3, ch->frame);
2386 } else if ( key == ATOM_type )
2387 { static const atom_t types[] =
2388 { ATOM_jump,
2389 ATOM_clause,
2390 ATOM_top,
2391 ATOM_catch,
2392 ATOM_debug
2393 };
2394
2395 if ( ch->type == CHP_JUMP &&
2396 in_clause_jump(ch) == (size_t)-1 )
2397 { if ( ch->value.PC == SUPERVISOR(next_clause) )
2398 return PL_unify_atom(A3, ATOM_clause);
2399 if ( decode(ch->value.PC[0]) == I_FREDO )
2400 return PL_unify_atom(A3, ATOM_foreign);
2401 assert(0);
2402 return FALSE;
2403 } else
2404 return PL_unify_atom(A3, types[ch->type]);
2405 } else if ( key == ATOM_pc )
2406 { size_t offset = in_clause_jump(ch);
2407
2408 if ( offset != (size_t)-1 )
2409 return PL_unify_int64(A3, offset);
2410 return FALSE;
2411 } else
2412 return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_key, A2);
2413
2414 }
2415
2416
2417 /*******************************
2418 * PUBLISH PREDICATES *
2419 *******************************/
2420
2421 BeginPredDefs(trace)
2422 PRED_DEF("prolog_current_choice", 1, prolog_current_choice, 0)
2423 PRED_DEF("prolog_frame_attribute", 3, prolog_frame_attribute, PL_FA_TRANSPARENT)
2424 PRED_DEF("prolog_choice_attribute", 3, prolog_choice_attribute, 0)
2425 PRED_DEF("prolog_skip_frame", 1, prolog_skip_frame, PL_FA_NOTRACE)
2426 PRED_DEF("prolog_skip_level", 2, prolog_skip_level, PL_FA_NOTRACE)
2427 EndPredDefs
2428