YAP 7.1.0
stack.c
Go to the documentation of this file.
1/*************************************************************************
2 * *
3 * YAP Prolog *
4 * *
5 * Yap Prolog was developed at NCCUP - Universidade do Porto *
6 * *
7 * Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
8 * *
9 **************************************************************************
10 * *
11 * File: stack.c *
12 * comments: Stack Introspection *
13 * *
14 * Last rev: $Date: 2008-07-22 23:34:44 $,$Author: vsc $ *
15 * $Log: not supported by cvs2svn $ *
16 * Revision 1.230 2008/06/02 17:20:28 vsc *
17 * *
18 * *
19 *************************************************************************/
20
32#include "Yap.h"
33#include "Yapproto.h"
34
35#ifdef YAPOR
36#include "or.macros.h"
37#endif /* YAPOR */
38#ifdef TABLING
39
40#include "tab.macros.h"
41#include "clause.h"
42#include "attvar.h"
43
44#endif /* TABLING */
45#if HAVE_STRING_H
46
47#include <string.h>
48
49#endif
50
51#include <heapgc.h>
52
53typedef struct __cp_frame {
54 CELL *start_cp;
55 CELL *end_cp;
56 CELL *to;
57#ifdef RATIONAL_TREES
58 CELL oldv;
59 int ground;
60#endif
61} _copy_frame;
62
63#if !defined(YAPOR) && !defined(THREADS)
64
65static void mark_pred(int, PredEntry *);
66
67static void do_toggle_static_predicates_in_use(int);
68
69#endif
70
71static Int in_use(USES_REGS1);
72
73static LogUpdIndex *find_owner_log_index(LogUpdIndex *, yamop *);
74
75static StaticIndex *find_owner_static_index(StaticIndex *, yamop *);
76
77#define IN_BLOCK(P, B, SZ) \
78 ((CODEADDR)(P) >= (CODEADDR)(B) && (CODEADDR)(P) < (CODEADDR)(B) + (SZ))
79
80
81static PredEntry *get_pred(Term t, Term tmod, char *pname) {
82 Term t0 = t;
83
84 restart:
85 if (IsVarTerm(t)) {
86 Yap_Error(INSTANTIATION_ERROR, t0, pname);
87 return NULL;
88 } else if (IsAtomTerm(t)) {
89 return RepPredProp(Yap_GetPredPropByAtom(AtomOfTerm(t), tmod));
90 } else if (IsIntegerTerm(t) && tmod == IDB_MODULE) {
91 return Yap_FindLUIntKey(IntegerOfTerm(t));
92 } else if (IsApplTerm(t)) {
93 Functor fun = FunctorOfTerm(t);
94 if (IsExtensionFunctor(fun)) {
95 Yap_Error(TYPE_ERROR_CALLABLE, Yap_TermToIndicator(t, tmod), pname);
96 return NULL;
97 }
98 if (fun == FunctorModule) {
99 Term tmod = ArgOfTerm(1, t);
100 if (IsVarTerm(tmod)) {
101 Yap_Error(INSTANTIATION_ERROR, t0, pname);
102 return NULL;
103 }
104 if (!IsAtomTerm(tmod)) {
105 Yap_Error(TYPE_ERROR_ATOM, t0, pname);
106 return NULL;
107 }
108 t = ArgOfTerm(2, t);
109 goto restart;
110 }
111 return RepPredProp(Yap_GetPredPropByFunc(fun, tmod));
112 } else
113 return NULL;
114}
115
116Term Yap_TermToIndicator(Term t, Term mod) {
117 CACHE_REGS
118 // generate predicate indicator in this case
119 Term ti[2];
120 t = Yap_YapStripModule(t, &mod);
121 if (IsApplTerm(t) && !IsExtensionFunctor(FunctorOfTerm(t))) {
122 ti[0] = MkAtomTerm(NameOfFunctor(FunctorOfTerm(t)));
123 ti[1] = MkIntegerTerm(ArityOfFunctor(FunctorOfTerm(t)));
124 } else if (IsPairTerm(t)) {
125 ti[0] = MkAtomTerm(AtomDot);
126 ti[1] = MkIntTerm(2);
127 } else {
128 return t;
129 }
130 t = Yap_MkApplTerm(FunctorSlash, 2, ti);
131 if (mod != PROLOG_MODULE && mod != USER_MODULE && mod != TermProlog) {
132 ti[0] = mod;
133 ti[1] = t;
134 return Yap_MkApplTerm(FunctorModule, 2, ti);
135 }
136 return t;
137}
138
139Term Yap_PredicateToIndicator(PredEntry *pe) {
140 CACHE_REGS
141 // generate predicate indicator in this case
142 Term ti[2];
143 Term mod = pe->ModuleOfPred;
144 if (mod == IDB_MODULE && pe->PredFlags & NumberDBPredFlag) {
145 Int id = pe->src.IndxId;
146 ti[0] = IDB_MODULE;
147 ti[1] = MkIntTerm(id);
148 return Yap_MkApplTerm(FunctorModule, 2, ti);
149 }
150 if (pe->ArityOfPE) {
151 ti[0] = MkAtomTerm(NameOfFunctor(pe->FunctorOfPred));
152 ti[1] = MkIntegerTerm(ArityOfFunctor(pe->FunctorOfPred));
153 } else {
154 ti[0] = MkAtomTerm((Atom) (pe->FunctorOfPred));
155 ti[1] = MkIntTerm(0);
156 }
157 Term t = Yap_MkApplTerm(FunctorSlash, 2, ti);
158 if (mod != PROLOG_MODULE && mod != USER_MODULE && mod != TermProlog) {
159 ti[0] = mod;
160 ti[1] = t;
161 return Yap_MkApplTerm(FunctorModule, 2, ti);
162 }
163 return t;
164}
165
166extern char *Yap_output_bug_location(yamop *yap_pc, int where_from, int psize);
167
168
169static int UnifyPredInfo(PredEntry *pe, int start_arg USES_REGS) {
170 arity_t arity = pe->ArityOfPE;
171 Term tmod, tname;
172
173 if (pe->ModuleOfPred != IDB_MODULE) {
174 if (pe->ModuleOfPred == PROLOG_MODULE) {
175 tmod = TermProlog;
176 } else {
177 tmod = pe->ModuleOfPred;
178 }
179 if (pe->ArityOfPE == 0) {
180 tname = MkAtomTerm((Atom) pe->FunctorOfPred);
181 } else {
182 Functor f = pe->FunctorOfPred;
183 tname = MkAtomTerm(NameOfFunctor(f));
184 }
185 } else {
186 tmod = pe->ModuleOfPred;
187 if (pe->PredFlags & NumberDBPredFlag) {
188 tname = MkIntegerTerm(pe->src.IndxId);
189 } else if (pe->PredFlags & AtomDBPredFlag) {
190 tname = MkAtomTerm((Atom) pe->FunctorOfPred);
191 } else {
192 Functor f = pe->FunctorOfPred;
193 tname = MkAtomTerm(NameOfFunctor(f));
194 }
195 }
196
197 return Yap_unify(tmod, XREGS[start_arg]) &&
198 Yap_unify(tname, XREGS[start_arg + 1]) &&
199 Yap_unify(MkIntegerTerm(arity), XREGS[start_arg + 2]);
200}
201
202static PredEntry *PredForChoicePt(yamop *p_code, op_numbers *opn) {
203 while (TRUE) {
204 op_numbers opnum;
205 if (!p_code)
206 return NULL;
207 opnum = Yap_op_from_opcode(p_code->opc);
208 if (opn)
209 *opn = opnum;
210 switch (opnum) {
211 case _Nstop:
212 return PredFail;
213 case _jump:
214 p_code = p_code->y_u.l.l;
215 break;
216 case _retry_me:
217 case _trust_me:
218 return p_code->y_u.Otapl.p;
219 case _retry_exo:
220 case _retry_all_exo:
221 return p_code->y_u.lp.p;
222 case _try_logical:
223 case _retry_logical:
224 case _trust_logical:
225 case _count_retry_logical:
226 case _count_trust_logical:
227 case _profiled_retry_logical:
228 case _profiled_trust_logical:
229 return p_code->y_u.OtaLl.d->ClPred;
230#ifdef TABLING
231 case _trie_trust_var:
232 case _trie_retry_var:
233 case _trie_trust_var_in_pair:
234 case _trie_retry_var_in_pair:
235 case _trie_trust_val:
236 case _trie_retry_val:
237 case _trie_trust_val_in_pair:
238 case _trie_retry_val_in_pair:
239 case _trie_trust_atom:
240 case _trie_retry_atom:
241 case _trie_trust_atom_in_pair:
242 case _trie_retry_atom_in_pair:
243 case _trie_trust_null:
244 case _trie_retry_null:
245 case _trie_trust_null_in_pair:
246 case _trie_retry_null_in_pair:
247 case _trie_trust_pair:
248 case _trie_retry_pair:
249 case _trie_trust_appl:
250 case _trie_retry_appl:
251 case _trie_trust_appl_in_pair:
252 case _trie_retry_appl_in_pair:
253 case _trie_trust_extension:
254 case _trie_retry_extension:
255 case _trie_trust_double:
256 case _trie_retry_double:
257 case _trie_trust_longint:
258 case _trie_retry_longint:
259 case _trie_trust_gterm:
260 case _trie_retry_gterm:
261 return NULL;
262 case _table_load_answer:
263 case _table_try_answer:
264 case _table_answer_resolution:
265 case _table_completion:
266#ifdef THREADS_CONSUMER_SHARING
267 case _table_answer_resolution_completion:
268#endif /* THREADS_CONSUMER_SHARING */
269 return NULL; /* ricroc: is this OK? */
270 /* compile error --> return ENV_ToP(gc_B->cp_cp); */
271#endif /* TABLING */
272 case _or_else:
273 return p_code->y_u.Osblp.p0;
274 break;
275 case _or_last:
276#ifdef YAPOR
277 return p_code->y_u.Osblp.p0;
278#else
279 return PredMetaCall;
280#endif /* YAPOR */
281 break;
282 case _count_retry_me:
283 case _retry_profiled:
284 case _retry2:
285 case _retry3:
286 case _retry4:
287 p_code = NEXTOP(p_code, l);
288 break;
289 default:
290 return p_code->y_u.Otapl.p;
291 }
292 }
293 return NULL;
294}
295
307PredEntry *Yap_PredForChoicePt(choiceptr cp, op_numbers *op) {
308 if (cp == NULL)
309 return NULL;
310 return PredForChoicePt(cp->cp_ap, op);
311}
312
313#if !defined(YAPOR) && !defined(THREADS)
314
315#if !defined(DOXYGEN) && 0
316
317static yamop *cur_clause(PredEntry *pe, yamop *codeptr) {
318 StaticClause *cl;
319
320 cl = ClauseCodeToStaticClause(pe->FirstClause);
321 do {
322 if (IN_BLOCK(codeptr, cl, cl->ClSize)) {
323 return cl->ClCode;
324 }
325 if (cl->ClCode == pe->cs.p_code.LastClause)
326 break;
327 cl = cl->ClNext;
328 } while (TRUE);
329 Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil,
330 "could not find clause for indexing code");
331 return (NULL);
332}
333
334#endif
335
336bool Yap_search_for_static_predicate_in_use(PredEntry *p,
337 bool check_everything) {
338 choiceptr b_ptr = B;
339 CELL *env_ptr = ENV;
340
341 if (check_everything && P && ENV) {
342 PredEntry *pe = EnvPreg(P);
343 if (p == pe)
344 return true;
345 pe = EnvPreg(CP);
346 if (p == pe)
347 return true;
348 }
349 do {
350 PredEntry *pe;
351
352 /* check first environments that are younger than our latest choicepoint */
353 if (check_everything && env_ptr) {
354 /*
355 I do not need to check environments for asserts,
356 only for retracts
357 */
358 while (env_ptr && b_ptr > (choiceptr) env_ptr) {
359 yamop *cp = (yamop *) env_ptr[E_CP];
360 PredEntry *pe;
361
362 if (!cp)
363 return false;
364 pe = EnvPreg(cp);
365 if (p == pe)
366 return true;
367 if (env_ptr == (CELL *) (env_ptr[E_E]))
368 return false;
369
370 if (env_ptr != NULL)
371 env_ptr = (CELL *) (env_ptr[E_E]);
372 }
373 }
374 /* now mark the choicepoint */
375 if (b_ptr) {
376 pe = PredForChoicePt(b_ptr->cp_ap, NULL);
377 } else
378 return false;
379 if (pe == p) {
380 return true;
381 }
382 env_ptr = b_ptr->cp_env;
383 if (b_ptr->cp_ap == NOCODE)
384 return false;
385 if (b_ptr->cp_ap == EXITCODE)
386 return false;
387 b_ptr = b_ptr->cp_b;
388 } while (b_ptr != NULL);
389 return (FALSE);
390}
391
392static void mark_pred(int mark, PredEntry *pe) {
393 /* if the predicate is static mark it */
394 if (pe->ModuleOfPred) {
395 PELOCK(39, p);
396 if (mark) {
397 pe->PredFlags |= InUsePredFlag;
398 } else {
399 pe->PredFlags &= ~InUsePredFlag;
400 }
401 UNLOCK(pe->PELock);
402 }
403}
404
405/* go up the chain of choice_points and environments,
406 marking all static predicates that current execution is depending
407 upon */
408static void do_toggle_static_predicates_in_use(int mask) {
409 choiceptr b_ptr = B;
410 CELL *env_ptr = ENV;
411
412 if (b_ptr == NULL)
413 return;
414
415 do {
416 PredEntry *pe;
417
418 /* check first environments that are younger than our latest choicepoint */
419 while (b_ptr > (choiceptr) env_ptr) {
420 yamop *env_cp = (yamop *) env_ptr[E_CP];
421 PredEntry *pe;
422
423 if (env_cp == YESCODE) {
424 pe = PredTrue;
425 } else {
426 // if (env_cp == BORDERCODE) {
427
428
429 //?? env_cp = (yamop *) env_ptr[-1 - EnvSizeInCells];
430 // }
431 pe = EnvPreg(env_cp);
432 }
433 mark_pred(mask, pe);
434 env_ptr = (CELL *) (env_ptr[E_E]);
435 }
436 /* now mark the choicepoint */
437 if ((b_ptr)) {
438 if ((pe = PredForChoicePt(b_ptr->cp_ap, NULL))) {
439 mark_pred(mask, pe);
440 }
441 }
442 env_ptr = b_ptr->cp_env;
443 b_ptr = b_ptr->cp_b;
444 } while (b_ptr != NULL);
445 /* mark or unmark all predicates */
446 STATIC_PREDICATES_MARKED = mask;
447}
448
449static Int toggle_static_predicates_in_use(USES_REGS1) {
450#if !defined(YAPOR) && !defined(THREADS)
451 Term t = Deref(ARG1);
452 Int mask;
453
454 /* find out whether we need to mark or unmark */
455 if (IsVarTerm(t)) {
456 Yap_Error(INSTANTIATION_ERROR, t, "toggle_static_predicates_in_use/1");
457 return (FALSE);
458 }
459 if (!IsIntTerm(t)) {
460 Yap_Error(TYPE_ERROR_INTEGER, t, "toggle_static_predicates_in_use/1");
461 return (FALSE);
462 } else {
463 mask = IntOfTerm(t);
464 }
465 do_toggle_static_predicates_in_use(mask);
466#endif
467 return TRUE;
468}
469
470#endif /* !defined(YAPOR) && !defined(THREADS) */
471
472static int code_in_pred_lu_index(LogUpdIndex *icl, yamop *codeptr,
473 void **startp, void **endp) {
474 LogUpdIndex *cicl;
475 if (IN_BLOCK(codeptr, icl, icl->ClSize)) {
476 if (startp)
477 *startp = (CODEADDR) icl;
478 if (endp)
479 *endp = (CODEADDR) icl + icl->ClSize;
480 return TRUE;
481 }
482 cicl = icl->ChildIndex;
483 while (cicl != NULL) {
484 if (code_in_pred_lu_index(cicl, codeptr, startp, endp))
485 return TRUE;
486 cicl = cicl->SiblingIndex;
487 }
488 return FALSE;
489}
490
491static int code_in_pred_s_index(StaticIndex *icl, yamop *codeptr, void **startp,
492 void **endp) {
493 StaticIndex *cicl;
494 if (IN_BLOCK(codeptr, icl, icl->ClSize)) {
495 if (startp)
496 *startp = (CODEADDR) icl;
497 if (endp)
498 *endp = (CODEADDR) icl + icl->ClSize;
499 return TRUE;
500 }
501 cicl = icl->ChildIndex;
502 while (cicl != NULL) {
503 if (code_in_pred_s_index(cicl, codeptr, startp, endp))
504 return TRUE;
505 cicl = cicl->SiblingIndex;
506 }
507 return FALSE;
508}
509
510static Int find_code_in_clause(PredEntry *pp, yamop *codeptr, void **startp,
511 void **endp) {
512 Int i = 1;
513 yamop *clcode;
514
515 clcode = pp->cs.p_code.FirstClause;
516 if (clcode != NULL) {
517 if (pp->PredFlags & LogUpdatePredFlag) {
518 LogUpdClause *cl = ClauseCodeToLogUpdClause(clcode);
519 do {
520 if (IN_BLOCK(codeptr, (CODEADDR) cl, cl->ClSize)) {
521 if (startp)
522 *startp = (CODEADDR) cl;
523 if (endp)
524 *endp = (CODEADDR) cl + cl->ClSize;
525 return i;
526 }
527 i++;
528 cl = cl->ClNext;
529 } while (cl != NULL);
530 } else if (pp->PredFlags & DynamicPredFlag) {
531 do {
532 DynamicClause *cl;
533
534 cl = ClauseCodeToDynamicClause(clcode);
535 if (IN_BLOCK(codeptr, cl, cl->ClSize)) {
536 if (startp)
537 *startp = (CODEADDR) cl;
538 if (endp)
539 *endp = (CODEADDR) cl + cl->ClSize;
540 return i;
541 }
542 if (clcode == pp->cs.p_code.LastClause)
543 break;
544 i++;
545 clcode = NextDynamicClause(clcode);
546 } while (TRUE);
547 } else if (pp->PredFlags & MegaClausePredFlag) {
548 MegaClause *cl;
549
550 cl = ClauseCodeToMegaClause(clcode);
551 if (IN_BLOCK(codeptr, cl, cl->ClSize)) {
552 if (startp)
553 *startp = (CODEADDR) cl;
554 if (endp)
555 *endp = (CODEADDR) cl + cl->ClSize;
556 return 1 + ((char *) codeptr - (char *) cl->ClCode) / cl->ClItemSize;
557 }
558 } else {
559 StaticClause *cl;
560
561 cl = ClauseCodeToStaticClause(clcode);
562 do {
563 if (cl == NULL)
564 return 0;
565 if (IN_BLOCK(codeptr, cl, cl->ClSize)) {
566 if (startp)
567 *startp = (CODEADDR) cl;
568 if (endp)
569 *endp = (CODEADDR) cl + cl->ClSize;
570 return i;
571 }
572 if (cl->ClCode == pp->cs.p_code.LastClause)
573 break;
574 i++;
575 cl = cl->ClNext;
576 } while (TRUE);
577 }
578 }
579 return (0);
580}
581
582/*
583 static bool put_clause_loc(yap_error_descriptor_t *t, void *clcode, PredEntry
584 *pp) {
585
586 CACHE_REGS
587 if (pp->PredFlags & LogUpdatePredFlag) {
588 LogUpdClause *cl = clcode;
589
590 if (cl->ClFlags & FactMask) {
591 t->prologPredLine = cl->lusl.ClLine;
592 } else {
593 t->prologPredLine = cl->lusl.ClSource->ag.line_number;
594 }
595 } else if (pp->PredFlags & DynamicPredFlag) {
596 // DynamicClause *cl;
597 // cl = ClauseCodeToDynamicClause(clcode);
598
599 return false;
600 } else if (pp->PredFlags & MegaClausePredFlag) {
601 MegaClause *mcl = ClauseCodeToMegaClause(pp->cs.p_code.FirstClause);
602 t->prologPredLine = mcl->ClLine;
603 } else {
604 StaticClause *cl;
605 cl = clcode;
606 if (cl->ClFlags & FactMask) {
607 t->prologPredLine = cl->uscs.ClLine;
608 } else if (cl->ClFlags & SrcMask) {
609 t->prologPredLine = cl->usc.ClSource->ag.line_number;
610 } else
611 return MkIntTerm(0);
612 }
613 return MkIntTerm(0);
614 }
615*/
616
617static Term clause_loc(void *clcode, PredEntry *pp) {
618
619 CACHE_REGS
620 if (pp->PredFlags & LogUpdatePredFlag) {
621 LogUpdClause *cl = clcode;
622
623 if (cl->ClFlags & FactMask) {
624 return MkIntegerTerm(cl->lusl.ClLine);
625 } else {
626 return MkIntegerTerm(cl->lusl.ClSource->ag.line_number);
627 }
628 } else if (pp->PredFlags & DynamicPredFlag) {
629 // DynamicClause *cl;
630 // cl = ClauseCodeToDynamicClause(clcode);
631
632 return MkIntTerm(0);
633 } else if (pp->PredFlags & MegaClausePredFlag) {
634 MegaClause *mcl = ClauseCodeToMegaClause(pp->cs.p_code.FirstClause);
635 return MkIntTerm(mcl->ClLine);
636 } else {
637 StaticClause *cl;
638 cl = clcode;
639
640 if (cl->ClFlags & FactMask) {
641 return MkIntTerm(cl->usc.ClLine);
642 } else if (cl->ClFlags & SrcMask) {
643 return MkIntTerm(cl->usc.ClSource->ag.line_number);
644 } else
645 return MkIntTerm(0);
646 }
647 return MkIntTerm(0);
648}
649
650static int cl_code_in_pred(PredEntry *pp, yamop *codeptr, void **startp,
651 void **endp) {
652 Int out;
653
654 PELOCK(39, pp);
655 /* check if the codeptr comes from the indexing code */
656 if (pp->PredFlags & IndexedPredFlag) {
657 if (pp->PredFlags & LogUpdatePredFlag) {
658 if (code_in_pred_lu_index(
659 ClauseCodeToLogUpdIndex(pp->cs.p_code.TrueCodeOfPred), codeptr,
660 startp, endp)) {
661 UNLOCK(pp->PELock);
662 return TRUE;
663 }
664 } else {
665 if (code_in_pred_s_index(
666 ClauseCodeToStaticIndex(pp->cs.p_code.TrueCodeOfPred), codeptr,
667 startp, endp)) {
668 UNLOCK(pp->PELock);
669 return TRUE;
670 }
671 }
672 }
673 if (pp->PredFlags & (CPredFlag | AsmPredFlag | UserCPredFlag)) {
674 StaticClause *cl = ClauseCodeToStaticClause(pp->CodeOfPred);
675 if (IN_BLOCK(codeptr, (CODEADDR) cl, cl->ClSize)) {
676 if (startp)
677 *startp = (CODEADDR) cl;
678 if (endp)
679 *endp = (CODEADDR) cl + cl->ClSize;
680 UNLOCK(pp->PELock);
681 return TRUE;
682 } else {
683 UNLOCK(pp->PELock);
684 return FALSE;
685 }
686 } else {
687 out = find_code_in_clause(pp, codeptr, startp, endp);
688 }
689 UNLOCK(pp->PELock);
690 if (out)
691 return TRUE;
692 return FALSE;
693}
694
702static Int code_in_pred(PredEntry *pp,
703 yamop *codeptr) {
704
705 PELOCK(40, pp);
706 /* check if the codeptr comes from the indexing code */
707 if (pp->PredFlags & IndexedPredFlag && pp->OpcodeOfPred != INDEX_OPCODE) {
708 if (pp->PredFlags & LogUpdatePredFlag) {
709 if (code_in_pred_lu_index(
710 ClauseCodeToLogUpdIndex(pp->cs.p_code.TrueCodeOfPred), codeptr,
711 NULL, NULL)) {
712 UNLOCK(pp->PELock);
713 return -1;
714 }
715 } else {
716 if (code_in_pred_s_index(
717 ClauseCodeToStaticIndex(pp->cs.p_code.TrueCodeOfPred), codeptr,
718 NULL, NULL)) {
719 UNLOCK(pp->PELock);
720 return -1;
721 }
722 }
723 }
724 return find_code_in_clause(pp, codeptr, NULL, NULL);
725}
726
730PredEntry *Yap_PredForCode(yamop *codeptr, find_pred_type hint, Int *cl) {
731 Int found = 0;
732 ModEntry *me = CurrentModules;
733 if (codeptr)
734 /* should we allow the user to see hidden predicates? */
735 while (me) {
736
737 PredEntry *pp;
738 pp = me->PredForME;
739 while (pp != NULL) {
740 if ((found = code_in_pred(pp, codeptr)) != 0) {
741 if (cl)
742 *cl = found;
743 return pp;
744 }
745 pp = pp->NextPredOfModule;
746 }
747 me = me->NextME;
748 }
749 return (0);
750}
751
752
753/*
754PredEntry * Yap_PredForCode(yamop *codeptr, find_pred_type where_from) {
755 PredEntry *p;
756
757 if (where_from == FIND_PRED_FROM_CP) {
758 p = PredForChoicePt(codeptr, NULL);
759 } else if (where_from == FIND_PRED_FROM_ENV) {
760 p = EnvPreg(codeptr);
761 if (p) {
762 Int out;
763 if (p->ModuleOfPred == PROLOG_MODULE)
764 *pmodule = TermProlog;
765 else
766 *pmodule = p->ModuleOfPred;
767 out = find_code_in_clause(p, codeptr, NULL, NULL);
768 clause_was_found(p, pat, parity);
769 return out;
770 }
771 } else {
772 return PredForCode(codeptr, pat, parity, pmodule, NULL);
773 }
774 if (p == NULL) {
775 return 0;
776 }
777 clause_was_found(p, pat, parity);
778 if (p->ModuleOfPred == PROLOG_MODULE)
779 *pmodule = TermProlog;
780 else
781 *pmodule = p->ModuleOfPred;
782 return -1;
783} */
784
785/* intruction blocks we found ourselves at */
786static PredEntry *walk_got_lu_block(LogUpdIndex *cl, void **startp,
787 void **endp) {
788 PredEntry *pp = cl->ClPred;
789 *startp = (CODEADDR) cl;
790 *endp = (CODEADDR) cl + cl->ClSize;
791 return pp;
792}
793
794/* intruction blocks we found ourselves at */
795static PredEntry *walk_got_lu_clause(LogUpdClause *cl, void **startp,
796 void **endp) {
797 *startp = (CODEADDR) cl;
798 *endp = (CODEADDR) cl + cl->ClSize;
799 return cl->ClPred;
800}
801
802/* we hit a meta-call, so we don't know what is happening */
803static PredEntry *found_meta_call(void **startp, void **endp) {
804 PredEntry *pp = PredMetaCall;
805 *startp = (CODEADDR) &(pp->OpcodeOfPred);
806 *endp = (CODEADDR) NEXTOP((yamop *) &(pp->OpcodeOfPred), e);
807 return pp;
808}
809
810/* intruction blocks we found ourselves at */
811static PredEntry *walk_found_c_pred(PredEntry *pp, void **startp, void **endp) {
812 StaticClause *cl = ClauseCodeToStaticClause(pp->CodeOfPred);
813 *startp = (CODEADDR) &(cl->ClCode);
814 *endp = (CODEADDR) &(cl->ClCode) + cl->ClSize;
815 return pp;
816}
817
818/* we hit a mega-clause, no point in going on */
819static PredEntry *found_mega_clause(PredEntry *pp, void **startp, void **endp) {
820 MegaClause *mcl = ClauseCodeToMegaClause(pp->cs.p_code.FirstClause);
821 *startp = (CODEADDR) mcl;
822 *endp = (CODEADDR) mcl + mcl->ClSize;
823 return pp;
824}
825
826/* we hit a mega-clause, no point in going on */
827static PredEntry *found_idb_clause(yamop *pc, void **startp, void **endp) {
828 LogUpdClause *cl = ClauseCodeToLogUpdClause(pc);
829
830 *startp = (CODEADDR) cl;
831 *endp = (CODEADDR) cl + cl->ClSize;
832 return cl->ClPred;
833}
834
835/* we hit a expand_index, no point in going on */
836static PredEntry *found_expand_index(yamop *pc, void **startp, void **endp,
837 yamop *codeptr USES_REGS) {
838 PredEntry *pp = codeptr->y_u.sssllp.p;
839 if (pc == codeptr) {
840 *startp = (CODEADDR) codeptr;
841 *endp = (CODEADDR) NEXTOP(codeptr, sssllp);
842 }
843 return pp;
844}
845
846/* we hit a expand_index, no point in going on */
847static PredEntry *found_fail(yamop *pc, void **startp, void **endp USES_REGS) {
848 PredEntry *pp = RepPredProp(Yap_GetPredPropByAtom(AtomFail, CurrentModule));
849 *startp = *endp = (CODEADDR) FAILCODE;
850 return pp;
851}
852
853/* we hit a expand_index, no point in going on */
854static PredEntry *found_owner_op(yamop *pc, void **startp,
855 void **endp USES_REGS) {
856 PredEntry *pp = ((PredEntry *) (Unsigned(pc) -
857 (CELL) (&(((PredEntry *) NULL)->OpcodeOfPred))));
858 *startp = (CODEADDR) &(pp->OpcodeOfPred);
859 *endp = (CODEADDR) NEXTOP((yamop *) &(pp->OpcodeOfPred), e);
860 return pp;
861}
862
863/* we hit a expand_index, no point in going on */
864static PredEntry *found_expand(yamop *pc, void **startp,
865 void **endp USES_REGS) {
866 PredEntry *pp =
867 ((PredEntry *) (Unsigned(pc) -
868 (CELL) (&(((PredEntry *) NULL)->cs.p_code.ExpandCode))));
869 *startp = (CODEADDR) &(pp->cs.p_code.ExpandCode);
870 *endp = (CODEADDR) NEXTOP((yamop *) &(pp->cs.p_code.ExpandCode), e);
871 return pp;
872}
873
874static PredEntry *found_ystop(yamop *pc, int clause_code, void **startp,
875 void **endp, PredEntry *pp USES_REGS) {
876 if (pc == YESCODE) {
877 pp = RepPredProp(Yap_GetPredPropByAtom(AtomTrue, CurrentModule));
878 if (startp)
879 *startp = (CODEADDR) YESCODE;
880 if (endp)
881 *endp = (CODEADDR) YESCODE + (CELL) (NEXTOP((yamop *) NULL, e));
882 return pp;
883 }
884 if (!pp) {
885 yamop *o = PREVOP(pc, Osbpp);
886 if (o->opc == Yap_opcode(_execute_cpred)) {
887 pp = o->y_u.Osbpp.p0;
888 } else {
889 /* must be an index */
890 PredEntry **pep = (PredEntry **) pc->y_u.l.l;
891 pp = pep[-1];
892 }
893 }
894 if (pp->PredFlags & LogUpdatePredFlag) {
895 if (clause_code) {
896 LogUpdClause *cl = ClauseCodeToLogUpdClause(pc->y_u.l.l);
897 *startp = (CODEADDR) cl;
898 *endp = (CODEADDR) cl + cl->ClSize;
899 } else {
900 LogUpdIndex *cl = ClauseCodeToLogUpdIndex(pc->y_u.l.l);
901 *startp = (CODEADDR) cl;
902 *endp = (CODEADDR) cl + cl->ClSize;
903 }
904 } else if (pp->PredFlags & DynamicPredFlag) {
905 DynamicClause *cl = ClauseCodeToDynamicClause(pc->y_u.l.l);
906 *startp = (CODEADDR) cl;
907 *endp = (CODEADDR) cl + cl->ClSize;
908 } else {
909 if (clause_code) {
910 StaticClause *cl = ClauseCodeToStaticClause(pc->y_u.l.l);
911 *startp = (CODEADDR) cl;
912 *endp = (CODEADDR) cl + cl->ClSize;
913 } else {
914 StaticIndex *cl = ClauseCodeToStaticIndex(pc->y_u.l.l);
915 *startp = (CODEADDR) cl;
916 *endp = (CODEADDR) cl + cl->ClSize;
917 }
918 }
919 return pp;
920}
921
922static PredEntry *ClauseInfoForCode(yamop *codeptr, void **startp,
923 void **endp USES_REGS) {
924 yamop *pc;
925 PredEntry *pp = NULL;
926 int clause_code = FALSE;
927
928 if (codeptr >= COMMA_CODE && codeptr < FAILCODE) {
929 pp = RepPredProp(Yap_GetPredPropByFunc(FunctorComma, CurrentModule));
930 *startp = (CODEADDR) COMMA_CODE;
931 *endp = (CODEADDR) (FAILCODE);
932 return pp;
933 }
934 pc = codeptr;
935
936#include "walkclause.h"
937
938 return NULL;
939}
940
941PredEntry *Yap_PredEntryForCode(yamop *codeptr, find_pred_type where_from,
942 void **startp, void **endp) {
943 CACHE_REGS
944 if (where_from == FIND_PRED_FROM_CP) {
945 PredEntry *pp = PredForChoicePt(codeptr, NULL);
946 if (cl_code_in_pred(pp, codeptr, startp, endp)) {
947 return pp;
948 }
949 } else if (where_from == FIND_PRED_FROM_ENV) {
950 PredEntry *pp = EnvPreg(codeptr);
951 if (cl_code_in_pred(pp, codeptr, startp, endp)) {
952 return pp;
953 }
954 } else {
955 return ClauseInfoForCode(codeptr, startp, endp PASS_REGS);
956 }
957 return NULL;
958}
959
968static Int in_use(USES_REGS1) { /* '$in_use'(+P,+Mod) */
969 PredEntry *pe;
970 Int out;
971
972 pe = get_pred(Deref(ARG1), Deref(ARG2), "$in_use");
973 if (EndOfPAEntr(pe))
974 return FALSE;
975 PELOCK(25, pe);
976 out = Yap_static_in_use(pe, TRUE);
977 UNLOCKPE(42, pe);
978 return (out);
979}
980
981
982static LogUpdIndex *find_owner_log_index(LogUpdIndex *cl, yamop *code_p) {
983 yamop *code_beg = cl->ClCode;
984 yamop *code_end = (yamop *) ((char *) cl + cl->ClSize);
985
986 if (code_p >= code_beg && code_p <= code_end) {
987 return cl;
988 }
989 cl = cl->ChildIndex;
990 while (cl != NULL) {
991 LogUpdIndex *out;
992 if ((out = find_owner_log_index(cl, code_p)) != NULL) {
993 return out;
994 }
995 cl = cl->SiblingIndex;
996 }
997 return NULL;
998}
999
1000static StaticIndex *find_owner_static_index(StaticIndex *cl, yamop *code_p) {
1001 yamop *code_beg = cl->ClCode;
1002 yamop *code_end = (yamop *) ((char *) cl + cl->ClSize);
1003
1004 if (code_p >= code_beg && code_p <= code_end) {
1005 return cl;
1006 }
1007 cl = cl->ChildIndex;
1008 while (cl != NULL) {
1009 StaticIndex *out;
1010 if ((out = find_owner_static_index(cl, code_p)) != NULL) {
1011 return out;
1012 }
1013 cl = cl->SiblingIndex;
1014 }
1015 return NULL;
1016}
1017
1018ClauseUnion *Yap_find_owner_index(yamop *ipc, PredEntry *ap) {
1019 /* we assume we have an owner index */
1020 if (ap->PredFlags & LogUpdatePredFlag) {
1021 LogUpdIndex *cl = ClauseCodeToLogUpdIndex(ap->cs.p_code.TrueCodeOfPred);
1022 return (ClauseUnion *) find_owner_log_index(cl, ipc);
1023 } else {
1024 StaticIndex *cl = ClauseCodeToStaticIndex(ap->cs.p_code.TrueCodeOfPred);
1025 return (ClauseUnion *) find_owner_static_index(cl, ipc);
1026 }
1027}
1028
1029static Term all_envs(CELL *env_ptr USES_REGS) {
1030 Term tf = AbsPair(HR);
1031 CELL *start = HR;
1032 CELL *bp = NULL;
1033
1034 /* walk the environment chain */
1035 while (env_ptr) {
1036 bp = HR;
1037 HR += 2;
1038 /* notice that MkIntegerTerm may increase the HReap */
1039 bp[0] = MkIntegerTerm(LCL0 - env_ptr);
1040 if (HR >= ASP - 1024) {
1041 HR = start;
1042 LOCAL_Error_Size = (ASP - 1024) - HR;
1043 while (env_ptr) {
1044 LOCAL_Error_Size += 2;
1045 env_ptr = (CELL *) (env_ptr[E_E]);
1046 }
1047 return 0L;
1048 } else {
1049 bp[1] = AbsPair(HR);
1050 }
1051 env_ptr = (CELL *) (env_ptr[E_E]);
1052 }
1053 bp[1] = TermNil;
1054 return tf;
1055}
1056
1057static Term all_cps(choiceptr b_ptr USES_REGS) {
1058 CELL *bp = NULL;
1059 CELL *start = HR;
1060 Term tf = AbsPair(HR);
1061
1062
1063 while (b_ptr) {
1064 bp = HR;
1065 HR += 2;
1066 /* notice that MkIntegerTerm may increase the HReap */
1067 bp[0] = MkIntegerTerm((Int) (LCL0 - (CELL *) b_ptr));
1068 if (HR >= ASP - 1024) {
1069 HR = start;
1070 LOCAL_Error_Size = (ASP - 1024) - HR;
1071 while (b_ptr) {
1072 LOCAL_Error_Size += 2;
1073 b_ptr = b_ptr->cp_b;
1074 }
1075 return 0L;
1076 } else {
1077 bp[1] = AbsPair(HR);
1078 }
1079 b_ptr = b_ptr->cp_b;
1080 if (!IsVarTerm((CELL) b_ptr) || (CELL *) b_ptr < HR || (CELL *) b_ptr > LCL0) {
1081 // Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "choice-point chain
1082 // corrupted at %p!!!\n", b_ptr);
1083 break;
1084 }
1085 }
1086 bp[1] = TermNil;
1087 return tf;
1088}
1089
1090static Int p_all_choicepoints(USES_REGS1) {
1091 Term t;
1092 while ((t = all_cps(B PASS_REGS)) == 0L) {
1093 if (!Yap_dogc()) {
1094 Yap_Error(RESOURCE_ERROR_STACK, TermNil, "while dumping choicepoints");
1095 return FALSE;
1096 }
1097 }
1098 return Yap_unify(ARG1, t);
1099}
1100
1101static Int p_all_envs(USES_REGS1) {
1102 Term t;
1103 while ((t = all_envs(ENV PASS_REGS)) == 0L) {
1104 if (!Yap_dogc( )) {
1105 Yap_Error(RESOURCE_ERROR_STACK, TermNil, "while dumping environments");
1106 return FALSE;
1107 }
1108 }
1109 return Yap_unify(ARG1, t);
1110}
1111
1112
1113static Term clause_info(yamop *codeptr, PredEntry *pp) {
1114 CACHE_REGS
1115 Term ts[2];
1116 void *begin;
1117
1118 if (pp->ArityOfPE == 0) {
1119 ts[0] = MkAtomTerm((Atom) pp->FunctorOfPred);
1120 ts[1] = MkIntTerm(0);
1121 } else {
1122 ts[0] = MkAtomTerm(NameOfFunctor(pp->FunctorOfPred));
1123 ts[1] = MkIntegerTerm(pp->ArityOfPE);
1124 }
1125
1126 ts[0] = MkAtomTerm(pp->src.OwnerFile);
1127 Term t1 = Yap_MkApplTerm(FunctorModule, 2, ts);
1128 if ((find_code_in_clause(pp, codeptr, &begin, NULL)) <= 0) {
1129 ts[0] = clause_loc(pp->cs.p_code.FirstClause, pp);
1130 ts[1] = clause_loc(pp->cs.p_code.LastClause, pp);
1131 if (ts[0] == ts[1] && ts[1] != TermNil) {
1132 } else if (ts[1] == TermNil && ts[0] != MkIntTerm(0))
1133 ts[0] = Yap_MkApplTerm(FunctorMinus, 2, ts);
1134 }
1135 ts[1] = t1;
1136 return Yap_MkApplTerm(FunctorModule, 2, ts);
1137}
1138
1139yap_error_descriptor_t *set_clause_info(yap_error_descriptor_t *t,
1140 yamop *codeptr, PredEntry *pp) {
1141 CACHE_REGS
1142
1143 void *begin;
1144 if (pp->ArityOfPE == 0) {
1145 t->prologPredName = AtomName((Atom) pp->FunctorOfPred);
1146 t->prologPredArity = 0;
1147 } else {
1148 t->prologPredName = AtomName(NameOfFunctor(pp->FunctorOfPred));
1149 t->prologPredArity = pp->ArityOfPE;
1150 }
1151 t->prologPredModule =
1152 (pp->ModuleOfPred ? RepAtom(AtomOfTerm(pp->ModuleOfPred))->StrOfAE
1153 : "prolog");
1154 t->prologPredFile = RepAtom(pp->src.OwnerFile)->StrOfAE;
1155 if (codeptr->opc == UNDEF_OPCODE) {
1156 t->prologPredLine = 0;
1157 return t;
1158 } else if (pp->cs.p_code.NOfClauses) {
1159 if ((t->prologPredLine = find_code_in_clause(pp, codeptr, &begin, NULL)) <=
1160 0) {
1161 t->prologPredLine = 0;
1162 } else {
1163 t->prologPredLine = IntegerOfTerm(clause_loc(begin, pp));
1164 }
1165 return t;
1166 } else {
1167 t->prologPredLine = t->errorLine;
1168 t->prologPredFile = t->errorFile;
1169 return t;
1170 }
1171}
1172
1173static Term error_culprit(bool internal USES_REGS) {
1174 PredEntry *pe;
1175 // case number 1: Yap_Error called from built-in.
1176 void *startp, *endp;
1177 // case number 1: Yap_Error called from built-in.
1178 pe = ClauseInfoForCode(P, &startp, &endp PASS_REGS);
1179 if (internal) {
1180 return clause_info(P, pe);
1181 } else {
1182 CELL *curENV = ENV;
1183 yamop *curCP = CP;
1184 PredEntry *pe = EnvPreg(curCP);
1185
1186 while (curCP) {// != BORDERCODE) {
1187 if (pe->ModuleOfPred)
1188 return clause_info(curCP, pe);
1189 curENV = (CELL *) (curENV[E_E]);
1190 curCP = (yamop *) (curENV[E_CP]);
1191 pe = EnvPreg(curCP);
1192 }
1193 }
1194 return TermNil;
1195}
1196
1197yap_error_descriptor_t *
1198Yap_prolog_add_culprit(yap_error_descriptor_t *t PASS_REGS) {
1199 PredEntry *pe;
1200 void *startp, *endp;
1201 // case number 1: Yap_Error called from built-in.
1202 pe = ClauseInfoForCode(P, &startp, &endp PASS_REGS);
1203 if (pe && (CurrentModule == 0 || !(pe->PredFlags & HiddenPredFlag))) {
1204 return set_clause_info(t, P, pe);
1205 } else {
1206 CELL *curENV = ENV;
1207 yamop *curCP = CP;
1208 choiceptr curB = B;
1209 PredEntry *pe = EnvPreg(curCP);
1210
1211 while (curCP) {// != BORDERCODE) {
1212 if (curENV) {
1213 pe = EnvPreg(curCP);
1214 curENV = (CELL *) (curENV[E_E]);
1215 if (curENV < ASP || curENV >= LCL0) {
1216 break;
1217 }
1218 curCP = (yamop *) curENV[E_CP];
1219 if (pe == NULL) {
1220 pe = PredMetaCall;
1221 }
1222 if (pe->ModuleOfPred || !(pe->PredFlags & HiddenPredFlag))
1223 return set_clause_info(t, curCP, pe);
1224 curCP = (yamop *) (curENV[E_CP]);
1225 } else if (0) {
1226 if (curB->cp_ap != NOCODE && curB->cp_ap != TRUSTFAILCODE &&
1227 curB->cp_ap != FAILCODE) {
1228 pe = curB->cp_ap->y_u.Otapl.p;
1229 if (pe && (pe->ModuleOfPred || !(pe->PredFlags & HiddenPredFlag)))
1230 return set_clause_info(t, curB->cp_ap, pe);
1231 }
1232 curB = curB->cp_b;
1233 }
1234 }
1235 }
1236
1237 return NULL;
1238}
1239
1240static Term all_calls(bool internal USES_REGS) {
1241 Term ts[6];
1242 Functor f = Yap_MkFunctor(AtomLocalSp, 6);
1243
1244 // The first argument is key: it tries to
1245 // catch the culprit at the user level,
1246 ts[0] = error_culprit(internal PASS_REGS);
1247 ts[1] = MkAddressTerm(P);
1248 ts[2] = MkAddressTerm(CP);
1249 ts[3] = MkAddressTerm(PP);
1250 if (trueLocalPrologFlag(STACK_DUMP_ON_ERROR_FLAG)) {
1251 ts[4] = all_envs(ENV PASS_REGS);
1252 ts[5] = all_cps(B PASS_REGS);
1253 if (ts[4] == 0L || ts[5] == 0L)
1254 return 0L;
1255 } else {
1256 ts[4] = ts[5] = TermNil;
1257 }
1258 return Yap_MkApplTerm(f, 6, ts);
1259}
1260
1261Term Yap_all_calls(void) {
1262 CACHE_REGS
1263 return all_calls(true PASS_REGS);
1264}
1265
1275static Int current_stack(USES_REGS1) {
1276 Term t;
1277 while ((t = all_calls(false PASS_REGS)) == 0L) {
1278 if (!Yap_dogc()) {
1279 Yap_Error(RESOURCE_ERROR_STACK, TermNil, "while dumping stack");
1280 return FALSE;
1281 }
1282 }
1283 return Yap_unify(ARG1, t);
1284}
1285
1286// #if LOW_PROF
1287
1288static void add_code_in_lu_index(LogUpdIndex *cl, PredEntry *pp) {
1289 char *code_end = (char *) cl + cl->ClSize;
1290 Yap_inform_profiler_of_clause(cl, code_end, pp, GPROF_LU_INDEX);
1291 cl = cl->ChildIndex;
1292 while (cl != NULL) {
1293 add_code_in_lu_index(cl, pp);
1294 cl = cl->SiblingIndex;
1295 }
1296}
1297
1298static void add_code_in_static_index(StaticIndex *cl, PredEntry *pp) {
1299 char *code_end = (char *) cl + cl->ClSize;
1300 Yap_inform_profiler_of_clause(cl, code_end, pp, GPROF_STATIC_INDEX);
1301 cl = cl->ChildIndex;
1302 while (cl != NULL) {
1303 add_code_in_static_index(cl, pp);
1304 cl = cl->SiblingIndex;
1305 }
1306}
1307
1308static void add_code_in_pred(PredEntry *pp) {
1309 yamop *clcode;
1310
1311 PELOCK(49, pp);
1312 /* check if the codeptr comes from the indexing code */
1313
1314 /* highly likely this is used for indexing */
1315 Yap_inform_profiler_of_clause(&(pp->OpcodeOfPred), &(pp->OpcodeOfPred) + 1,
1316 pp, GPROF_INIT_OPCODE);
1317 if (pp->PredFlags & (CPredFlag | AsmPredFlag)) {
1318 char *code_end;
1319 StaticClause *cl;
1320
1321 clcode = pp->CodeOfPred;
1322 cl = ClauseCodeToStaticClause(clcode);
1323 code_end = (char *) cl + cl->ClSize;
1324 Yap_inform_profiler_of_clause(cl, code_end, pp, GPROF_INIT_SYSTEM_CODE);
1325 UNLOCK(pp->PELock);
1326 return;
1327 }
1328 Yap_inform_profiler_of_clause(&(pp->cs.p_code.ExpandCode),
1329 &(pp->cs.p_code.ExpandCode) + 1, pp,
1330 GPROF_INIT_EXPAND);
1331 clcode = pp->cs.p_code.TrueCodeOfPred;
1332 if (pp->PredFlags & IndexedPredFlag) {
1333 if (pp->PredFlags & LogUpdatePredFlag) {
1334 LogUpdIndex *cl = ClauseCodeToLogUpdIndex(clcode);
1335 add_code_in_lu_index(cl, pp);
1336 } else {
1337 StaticIndex *cl = ClauseCodeToStaticIndex(clcode);
1338 add_code_in_static_index(cl, pp);
1339 }
1340 }
1341 clcode = pp->cs.p_code.FirstClause;
1342 if (clcode != NULL) {
1343 if (pp->PredFlags & LogUpdatePredFlag) {
1344 LogUpdClause *cl = ClauseCodeToLogUpdClause(clcode);
1345 do {
1346 char *code_end;
1347
1348 code_end = (char *) cl + cl->ClSize;
1349 Yap_inform_profiler_of_clause(cl, code_end, pp,
1350 GPROF_INIT_LOG_UPD_CLAUSE);
1351 cl = cl->ClNext;
1352 } while (cl != NULL);
1353 } else if (pp->PredFlags & DynamicPredFlag) {
1354 do {
1355 DynamicClause *cl;
1356 CODEADDR code_end;
1357
1358 cl = ClauseCodeToDynamicClause(clcode);
1359 code_end = (CODEADDR) cl + cl->ClSize;
1360 Yap_inform_profiler_of_clause(cl, code_end, pp,
1361 GPROF_INIT_DYNAMIC_CLAUSE);
1362 if (clcode == pp->cs.p_code.LastClause)
1363 break;
1364 clcode = NextDynamicClause(clcode);
1365 } while (TRUE);
1366 } else {
1367 StaticClause *cl = ClauseCodeToStaticClause(clcode);
1368 do {
1369 char *code_end;
1370
1371 code_end = (char *) cl + cl->ClSize;
1372 Yap_inform_profiler_of_clause(cl, code_end, pp,
1373 GPROF_INIT_STATIC_CLAUSE);
1374 if (cl->ClCode == pp->cs.p_code.LastClause)
1375 break;
1376 cl = cl->ClNext;
1377 } while (TRUE);
1378 }
1379 }
1380 UNLOCK(pp->PELock);
1381}
1382
1383void Yap_dump_code_area_for_profiler(void) {
1384 ModEntry *me = CurrentModules;
1385
1386 while (me) {
1387 PredEntry *pp = me->PredForME;
1388
1389 while (pp != NULL) {
1390 /* if (pp->ArityOfPE) {
1391 fprintf(stderr,"%%s/%d %p\n",
1392 RepAtom(NameOfFunctor(pp->FunctorOfPred))->StrOfAE,
1393 pp->ArityOfPE,
1394 pp);
1395 } else {
1396 fprintf(stderr,"%%s %p\n",
1397 RepAtom((Atom)(pp->FunctorOfPred))->StrOfAE,
1398 pp);
1399 }*/
1400 add_code_in_pred(pp);
1401 pp = pp->NextPredOfModule;
1402 }
1403 me = me->NextME;
1404 }
1405 Yap_inform_profiler_of_clause(
1406 COMMA_CODE, FAILCODE, RepPredProp(Yap_GetPredPropByFunc(FunctorComma, 0 )),
1407 GPROF_INIT_COMMA);
1408 Yap_inform_profiler_of_clause(FAILCODE, FAILCODE + 1,
1409 RepPredProp(Yap_GetPredPropByAtom(AtomFail, 0)),
1410 GPROF_INIT_FAIL);
1411}
1412
1413
1414
1415static Term BuildActivePred(PredEntry *ap, CELL *vect) {
1416 CACHE_REGS
1417 arity_t i;
1418
1419 if (!ap->ArityOfPE) {
1420 return MkAtomTerm((Atom) ap->FunctorOfPred);
1421 }
1422 for (i = 0; i < ap->ArityOfPE; i++) {
1423 Term t = Deref(vect[i]);
1424 if (IsVarTerm(t)) {
1425 CELL *pt = VarOfTerm(t);
1426 /* one stack */
1427 if (pt > HR) {
1428 Term nt = MkVarTerm();
1429 Yap_unify(t, nt);
1430 }
1431 }
1432 }
1433 return Yap_MkApplTerm(ap->FunctorOfPred, ap->ArityOfPE, vect);
1434}
1435
1436static Int ClauseId(yamop *ipc, PredEntry *pe) {
1437 if (!ipc)
1438 return 0;
1439 return find_code_in_clause(pe, ipc, NULL, NULL);
1440}
1441
1442static Int env_info(USES_REGS1) {
1443 CELL *env = LCL0 - IntegerOfTerm(Deref(ARG1));
1444 yamop *env_cp;
1445 Term env_b, taddr;
1446
1447 if (!env)
1448 return FALSE;
1449 env_b = MkIntegerTerm((Int) (LCL0 - (CELL *) env[E_CB]));
1450 env_cp = (yamop *) env[E_CP];
1451
1452 /* pe = PREVOP(env_cp,Osbpp)->y_u.Osbpp.p0; */
1453 taddr = MkIntegerTerm((Int) env);
1454 return Yap_unify(ARG3, MkIntegerTerm((Int) env_cp)) &&
1455 Yap_unify(ARG2, taddr) && Yap_unify(ARG4, env_b);
1456}
1457
1458static Int p_cpc_info(USES_REGS1) {
1459 PredEntry *pe;
1460 yamop *ipc = (yamop *) IntegerOfTerm(Deref(ARG1));
1461
1462 pe = PREVOP(ipc, Osbpp)->y_u.Osbpp.p0;
1463 return UnifyPredInfo(pe, 2 PASS_REGS) &&
1464 Yap_unify(ARG5, MkIntegerTerm(ClauseId(ipc, pe)));
1465}
1466
1467static PredEntry *choicepoint_owner(choiceptr cptr, Term *tp, yamop **nclp) {
1468 PredEntry *pe =
1469 NULL;
1470 int go_on = TRUE;
1471 yamop *ipc = cptr->cp_ap;
1472 yamop *ncl = NULL;
1473 Term t = TermNil;
1474
1475 while (go_on) {
1476 op_numbers opnum = Yap_op_from_opcode(ipc->opc);
1477 go_on = FALSE;
1478 switch (opnum) {
1479#ifdef TABLING
1480 case _table_load_answer:
1481#ifdef LOW_LEVEL_TRACER
1482 pe = LOAD_CP(cptr)->cp_pred_entry;
1483#else
1484 pe = UndefCode;
1485#endif
1486 t = MkVarTerm();
1487 break;
1488 case _table_try_answer:
1489 case _table_retry_me:
1490 case _table_trust_me:
1491 case _table_retry:
1492 case _table_trust:
1493 case _table_completion:
1494#ifdef THREADS_CONSUMER_SHARING
1495 case _table_answer_resolution_completion:
1496#endif /* THREADS_CONSUMER_SHARING */
1497#ifdef LOW_LEVEL_TRACER
1498#ifdef DETERMINISTIC_TABLING
1499 if (IS_DET_GEN_CP(cptr)) {
1500 pe = DET_GEN_CP(cptr)->cp_pred_entry;
1501 t = MkVarTerm();
1502 } else
1503#endif /* DETERMINISTIC_TABLING */
1504 {
1505 pe = GEN_CP(cptr)->cp_pred_entry;
1506 t = BuildActivePred(pe, (CELL *) (GEN_CP(B) + 1));
1507 }
1508#else
1509 pe = UndefCode;
1510 t = MkVarTerm();
1511#endif
1512 break;
1513 case _table_answer_resolution:
1514#ifdef LOW_LEVEL_TRACER
1515 pe = CONS_CP(cptr)->cp_pred_entry;
1516#else
1517 pe = UndefCode;
1518#endif
1519 t = MkVarTerm();
1520 break;
1521 case _trie_trust_var:
1522 case _trie_retry_var:
1523 case _trie_trust_var_in_pair:
1524 case _trie_retry_var_in_pair:
1525 case _trie_trust_val:
1526 case _trie_retry_val:
1527 case _trie_trust_val_in_pair:
1528 case _trie_retry_val_in_pair:
1529 case _trie_trust_atom:
1530 case _trie_retry_atom:
1531 case _trie_trust_atom_in_pair:
1532 case _trie_retry_atom_in_pair:
1533 case _trie_trust_null:
1534 case _trie_retry_null:
1535 case _trie_trust_null_in_pair:
1536 case _trie_retry_null_in_pair:
1537 case _trie_trust_pair:
1538 case _trie_retry_pair:
1539 case _trie_trust_appl:
1540 case _trie_retry_appl:
1541 case _trie_trust_appl_in_pair:
1542 case _trie_retry_appl_in_pair:
1543 case _trie_trust_extension:
1544 case _trie_retry_extension:
1545 case _trie_trust_double:
1546 case _trie_retry_double:
1547 case _trie_trust_longint:
1548 case _trie_retry_longint:
1549 case _trie_trust_gterm:
1550 case _trie_retry_gterm:
1551 pe = UndefHook;
1552 t = MkVarTerm();
1553 break;
1554#endif /* TABLING */
1555 case _try_logical:
1556 case _retry_logical:
1557 case _trust_logical:
1558 case _count_retry_logical:
1559 case _count_trust_logical:
1560 case _profiled_retry_logical:
1561 case _profiled_trust_logical:
1562 ncl = ipc->y_u.OtaLl.d->ClCode;
1563 pe = ipc->y_u.OtaLl.d->ClPred;
1564 t = BuildActivePred(pe, cptr->cp_args);
1565 break;
1566 case _or_else:
1567 pe = ipc->y_u.Osblp.p0;
1568 ncl = ipc;
1569 t = Yap_MkNewApplTerm(FunctorOr, 2);
1570 break;
1571
1572 case _or_last:
1573#ifdef YAPOR
1574 pe = ipc->y_u.Osblp.p0;
1575#else
1576 pe = PredMetaCall;
1577#endif
1578 ncl = ipc;
1579 t = Yap_MkNewApplTerm(FunctorOr, 2);
1580 break;
1581 case _retry2:
1582 case _retry3:
1583 case _retry4:
1584 pe = NULL;
1585 t = TermNil;
1586 ipc = NEXTOP(ipc, l);
1587 if (!ncl)
1588 ncl = ipc->y_u.Otapl.d;
1589 go_on = TRUE;
1590 break;
1591 case _jump:
1592 pe = NULL;
1593 t = TermNil;
1594 ipc = ipc->y_u.l.l;
1595 go_on = TRUE;
1596 break;
1597 case _retry_c:
1598 case _retry_userc:
1599 ncl = NEXTOP(ipc, OtapFs);
1600 pe = ipc->y_u.OtapFs.p;
1601 t = BuildActivePred(pe, cptr->cp_args);
1602 break;
1603 case _retry_profiled:
1604 case _count_retry:
1605 pe = NULL;
1606 t = TermNil;
1607 ncl = ipc->y_u.Otapl.d;
1608 ipc = NEXTOP(ipc, p);
1609 go_on = TRUE;
1610 break;
1611 case _retry_me:
1612 case _trust_me:
1613 case _count_retry_me:
1614 case _count_trust_me:
1615 case _profiled_retry_me:
1616 case _profiled_trust_me:
1617 case _retry_and_mark:
1618 case _profiled_retry_and_mark:
1619 case _retry:
1620 case _trust:
1621 if (!ncl)
1622 ncl = ipc->y_u.Otapl.d;
1623 pe = ipc->y_u.Otapl.p;
1624 t = BuildActivePred(pe, cptr->cp_args);
1625 break;
1626 case _retry_exo:
1627 case _retry_all_exo:
1628 ncl = NULL;
1629 pe = ipc->y_u.lp.p;
1630 t = BuildActivePred(pe, cptr->cp_args);
1631 break;
1632 case _Nstop: {
1633 Atom at = AtomLive;
1634 t = MkAtomTerm(at);
1635 pe = RepPredProp(PredPropByAtom(at, CurrentModule));
1636 }
1637 break;
1638 case _Ystop:
1639 default:
1640 pe = NULL;
1641 }
1642 }
1643 if (tp)
1644 *tp = t;
1645 if (nclp)
1646 *nclp = ncl;
1647 return pe;
1648}
1649
1650static Int p_choicepoint_info(USES_REGS1) {
1651 PredEntry *pe;
1652 Term t;
1653 yamop *ncl;
1654
1655 choiceptr cptr = (choiceptr) (LCL0 - IntegerOfTerm(Deref(ARG1)));
1656 //Term taddr = MkIntegerTerm((Int) cptr);
1657 pe = choicepoint_owner(cptr, &t, &ncl);
1658 return UnifyPredInfo(pe, 3 PASS_REGS);
1659}
1660
1661static int hidden(Atom);
1662
1663static int legal_env(CELL *CACHE_TYPE);
1664
1665#define ONLOCAL(ptr) \
1666 (CellPtr(ptr) > CellPtr(HR) && CellPtr(ptr) < CellPtr(LOCAL_LocalBase))
1667
1668static int hidden(Atom at) {
1669 AtomEntry *chain;
1670
1671 READ_LOCK(INVISIBLECHAIN.AERWLock);
1672 chain = RepAtom(INVISIBLECHAIN.Entry);
1673 while (!EndOfPAEntr(chain) && AbsAtom(chain) != at)
1674 chain = RepAtom(chain->NextOfAE);
1675 READ_UNLOCK(INVISIBLECHAIN.AERWLock);
1676 if (EndOfPAEntr(chain))
1677 return (FALSE);
1678 return (TRUE);
1679}
1680
1681static int legal_env(CELL *ep USES_REGS) {
1682 CELL cp, ps;
1683 PredEntry *pe;
1684 if (!ONLOCAL(ep) || Unsigned(ep) & 3)
1685 return (FALSE);
1686 cp = ep[E_CP];
1687 if (!ONHEAP(cp))
1688 return (FALSE);
1689 ps = *((CELL *) (Addr(cp) - CellSize));
1690 pe = (PredEntry *) (ps - sizeof(OPREG) - sizeof(Prop));
1691 PELOCK(70, pe);
1692 if (!ONHEAP(pe) || Unsigned(pe) & 3 || pe->KindOfPE & 0xff00) {
1693 UNLOCK(pe->PELock);
1694 return (FALSE);
1695 }
1696 UNLOCK(pe->PELock);
1697 return (TRUE);
1698}
1699
1700#if 0
1701static Int program_continuation(USES_REGS1) {
1702 PredEntry *pe = EnvPreg((yamop *) ((ENV_Parent(ENV))[E_CP]));
1703 if (pe->ModuleOfPred) {
1704 if (!Yap_unify(ARG1, pe->ModuleOfPred))
1705 return FALSE;
1706 } else {
1707 if (!Yap_unify(ARG1, TermProlog))
1708 return FALSE;
1709 }
1710 if (pe->ArityOfPE) {
1711 if (!Yap_unify(ARG2, MkAtomTerm(NameOfFunctor(pe->FunctorOfPred))))
1712 return FALSE;
1713 if (!Yap_unify(ARG3, MkIntegerTerm(ArityOfFunctor(pe->FunctorOfPred))))
1714 return FALSE;
1715 } else {
1716 if (!Yap_unify(ARG2, MkAtomTerm((Atom) pe->FunctorOfPred)))
1717 return FALSE;
1718 if (!Yap_unify(ARG3, MkIntTerm(0)))
1719 return FALSE;
1720 }
1721 return TRUE;
1722}
1723
1724static bool handled_exception(USES_REGS1) {
1725 yamop *pos = NEXTOP(PredCatch->cs.p_code.TrueCodeOfPred, l);
1726 bool found_handler = false;
1727 choiceptr gc_b;
1728
1729 gc_b = B;
1730 while (gc_b) {
1731 yamop *ap = gc_b->cp_ap;
1732 if (ap == NOCODE) {
1733 /* C-code: let they deal with that */
1734 return false;
1735 } else if (ap == pos) {
1736 if (found_handler)
1737 return TRUE; /* we have two handlers */
1738 found_handler = true;
1739 }
1740 gc_b = gc_b->cp_b;
1741 }
1742 /* handled by Top c-code? */
1743 return !found_handler;
1744}
1745#endif
1746
1747typedef struct buf_struct_t {
1748 char *buf_;
1749 char *lbuf_;
1750 size_t bufsize_;
1751 size_t lbufsz_;
1752} buf_t;
1753
1754#define buf bufp->buf_
1755#define lbuf bufp->lbuf_
1756#define bufsize bufp->bufsize_
1757#define lbufsz bufp->lbufsz_
1758
1759
1760#define ADDBUF(CMD) { \
1761 while (true) { \
1762 size_t sz = CMD; \
1763 if (sz < lbufsz-256) { \
1764 lbuf += sz; \
1765 lbufsz -= sz; \
1766 break; \
1767 } \
1768 char *nbuf = realloc(buf, bufsize += 1024); \
1769 lbuf = nbuf + (lbuf-buf); \
1770 buf = nbuf; \
1771 lbufsz += 1024; \
1772 } \
1773 }
1774
1775
1776static char *ADDSTR(const char *STR, struct buf_struct_t *bufp) {
1777 \
1778 while (true) {
1779 \
1780 size_t sz = strlen(STR); \
1781 if (sz < lbufsz - 256) {
1782 \
1783 strcpy(lbuf, STR);
1784 lbuf += sz; \
1785 lbufsz -= sz; \
1786 break; \
1787
1788 } \
1789
1790 char *nbuf = realloc(buf, bufsize += 1024); \
1791 lbuf = nbuf + (lbuf - buf); \
1792 buf = nbuf; \
1793 lbufsz += 1024; \
1794
1795 } \
1796return lbuf;
1797}
1798
1799
1800#if UNDEFINED
1801static void shortstack( choiceptr b_ptr, CELL * env_ptr , buf_struct_t *bufp) {
1802 yamop *ipc = CP;
1803 int max_count = 200;
1804 int lvl = push_text_stack();
1805 while (b_ptr != NULL) {
1806 while (env_ptr && env_ptr <= (CELL *)b_ptr) {
1807 tp = Yap_output_bug_location(ipc, FIND_PRED_FROM_ENV, 256);
1808 if (env_ptr == (CELL *)b_ptr && (choiceptr)env_ptr[E_CB] > b_ptr) {
1809 b_ptr = b_ptr->cp_b;
1810 ADDBUF(snprintf(lbuf, lbufsz , "%% %s\n", tp));
1811 } else {
1812 ADDBUF(snprintf(lbuf, lbufsz , "%% %s\n", tp));
1813 }
1814 if (!max_count--) {
1815 ADDBUF(snprintf(lbuf, lbufsz , "%% .....\n"));
1816 return pop_output_text_stack(lvl, buf);
1817 }
1818 ipc = (yamop *)(env_ptr[E_CP]);
1819 env_ptr = (CELL *)(env_ptr[E_E]);
1820 }
1821 if (b_ptr) {
1822 if (!max_count--) {
1823 ADDBUF(snprintf(lbuf, lbufsz , "// .....\n"));
1824 return pop_output_text_stack(lvl, buf);
1825 }
1826 if (b_ptr->cp_ap && /* tabling */
1827 b_ptr->cp_ap->opc != Yap_opcode(_or_else) &&
1828 b_ptr->cp_ap->opc != Yap_opcode(_or_last) &&
1829 b_ptr->cp_ap->opc != Yap_opcode(_Nstop)) {
1830 /* we can safely ignore ; because there is always an upper env */
1831 Term tp = Yap_output_bug_location(b_ptr->cp_ap, FIND_PRED_FROM_CP, 256);
1832 ADDBUF(snprintf(lbuf, lbufsz , "%% %s (%luKB--%luKB)\n!!!", tp,
1833 (unsigned long int)((b_ptr->cp_h - H0) * sizeof(CELL) / 1024),
1834 (unsigned long int)((ADDR)LCL0 - (ADDR)b_ptr) / 1024));
1835 }
1836 b_ptr = b_ptr->cp_b;
1837 }
1838 }
1839
1840#endif
1841
1842const char *Yap_dump_stack(void) {
1843 CACHE_REGS
1844 int lvl = push_text_stack();
1845 struct buf_struct_t b, *bufp = &b;
1846 buf = malloc(4096);
1847 lbuf = buf;
1848 bufsize = 4096;
1849 lbufsz = bufsize - 256;
1850 /* check if handled */
1851 // if (handled_exception(PASS_REGS1))
1852 // return;
1853#if DEBUG
1854 ADDBUF(snprintf(lbuf, lbufsz,
1855 "%% YAP regs: P=%p, CP=%p, ASP=%p, H=%p, TR=%p, HeapTop=%p\n", P,
1856 CP, ASP, HR, TR, HeapTop));
1857
1858 ADDSTR("%% \n%% =====================================\n%%\n", bufp);
1859 ADDSTR("%% \n%% YAP Status:\n", bufp);
1860 ADDSTR("%% \n%% -------------------------------------\n%%\n", bufp);
1861 yap_error_number errnbr = LOCAL_Error_TYPE;
1862 yap_error_class_number classno = Yap_errorClass(errnbr);
1863
1864 ADDBUF(snprintf(lbuf, lbufsz, "%% Error STATUS: %s/%s\n\n", Yap_errorName(errnbr),
1865 Yap_errorClassName(classno)));
1866
1867 ADDSTR("%% Execution mode\n", bufp);
1868 if (LOCAL_PrologMode & BootMode)
1869 ADDSTR("%% Bootstrap\n", bufp);
1870 if (LOCAL_PrologMode & UserMode)
1871 ADDSTR("%% User Prologg\n", bufp);
1872 if (LOCAL_PrologMode & CritMode)
1873 ADDSTR("%% Exclusive Access Mode\n", bufp);
1874 if (LOCAL_PrologMode & AbortMode)
1875 ADDSTR("%% Abort\n", bufp);
1876 if (LOCAL_PrologMode & InterruptMode)
1877 ADDSTR("%% Interrupt\n", bufp);
1878 if (LOCAL_PrologMode & InErrorMode)
1879 ADDSTR("%% Error\n", bufp);
1880 if (LOCAL_PrologMode & ConsoleGetcMode)
1881 ADDSTR("%% Prompt Console\n", bufp);
1882 if (LOCAL_PrologMode & ExtendStackMode)
1883 ADDSTR("%% Stack expansion \n", bufp);
1884 if (LOCAL_PrologMode & GrowHeapMode)
1885 ADDSTR("%% Data Base Expansion\n", bufp);
1886 if (LOCAL_PrologMode & GrowStackMode)
1887 ADDSTR("%% User Prolog\n", bufp);
1888 if (LOCAL_PrologMode & GCMode)
1889 ADDSTR("%% Garbage Collection\n", bufp);
1890 if (LOCAL_PrologMode & ErrorHandlingMode)
1891 ADDSTR("%% Error handler\n", bufp);
1892 if (LOCAL_PrologMode & CCallMode)
1893 ADDSTR("%% System Foreign Code\n", bufp);
1894 if (LOCAL_PrologMode & UnifyMode)
1895 ADDSTR("%% Off-line Foreign Code\n", bufp);
1896 if (LOCAL_PrologMode & UserCCallMode)
1897 ADDSTR("%% User Foreig C\n", bufp);
1898 if (LOCAL_PrologMode & MallocMode)
1899 ADDSTR("%% Heap Allocaror\n", bufp);
1900 if (LOCAL_PrologMode & SystemMode)
1901 ADDSTR("%% Prolog Internals\n", bufp);
1902 if (LOCAL_PrologMode & AsyncIntMode)
1903 ADDSTR("%% Async Interruot mode\n", bufp);
1904 if (LOCAL_PrologMode & InReadlineMode)
1905 ADDSTR("%% Readline Console\n", bufp);
1906 if (LOCAL_PrologMode & TopGoalMode)
1907 ADDSTR("%% Creating new query\n", bufp);
1908#endif
1909 ADDSTR("%% \n%% -------------------------------------\n%%\n", bufp);
1910 ADDSTR("%% \n%% YAP Program:\n", bufp);
1911 ADDSTR("%% \n%% -------------------------------------\n%%\n", bufp);
1912 ADDBUF(snprintf(lbuf, lbufsz, "%% Program Position: %s\n\n", Yap_errorName(errno)));
1913 char *o = Yap_output_bug_location(P, FIND_PRED_FROM_ANYWHERE, 256);
1914 ADDBUF(snprintf(lbuf, lbufsz, "%% PC: %s\n", o));
1915 o = Yap_output_bug_location(CP, FIND_PRED_FROM_ANYWHERE, 256);
1916 ADDBUF(snprintf(lbuf, lbufsz, "%% Continuation: %s\n", o));
1917 o = Yap_output_bug_location(B->cp_ap, FIND_PRED_FROM_ANYWHERE, 256);
1918 ADDBUF(snprintf(lbuf, lbufsz, "%% Alternative: %s\n", o));
1919
1920 ADDSTR("%% \n%% -------------------------------------\n%%\n", bufp);
1921 ADDSTR("%% \n%% YAP Stack Usage:\n", bufp);
1922 ADDSTR("%% \n%% -------------------------------------\n%%\n", bufp);
1923 if (HR > ASP || HR > LCL0) {
1924 ADDBUF(snprintf(lbuf, lbufsz, "%% YAP ERROR: Global Collided against Local (%p--%p)\n",
1925 HR, ASP));
1926 } else if (HeapTop > (ADDR) LOCAL_GlobalBase) {
1927 ADDBUF(snprintf(lbuf, lbufsz,
1928 "%% YAP ERROR: Code Space Collided against Global (%p--%p)\n",
1929 HeapTop, LOCAL_GlobalBase));
1930 } else {
1931#if !USE_SYSTEM_MALLOC
1932 ADDBUF(snprintf(lbuf, lbufsz, "%%ldKB of Code Space (%p--%p)\n",
1933 (long int) ((CELL) HeapTop - (CELL) Yap_HeapBase) / 1024, Yap_HeapBase,
1934 HeapTop));
1935#if USE_DL_MALLOC
1936 if (Yap_NOfMemoryHoles) {
1937 UInt i;
1938
1939 for (i = 0; i < Yap_NOfMemoryHoles; i++)
1940 ADDBUF(snprintf(lbuf, lbufsz , " Current hole: %p--%p\n", Yap_MemoryHoles[i].start,
1941 Yap_MemoryHoles[i].end));
1942 }
1943#endif
1944#endif
1945 ADDBUF(snprintf(lbuf, lbufsz, "%% %luKB of Global Stack (%p--%p)\n",
1946 (unsigned long int) (sizeof(CELL) * (HR - H0)) / 1024, H0, HR));
1947 ADDBUF(snprintf(lbuf, lbufsz, "%% %luKB of Local Stack (%p--%p)\n",
1948 (unsigned long int) (sizeof(CELL) * (LCL0 - ASP)) / 1024, ASP, LCL0));
1949 ADDBUF(snprintf(lbuf, lbufsz, "%% %luKB of Trail (%p--%p)\n",
1950 (unsigned long int) ((ADDR) TR - LOCAL_TrailBase) / 1024,
1951 LOCAL_TrailBase, TR));
1952 ADDBUF(snprintf(lbuf, lbufsz, "%% Performed %ld garbage collections\n",
1953 (unsigned long int) LOCAL_GcCalls));
1954#if LOW_LEVEL_TRACER
1955 {
1956 extern unsigned long long vsc_count;
1957 if (vsc_count) {
1958#if _WIN32
1959 ADDBUF(snprintf(lbuf, lbufsz , "Trace Counter at %I64d\n", vsc_count));
1960#else
1961 ADDBUF(snprintf(lbuf, lbufsz, "Trace Counter at %lld\n", vsc_count));
1962#endif
1963 }
1964 }
1965#endif
1966 ADDSTR("%% \n%% -------------------------------------\n%%\n", bufp);
1967 ADDSTR("%% \n%% YAP Stack:\n", bufp);
1968 ADDSTR("%% \n%% -------------------------------------\n%%\n", bufp);
1969 ADDSTR("%% All Active Calls and\n", bufp);
1970 ADDSTR("%% Goals With Alternatives Open (Global In "
1971 "Use--Local In Use)\n%%\n", bufp);
1972 }
1973 return pop_output_text_stack(lvl, buf);
1974}
1975
1976
1977static bool outputep(CELL *ep, struct buf_struct_t *bufp) {
1978 PredEntry *pe = EnvPreg((yamop *) ep);
1979 if (!ONLOCAL(ep) || (Unsigned(ep) & (sizeof(CELL) - 1)))
1980 return false;
1981 Functor f;
1982 UNLOCK(pe->PELock);
1983 f = pe->FunctorOfPred;
1984 if (pe->KindOfPE && hidden(NameOfFunctor(f))) {
1985 return true;
1986 }
1987 Term mod = pe->ModuleOfPred;
1988 if (mod == PROLOG_MODULE)
1989 mod = TermProlog;
1990 arity_t arity = ArityOfFunctor(f);
1991
1992 int i;
1993 ADDSTR(RepAtom(AtomOfTerm(mod))->StrOfAE, bufp);
1994 if (arity == 0) {
1995 ADDSTR(RepAtom(((Atom) f))->StrOfAE, bufp);
1996 return true;
1997 }
1998 Atom At = NameOfFunctor(f);
1999 ADDBUF(snprintf(lbuf, lbufsz, "%s(", RepAtom(At)->StrOfAE));
2000 for (i = 0; i < arity; i++) {
2001 if (i > 0) ADDSTR("...,", bufp);
2002 }
2003 ADDSTR("...)", bufp);
2004 return true;
2005}
2006
2007static bool outputcp(choiceptr cp, struct buf_struct_t *bufp) {
2008 choiceptr b_ptr = cp;
2009 PredEntry *pe = Yap_PredForChoicePt(b_ptr, NULL);
2010 ADDBUF(snprintf(lbuf, lbufsz, "%% %p ", cp));
2011 op_numbers opnum = Yap_op_from_opcode(b_ptr->cp_ap->opc);
2012 if (opnum == _Nstop) {
2013 bool rc = outputep((CELL *) cp, bufp);
2014 ADDSTR(" ********** C-Code Interface Boundary ***********\n", bufp);
2015 return rc;
2016 }
2017 Functor f;
2018 Term mod = PROLOG_MODULE;
2019
2020 f = pe->FunctorOfPred;
2021 if (pe->ModuleOfPred)
2022 mod = pe->ModuleOfPred;
2023 else
2024 mod = TermProlog;
2025 if (mod != TermProlog && mod != MkAtomTerm(AtomUser)) {
2026 ADDBUF(snprintf(lbuf, lbufsz, "%s:", RepAtom(AtomOfTerm(mod))->StrOfAE));
2027 }
2028 if (mod == IDB_MODULE) {
2029 if (pe->PredFlags & NumberDBPredFlag) {
2030 Term t = MkIntegerTerm(pe->src.IndxId);
2031 char *b = Yap_TermToBuffer(t, 0);
2032 if (!b)
2033 return false;
2034 ADDSTR(b, bufp);
2035 } else if (pe->PredFlags & AtomDBPredFlag) {
2036 Atom At = (Atom) pe->FunctorOfPred;
2037 ADDSTR(RepAtom(At)->StrOfAE, bufp);
2038 } else {
2039 Functor f = pe->FunctorOfPred;
2040 arity_t arity = ArityOfFunctor(f);
2041 int i;
2042
2043 ADDBUF(snprintf(lbuf, lbufsz, "%s(", RepAtom((Atom) f)->StrOfAE));
2044 for (i = 0; i < arity; i++) {
2045 if (i > 0) ADDSTR("_,", bufp);
2046 }
2047 ADDSTR("), ", bufp);
2048 }
2049 char *b = Yap_TermToBuffer(b_ptr->cp_a2, 0);
2050 if (!b)
2051 return false;
2052 ADDSTR(b, bufp);
2053 ADDSTR(",_)", bufp);
2054 } else {
2055 ADDSTR(RepAtom((Atom) f)->StrOfAE, bufp);
2056 if (pe->ArityOfPE == 0) {
2057 Int i = 0, arity = pe->ArityOfPE;
2058 if (opnum == _or_last || opnum == _or_else) {
2059 /* skip, it should be in the list as an environment }
2060 Yap_plwrite(MkAtomTerm(NameOfFunctor(f)), GLOBAL_Stream + 2, 0, 0,
2061 GLOBAL_MaxPriority);
2062 fputc('(', stderr);
2063 for (i = 0; i < arity; i++) {
2064 if (i > 0)
2065 fputc(',', stderr);
2066 fputc('_', stderr);
2067 }
2068 fputs(") :- ... ( _ ; _ ", stderr);
2069 */
2070 } else {
2071 Term *args = &(b_ptr->cp_a1);
2072 ADDBUF(snprintf(lbuf, lbufsz, "%s(", RepAtom(NameOfFunctor(pe->FunctorOfPred))->StrOfAE));
2073 for (i = 0; i < arity; i++) {
2074 if (i > 0)
2075 ADDSTR(", ", bufp);
2076
2077 char *b = Yap_TermToBuffer(args[i], 0);
2078 if (!b)
2079 return false;
2080 ADDSTR(b, bufp);
2081 }
2082 ADDSTR(") ", bufp);
2083 }
2084 }
2085 ADDSTR("\n", bufp);
2086 }
2087 return true;
2088}
2089
2090char *DumpActiveGoals(USES_REGS1) {
2091 /* try to dump active goals */
2092 void *ep = YENV; /* and current environment */
2093 void *cp = B;
2094 PredEntry *pe;
2095 int lvl = push_text_stack();
2096 struct buf_struct_t buf0, *bufp = &buf0;
2097
2098 buf = Malloc(4096);
2099 lbuf = buf;
2100 bufsize = 4096;
2101 lbufsz = bufsize - 256;
2102 if (legal_env(YENV PASS_REGS) && YENV < ENV)
2103 ep = YENV;
2104 else if (legal_env(ENV PASS_REGS))
2105 ep = ENV;
2106 while (true) {
2107 if (!ONHEAP(cp) || (Unsigned(cp) & (sizeof(CELL) - 1)))
2108 break;
2109 PELOCK(71, pe);
2110 if (pe->KindOfPE & 0xff00) {
2111 UNLOCK(pe->PELock);
2112 break;
2113 }
2114 if (cp <= ep) {
2115 choiceptr p = cp;
2116 pe = choicepoint_owner(p, NULL, NULL);
2117 outputcp(p, bufp);
2118 cp = p->cp_b;
2119 if (cp == ep) {
2120 CELL *e = ep;
2121 ep = (void *) e[E_E];
2122 }
2123 cp = p;
2124 } else {
2125 CELL *e = ep;
2126 pe = EnvPreg((yamop *) e);
2127 if (!outputep(e, bufp))
2128 break;
2129 ep = (void *) e[E_E];
2130 }
2131 }
2132 return pop_output_text_stack(lvl, buf);
2133}
2134
2135char *DumpStack(USES_REGS1) {
2136 char *s = DumpActiveGoals(PASS_REGS1);
2137 fputs(s, stderr);
2138 fflush(stderr);
2139 return s;
2140}
2141
2146char *Yap_output_bug_location(yamop *yap_pc, int where_from, int psize) {
2147 Atom pred_name;
2148 UInt pred_arity;
2149 Term pred_module;
2150 PredEntry *pred;
2151 Int cl;
2152
2153 char *o = Malloc(256);
2154 if ((pred = Yap_PredForCode(yap_pc, where_from, &cl)) == NULL) {
2155 /* system predicate */
2156 snprintf(o, 255, "%% %s", "meta-call");
2157 } else {
2158 pred_arity = pred->ArityOfPE;
2159 pred_module = pred->ModuleOfPred;
2160 pred_name = NameOfPred(pred);
2161 if (pred_module == 0) {
2162 snprintf(o, 255, "in prolog:%s/%lu", RepAtom(pred_name)->StrOfAE,
2163 (unsigned long int) pred_arity);
2164 } else if (cl < 0) {
2165 snprintf(o, 255, "%% %s:%s/%lu", RepAtom(AtomOfTerm(pred_module))->StrOfAE,
2166 RepAtom(pred_name)->StrOfAE, (unsigned long int) pred_arity);
2167 } else {
2168 snprintf(o, 255, "%% %s:%s/%lu at clause %lu",
2169 RepAtom(AtomOfTerm(pred_module))->StrOfAE,
2170 RepAtom(pred_name)->StrOfAE, (unsigned long int) pred_arity,
2171 (unsigned long int) cl);
2172 }
2173 }
2174 return o;
2175}
2176
2177static yap_error_descriptor_t *add_bug_location(yap_error_descriptor_t *p,
2178 yamop *codeptr, PredEntry *pe) {
2179 CACHE_REGS
2180 if (pe->ModuleOfPred == PROLOG_MODULE)
2181 p->prologPredModule = AtomName(AtomProlog);
2182 else
2183 p->prologPredModule = AtomName(AtomOfTerm(pe->ModuleOfPred));
2184 if (pe->ArityOfPE)
2185 p->prologPredName = AtomName(NameOfFunctor(pe->FunctorOfPred));
2186 else
2187 p->prologPredName = AtomName((Atom) (pe->FunctorOfPred));
2188 p->prologPredArity = pe->ArityOfPE;
2189 p->prologPredFile = AtomName(pe->src.OwnerFile);
2190 p->prologPredLine = 0;
2191 if (pe->src.OwnerFile) {
2192 if (pe->PredFlags & MegaClausePredFlag) {
2193 MegaClause *mcl;
2194 mcl = ClauseCodeToMegaClause(pe->cs.p_code.FirstClause);
2195 p->prologPredLine = mcl->ClLine;
2196 } else {
2197 void *clcode;
2198 if (find_code_in_clause(pe, codeptr, &clcode, NULL) > 0) {
2199 if (pe->PredFlags & LogUpdatePredFlag) {
2200 LogUpdClause *cl = clcode;
2201
2202 if (cl->ClFlags & FactMask) {
2203 p->prologPredLine = cl->lusl.ClSource->ag.line_number;
2204 }
2205 } else if (pe->PredFlags & DynamicPredFlag) {
2206
2207 p->prologPredLine = 0;
2208 } else {
2209 StaticClause *cl;
2210 cl = clcode;
2211
2212 if (cl->ClFlags & FactMask) {
2213 p->prologPredLine = MkIntTerm(cl->usc.ClLine);
2214 } else if (cl->ClFlags & SrcMask) {
2215 p->prologPredLine = cl->usc.ClSource->ag.line_number;
2216 } else
2217 p->prologPredLine = 0;
2218 }
2219 } else {
2220 p->prologPredLine = 0;
2221 }
2222 }
2223 } else if (pe->OpcodeOfPred == UNDEF_OPCODE) {
2224 p->prologPredFile = "undefined";
2225 } else {
2226 // by default, user_input
2227 p->prologPredFile = AtomName(AtomUserIn);
2228 p->prologPredLine = 0;
2229 }
2230 return p;
2231}
2232
2233yap_error_descriptor_t *Yap_pc_add_location(yap_error_descriptor_t *t,
2234 void *pc0, void *b_ptr0,
2235 void *env0) {
2236 CACHE_REGS
2237 yamop *xc = pc0;
2238 // choiceptr b_ptr = b_ptr0;
2239 // CELL *env = env0;
2240
2241 PredEntry *pe;
2242 if (PP == NULL) {
2243 if ((pe = Yap_PredForCode(xc, 0, NULL)) == NULL)
2244 return NULL;
2245 } else
2246 pe = PP;
2247 if (pe != NULL
2248 // pe->ModuleOfPred != PROLOG_MODULE &&
2249 // &&!(pe->PredFlags & HiddenPredFlag)
2250 ) {
2251 return add_bug_location(t, xc, pe);
2252 }
2253 return NULL;
2254}
2255
2256yap_error_descriptor_t *Yap_env_add_location(yap_error_descriptor_t *t,
2257 void *cp0, void *b_ptr0,
2258 void *env0, YAP_Int ignore_first) {
2259 yamop *cp = cp0;
2260 choiceptr b_ptr = b_ptr0;
2261 CELL *env = env0;
2262 while (true) {
2263 if (b_ptr == NULL || env == NULL)
2264 return NULL;
2265 PredEntry *pe = EnvPreg(cp);
2266 if (pe == PredTrue)
2267 return NULL;
2268 if (ignore_first <= 0 &&
2269 pe
2270 // pe->ModuleOfPred != PROLOG_MODULE &&s
2271 && !(pe->PredFlags & HiddenPredFlag)) {
2272 return add_bug_location(t, cp, pe);
2273 } else {
2274 if (NULL && b_ptr && b_ptr->cp_env < env) {
2275 cp = b_ptr->cp_cp;
2276 env = b_ptr->cp_env;
2277 b_ptr = b_ptr->cp_b;
2278 } else {
2279 cp = (yamop *) env[E_CP];
2280 env = ENV_Parent(env);
2281 }
2282 ignore_first--;
2283 }
2284 }
2285}
2286
2287/*
2288 Term Yap_env_location(yamop *cp, choiceptr b_ptr, CELL *env, Int ignore_first)
2289 { while (true) { if (b_ptr == NULL || env == NULL) return TermNil; PredEntry
2290 *pe = EnvPreg(cp); if (pe == PredTrue) return TermNil; if (ignore_first <= 0
2291 && pe
2292 // pe->ModuleOfPred != PROLOG_MODULE &&s
2293 && !(pe->PredFlags & HiddenPredFlag)) {
2294 return add_bug_location(cp, pe);
2295 } else {
2296 if (NULL && b_ptr && b_ptr->cp_env < env) {
2297 cp = b_ptr->cp_cp;
2298 env = b_ptr->cp_env;
2299 b_ptr = b_ptr->cp_b;
2300 } else {
2301 cp = (yamop *)env[E_CP];
2302 env = ENV_Parent(env);
2303 }
2304 ignore_first--;
2305 }
2306 }
2307 }
2308*/
2309
2310
2311#if 0
2312static Term mkloc(yap_error_descriptor_t *t) { return TermNil; }
2313
2314
2315static Int /* $parent_pred(Module, Name, Arity) */
2316parent_pred(USES_REGS1) {
2317 /* This predicate is called from the debugger.
2318 We assume a sequence of the form a -> b */
2319 PredEntry *pe;
2320 Int cl;
2321 if (!(pe = Yap_PredForCode(P_before_spy, 0, &cl))) {
2322 return false;
2323 }
2324 return UnifyPredInfo(pe, 2);
2325}
2326
2327static Int clause_location(USES_REGS1) {
2328 yap_error_descriptor_t t;
2329 memset(&t, 0, sizeof(yap_error_descriptor_t));
2330 return Yap_unify(mkloc(Yap_pc_add_location(&t, P, B, ENV)), ARG1) &&
2331 Yap_unify(mkloc(Yap_env_add_location(&t, CP, B, ENV, 1)), ARG2);
2332}
2333
2334 static Int ancestor_location(USES_REGS1) {
2335 yap_error_descriptor_t t;
2336 memset(&t, 0, sizeof(yap_error_descriptor_t));
2337 return Yap_unify(mkloc(Yap_env_add_location(&t, CP, B, ENV, 2)), ARG2) &&
2338 Yap_unify(mkloc(Yap_env_add_location(&t, CP, B, ENV, 3)), ARG2);
2339}
2340#endif
2341
2342static int Yap_DebugDepthMax = 4;
2343
2344void ShowTerm(Term *tp, int depth) {
2345 if (depth == Yap_DebugDepthMax) return;
2346 Term t = *tp;
2347 if (IsVarTerm(t)) {
2348 fprintf(stderr, "R%ld", tp - HR);
2349 if (t == *(CELL *) t) fprintf(stderr, "->V ");
2350 else {
2351 fprintf(stderr, "->");
2352 ShowTerm((CELL *) t, depth);
2353 }
2354 } else if (IsAtomTerm(t)) {
2355 fprintf(stderr, "A:%ld(%s) ", tp - HR, RepAtom(AtomOfTerm(t))->StrOfAE);
2356 } else if (IsIntTerm(t)) {
2357 fprintf(stderr, "I:%ld(%ld) ", tp - HR, IntOfTerm(t));
2358 } else if (IsPairTerm(t)) {
2359 fprintf(stderr, "A:%ld([...]) ", tp - HR);
2360 fprintf(stderr, "\n%*c", depth << 2, ' ');
2361 ShowTerm(RepPair(t), depth + 1);
2362 fprintf(stderr, "\n%*c", depth << 2, ' ');
2363 ShowTerm(RepPair(t) + 1, depth + 1);
2364 } else {
2365 fprintf(stderr, "A:%ld(%lx) ", tp - HR, *RepAppl(t));
2366 if (!IsVarTerm(*RepAppl(t))) return;
2367 Functor f = FunctorOfTerm(t);
2368 arity_t n = ArityOfFunctor(f);
2369
2370 fprintf(stderr, "\n%*c", depth << 2, ' ');
2371 if (IsExtensionFunctor(f)) Yap_DebugPlWriteln(t);
2372 else {
2373 int i;
2374 fprintf(stderr, "\n%*c", depth << 2, ' ');
2375 fprintf(stderr, "%s/%ld\n", RepAtom(NameOfFunctor(f))->StrOfAE, n);
2376 for (i = 0; i < n; i++) {
2377 fprintf(stderr, "\n%*c", depth << 2, ' ');
2378 ShowTerm(RepPair(t) + (i + 1), depth + 1);
2379 }
2380 }
2381 }
2382}
2383
2384
2385void Yap_ShowTerm(Term t) {
2386 *HR++ = t;
2387 ShowTerm(HR - 1, 0);
2388}
2389
2390
2391#if GC_NO_TAGS
2392#define NOGC(t) t
2393#else
2394#define NOGC(t) (t & ~(MBIT|RBIT))
2395#endif
2396
2397static void line(int c, bool hid, int lvl, void *src, void *tgt, const char s0[], const char s[]) {
2398 fprintf(stderr, "%c %c%p%*c %s%s\n", c, hid ? '*' : ' ', src, lvl, ' ', s0, s);
2399}
2400
2401static void entry(int c, bool hid, int lvl, void *src, void *tgt, const char is0[], char is[]) {
2402 char s0[1024];
2403 strcpy(s0,is0);
2404 char s[1024];
2405 strcpy(s,is);
2406 Term t = NOGC(*(CELL*)tgt);
2407 if (IsVarTerm(t)) {
2408 CELL *v = (CELL *) t;
2409 if (false && IsAttVar(v)) {
2410 fputs("ATT V:\n", stderr);
2411 //pp__(&RepAttVar(v),lvl+1);
2412 return;
2413 }
2414 if (t == (CELL) v) {
2415 strcat(s0, "V=");
2416 } else {
2417 strcat(s0, "R=*");
2418 }
2419 if (v < HR)
2420 sprintf(s+strlen(s), "_H%ld\n", v - (CELL*)tgt);
2421 else
2422 sprintf(s+strlen(s), "_L%ld\n", v-(CELL*)tgt);
2423 line(c, hid, lvl, v, v, s0, s);
2424 } else if (IsAtomTerm(t)) {
2425 sprintf(s+strlen(s), "%s", RepAtom(AtomOfTerm(t))->StrOfAE);
2426 line(c, hid, lvl, tgt, tgt, "at=", s);
2427 } else if (IsIntTerm(t)) {
2428 // int
2429 sprintf(s+strlen(s), "%ld", IntOfTerm(t));
2430 line(c, hid, lvl, tgt, tgt, "int=", s);
2431 } else if (IsApplTerm(t)) {
2432 Functor f = (Functor) NOGC(RepAppl(t)[0]);
2433 if (IsExtensionFunctor(f)) {
2434 line(c, hid, lvl, tgt, RepAppl(t), "( blob )", "");
2435 }
2436 CELL *v = RepAppl(t);
2437 sprintf(s+strlen(s), "%ld\n", v - (CELL*)tgt);
2438 line(c, hid, lvl, tgt, tgt, "appl=", s);
2439 }
2440 CELL *v = RepPair(t);
2441 sprintf(s+strlen(s), "%ld\n", v - (CELL*)tgt);
2442 line(c, hid, lvl, tgt, tgt, "list=", s);
2443}
2444
2445
2446void pp__(Term *tp, int lvl, char *s0, char *s) {
2447 int i, c;
2448 if (lvl > 6)
2449 return;
2450 Term t = NOGC(tp[0]);
2451 bool hid = false;
2452 s[10] = s0[0] = '\0';
2453 if (t == *tp) c = 'G';
2454 else c = ' ';
2455 if (IsPairTerm(t)) {
2456 /* if ((void *) RepPair(t) >= (void *) (LOCAL_WorkerBuffer.data) && */
2457 /* (void *) RepPair(t) < (void *) (LOCAL_WorkerBuffer.data + LOCAL_WorkerBuffer.sz)) { */
2458 /* copy_frame *cp = ((copy_frame *) RepPair(t)); */
2459 /* t = cp->oldv; */
2460 /* hid = true; */
2461 /* goto restart; */
2462 /* } */
2463 entry(c, hid, lvl, tp, RepPair(t), "", "[");
2464 entry(c, hid, lvl, tp, RepPair(t)+1, "", "]");
2465 pp__(RepPair(t), lvl + 2, s0, s);
2466 pp__(RepPair(t) + 1, lvl + 2, s0, s);
2467 } else {
2468 Functor f = (Functor) NOGC(RepAppl(t)[0]);
2469 if (IsPairTerm((CELL) f)) {
2470 copy_frame *cp = ((copy_frame *) RepPair((CELL) f));
2471 hid = true;
2472 f = (Functor) (cp->oldv);
2473 }
2474 if (!IsExtensionFunctor(f)) {
2475 arity_t a = ArityOfFunctor(f);
2476 snprintf(s, 4095, "%s/%ld(", RepAtom(NameOfFunctor(f))->StrOfAE, a);
2477 for (i = 1; i < a; i++) {
2478 entry(c, hid, lvl, tp, RepPair(t)+i, "", "");
2479 }
2480 entry(c, hid, lvl, tp,RepPair(t)+i , "", ")");
2481 for (i = 1; i <= a; i++) {
2482 pp__(RepAppl(t) + i, lvl + 2, s0, s);
2483 }
2484 }
2485 }
2486}
2487
2488void pp(Term t) {
2489 char *s = malloc(4096), *s0 = malloc(4096);
2490 pp__(&t, 0, s, s0);
2491 free(s);
2492 free(s0);
2493}
2494
2495
2496static bool JumpToEnv(USES_REGS1) {
2497 /* just keep the throwm object away, we don't need to care about it
2498 */
2499 /* careful, previous step may have caused a stack shift,
2500 so get pointers here */
2501 /* find the first choicepoint that may be a catch */
2502 // DBTerm *dbt = Yap_RefToException();
2503 if (LOCAL_PrologMode & AsyncIntMode) {
2504 Yap_signal(YAP_FAIL_SIGNAL);
2505 }
2506 P = FAILCODE;
2507
2508 /* just keep the thrown object away, we don't need to care about
2509 it
2510 */
2511 /* careful, previous step may have caused a stack shift,
2512 so get pointers here */
2513 /* find the first choicepoint that may be a catch */
2514 // DBTerm *dbt = Yap_RefToException();
2515 // choiceptr cborder = (choiceptr)(LCL0 - LOCAL_CBorder), pruned;
2516
2517 // first, we re already there,
2518 LOCAL_DoingUndefp = false;
2519 while (B) {
2520 if ( B->cp_ap->y_u.Otapl.p == PredCatch &&
2521 LOCAL_ActiveError->errorNo != ABORT_EVENT) {
2522 Yap_RestartYap(5);
2523 }
2524 if (B->cp_ap == NOCODE) {
2525 return false;
2526 }
2527 B=B->cp_b;
2528 }
2529}
2530
2531//
2532// throw has to be *exactly* after system catch!
2533//
2542bool Yap_JumpToEnv(void ) {
2543 CACHE_REGS
2544
2545 return
2546 JumpToEnv(PASS_REGS);
2547 }
2548
2549/* This does very nasty stuff!!!!! */
2550static Int yap_throw(USES_REGS1) {
2551 Term t = Deref(
2552 ARG1);
2553 if (t == TermDAbort)
2554 Yap_ThrowError( ABORT_EVENT, TermDAbort, NULL);
2555 if (IsVarTerm(t)) {
2556 Yap_ThrowError(INSTANTIATION_ERROR, t,
2557 "throw/1 must be called instantiated");
2558 }
2559 memset(LOCAL_ActiveError, 0, sizeof(yap_error_descriptor_t)); if (IsApplTerm(t) && FunctorOfTerm(t) == FunctorError) {
2560 Term t2 = ArgOfTerm(2,t);
2561 if (IsVarTerm(t2)) {
2562 LOCAL_ActiveError->errorUserTerm = ARG1;
2563 }
2564
2565 t = Yap_MkPrologError(t,NULL);
2566 } else {
2567 LOCAL_ActiveError->errorNo = USER_DEFINED_EVENT;
2568 LOCAL_ActiveError->errorUserTerm = Yap_SaveTerm(t);
2569 t = Yap_MkPrologError(t,NULL);
2570 }
2571 Yap_JumpToEnv();
2572 return false;
2573}
2574
2575void Yap_InitStInfo(void) {
2576 CACHE_REGS
2577 Term cm = CurrentModule;
2578
2579 Yap_InitCPred("throw", 1, yap_throw,
2580 TestPredFlag | SafePredFlag | SyncPredFlag);
2581 Yap_InitCPred("in_use", 2, in_use,
2582 HiddenPredFlag | TestPredFlag | SafePredFlag | SyncPredFlag);
2583#ifndef THREADS
2584 Yap_InitCPred("toggle_static_predicates_in_use", 0,
2585 toggle_static_predicates_in_use,
2586 HiddenPredFlag | SafePredFlag | SyncPredFlag);
2587#endif
2588 CurrentModule = HACKS_MODULE;
2589 Yap_InitCPred("current_choice_points", 1, p_all_choicepoints, 0);
2590 Yap_InitCPred("current_continuations", 1, p_all_envs, 0);
2591 Yap_InitCPred("choicepoint", 7, p_choicepoint_info, 0);
2592 Yap_InitCPred("continuation", 4, env_info, 0);
2593 Yap_InitCPred("cp_to_predicate", 5, p_cpc_info, 0);
2594 CurrentModule = cm;
2595 Yap_InitCPred("current_stack", 1, current_stack, HiddenPredFlag);
2596}
Yap.h
Main definitions.
Malloc
void * Malloc(size_t sz USES_REGS)
allocate a temporary text block
Definition: alloc.c:1759
copy_frame
Definition: utilpreds.c:517
Yap_PredForCode
PredEntry * Yap_PredForCode(yamop *codeptr, find_pred_type hint, Int *cl)
given an arbitrary code point codeptr search the database for the owner predicate pp identifying the ...
Definition: stack.c:730
Yap_PredForChoicePt
PredEntry * Yap_PredForChoicePt(choiceptr cp, op_numbers *op)
Yap_v<<ChoicePt(): find out the predicate who generated a CP.
Definition: stack.c:307
Yap_output_bug_location
char * Yap_output_bug_location(yamop *yap_pc, int where_from, int psize)
Used for debugging.
Definition: stack.c:2146
__cp_frame
Definition: stack.c:53
buf_struct_t
Definition: stack.c:1747
clause_info_struct
Definition: amasm.c:216
dynamic_clause
Definition: clause.h:101
logic_upd_clause
Definition: clause.h:64
logic_upd_index
Definition: clause.h:46
mod_entry
Module property: low-level data used to manage modes.
Definition: Yatom.h:209
mod_entry::NextME
struct mod_entry * NextME
Module local flags (from SWI compat)
Definition: Yatom.h:220
mod_entry::PredForME
struct pred_entry * PredForME
kind of property
Definition: Yatom.h:212
pred_entry
Definition: Yatom.h:544
s_yap_error_descriptor
all we need to know about an error/throw
Definition: YapError.h:205
static_clause
Definition: clause.h:127
static_index
Definition: clause.h:116
static_mega_clause
Definition: clause.h:140
yami
Definition: amidefs.h:264
clause_obj
Definition: clause.h:152