YAP 7.1.0
dbase.c
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: dbase.c *
12* Last rev: 8/2/88 *
13* mods: *
14* comments: YAP's internal data base *
15* *
16*************************************************************************/
17#ifdef SCCS
18static char SccsId[] = "%W% %G%";
19#endif
20
99#include "Yap.h"
100#include "attvar.h"
101#include "clause.h"
102#include "heapgc.h"
103#include "yapio.h"
104#if HAVE_STRING_H
105#include <string.h>
106#endif
107#if HAVE_STRING_H
108#include <string.h>
109#endif
110#include <stdlib.h>
111
112/* There are two options to implement traditional immediate update semantics.
113
114 - In the first option, we only remove an element of the chain when
115 it is physically disposed of. This simplifies things, because
116 pointers are always valid, but it complicates some stuff a bit:
117
118 o You may have go through long lines of deleted db entries before you
119 actually reach the one you want.
120
121 o Deleted clauses are also not removed of the chain. The solution
122 was to place a fail in every clause, but you still have to
123 backtrack through failed clauses.
124
125 An alternative solution is to remove clauses from the chain, even
126 if they are still phisically present. Unfortunately this creates
127 problems because immediate update semantics means you have to
128 backtrack clauses or see the db entries stored later.
129
130 There are several solutions. One of the simplest is to use an age
131 counter. When you backtrack to a removed clause or to a deleted db
132 entry you use the age to find newly entered clauses in the DB.
133
134 This still causes a problem when you backtrack to a deleted
135 clause, because clauses are supposed to point to the next
136 alternative, and having been removed from the chain you cannot
137 point there directly. One solution is to have a predicate in C that
138 recovers the place where to go to and then gets rid of the clause.
139
140*/
141
142#define DISCONNECT_OLD_ENTRIES 1
143
144#ifdef MACYAPBUG
145#define Register
146#else
147#define Register register
148#endif
149
150/* Flags for recorda or recordz */
151/* MkCode should be the same as CodeDBProperty */
152#define MkFirst 1
153#define MkCode CodeDBBit
154#define MkLast 4
155#define WithRef 8
156#define MkIfNot 16
157#define InQueue 32
158
159#define FrstDBRef(V) ((V)->First)
160#define NextDBRef(V) ((V)->Next)
161
162#define DBLength(V) (sizeof(DBStruct) + (Int)(V) + CellSize)
163#define AllocDBSpace(V) ((DBRef)Yap_AllocCodeSpace(V))
164#define FreeDBSpace(V) Yap_FreeCodeSpace(V)
165
166#if SIZEOF_INT_P == 4
167#define ToSmall(V) ((link_entry)(Unsigned(V) >> 2))
168#else
169#define ToSmall(V) ((link_entry)(Unsigned(V) >> 3))
170#endif
171
172#ifdef SFUNC
173
174#define MaxSFs 256
175
176typedef struct {
177 Term SName; /* The culprit */
178 CELL *SFather; /* and his father's position */
179} SFKeep;
180#endif
181
182#define HashFieldMask ((CELL)0xffL)
183#define DualHashFieldMask ((CELL)0xffffL)
184#define TripleHashFieldMask ((CELL)0xffffffL)
185#define FourHashFieldMask ((CELL)0xffffffffL)
186
187#define ONE_FIELD_SHIFT 8
188#define TWO_FIELDS_SHIFT 16
189#define THREE_FIELDS_SHIFT 24
190
191#define AtomHash(t) (Unsigned(t) >> 4)
192#define FunctorHash(t) (Unsigned(t) >> 4)
193#define NumberHash(t) (Unsigned(IntOfTerm(t)))
194
195#define LARGE_IDB_LINK_TABLE 1
196
197/* traditionally, YAP used a link table to recover IDB terms*/
198#if LARGE_IDB_LINK_TABLE
199typedef BITS32 link_entry;
200#define SIZEOF_LINK_ENTRY 4
201#else
202typedef BITS16 link_entry;
203#define SIZEOF_LINK_ENTRY 2
204#endif
205
206/* These global variables are necessary to build the data base
207 structure */
208typedef struct db_globs {
209 link_entry *lr, *LinkAr;
210 /* we cannot call Error directly from within recorded(). These flags are used
211 to delay for a while
212 */
213 DBRef *tofref; /* place the refs also up */
214#ifdef SFUNC
215 CELL *FathersPlace; /* Where the father was going when the term
216 * was reached */
217 SFKeep *SFAr, *TopSF; /* Where are we putting our SFunctors */
218#endif
219 DBRef found_one; /* Place where we started recording */
220 UInt sz; /* total size */
221} dbglobs;
222
223#ifdef SUPPORT_HASH_TABLES
224typedef struct {
225 CELL key;
226 DBRef entry;
227} hash_db_entry;
228
229typedef table {
230 Int NOfEntries;
231 Int HashArg;
232 hash_db_entry *table;
233}
234hash_db_table;
235#endif
236
237static CELL *cpcells(CELL *, CELL *, Int);
238static void linkblk(link_entry *, CELL *, CELL);
239static Int cmpclls(CELL *, CELL *, Int);
240static Prop FindDBProp(AtomEntry *, int, unsigned int, Term);
241static CELL CalcKey(Term);
242#ifdef COROUTINING
243static CELL *MkDBTerm(CELL *, CELL *, CELL *, CELL *, CELL *, CELL *, int *,
244 struct db_globs *);
245#else
246static CELL *MkDBTerm(CELL *, CELL *, CELL *, CELL *, CELL *, int *,
247 struct db_globs *);
248#endif
249static DBRef CreateDBStruct(Term, DBProp, int, int *, UInt, struct db_globs *);
250static DBRef record(int, Term, Term, Term CACHE_TYPE);
251static DBRef check_if_cons(DBRef, Term);
252static DBRef check_if_var(DBRef);
253static DBRef check_if_wvars(DBRef, unsigned int, CELL *);
254static int scheckcells(int, CELL *, CELL *, link_entry *, CELL);
255static DBRef check_if_nvars(DBRef, unsigned int, CELL *, struct db_globs *);
256static Int p_rcda(USES_REGS1);
257static Int p_rcdap(USES_REGS1);
258static Int p_rcdz(USES_REGS1);
259static Int p_rcdzp(USES_REGS1);
260static Int p_drcdap(USES_REGS1);
261static Int p_drcdzp(USES_REGS1);
262static Term GetDBTerm(DBTerm *, int src CACHE_TYPE);
263static DBProp FetchDBPropFromKey(Term, int, int, char *);
264static Int i_recorded(DBProp, Term CACHE_TYPE);
265static Int c_recorded(int CACHE_TYPE);
266static Int co_rded(USES_REGS1);
267static Int in_rdedp(USES_REGS1);
268static Int co_rdedp(USES_REGS1);
269static Int p_first_instance(USES_REGS1);
270static void ErasePendingRefs(DBTerm *CACHE_TYPE);
271static void RemoveDBEntry(DBRef CACHE_TYPE);
272static void EraseLogUpdCl(LogUpdClause *);
273static void MyEraseClause(DynamicClause *CACHE_TYPE);
274static void PrepareToEraseClause(DynamicClause *, DBRef);
275static void EraseEntry(DBRef);
276static Int p_erase(USES_REGS1);
277static Int p_eraseall(USES_REGS1);
278static Int p_erased(USES_REGS1);
279static Int p_instance(USES_REGS1);
280static int NotActiveDB(DBRef);
281static DBEntry *NextDBProp(PropEntry *);
282static Int init_current_key(USES_REGS1);
283static Int cont_current_key(USES_REGS1);
284static Int cont_current_key_integer(USES_REGS1);
285static Int p_rcdstatp(USES_REGS1);
286static Int p_somercdedp(USES_REGS1);
287static yamop *find_next_clause(DBRef USES_REGS);
288static Int p_jump_to_next_dynamic_clause(USES_REGS1);
289#ifdef SFUNC
290static void SFVarIn(Term);
291static void sf_include(SFKeep *);
292#endif
293static Int p_init_queue(USES_REGS1);
294static Int p_enqueue(USES_REGS1);
295static void keepdbrefs(DBTerm *CACHE_TYPE);
296static Int p_dequeue(USES_REGS1);
297static void ErDBE(DBRef CACHE_TYPE);
298static void ReleaseTermFromDB(DBTerm *CACHE_TYPE);
299static PredEntry *new_lu_entry(Term);
300static PredEntry *new_lu_int_key(Int);
301static PredEntry *find_lu_entry(Term);
302static DBProp find_int_key(Int);
303
304#define db_check_trail(x) \
305 { \
306 if (Unsigned(dbg->tofref) == Unsigned(x)) { \
307 goto error_tr_overflow; \
308 } \
309 }
310
311static UInt new_trail_size(void) {
312 CACHE_REGS
313 UInt sz = (LOCAL_TrailTop - (ADDR)TR) / 2;
314 if (sz < K64)
315 return K64;
316 if (sz > M1)
317 return M1;
318 return sz;
319}
320
321static int recover_from_record_error(int nargs) {
322 CACHE_REGS
323 switch (LOCAL_Error_TYPE) {
324 case RESOURCE_ERROR_STACK:
325 if (!Yap_dogc()) {
326 Yap_ThrowError(RESOURCE_ERROR_STACK, TermNil, LOCAL_ErrorMessage);
327 return FALSE;
328 }
329 goto recover_record;
330 case RESOURCE_ERROR_TRAIL:
331 if (!Yap_growtrail(new_trail_size(), FALSE)) {
332 Yap_ThrowError(RESOURCE_ERROR_TRAIL, TermNil,
333 "YAP could not grow trail in recorda/3");
334 return FALSE;
335 }
336 goto recover_record;
337 case RESOURCE_ERROR_HEAP:
338 if (!Yap_growheap(FALSE, LOCAL_Error_Size, NULL)) {
339 Yap_ThrowError(RESOURCE_ERROR_HEAP, TermNil, LOCAL_ErrorMessage);
340 return FALSE;
341 }
342 goto recover_record;
343 case RESOURCE_ERROR_AUXILIARY_STACK:
344 if (!Yap_ExpandPreAllocCodeSpace(LOCAL_Error_Size, NULL, TRUE)) {
345 Yap_ThrowError(RESOURCE_ERROR_AUXILIARY_STACK, TermNil, LOCAL_ErrorMessage);
346 return FALSE;
347 }
348 goto recover_record;
349 default:
350 Yap_ThrowError(LOCAL_Error_TYPE, TermNil, LOCAL_ErrorMessage);
351 return FALSE;
352 }
353recover_record:
354 LOCAL_Error_Size = 0;
355 LOCAL_Error_TYPE = YAP_NO_ERROR;
356 return TRUE;
357}
358
359#ifdef SUPPORT_HASH_TABLES
360/* related property and hint on number of entries */
361static void create_hash_table(DBProp p, Int hint) {
362 int off = sizeof(CELL) * 4, out;
363 Int size;
364
365 if (hint < p->NOfEntries)
366 hint = p->NOfEntries;
367 while (off) {
368 Int limit = ((CELL)1) << (off);
369 if (inp >= limit) {
370 out += off;
371 inp >>= off;
372 }
373 off >>= 1;
374 }
375 if ((size = ((CELL)1) << out) < hint)
376 hint <<= 1;
377 /* clean up the table */
378 pt = tbl = (hash_db_entry *)AllocDBSpace(hint * sizeof(hash_db_entry));
379 Yap_LUClauseSpace += hint * sizeof(hash_db_entry);
380 for (i = 0; i < hint; i++) {
381 pt->key = NULL;
382 pt++;
383 }
384 /* next insert the entries */
385}
386
387static void insert_in_table() {}
388
389static void remove_from_table() {}
390#endif
391
392inline static CELL *cpcells(CELL *to, CELL *from, Int n) {
393#if HAVE_MEMMOVE
394 memmove((void *)to, (void *)from, (size_t)(n * sizeof(CELL)));
395 return (to + n);
396#else
397 while (n-- >= 0) {
398 *to++ = *from++;
399 }
400 return (to);
401#endif
402}
403
404static void linkblk(link_entry *r, CELL *c, CELL offs) {
405 CELL p;
406 while ((p = (CELL)*r) != 0) {
407 Term t = c[p];
408 r++;
409 c[p] = AdjustIDBPtr(t, offs);
410 }
411}
412
413static Int cmpclls(CELL *a, CELL *b, Int n) {
414 while (n-- > 0) {
415 if (*a++ != *b++)
416 return FALSE;
417 }
418 return TRUE;
419}
420
421/* get DB entry for ap/arity; */
422static Prop FindDBPropHavingLock(AtomEntry *ae, int CodeDB, unsigned int arity,
423 Term dbmod) {
424 Prop p0;
425 DBProp p;
426
427 p = RepDBProp(p0 = ae->PropsOfAE);
428 while (p0 &&
429 (((p->KindOfPE & ~0x1) != (CodeDB | DBProperty)) ||
430 (p->ArityOfDB != arity) ||
431 ((CodeDB & MkCode) && p->ModuleOfDB && p->ModuleOfDB != dbmod))) {
432 p = RepDBProp(p0 = p->NextOfPE);
433 }
434 return p0;
435}
436
437/* get DB entry for ap/arity; */
438static Prop FindDBProp(AtomEntry *ae, int CodeDB, unsigned int arity,
439 Term dbmod) {
440 Prop out;
441
442 READ_LOCK(ae->ARWLock);
443 out = FindDBPropHavingLock(ae, CodeDB, arity, dbmod);
444 READ_UNLOCK(ae->ARWLock);
445 return (out);
446}
447
448/* These two functions allow us a fast lookup method in the data base */
449/* PutMasks builds the mask and hash for a single argument */
450inline static CELL CalcKey(Term tw) {
451 /* The first argument is known to be instantiated */
452 if (IsApplTerm(tw)) {
453 Functor f = FunctorOfTerm(tw);
454 if (IsExtensionFunctor(f)) {
455 if (f == FunctorDBRef) {
456 return (FunctorHash(tw)); /* Ref */
457 } /* if (f == FunctorLongInt || f == FunctorDouble) */
458 return (NumberHash(RepAppl(tw)[1]));
459 }
460 return (FunctorHash(f));
461 } else if (IsAtomOrIntTerm(tw)) {
462 if (IsAtomTerm(tw)) {
463 return (AtomHash(tw));
464 }
465 return (NumberHash(tw));
466 }
467 return (FunctorHash(FunctorList));
468}
469
470/* EvalMasks builds the mask and hash for up to three arguments of a term */
471static CELL EvalMasks(register Term tm, CELL *keyp) {
472
473 if (IsVarTerm(tm)) {
474 *keyp = 0L;
475 return (0L);
476 } else if (IsApplTerm(tm)) {
477 Functor fun = FunctorOfTerm(tm);
478
479 if (IsExtensionFunctor(fun)) {
480 if (fun == FunctorDBRef) {
481 *keyp = FunctorHash(tm); /* Ref */
482 } else /* if (f == FunctorLongInt || f == FunctorDouble) */ {
483 *keyp = NumberHash(RepAppl(tm)[1]);
484 }
485 return (FourHashFieldMask);
486 } else {
487 unsigned int arity;
488
489 arity = ArityOfFunctor(fun);
490#ifdef SFUNC
491 if (arity == SFArity) { /* do not even try to calculate masks */
492 *keyp = key;
493 return (FourHashFieldMask);
494 }
495#endif
496 switch (arity) {
497 case 1: {
498 Term tw = ArgOfTerm(1, tm);
499
500 if (IsNonVarTerm(tw)) {
501 *keyp = (FunctorHash(fun) & DualHashFieldMask) |
502 (CalcKey(tw) << TWO_FIELDS_SHIFT);
503 return (FourHashFieldMask);
504 } else {
505 *keyp = (FunctorHash(fun) & DualHashFieldMask);
506 return (DualHashFieldMask);
507 }
508 }
509 case 2: {
510 Term tw1, tw2;
511 CELL key, mask;
512
513 key = FunctorHash(fun) & DualHashFieldMask;
514 mask = DualHashFieldMask;
515
516 tw1 = ArgOfTerm(1, tm);
517 if (IsNonVarTerm(tw1)) {
518 key |= ((CalcKey(tw1) & HashFieldMask) << TWO_FIELDS_SHIFT);
519 mask |= (HashFieldMask << TWO_FIELDS_SHIFT);
520 }
521 tw2 = ArgOfTerm(2, tm);
522 if (IsNonVarTerm(tw2)) {
523 *keyp = key | (CalcKey(tw2) << THREE_FIELDS_SHIFT);
524 return (mask | (HashFieldMask << THREE_FIELDS_SHIFT));
525 } else {
526 *keyp = key;
527 return (mask);
528 }
529 }
530 default: {
531 Term tw1, tw2, tw3;
532 CELL key, mask;
533
534 key = FunctorHash(fun) & HashFieldMask;
535 mask = HashFieldMask;
536
537 tw1 = ArgOfTerm(1, tm);
538 if (IsNonVarTerm(tw1)) {
539 key |= (CalcKey(tw1) & HashFieldMask) << ONE_FIELD_SHIFT;
540 mask |= HashFieldMask << ONE_FIELD_SHIFT;
541 }
542 tw2 = ArgOfTerm(2, tm);
543 if (IsNonVarTerm(tw2)) {
544 key |= (CalcKey(tw2) & HashFieldMask) << TWO_FIELDS_SHIFT;
545 mask |= HashFieldMask << TWO_FIELDS_SHIFT;
546 }
547 tw3 = ArgOfTerm(3, tm);
548 if (IsNonVarTerm(tw3)) {
549 *keyp = key | (CalcKey(tw3) << THREE_FIELDS_SHIFT);
550 return (mask | (HashFieldMask << THREE_FIELDS_SHIFT));
551 } else {
552 *keyp = key;
553 return (mask);
554 }
555 }
556 }
557 }
558 } else {
559 CELL key = (FunctorHash(FunctorList) & DualHashFieldMask);
560 CELL mask = DualHashFieldMask;
561 Term th = HeadOfTerm(tm), tt;
562
563 if (IsNonVarTerm(th)) {
564 mask |= (HashFieldMask << TWO_FIELDS_SHIFT);
565 key |= (CalcKey(th) << TWO_FIELDS_SHIFT);
566 }
567 tt = TailOfTerm(tm);
568 if (IsNonVarTerm(tt)) {
569 *keyp = key | (CalcKey(tt) << THREE_FIELDS_SHIFT);
570 return (mask | (HashFieldMask << THREE_FIELDS_SHIFT));
571 }
572 *keyp = key;
573 return (mask);
574 }
575}
576
577CELL Yap_EvalMasks(register Term tm, CELL *keyp) { return EvalMasks(tm, keyp); }
578
579/* Called to inform that a new pointer to a data base entry has been added */
580#define MarkThisRef(Ref) ((Ref)->NOfRefsTo++)
581
582/* From a term, builds its representation in the data base */
583
584/* otherwise, we just need to restore variables*/
585typedef struct { CELL *addr; } visitel;
586#define DB_UNWIND_CUNIF() \
587 while (visited < (visitel *)AuxSp) { \
588 RESET_VARIABLE(visited->addr); \
589 visited++; \
590 }
591
592/* no checking for overflow while building DB terms yet */
593#define CheckDBOverflow(X) \
594 if (CodeMax + X >= (CELL *)visited - 1024) { \
595 goto error; \
596 }
597
598/* no checking for overflow while building DB terms yet */
599#define CheckVisitOverflow() \
600 if ((CELL *)tovisit + 1024 >= ASP) { \
601 goto error2; \
602 }
603
604static CELL *copy_long_int(CELL *st, CELL *pt) {
605 /* first thing, store a link to the list before we move on */
606 st[0] = (CELL)FunctorLongInt;
607 st[1] = pt[1];
608 st[2] = CloseExtension(st);
609 /* now reserve space */
610 return st + 3;
611}
612
613static CELL *copy_double(CELL *st, CELL *pt) {
614 /* first thing, store a link to the list before we move on */
615 st[0] = (CELL)FunctorDouble;
616 st[1] = pt[1];
617#if SIZEOF_DOUBLE == 2 * SIZEOF_INT_P
618 st[2] = pt[2];
619 st[3] = CloseExtension(st);
620#else
621 st[2] = CloseExtension(st);
622#endif
623 /* now reserve space */
624 return st + (2 + SIZEOF_DOUBLE / SIZEOF_INT_P);
625}
626
627static CELL *copy_string(CELL *st, CELL *pt) {
628 UInt sz = pt[1] + 3;
629 /* first thing, store a link to the list before we move on */
630 memcpy(st, pt, sizeof(CELL) * sz);
631 /* now reserve space */
632 return st + sz;
633}
634
635#ifdef USE_GMP
636static CELL *copy_big_int(CELL *st, CELL *pt) {
637 Int sz =
638 sizeof(MP_INT) + (((MP_INT *)(pt + 2))->_mp_alloc * sizeof(mp_limb_t));
639
640 /* first functor */
641 st[0] = (CELL)FunctorBigInt;
642 st[1] = pt[1];
643 /* then the actual number */
644 memcpy((void *)(st + 2), (void *)(pt + 2), sz);
645 st = st + 2 + sz / CellSize;
646 /* then the tail for gc */
647 st[0] = CloseExtension(st);
648 return st + 1;
649}
650#endif /* BIG_INT */
651
652#define DB_MARKED(d0) ((CELL *)(d0) < CodeMax && (CELL *)(d0) >= tbase)
653
654/* This routine creates a complex term in the heap. */
655static CELL *MkDBTerm(register CELL *pt0, register CELL *pt0_end,
656 register CELL *StoPoint, CELL *CodeMax, CELL *tbase,
657#ifdef COROUTINING
658 CELL *attachmentsp,
659#endif
660 int *vars_foundp, struct db_globs *dbg) {
661 CACHE_REGS
662#if THREADS
663#undef Yap_REGS
664 register REGSTORE *regp = Yap_regp;
665#define Yap_REGS (*regp)
666#endif
667 register visitel *visited = (visitel *)AuxSp;
668 /* store this in H */
669 register CELL **tovisit = (CELL **)HR;
670 CELL **tovisit_base = tovisit;
671 /* where we are going to add a new pair */
672 int vars_found = 0;
673#ifdef COROUTINING
674 Term ConstraintsTerm = TermNil;
675 CELL *origH = HR;
676#endif
677 CELL *CodeMaxBase = CodeMax;
678
679loop:
680 while (pt0 <= pt0_end) {
681
682 CELL *ptd0 = pt0;
683 CELL d0 = *ptd0;
684 restart:
685 if (IsVarTerm(d0))
686 goto deref_var;
687
688 if (IsApplTerm(d0)) {
689 register Functor f;
690 register CELL *ap2;
691
692 /* we will need to link afterwards */
693 ap2 = RepAppl(d0);
694#ifdef RATIONAL_TREES
695 if (ap2 >= tbase && ap2 <= StoPoint) {
696 db_check_trail(dbg->lr + 1);
697 *dbg->lr++ = ToSmall((CELL)(StoPoint) - (CELL)(tbase));
698 *StoPoint++ = d0;
699 ++pt0;
700 continue;
701 }
702#endif
703 db_check_trail(dbg->lr + 1);
704 *dbg->lr++ = ToSmall((CELL)(StoPoint) - (CELL)(tbase));
705 f = (Functor)(*ap2);
706 if (IsExtensionFunctor(f)) {
707 switch ((CELL)f) {
708 case (CELL)FunctorDBRef: {
710
711 dbentry = DBRefOfTerm(d0);
712 *StoPoint++ = d0;
713 dbg->lr--;
714 if (dbentry->Flags & LogUpdMask) {
716/* store now the correct entry */
717#if DEBUG
718 if (GLOBAL_Option['i' - 'a' + 1]) {
719 const char *b;
720 Yap_DebugPlWriteln(d0);
721 fprintf(stderr, "+%p@%p %s\n", cl, cl->ClPred,
722 (b=IndicatorOfPred(cl->ClPred)));
723 free((void *)b);
724 }
725#endif
726 cl->ClRefCount++;
727 } else {
728 dbentry->NOfRefsTo++;
729 }
730 *--dbg->tofref = dbentry;
731 db_check_trail(dbg->lr);
732 /* just continue the loop */
733 ++pt0;
734 continue;
735 }
736 case (CELL)FunctorLongInt:
737 CheckDBOverflow(3);
738 *StoPoint++ = AbsAppl(CodeMax);
739 CodeMax = copy_long_int(CodeMax, ap2);
740 ++pt0;
741 continue;
742#ifdef USE_GMP
743 case (CELL)FunctorBigInt:
744 CheckDBOverflow(3 + Yap_SizeOfBigInt(d0));
745 /* first thing, store a link to the list before we move on */
746 *StoPoint++ = AbsAppl(CodeMax);
747 CodeMax = copy_big_int(CodeMax, ap2);
748 ++pt0;
749 continue;
750#endif
751 case (CELL)FunctorString: {
752 CELL *st = CodeMax;
753
754 CheckDBOverflow(3 + ap2[1]);
755 /* first thing, store a link to the list before we move on */
756 *StoPoint++ = AbsAppl(st);
757 CodeMax = copy_string(CodeMax, ap2);
758 ++pt0;
759 continue;
760 }
761 case (CELL)FunctorDouble: {
762 CELL *st = CodeMax;
763
764 CheckDBOverflow(4);
765 /* first thing, store a link to the list before we move on */
766 *StoPoint++ = AbsAppl(st);
767 CodeMax = copy_double(CodeMax, ap2);
768 ++pt0;
769 continue;
770 }
771 }
772 }
773 /* first thing, store a link to the list before we move on */
774 *StoPoint++ = AbsAppl(CodeMax);
775 /* next, postpone analysis to the rest of the current list */
776 CheckVisitOverflow();
777#ifdef RATIONAL_TREES
778 tovisit[0] = pt0 + 1;
779 tovisit[1] = pt0_end;
780 tovisit[2] = StoPoint;
781 tovisit[3] = (CELL *)*pt0;
782 tovisit += 4;
783 *pt0 = StoPoint[-1];
784#else
785 if (pt0 < pt0_end) {
786 tovisit[0] = pt0 + 1;
787 tovisit[1] = pt0_end;
788 tovisit[2] = StoPoint;
789 tovisit += 3;
790 }
791#endif
792 d0 = ArityOfFunctor(f);
793 pt0 = ap2 + 1;
794 pt0_end = ap2 + d0;
795 CheckDBOverflow(d0 + 1);
796 /* prepare for our new compound term */
797 /* first the functor */
798 *CodeMax++ = (CELL)f;
799 /* we'll be working here */
800 StoPoint = CodeMax;
801 /* now reserve space */
802 CodeMax += d0;
803 continue;
804 } else if (IsPairTerm(d0)) {
805 /* we will need to link afterwards */
806 CELL *ap2 = RepPair(d0);
807 if (ap2 >= tbase && ap2 <= StoPoint) {
808 db_check_trail(dbg->lr + 1);
809 *dbg->lr++ = ToSmall((CELL)(StoPoint) - (CELL)(tbase));
810 *StoPoint++ = d0;
811 ++pt0;
812 continue;
813 }
814 if (IsAtomOrIntTerm(Deref(ap2[0])) && IsPairTerm(Deref(ap2[1]))) {
815 /* shortcut for [1,2,3,4,5] */
816 Term tt = Deref(ap2[1]);
817 Term th = Deref(ap2[0]);
818 Int direction = RepPair(tt) - ap2;
819 CELL *OldStoPoint;
820 CELL *lp;
821
822 if (direction < 0)
823 direction = -1;
824 else
825 direction = 1;
826 db_check_trail(dbg->lr + 1);
827 *dbg->lr++ = ToSmall((CELL)(StoPoint) - (CELL)(tbase));
828 *StoPoint++ = AbsPair(CodeMax);
829 OldStoPoint = StoPoint;
830 do {
831 lp = RepPair(tt);
832
833 if (lp >= tbase && lp <= StoPoint) {
834 break;
835 }
836 CheckDBOverflow(2);
837 CodeMax[0] = th;
838 db_check_trail(dbg->lr + 1);
839 *dbg->lr++ = ToSmall((CELL)(CodeMax + 1) - (CELL)(tbase));
840 CodeMax[1] = AbsPair(CodeMax + 2);
841 CodeMax += 2;
842 th = Deref(lp[0]);
843 tt = Deref(lp[1]);
844 } while (IsAtomOrIntTerm(th) && IsPairTerm(tt) &&
845 /* have same direction to avoid infinite terms X = [a|X] */
846 (RepPair(tt) - lp) * direction > 0);
847 if (lp >= tbase && lp <= StoPoint) {
848 CodeMax[-1] = tt;
849 break;
850 }
851 if (IsAtomOrIntTerm(th) && IsAtomOrIntTerm(tt)) {
852 CheckDBOverflow(2);
853 CodeMax[0] = th;
854 CodeMax[1] = tt;
855 CodeMax += 2;
856 ++pt0;
857 continue;
858 }
859 d0 = AbsPair(lp);
860 StoPoint = OldStoPoint;
861 } else {
862 db_check_trail(dbg->lr + 1);
863 *dbg->lr++ = ToSmall((CELL)(StoPoint) - (CELL)(tbase));
864 *StoPoint++ = AbsPair(CodeMax);
865 }
866/* next, postpone analysis to the rest of the current list */
867#ifdef RATIONAL_TREES
868 tovisit[0] = pt0 + 1;
869 tovisit[1] = pt0_end;
870 tovisit[2] = StoPoint;
871 tovisit[3] = (CELL *)*pt0;
872 tovisit += 4;
873 *pt0 = StoPoint[-1];
874#else
875 if (pt0 < pt0_end) {
876 tovisit[0] = pt0 + 1;
877 tovisit[1] = pt0_end;
878 tovisit[2] = StoPoint;
879 tovisit += 3;
880 }
881#endif
882 CheckVisitOverflow();
883 /* new list */
884 /* we are working at CodeMax */
885 StoPoint = CodeMax;
886 /* set ptr to new term being analysed */
887 pt0 = RepPair(d0);
888 pt0_end = RepPair(d0) + 1;
889 /* reserve space for our new list */
890 CodeMax += 2;
891 CheckDBOverflow(2);
892 continue;
893 } else if (IsAtomOrIntTerm(d0)) {
894 *StoPoint++ = d0;
895 ++pt0;
896 continue;
897 }
898
899 /* the code to dereference a variable */
900 deref_var:
901 if (!DB_MARKED(d0)) {
902 if (
903#if YAPOR_SBA
904 d0 != 0
905#else
906 d0 != (CELL)ptd0
907#endif
908 ) {
909 ptd0 = (Term *)d0;
910 d0 = *ptd0;
911 goto restart; /* continue dereferencing */
912 }
913 /* else just drop to found_var */
914 }
915 /* else just drop to found_var */
916 {
917 CELL displacement = (CELL)(StoPoint) - (CELL)(tbase);
918
919 pt0++;
920 /* first time we found this variable! */
921 if (!DB_MARKED(d0)) {
922
923 /* store previous value */
924 visited--;
925 visited->addr = ptd0;
926 CheckDBOverflow(1);
927 /* variables need to be offset at read time */
928 *ptd0 = (CELL)StoPoint;
929#if YAPOR_SBA
930 /* the copy we keep will be an empty variable */
931 *StoPoint++ = 0;
932#else
933 /* the copy we keep will be the current displacement */
934 *StoPoint = (CELL)StoPoint;
935 StoPoint++;
936 db_check_trail(dbg->lr + 1);
937 *dbg->lr++ = ToSmall(displacement);
938#endif
939 /* indicate we found variables */
940 vars_found++;
941#ifdef COROUTINING
942 if (SafeIsAttachedTerm((CELL)ptd0)) {
943 Term t[4];
944 int sz = tovisit - tovisit_base;
945
946 HR = (CELL *)tovisit;
947 /* store the constraint away for: we need a back pointer to
948 the variable, the constraint in some cannonical form, what type
949 of constraint, and a list pointer */
950 t[0] = (CELL)ptd0;
951 t[1] = GLOBAL_attas[ExtFromCell(ptd0)].to_term_op(ptd0);
952 t[2] = MkIntegerTerm(ExtFromCell(ptd0));
953 t[3] = ConstraintsTerm;
954 ConstraintsTerm = Yap_MkApplTerm(FunctorClist, 4, t);
955 if (HR + sz >= ASP) {
956 goto error2;
957 }
958 memcpy((void *)HR, (void *)(tovisit_base), sz * sizeof(CELL *));
959 tovisit_base = (CELL **)HR;
960 tovisit = tovisit_base + sz;
961 }
962#endif
963 continue;
964 } else {
965 /* references need to be offset at read time */
966 db_check_trail(dbg->lr + 1);
967 *dbg->lr++ = ToSmall(displacement);
968 /* store the offset */
969 *StoPoint = d0;
970 StoPoint++;
971 continue;
972 }
973 }
974 }
975
976 /* Do we still have compound terms to visit */
977 if (tovisit > tovisit_base) {
978#ifdef RATIONAL_TREES
979 tovisit -= 4;
980 pt0 = tovisit[0];
981 pt0_end = tovisit[1];
982 StoPoint = tovisit[2];
983 pt0[-1] = (CELL)tovisit[3];
984#else
985 tovisit -= 3;
986 pt0 = tovisit[0];
987 pt0_end = tovisit[1];
988 CheckDBOverflow(1);
989 StoPoint = tovisit[2];
990#endif
991 goto loop;
992 }
993
994#ifdef COROUTINING
995 /* we still may have constraints to do */
996 if (ConstraintsTerm != TermNil &&
997 !IN_BETWEEN(tbase, RepAppl(ConstraintsTerm), CodeMax)) {
998 *attachmentsp = (CELL)(CodeMax + 1);
999 pt0 = RepAppl(ConstraintsTerm) + 1;
1000 pt0_end = RepAppl(ConstraintsTerm) + 4;
1001 StoPoint = CodeMax;
1002 *StoPoint++ = RepAppl(ConstraintsTerm)[0];
1003 ConstraintsTerm = AbsAppl(CodeMax);
1004 CheckDBOverflow(1);
1005 CodeMax += 5;
1006 goto loop;
1007 }
1008#endif
1009 /* we're done */
1010 *vars_foundp = vars_found;
1011 DB_UNWIND_CUNIF();
1012#ifdef COROUTINING
1013 HR = origH;
1014#endif
1015 return CodeMax;
1016
1017error:
1018 LOCAL_Error_TYPE = RESOURCE_ERROR_AUXILIARY_STACK;
1019 LOCAL_Error_Size = 1024 + ((char *)AuxSp - (char *)CodeMaxBase);
1020 *vars_foundp = vars_found;
1021#ifdef RATIONAL_TREES
1022 while (tovisit > tovisit_base) {
1023 tovisit -= 4;
1024 pt0 = tovisit[0];
1025 pt0_end = tovisit[1];
1026 StoPoint = tovisit[2];
1027 pt0[-1] = (CELL)tovisit[3];
1028 }
1029#endif
1030 DB_UNWIND_CUNIF();
1031#ifdef COROUTINING
1032 HR = origH;
1033#endif
1034 return NULL;
1035
1036error2:
1037 LOCAL_Error_TYPE = RESOURCE_ERROR_STACK;
1038 *vars_foundp = vars_found;
1039#ifdef RATIONAL_TREES
1040 while (tovisit > tovisit_base) {
1041 tovisit -= 4;
1042 pt0 = tovisit[0];
1043 pt0_end = tovisit[1];
1044 StoPoint = tovisit[2];
1045 pt0[-1] = (CELL)tovisit[3];
1046 }
1047#endif
1048 DB_UNWIND_CUNIF();
1049#ifdef COROUTINING
1050 HR = origH;
1051#endif
1052 return NULL;
1053
1054error_tr_overflow:
1055 LOCAL_Error_TYPE = RESOURCE_ERROR_TRAIL;
1056 *vars_foundp = vars_found;
1057#ifdef RATIONAL_TREES
1058 while (tovisit > tovisit_base) {
1059 tovisit -= 4;
1060 pt0 = tovisit[0];
1061 pt0_end = tovisit[1];
1062 StoPoint = tovisit[2];
1063 pt0[-1] = (CELL)tovisit[3];
1064 }
1065#endif
1066 DB_UNWIND_CUNIF();
1067#ifdef COROUTINING
1068 HR = origH;
1069#endif
1070 return NULL;
1071#if THREADS
1072#undef Yap_REGS
1073#define Yap_REGS (*Yap_regp)
1074#endif /* THREADS */
1075}
1076
1077#ifdef SFUNC
1078/*
1079 * The sparse terms existing in the structure are to be included now. This
1080 * means simple copy for constant terms but, some care about variables If
1081 * they have appeared before, we will know by their position number
1082 */
1083static void sf_include(SFKeep *sfp, struct db_globs *dbg) SFKeep *sfp;
1084{
1085 Term Tm = sfp->SName;
1086 CELL *tp = ArgsOfSFTerm(Tm);
1087 Register Term *StoPoint = ntp;
1088 CELL *displacement = CodeAbs;
1089 CELL arg_no;
1090 Term tvalue;
1091 int j = 3;
1092
1093 if (sfp->SFather != NIL)
1094 *(sfp->SFather) = AbsAppl(displacement);
1095 *StoPoint++ = FunctorOfTerm(Tm);
1096 db_check_trail(dbg->lr + 1);
1097 *dbg->lr++ = ToSmall(displacement + 1);
1098 *StoPoint++ = (Term)(displacement + 1);
1099 while (*tp) {
1100 arg_no = *tp++;
1101 tvalue = Derefa(tp++);
1102 if (IsVarTerm(tvalue)) {
1103 if (((VarKeep *)tvalue)->NOfVars != 0) {
1104 *StoPoint++ = arg_no;
1105 db_check_trail(dbg->lr + 1);
1106 *dbg->lr++ = ToSmall(displacement + j);
1107 if (((VarKeep *)tvalue)->New == 0)
1108 *StoPoint++ = ((VarKeep *)tvalue)->New = Unsigned(displacement + j);
1109 else
1110 *StoPoint++ = ((VarKeep *)tvalue)->New;
1111 j += 2;
1112 }
1113 } else if (IsAtomicTerm(tvalue)) {
1114 *StoPoint++ = arg_no;
1115 *StoPoint++ = tvalue;
1116 j += 2;
1117 } else {
1118 LOCAL_Error_TYPE = TYPE_ERROR_DBTERM;
1119 LOCAL_ErrorMessage = "wrong term in SF";
1120 return (NULL);
1121 }
1122 }
1123 *StoPoint++ = 0;
1124 ntp = StoPoint;
1125 CodeAbs = displacement + j;
1126}
1127#endif
1128
1129/*
1130 * This function is used to check if one of the terms in the idb is the
1131 * constant to_compare
1132 */
1133inline static DBRef check_if_cons(DBRef p, Term to_compare) {
1134 while (p != NIL &&
1135 (p->Flags & (DBCode | ErasedMask | DBVar | DBNoVars | DBComplex) ||
1136 p->DBT.Entry != Unsigned(to_compare)))
1137 p = NextDBRef(p);
1138 return p;
1139}
1140
1141/*
1142 * This function is used to check if one of the terms in the idb is a prolog
1143 * variable
1144 */
1145static DBRef check_if_var(DBRef p) {
1146 while (p != NIL &&
1147 p->Flags & (DBCode | ErasedMask | DBAtomic | DBNoVars | DBComplex))
1148 p = NextDBRef(p);
1149 return p;
1150}
1151
1152/*
1153 * This function is used to check if a Prolog complex term with variables
1154 * already exists in the idb for that key. The comparison is alike ==, but
1155 * only the relative binding of variables, not their position is used. The
1156 * comparison is done using the function cmpclls only. The function could
1157 * only fail if a functor was matched to a Prolog term, but then, it should
1158 * have failed before because the structure of term would have been very
1159 * different
1160 */
1161static DBRef check_if_wvars(DBRef p, unsigned int NOfCells, CELL *BTptr) {
1162 CELL *memptr;
1163
1164 do {
1165 while (p != NIL &&
1166 p->Flags & (DBCode | ErasedMask | DBAtomic | DBNoVars | DBVar))
1167 p = NextDBRef(p);
1168 if (p == NIL)
1169 return p;
1170 memptr = CellPtr(&(p->DBT.Contents));
1171 if (NOfCells == p->DBT.NOfCells && cmpclls(memptr, BTptr, NOfCells))
1172 return p;
1173 else
1174 p = NextDBRef(p);
1175 } while (TRUE);
1176 return NIL;
1177}
1178
1179static int scheckcells(int NOfCells, register CELL *m1, register CELL *m2,
1180 link_entry *lp, register CELL bp) {
1181 CELL base = Unsigned(m1);
1182 link_entry *lp1;
1183
1184 while (NOfCells-- > 0) {
1185 Register CELL r1, r2;
1186
1187 r1 = *m1++;
1188 r2 = *m2++;
1189 if (r1 == r2)
1190 continue;
1191 else if (r2 + bp == r1) {
1192 /* link pointers may not have been generated in the */
1193 /* same order */
1194 /* make sure r1 is really an offset. */
1195 lp1 = lp;
1196 r1 = m1 - (CELL *)base;
1197 while (*lp1 != r1 && *lp1)
1198 lp1++;
1199 if (!(*lp1))
1200 return FALSE;
1201 /* keep the old link pointer for future search. */
1202 /* vsc: this looks like a bug!!!! */
1203 /* *lp1 = *lp++; */
1204 } else {
1205 return FALSE;
1206 }
1207 }
1208 return TRUE;
1209}
1210
1211/*
1212 * the cousin of the previous, but with things a bit more sophisticated.
1213 * mtchcells, if an error was an found, needs to test ........
1214 */
1215static DBRef check_if_nvars(DBRef p, unsigned int NOfCells, CELL *BTptr,
1216 struct db_globs *dbg) {
1217 CELL *memptr;
1218
1219 do {
1220 while (p != NIL &&
1221 p->Flags & (DBCode | ErasedMask | DBAtomic | DBComplex | DBVar))
1222 p = NextDBRef(p);
1223 if (p == NIL)
1224 return p;
1225 memptr = CellPtr(p->DBT.Contents);
1226 if (scheckcells(NOfCells, memptr, BTptr, dbg->LinkAr,
1227 Unsigned(p->DBT.Contents - 1)))
1228 return p;
1229 else
1230 p = NextDBRef(p);
1231 } while (TRUE);
1232 return NIL;
1233}
1234
1235static DBRef generate_dberror_msg(int errnumb, UInt sz, char *msg) {
1236 CACHE_REGS
1237 LOCAL_Error_Size = sz;
1238 LOCAL_Error_TYPE = errnumb;
1239 LOCAL_ErrorMessage = msg;
1240 return NULL;
1241}
1242
1243static DBRef CreateDBWithDBRef(Term Tm, DBProp p, struct db_globs *dbg) {
1244 DBRef pp, dbr = DBRefOfTerm(Tm);
1245 DBTerm *ppt;
1246
1247 if (p == NULL) {
1248 UInt sz = sizeof(DBTerm) + 2 * sizeof(CELL);
1249 ppt = (DBTerm *)AllocDBSpace(sz);
1250 if (ppt == NULL) {
1251 return generate_dberror_msg(RESOURCE_ERROR_HEAP, TermNil,
1252 "could not allocate heap");
1253 }
1254 dbg->sz = sz;
1255 Yap_LUClauseSpace += sz;
1256 pp = (DBRef)ppt;
1257 } else {
1258 UInt sz = DBLength(2 * sizeof(DBRef));
1259 pp = AllocDBSpace(sz);
1260 if (pp == NULL) {
1261 return generate_dberror_msg(RESOURCE_ERROR_HEAP, 0,
1262 "could not allocate space");
1263 }
1264 Yap_LUClauseSpace += sz;
1265 dbg->sz = sz;
1266 pp->id = FunctorDBRef;
1267 pp->Flags = DBNoVars | DBComplex | DBWithRefs;
1268 INIT_LOCK(pp->lock);
1269 INIT_DBREF_COUNT(pp);
1270 ppt = &(pp->DBT);
1271 }
1272 if (dbr->Flags & LogUpdMask) {
1273 LogUpdClause *cl = (LogUpdClause *)dbr;
1274 cl->ClRefCount++;
1275 } else {
1276 dbr->NOfRefsTo++;
1277 }
1278 ppt->Entry = Tm;
1279 ppt->NOfCells = 0;
1280 ppt->Contents[0] = (CELL)NULL;
1281 ppt->Contents[1] = (CELL)dbr;
1282 ppt->DBRefs = (DBRef *)(ppt->Contents + 2);
1283#ifdef COROUTINING
1284 ppt->ag.attachments = 0L;
1285#endif
1286 return pp;
1287}
1288
1289static DBTerm *CreateDBTermForAtom(Term Tm, UInt extra_size,
1290 struct db_globs *dbg) {
1291 DBTerm *ppt;
1292 ADDR ptr;
1293 UInt sz = extra_size + sizeof(DBTerm);
1294
1295 ptr = (ADDR)AllocDBSpace(sz);
1296 if (ptr == NULL) {
1297 return (DBTerm *)generate_dberror_msg(RESOURCE_ERROR_HEAP, 0,
1298 "could not allocate space");
1299 }
1300 Yap_LUClauseSpace += sz;
1301 dbg->sz = sz;
1302 ppt = (DBTerm *)(ptr + extra_size);
1303 ppt->NOfCells = 0;
1304 ppt->DBRefs = NULL;
1305#ifdef COROUTINING
1306 ppt->ag.attachments = 0;
1307#endif
1308 ppt->DBRefs = NULL;
1309 ppt->Entry = Tm;
1310 return ppt;
1311}
1312
1313static DBTerm *CreateDBTermForVar(UInt extra_size, struct db_globs *dbg) {
1314 DBTerm *ppt;
1315 ADDR ptr;
1316 UInt sz = extra_size + sizeof(DBTerm);
1317
1318 ptr = (ADDR)AllocDBSpace(sz);
1319 if (ptr == NULL) {
1320 return (DBTerm *)generate_dberror_msg(RESOURCE_ERROR_HEAP, 0,
1321 "could not allocate space");
1322 }
1323 Yap_LUClauseSpace += sz;
1324 dbg->sz = sz;
1325 ppt = (DBTerm *)(ptr + extra_size);
1326 ppt->NOfCells = 0;
1327 ppt->DBRefs = NULL;
1328#ifdef COROUTINING
1329 ppt->ag.attachments = 0;
1330#endif
1331 ppt->DBRefs = NULL;
1332 ppt->Entry = (CELL)(&(ppt->Entry));
1333 return ppt;
1334}
1335
1336static DBRef CreateDBRefForAtom(Term Tm, DBProp p, int InFlag,
1337 struct db_globs *dbg) {
1338 Register DBRef pp;
1339 SMALLUNSGN flag;
1340 UInt sz = DBLength(NIL);
1341
1342 flag = DBAtomic;
1343 if (InFlag & MkIfNot && (dbg->found_one = check_if_cons(p->First, Tm)))
1344 return dbg->found_one;
1345 pp = AllocDBSpace(sz);
1346 if (pp == NIL) {
1347 return generate_dberror_msg(RESOURCE_ERROR_HEAP, 0,
1348 "could not allocate space");
1349 }
1350 Yap_LUClauseSpace += sz;
1351 dbg->sz = sz;
1352 pp->id = FunctorDBRef;
1353 INIT_LOCK(pp->lock);
1354 INIT_DBREF_COUNT(pp);
1355 pp->Flags = flag;
1356 pp->Code = NULL;
1357 pp->DBT.Entry = Tm;
1358 pp->DBT.DBRefs = NULL;
1359 pp->DBT.NOfCells = 0;
1360#ifdef COROUTINING
1361 pp->DBT.ag.attachments = 0;
1362#endif
1363 return (pp);
1364}
1365
1366static DBRef CreateDBRefForVar(Term Tm, DBProp p, int InFlag,
1367 struct db_globs *dbg) {
1368 Register DBRef pp;
1369 UInt sz = DBLength(NULL);
1370
1371 if (InFlag & MkIfNot && (dbg->found_one = check_if_var(p->First)))
1372 return dbg->found_one;
1373 pp = AllocDBSpace(sz);
1374 if (pp == NULL) {
1375 return generate_dberror_msg(RESOURCE_ERROR_HEAP, 0,
1376 "could not allocate space");
1377 }
1378 Yap_LUClauseSpace += sz;
1379 dbg->sz = sz;
1380 pp->id = FunctorDBRef;
1381 pp->Flags = DBVar;
1382 pp->DBT.Entry = (CELL)Tm;
1383 pp->Code = NULL;
1384 pp->DBT.NOfCells = 0;
1385 pp->DBT.DBRefs = NULL;
1386#ifdef COROUTINING
1387 pp->DBT.ag.attachments = 0;
1388#endif
1389 INIT_LOCK(pp->lock);
1390 INIT_DBREF_COUNT(pp);
1391 return pp;
1392}
1393
1394static DBRef CreateDBStruct(Term Tm, DBProp p, int InFlag, int *pstat,
1395 UInt extra_size, struct db_globs *dbg) {
1396 CACHE_REGS
1397 Register Term tt, *nar = NIL;
1398 SMALLUNSGN flag;
1399 int NOfLinks = 0;
1400 /* place DBRefs in ConsultStack */
1401 DBRef *TmpRefBase;
1402 CELL *CodeAbs; /* how much code did we find */
1403 int vars_found = FALSE;
1404 yap_error_number oerr = LOCAL_Error_TYPE;
1405
1406 retry_record:
1407 LOCAL_Error_TYPE = YAP_NO_ERROR;
1408 TmpRefBase = (DBRef *)LOCAL_TrailTop;
1409 if (p == NULL) {
1410 if (IsVarTerm(Tm)) {
1411#ifdef COROUTINING
1412 if (!SafeIsAttachedTerm(Tm)) {
1413#endif
1414 DBRef out = (DBRef)CreateDBTermForVar(extra_size, dbg);
1415 *pstat = TRUE;
1416 LOCAL_Error_TYPE = oerr;
1417 return out;
1418#ifdef COROUTINING
1419 }
1420#endif
1421 } else if (IsAtomOrIntTerm(Tm)) {
1422 DBRef out = (DBRef)CreateDBTermForAtom(Tm, extra_size, dbg);
1423 *pstat = FALSE;
1424 LOCAL_Error_TYPE = oerr;
1425 return out;
1426 }
1427 } else {
1428 if (IsVarTerm(Tm)
1429#ifdef COROUTINING
1430 && !SafeIsAttachedTerm(Tm)
1431#endif
1432 ) {
1433 *pstat = TRUE;
1434 LOCAL_Error_TYPE = oerr;
1435 return CreateDBRefForVar(Tm, p, InFlag, dbg);
1436 } else if (IsAtomOrIntTerm(Tm)) {
1437 LOCAL_Error_TYPE = oerr;
1438 return CreateDBRefForAtom(Tm, p, InFlag, dbg);
1439 }
1440 }
1441 /* next, let's process a compound term */
1442 {
1443 DBTerm *ppt, *ppt0;
1444 DBRef pp, pp0;
1445 Term *ntp0, *ntp;
1446 unsigned int NOfCells = 0;
1447#ifdef COROUTINING
1448 CELL attachments = 0;
1449#endif
1450
1451 dbg->tofref = TmpRefBase;
1452
1453 if (p == NULL) {
1454 ADDR ptr = Yap_PreAllocCodeSpace();
1455 ppt0 = (DBTerm *)(ptr + extra_size);
1456 pp0 = (DBRef)ppt0;
1457 } else {
1458 pp0 = (DBRef)Yap_PreAllocCodeSpace();
1459 ppt0 = &(pp0->DBT);
1460 }
1461 if ((ADDR)ppt0 >= (ADDR)AuxSp - 1024) {
1462 LOCAL_Error_Size = (UInt)(extra_size + sizeof(ppt0));
1463 LOCAL_Error_TYPE = RESOURCE_ERROR_AUXILIARY_STACK;
1464 Yap_ReleasePreAllocCodeSpace((ADDR)pp0);
1465 LOCAL_Error_TYPE = oerr;
1466 return NULL;
1467 }
1468 ntp0 = ppt0->Contents;
1469 if ((ADDR)TR >= LOCAL_TrailTop - 1024) {
1470 LOCAL_Error_Size = 0;
1471 LOCAL_Error_TYPE = RESOURCE_ERROR_TRAIL;
1472 Yap_ReleasePreAllocCodeSpace((ADDR)pp0);
1473 LOCAL_Error_TYPE = oerr;
1474
1475 return NULL;
1476 }
1477 dbg->lr = dbg->LinkAr = (link_entry *)TR;
1478#ifdef COROUTINING
1479 /* attachment */
1480 if (IsVarTerm(Tm)) {
1481 tt = (CELL)(ppt0->Contents);
1482 ntp = MkDBTerm(VarOfTerm(Tm), VarOfTerm(Tm), ntp0, ntp0 + 1, ntp0 - 1,
1483 &attachments, &vars_found, dbg);
1484 if (ntp == NULL) {
1485 Yap_ReleasePreAllocCodeSpace((ADDR)pp0);
1486 LOCAL_Error_TYPE = oerr;
1487 return NULL;
1488 }
1489 } else
1490#endif
1491 if (IsPairTerm(Tm)) {
1492 /* avoid null pointers!! */
1493 tt = AbsPair(ppt0->Contents);
1494 ntp = MkDBTerm(RepPair(Tm), RepPair(Tm) + 1, ntp0, ntp0 + 2, ntp0 - 1,
1495#ifdef COROUTINING
1496 &attachments,
1497#endif
1498 &vars_found, dbg);
1499 if (ntp == NULL) {
1500 Yap_ReleasePreAllocCodeSpace((ADDR)pp0);
1501 LOCAL_Error_TYPE = oerr;
1502 return NULL;
1503 }
1504 } else {
1505 unsigned int arity;
1506 Functor fun;
1507 vars_found = true;
1508 tt = AbsAppl(ppt0->Contents);
1509 /* we need to store the functor manually */
1510 fun = FunctorOfTerm(Tm);
1511 if (IsExtensionFunctor(fun)) {
1512 switch ((CELL)fun) {
1513 case (CELL)FunctorDouble:
1514 ntp = copy_double(ntp0, RepAppl(Tm));
1515 break;
1516 case (CELL)FunctorString:
1517 {
1518 UInt sz = 1024+sizeof(CELL)*(3 + RepAppl(Tm)[1]);
1519 if (sz >
1520 (char*)AuxSp-(char*)ppt0) {
1521 LOCAL_Error_Size = sz;
1522 if (!Yap_ExpandPreAllocCodeSpace(LOCAL_Error_Size, NULL, TRUE)) {
1523 Yap_ThrowError(RESOURCE_ERROR_AUXILIARY_STACK, TermNil, LOCAL_ErrorMessage);
1524 return NULL;
1525 }
1526 goto retry_record;
1527 }
1528 }
1529 ntp = copy_string(ntp0, RepAppl(Tm));
1530 break;
1531 case (CELL)FunctorDBRef:
1532 Yap_ReleasePreAllocCodeSpace((ADDR)pp0);
1533 return CreateDBWithDBRef(Tm, p, dbg);
1534#ifdef USE_GMP
1535 case (CELL)FunctorBigInt:
1536 {
1537 UInt sz = 1024+sizeof(CELL)*Yap_SizeOfBigInt(Tm);
1538 if (sz >
1539 (char*)AuxSp-(char*)ppt0) {
1540 LOCAL_Error_Size = sizeof(CELL)*(3 + RepAppl(Tm)[1]);
1541 if (!Yap_ExpandPreAllocCodeSpace(LOCAL_Error_Size, NULL, TRUE)) {
1542 Yap_ThrowError(RESOURCE_ERROR_AUXILIARY_STACK, TermNil, LOCAL_ErrorMessage);
1543 return NULL;
1544 }
1545 goto retry_record;
1546 }
1547 }
1548 ntp = copy_big_int(ntp0, RepAppl(Tm));
1549 break;
1550#endif
1551 default: /* LongInt */
1552 ntp = copy_long_int(ntp0, RepAppl(Tm));
1553 break;
1554 }
1555 } else {
1556 *ntp0 = (CELL)fun;
1557 arity = ArityOfFunctor(fun);
1558 ntp = MkDBTerm(RepAppl(Tm) + 1, RepAppl(Tm) + arity, ntp0 + 1,
1559 ntp0 + 1 + arity, ntp0 - 1,
1560#ifdef COROUTINING
1561 &attachments,
1562#endif
1563 &vars_found, dbg);
1564 if (ntp == NULL) {
1565 Yap_ReleasePreAllocCodeSpace((ADDR)pp0);
1566 LOCAL_Error_TYPE = oerr;
1567 return NULL;
1568 }
1569 }
1570 }
1571 CodeAbs = (CELL *)((CELL)ntp - (CELL)ntp0);
1572 if (LOCAL_Error_TYPE) {
1573 Yap_ReleasePreAllocCodeSpace((ADDR)pp0);
1574 LOCAL_Error_TYPE = oerr;
1575 return NULL; /* Error Situation */
1576 }
1577 NOfCells = ntp - ntp0; /* End Of Code Info */
1578 *dbg->lr++ = 0;
1579 NOfLinks = (dbg->lr - dbg->LinkAr);
1580 if (vars_found || InFlag & InQueue) {
1581
1582 /*
1583 * Take into account the fact that one needs an entry
1584 * for the number of links
1585 */
1586 flag = DBComplex;
1587 CodeAbs += (NOfLinks + (sizeof(CELL) / sizeof(BITS32) - 1)) /
1588 (sizeof(CELL) / sizeof(BITS32));
1589 if ((CELL *)((char *)ntp0 + (CELL)CodeAbs) > AuxSp) {
1590 LOCAL_Error_Size = (UInt)DBLength(CodeAbs);
1591 LOCAL_Error_TYPE = RESOURCE_ERROR_AUXILIARY_STACK;
1592 Yap_ReleasePreAllocCodeSpace((ADDR)pp0);
1593 LOCAL_Error_TYPE = oerr;
1594 return NULL;
1595 }
1596 if ((InFlag & MkIfNot) &&
1597 (dbg->found_one = check_if_wvars(p->First, NOfCells, ntp0))) {
1598 Yap_ReleasePreAllocCodeSpace((ADDR)pp0);
1599 LOCAL_Error_TYPE = oerr;
1600 return dbg->found_one;
1601 }
1602 } else {
1603 flag = DBNoVars;
1604 if ((InFlag & MkIfNot) &&
1605 (dbg->found_one = check_if_nvars(p->First, NOfCells, ntp0, dbg))) {
1606 Yap_ReleasePreAllocCodeSpace((ADDR)pp0);
1607 LOCAL_Error_TYPE = oerr;
1608 return dbg->found_one;
1609 }
1610 }
1611 if (dbg->tofref != TmpRefBase) {
1612 CodeAbs += (TmpRefBase - dbg->tofref) + 1;
1613 if ((CELL *)((char *)ntp0 + (CELL)CodeAbs) > AuxSp) {
1614 LOCAL_Error_Size = (UInt)DBLength(CodeAbs);
1615 LOCAL_Error_TYPE = RESOURCE_ERROR_AUXILIARY_STACK;
1616 Yap_ReleasePreAllocCodeSpace((ADDR)pp0);
1617 LOCAL_Error_TYPE = oerr;
1618 return NULL;
1619 }
1620 flag |= DBWithRefs;
1621 }
1622#if SIZEOF_LINK_ENTRY == 2
1623 if (Unsigned(CodeAbs) >= 0x40000) {
1624 Yap_ReleasePreAllocCodeSpace((ADDR)pp0);
1625 LOCAL_Error_TYPE = oerr;
1626 return generate_dberror_msg(SYSTEM_ERROR_INTERNAL, 0,
1627 "trying to store term larger than 256KB");
1628 }
1629#endif
1630 if (p == NULL) {
1631 UInt sz = (CELL)CodeAbs + extra_size + sizeof(DBTerm);
1632 ADDR ptr = Yap_AllocCodeSpace(sz);
1633 ppt = (DBTerm *)(ptr + extra_size);
1634 if (ptr == NULL) {
1635 Yap_ReleasePreAllocCodeSpace((ADDR)pp0);
1636 LOCAL_Error_TYPE = oerr;
1637 return generate_dberror_msg(RESOURCE_ERROR_HEAP, sz,
1638 "heap crashed against stacks");
1639 }
1640 Yap_LUClauseSpace += sz;
1641 dbg->sz = sz;
1642 pp = (DBRef)ppt;
1643 } else {
1644 UInt sz = DBLength(CodeAbs);
1645 pp = AllocDBSpace(sz);
1646 if (pp == NULL) {
1647 Yap_ReleasePreAllocCodeSpace((ADDR)pp0);
1648 LOCAL_Error_TYPE = oerr;
1649 return generate_dberror_msg(RESOURCE_ERROR_HEAP, sz,
1650 "heap crashed against stacks");
1651 }
1652 Yap_LUClauseSpace += sz;
1653 dbg->sz = sz;
1654 pp->id = FunctorDBRef;
1655 pp->Flags = flag;
1656 INIT_LOCK(pp->lock);
1657 INIT_DBREF_COUNT(pp);
1658 ppt = &(pp->DBT);
1659 }
1660 if (flag & DBComplex) {
1661 link_entry *woar;
1662
1663 ppt->NOfCells = NOfCells;
1664#ifdef COROUTINING
1665 ppt->ag.attachments = attachments;
1666#endif
1667 if (pp0 != pp) {
1668 nar = ppt->Contents;
1669 nar = (Term *)cpcells(CellPtr(nar), ntp0, Unsigned(NOfCells));
1670 } else {
1671 nar = ppt->Contents + Unsigned(NOfCells);
1672 }
1673 woar = (link_entry *)nar;
1674 memcpy((void *)woar, (const void *)dbg->LinkAr,
1675 (size_t)(NOfLinks * sizeof(link_entry)));
1676 woar += NOfLinks;
1677#ifdef ALIGN_LONGS
1678#if SIZEOF_INT_P == 8
1679 while ((Unsigned(woar) & 7) != 0)
1680 woar++;
1681#else
1682 if ((Unsigned(woar) & 3) != 0)
1683 woar++;
1684#endif
1685#endif
1686 nar = (Term *)(woar);
1687 *pstat = TRUE;
1688 } else if (flag & DBNoVars) {
1689 if (pp0 != pp) {
1690 nar = (Term *)cpcells(CellPtr(ppt->Contents), ntp0, Unsigned(NOfCells));
1691 } else {
1692 nar = ppt->Contents + Unsigned(NOfCells);
1693 }
1694 ppt->NOfCells = NOfCells;
1695 }
1696 if (ppt != ppt0) {
1697 linkblk(dbg->LinkAr, CellPtr(ppt->Contents - 1), (CELL)ppt - (CELL)ppt0);
1698 ppt->Entry = AdjustIDBPtr(tt, (CELL)ppt - (CELL)ppt0);
1699#ifdef COROUTINING
1700 if (attachments)
1701 ppt->ag.attachments = AdjustIDBPtr(attachments, (CELL)ppt - (CELL)ppt0);
1702 else
1703 ppt->ag.attachments = 0L;
1704#endif
1705 } else {
1706 ppt->Entry = tt;
1707#ifdef COROUTINING
1708 ppt->ag.attachments = attachments;
1709#endif
1710 }
1711 if (flag & DBWithRefs) {
1712 DBRef *ptr = TmpRefBase, *rfnar = (DBRef *)nar;
1713
1714 *rfnar++ = NULL;
1715 while (ptr != dbg->tofref)
1716 *rfnar++ = *--ptr;
1717 ppt->DBRefs = rfnar;
1718 } else {
1719 ppt->DBRefs = NULL;
1720 }
1721 Yap_ReleasePreAllocCodeSpace((ADDR)pp0);
1722 LOCAL_Error_TYPE = oerr;
1723 return pp;
1724 }
1725}
1726
1727static DBRef record(int Flag, Term key, Term t_data, Term t_code USES_REGS) {
1728 Register Term twork = key;
1729 Register DBProp p;
1730 Register DBRef x;
1731 int needs_vars;
1732 struct db_globs dbg;
1733
1734 dbg.found_one = NULL;
1735#ifdef SFUNC
1736 FathersPlace = NIL;
1737#endif
1738 if (EndOfPAEntr(
1739 p = FetchDBPropFromKey(twork, Flag & MkCode, TRUE, "record/3"))) {
1740 return NULL;
1741 }
1742 if ((x = CreateDBStruct(t_data, p, Flag, &needs_vars, 0, &dbg)) == NULL) {
1743 return NULL;
1744 }
1745 if ((Flag & MkIfNot) && dbg.found_one)
1746 return NULL;
1747 TRAIL_REF(x);
1748 if (x->Flags & (DBNoVars | DBComplex))
1749 x->Mask = EvalMasks(t_data, &x->Key);
1750 else
1751 x->Mask = x->Key = 0;
1752 if (Flag & MkCode)
1753 x->Flags |= DBCode;
1754 else
1755 x->Flags |= DBNoCode;
1756 x->Parent = p;
1757#if MULTIPLE_STACKS
1758 x->Flags |= DBClMask;
1759 x->ref_count = 1;
1760#else
1761 x->Flags |= (InUseMask | DBClMask);
1762#endif
1763 x->NOfRefsTo = 0;
1764 WRITE_LOCK(p->DBRWLock);
1765 if (p->F0 == NULL) {
1766 p->F0 = p->L0 = x;
1767 x->p = x->n = NULL;
1768 } else {
1769 if (Flag & MkFirst) {
1770 x->n = p->F0;
1771 p->F0->p = x;
1772 p->F0 = x;
1773 x->p = NULL;
1774 } else {
1775 x->p = p->L0;
1776 p->L0->n = x;
1777 p->L0 = x;
1778 x->n = NULL;
1779 }
1780 }
1781 if (p->First == NIL) {
1782 p->First = p->Last = x;
1783 x->Prev = x->Next = NIL;
1784 } else if (Flag & MkFirst) {
1785 x->Prev = NIL;
1786 (p->First)->Prev = x;
1787 x->Next = p->First;
1788 p->First = x;
1789 } else {
1790 x->Next = NIL;
1791 (p->Last)->Next = x;
1792 x->Prev = p->Last;
1793 p->Last = x;
1794 }
1795 if (Flag & MkCode) {
1796 x->Code = (yamop *)IntegerOfTerm(t_code);
1797 }
1798 WRITE_UNLOCK(p->DBRWLock);
1799 return x;
1800}
1801
1802/* add a new entry next to an old one */
1803static DBRef record_at(int Flag, DBRef r0, Term t_data, Term t_code USES_REGS) {
1804 Register DBProp p;
1805 Register DBRef x;
1806 int needs_vars;
1807 struct db_globs dbg;
1808
1809#ifdef SFUNC
1810 FathersPlace = NIL;
1811#endif
1812 p = r0->Parent;
1813 if ((x = CreateDBStruct(t_data, p, Flag, &needs_vars, 0, &dbg)) == NULL) {
1814 return NULL;
1815 }
1816 TRAIL_REF(x);
1817 if (x->Flags & (DBNoVars | DBComplex))
1818 x->Mask = EvalMasks(t_data, &x->Key);
1819 else
1820 x->Mask = x->Key = 0;
1821 if (Flag & MkCode)
1822 x->Flags |= DBCode;
1823 else
1824 x->Flags |= DBNoCode;
1825 x->Parent = p;
1826#if MULTIPLE_STACKS
1827 x->Flags |= DBClMask;
1828 x->ref_count = 1;
1829#else
1830 x->Flags |= (InUseMask | DBClMask);
1831#endif
1832 x->NOfRefsTo = 0;
1833 WRITE_LOCK(p->DBRWLock);
1834 if (Flag & MkFirst) {
1835 x->n = r0;
1836 x->p = r0->p;
1837 if (p->F0 == r0) {
1838 p->F0 = x;
1839 } else {
1840 r0->p->n = x;
1841 }
1842 r0->p = x;
1843 } else {
1844 x->p = r0;
1845 x->n = r0->n;
1846 if (p->L0 == r0) {
1847 p->L0 = x;
1848 } else {
1849 r0->n->p = x;
1850 }
1851 r0->n = x;
1852 }
1853 if (Flag & MkFirst) {
1854 x->Prev = r0->Prev;
1855 x->Next = r0;
1856 if (p->First == r0) {
1857 p->First = x;
1858 } else {
1859 r0->Prev->Next = x;
1860 }
1861 r0->Prev = x;
1862 } else {
1863 x->Next = r0->Next;
1864 x->Prev = r0;
1865 if (p->Last == r0) {
1866 p->Last = x;
1867 } else {
1868 r0->Next->Prev = x;
1869 }
1870 r0->Next = x;
1871 }
1872 if (Flag & WithRef) {
1873 x->Code = (yamop *)IntegerOfTerm(t_code);
1874 }
1875 WRITE_UNLOCK(p->DBRWLock);
1876 return x;
1877}
1878
1879static LogUpdClause *new_lu_db_entry(Term t, PredEntry *pe) {
1880 CACHE_REGS
1881 DBTerm *x;
1882 LogUpdClause *cl;
1883 yamop *ipc;
1884 int needs_vars = FALSE;
1885 struct db_globs dbg;
1886 int d_flag = 0;
1887
1888#if MULTIPLE_STACKS
1889 /* we cannot allow sharing between threads (for now) */
1890 if (!pe || !(pe->PredFlags & ThreadLocalPredFlag))
1891 d_flag |= InQueue;
1892#endif
1893 ipc = NEXTOP(((LogUpdClause *)NULL)->ClCode, e);
1894 if ((x = (DBTerm *)CreateDBStruct(t, NULL, d_flag, &needs_vars, (UInt)ipc,
1895 &dbg)) == NULL) {
1896 return NULL; /* crash */
1897 }
1898 cl = (LogUpdClause *)((ADDR)x - (UInt)ipc);
1899 ipc = cl->ClCode;
1900 cl->Id = FunctorDBRef;
1901 cl->ClFlags = LogUpdMask;
1902 cl->lusl.ClSource = x;
1903 cl->ClRefCount = 0;
1904 cl->ClPred = pe;
1905 cl->ClExt = NULL;
1906 cl->ClPrev = cl->ClNext = NULL;
1907 cl->ClSize = dbg.sz;
1908 /* Support for timestamps */
1909 if (pe && pe->LastCallOfPred != LUCALL_ASSERT) {
1910 if (pe->TimeStampOfPred >= TIMESTAMP_RESET)
1911 Yap_UpdateTimestamps(pe);
1912 ++pe->TimeStampOfPred;
1913 /* fprintf(stderr,"+
1914 * %x--%d--%ul\n",pe,pe->TimeStampOfPred,pe->ArityOfPE);*/
1915 pe->LastCallOfPred = LUCALL_ASSERT;
1916 cl->ClTimeStart = pe->TimeStampOfPred;
1917 } else {
1918 cl->ClTimeStart = 0L;
1919 }
1920 cl->ClTimeEnd = TIMESTAMP_EOT;
1921
1922#if MULTIPLE_STACKS
1923 // INIT_LOCK(cl->ClLock);
1924 INIT_CLREF_COUNT(cl);
1925 ipc->opc = Yap_opcode(_copy_idb_term);
1926#else
1927 if (needs_vars)
1928 ipc->opc = Yap_opcode(_copy_idb_term);
1929 else
1930 ipc->opc = Yap_opcode(_unify_idb_term);
1931#endif
1932
1933 return cl;
1934}
1935
1936LogUpdClause *Yap_new_ludbe(Term t, PredEntry *pe, UInt nargs) {
1937 CACHE_REGS
1938 LogUpdClause *x;
1939
1940 LOCAL_Error_Size = 0;
1941 while ((x = new_lu_db_entry(t, pe)) == NULL) {
1942 if (LOCAL_Error_TYPE == YAP_NO_ERROR) {
1943 break;
1944 } else {
1945 XREGS[nargs + 1] = t;
1946 if (recover_from_record_error(nargs + 1)) {
1947 t = Deref(XREGS[nargs + 1]);
1948 } else {
1949 return FALSE;
1950 }
1951 }
1952 }
1953 return x;
1954}
1955
1956static LogUpdClause *record_lu(PredEntry *pe, Term t, int position) {
1957 LogUpdClause *cl;
1958
1959 if ((cl = new_lu_db_entry(t, pe)) == NULL) {
1960 return NULL;
1961 }
1962 {
1963 Yap_inform_profiler_of_clause(cl, (char *)cl + cl->ClSize, pe,
1964 GPROF_NEW_LU_CLAUSE);
1965 }
1966 Yap_add_logupd_clause(pe, cl, (position == MkFirst ? 2 : 0));
1967 return cl;
1968}
1969
1970static LogUpdClause *record_lu_at(int position, LogUpdClause *ocl, Term t) {
1971 LogUpdClause *cl;
1972 PredEntry *pe;
1973
1974 pe = ocl->ClPred;
1975 PELOCK(62, pe);
1976 if ((cl = new_lu_db_entry(t, pe)) == NULL) {
1977 UNLOCK(pe->PELock);
1978 return NULL;
1979 }
1980 if (pe->cs.p_code.NOfClauses > 1)
1981 Yap_RemoveIndexation(pe);
1982 if (position == MkFirst) {
1983 /* add before current clause */
1984 cl->ClNext = ocl;
1985 if (ocl->ClCode == pe->cs.p_code.FirstClause) {
1986 cl->ClPrev = NULL;
1987 pe->cs.p_code.FirstClause = cl->ClCode;
1988 } else {
1989 cl->ClPrev = ocl->ClPrev;
1990 ocl->ClPrev->ClNext = cl;
1991 }
1992 ocl->ClPrev = cl;
1993 } else {
1994 /* add after current clause */
1995 cl->ClPrev = ocl;
1996 if (ocl->ClCode == pe->cs.p_code.LastClause) {
1997 cl->ClNext = NULL;
1998 pe->cs.p_code.LastClause = cl->ClCode;
1999 } else {
2000 cl->ClNext = ocl->ClNext;
2001 ocl->ClNext->ClPrev = cl;
2002 }
2003 ocl->ClNext = cl;
2004 }
2005 pe->cs.p_code.NOfClauses++;
2006 if (pe->cs.p_code.NOfClauses > 1) {
2007 pe->OpcodeOfPred = INDEX_OPCODE;
2008 pe->CodeOfPred = (yamop *)(&(pe->OpcodeOfPred));
2009 }
2010 UNLOCK(pe->PELock);
2011 return cl;
2012}
2013
2014/* recorda(+Functor,+Term,-Ref) */
2015static Int p_rcda(USES_REGS1) {
2016 /* Idiotic xlc's cpp does not work with ARG1 within MkDBRefTerm */
2017 Term TRef, t1 = Deref(ARG1);
2018 PredEntry *pe = NULL;
2019 if (!IsVarTerm(Deref(ARG3)))
2020 return (FALSE);
2021 pe = find_lu_entry(t1);
2022 LOCAL_Error_Size = 0;
2023restart_record:
2024 if (pe) {
2025 LogUpdClause *cl;
2026
2027 PELOCK(61, pe);
2028 cl = record_lu(pe, Deref(ARG2), MkFirst);
2029 if (cl != NULL) {
2030 TRAIL_CLREF(cl);
2031#if MULTIPLE_STACKS
2032 INC_CLREF_COUNT(cl);
2033#else
2034 cl->ClFlags |= InUseMask;
2035#endif
2036 TRef = MkDBRefTerm((DBRef)cl);
2037 } else {
2038 TRef = TermNil;
2039 }
2040 UNLOCK(pe->PELock);
2041 } else {
2042 TRef = MkDBRefTerm(record(MkFirst, t1, Deref(ARG2), Unsigned(0) PASS_REGS));
2043 }
2044 if (LOCAL_Error_TYPE != YAP_NO_ERROR) {
2045 if (recover_from_record_error(3)) {
2046 goto restart_record;
2047 } else {
2048 return FALSE;
2049 }
2050 }
2051 if (!pe)
2052 return FALSE;
2053 return Yap_unify(ARG3, TRef);
2054}
2055
2056/* '$recordap'(+Functor,+Term,-Ref) */
2057static Int p_rcdap(USES_REGS1) {
2058 Term TRef, t1 = Deref(ARG1), t2 = Deref(ARG2);
2059
2060 if (!IsVarTerm(Deref(ARG3)))
2061 return FALSE;
2062 LOCAL_Error_Size = 0;
2063restart_record:
2064 TRef = MkDBRefTerm(record(MkFirst | MkCode, t1, t2, Unsigned(0) PASS_REGS));
2065
2066 if (LOCAL_Error_TYPE != YAP_NO_ERROR) {
2067 if (recover_from_record_error(3)) {
2068 t1 = Deref(ARG1);
2069 t2 = Deref(ARG2);
2070 goto restart_record;
2071 } else {
2072 return FALSE;
2073 }
2074 }
2075 return Yap_unify(ARG3, TRef);
2076}
2077
2078/* recorda_at(+DBRef,+Term,-Ref) */
2087static Int p_rcda_at(USES_REGS1) {
2088 /* Idiotic xlc's cpp does not work with ARG1 within MkDBRefTerm */
2089 Term TRef, t1 = Deref(ARG1), t2 = Deref(ARG2);
2090 DBRef dbr;
2091
2092 if (!IsVarTerm(Deref(ARG3)))
2093 return FALSE;
2094 if (IsVarTerm(t1)) {
2095 Yap_ThrowError(INSTANTIATION_ERROR, t1, "recorda_at/3");
2096 return FALSE;
2097 }
2098 if (!IsDBRefTerm(t1)) {
2099 Yap_ThrowError(TYPE_ERROR_DBREF, t1, "recorda_at/3");
2100 return FALSE;
2101 }
2102 LOCAL_Error_Size = 0;
2103restart_record:
2104 dbr = DBRefOfTerm(t1);
2105 if (dbr->Flags & ErasedMask) {
2106 /* doesn't make sense */
2107 return FALSE;
2108 }
2109 if (dbr->Flags & LogUpdMask) {
2110 TRef = MkDBRefTerm((DBRef)record_lu_at(MkFirst, (LogUpdClause *)dbr, t2));
2111 } else {
2112 TRef = MkDBRefTerm(
2113 record_at(MkFirst, DBRefOfTerm(t1), t2, Unsigned(0) PASS_REGS));
2114 }
2115 if (LOCAL_Error_TYPE != YAP_NO_ERROR) {
2116 if (recover_from_record_error(3)) {
2117 t1 = Deref(ARG1);
2118 t2 = Deref(ARG2);
2119 goto restart_record;
2120 } else {
2121 return FALSE;
2122 }
2123 }
2124 return Yap_unify(ARG3, TRef);
2125}
2126
2127/* recordz(+Functor,+Term,-Ref) */
2134static Int p_rcdz(USES_REGS1) { Term TRef, t1 = Deref(ARG1), t2 = Deref(ARG2);
2135 PredEntry *pe;
2136
2137 if (!IsVarTerm(Deref(ARG3)))
2138 return (FALSE);
2139 pe = find_lu_entry(t1);
2140 LOCAL_Error_Size = 0;
2141restart_record:
2142 if (pe) {
2143 LogUpdClause *cl;
2144
2145 PELOCK(62, pe);
2146 cl = record_lu(pe, t2, MkLast);
2147 if (cl != NULL) {
2148 TRAIL_CLREF(cl);
2149#if MULTIPLE_STACKS
2150 INC_CLREF_COUNT(cl);
2151#else
2152 cl->ClFlags |= InUseMask;
2153#endif
2154 TRef = MkDBRefTerm((DBRef)cl);
2155 } else {
2156 TRef = TermNil;
2157 }
2158 UNLOCK(pe->PELock);
2159 } else {
2160 TRef = MkDBRefTerm(record(MkLast, t1, t2, Unsigned(0) PASS_REGS));
2161 }
2162 if (LOCAL_Error_TYPE != YAP_NO_ERROR) {
2163 if (recover_from_record_error(3)) {
2164 t1 = Deref(ARG1);
2165 t2 = Deref(ARG2);
2166 goto restart_record;
2167 } else {
2168 return FALSE;
2169 }
2170 }
2171 if (!pe)
2172 return FALSE;
2173 return Yap_unify(ARG3, TRef);
2174}
2175
2176/* recordz(+Functor,+Term,-Ref) */
2177Int Yap_Recordz(Atom at, Term t2) {
2178 CACHE_REGS
2179 PredEntry *pe;
2180
2181 pe = find_lu_entry(MkAtomTerm(at));
2182 LOCAL_Error_Size = 0;
2183restart_record:
2184 if (pe) {
2185 record_lu(pe, t2, MkLast);
2186 } else {
2187 record(MkLast, MkAtomTerm(at), t2, Unsigned(0) PASS_REGS);
2188 }
2189 if (LOCAL_Error_TYPE != YAP_NO_ERROR) {
2190 ARG1 = t2;
2191 if (recover_from_record_error(1)) {
2192 t2 = ARG1;
2193 goto restart_record;
2194 } else {
2195 return FALSE;
2196 }
2197 }
2198 return TRUE;
2199}
2200
2201/* '$recordzp'(+Functor,+Term,-Ref) */
2202static Int p_rcdzp(USES_REGS1) {
2203 Term TRef, t1 = Deref(ARG1), t2 = Deref(ARG2);
2204
2205 if (!IsVarTerm(Deref(ARG3)))
2206 return (FALSE);
2207 LOCAL_Error_Size = 0;
2208restart_record:
2209 TRef = MkDBRefTerm(record(MkLast | MkCode, t1, t2, Unsigned(0) PASS_REGS));
2210 if (LOCAL_Error_TYPE != YAP_NO_ERROR) {
2211 if (recover_from_record_error(3)) {
2212 t1 = Deref(ARG1);
2213 t2 = Deref(ARG2);
2214 goto restart_record;
2215 } else {
2216 return FALSE;
2217 }
2218 }
2219 return Yap_unify(ARG3, TRef);
2220}
2221
2222/* recordz_at(+Functor,+Term,-Ref) */
2231static Int p_rcdz_at(USES_REGS1) {
2232 /* Idiotic xlc's cpp does not work with ARG1 within MkDBRefTerm */
2233 Term TRef, t1 = Deref(ARG1), t2 = Deref(ARG2);
2234 DBRef dbr;
2235
2236 if (!IsVarTerm(Deref(ARG3)))
2237 return (FALSE);
2238 if (IsVarTerm(t1)) {
2239 Yap_ThrowError(INSTANTIATION_ERROR, t1, "recordz_at/3");
2240 return FALSE;
2241 }
2242 if (!IsDBRefTerm(t1)) {
2243 Yap_ThrowError(TYPE_ERROR_DBREF, t1, "recordz_at/3");
2244 return FALSE;
2245 }
2246 LOCAL_Error_Size = 0;
2247restart_record:
2248 dbr = DBRefOfTerm(t1);
2249 if (dbr->Flags & ErasedMask) {
2250 /* doesn't make sense */
2251 return FALSE;
2252 }
2253 if (dbr->Flags & LogUpdMask) {
2254 TRef = MkDBRefTerm((DBRef)record_lu_at(MkLast, (LogUpdClause *)dbr, t2));
2255 } else {
2256 TRef = MkDBRefTerm(record_at(MkLast, dbr, t2, Unsigned(0) PASS_REGS));
2257 }
2258 if (LOCAL_Error_TYPE != YAP_NO_ERROR) {
2259 if (recover_from_record_error(3)) {
2260 t1 = Deref(ARG1);
2261 t2 = Deref(ARG2);
2262 goto restart_record;
2263 } else {
2264 return FALSE;
2265 }
2266 }
2267 return Yap_unify(ARG3, TRef);
2268}
2269
2270/* '$record_stat_source'(+Functor,+Term) */
2271static Int p_rcdstatp(USES_REGS1) {
2272 Term t1 = Deref(ARG1), t2 = Deref(ARG2), t3 = Deref(ARG3);
2273 int mk_first;
2274 Term TRef;
2275
2276 if (IsVarTerm(t3) || !IsIntTerm(t3))
2277 return (FALSE);
2278 if (IsVarTerm(t3) || !IsIntTerm(t3))
2279 return (FALSE);
2280 mk_first = ((IntOfTerm(t3) % 4) == 2);
2281 LOCAL_Error_Size = 0;
2282restart_record:
2283 if (mk_first)
2284 TRef =
2285 MkDBRefTerm(record(MkFirst | MkCode, t1, t2, MkIntTerm(0) PASS_REGS));
2286 else
2287 TRef = MkDBRefTerm(record(MkLast | MkCode, t1, t2, MkIntTerm(0) PASS_REGS));
2288 if (LOCAL_Error_TYPE != YAP_NO_ERROR) {
2289 if (recover_from_record_error(4)) {
2290 t1 = Deref(ARG1);
2291 t2 = Deref(ARG2);
2292 t3 = Deref(ARG3);
2293 goto restart_record;
2294 } else {
2295 return FALSE;
2296 }
2297 }
2298 return Yap_unify(ARG4, TRef);
2299}
2300
2301/* '$recordap'(+Functor,+Term,-Ref,+CRef) */
2302static Int p_drcdap(USES_REGS1) {
2303 Term TRef, t1 = Deref(ARG1), t2 = Deref(ARG2), t4 = Deref(ARG4);
2304
2305 if (!IsVarTerm(Deref(ARG3)))
2306 return (FALSE);
2307 if (IsVarTerm(t4) || !IsIntegerTerm(t4))
2308 return (FALSE);
2309 LOCAL_Error_Size = 0;
2310restart_record:
2311 TRef = MkDBRefTerm(record(MkFirst | MkCode | WithRef, t1, t2, t4 PASS_REGS));
2312 if (LOCAL_Error_TYPE != YAP_NO_ERROR) {
2313 if (recover_from_record_error(4)) {
2314 t1 = Deref(ARG1);
2315 t2 = Deref(ARG2);
2316 t4 = Deref(ARG4);
2317 goto restart_record;
2318 } else {
2319 return FALSE;
2320 }
2321 }
2322 return Yap_unify(ARG3, TRef);
2323}
2324
2325/* '$recordzp'(+Functor,+Term,-Ref,+CRef) */
2326static Int p_drcdzp(USES_REGS1) {
2327 Term TRef, t1 = Deref(ARG1), t2 = Deref(ARG2), t4 = Deref(ARG4);
2328
2329 if (!IsVarTerm(Deref(ARG3)))
2330 return (FALSE);
2331 if (IsVarTerm(t4) || !IsIntegerTerm(t4))
2332 return (FALSE);
2333restart_record:
2334 LOCAL_Error_Size = 0;
2335 TRef = MkDBRefTerm(record(MkLast | MkCode | WithRef, t1, t2, t4 PASS_REGS));
2336 if (LOCAL_Error_TYPE != YAP_NO_ERROR) {
2337 if (recover_from_record_error(4)) {
2338 t1 = Deref(ARG1);
2339 t2 = Deref(ARG2);
2340 t4 = Deref(ARG4);
2341 goto restart_record;
2342 } else {
2343 return FALSE;
2344 }
2345 }
2346 return Yap_unify(ARG3, TRef);
2347}
2348
2349static Int p_still_variant(USES_REGS1) {
2350 CELL *old_h = B->cp_h;
2351 tr_fr_ptr old_tr = B->cp_tr;
2352 Term t1 = Deref(ARG1), t2 = Deref(ARG2);
2353 DBTerm *dbt;
2354 DBRef dbr;
2355
2356 if (IsVarTerm(t1) || !IsDBRefTerm(t1)) {
2357 return (FALSE);
2358 /* limited sanity checking */
2359 if (dbr->id != FunctorDBRef) {
2360 return FALSE;
2361 }
2362 } else {
2363 dbr = DBRefOfTerm(t1);
2364 }
2365 /* ok, we assume there was a choicepoint before we copied the term */
2366
2367 /* skip binding for argument variable */
2368 old_tr++;
2369 if (dbr->Flags & LogUpdMask) {
2370 LogUpdClause *cl = (LogUpdClause *)dbr;
2371
2372 if (old_tr == TR - 1) {
2373 if (TrailTerm(old_tr) != CLREF_TO_TRENTRY(cl))
2374 return FALSE;
2375 } else if (old_tr != TR)
2376 return FALSE;
2377 if (Yap_op_from_opcode(cl->ClCode->opc) == _unify_idb_term) {
2378 return TRUE;
2379 } else {
2380 dbt = cl->lusl.ClSource;
2381 }
2382 } else {
2383 if (old_tr == TR - 1) {
2384 if (TrailTerm(old_tr) != REF_TO_TRENTRY(dbr))
2385 return FALSE;
2386 } else if (old_tr != TR)
2387 return FALSE;
2388 if (dbr->Flags & (DBNoVars | DBAtomic))
2389 return TRUE;
2390 if (dbr->Flags & DBVar)
2391 return IsVarTerm(t2);
2392 dbt = &(dbr->DBT);
2393 }
2394 /*
2395 we checked the trail, so we are sure only variables in the new term
2396 were bound
2397 */
2398 {
2399 link_entry *lp = (link_entry *)(dbt->Contents + dbt->NOfCells);
2400 link_entry link;
2401
2402 if (!dbt->NOfCells) {
2403 return IsVarTerm(t2);
2404 }
2405 while ((link = *lp++)) {
2406 Term t2 = Deref(old_h[link - 1]);
2407 if (IsUnboundVar(dbt->Contents + (link - 1))) {
2408 if (IsVarTerm(t2)) {
2409 Yap_unify(t2, MkAtomTerm(AtomFoundVar));
2410 } else {
2411 return FALSE;
2412 }
2413 }
2414 }
2415 }
2416 return TRUE;
2417}
2418
2419#ifdef COROUTINING
2420static int copy_attachments(CELL *ts USES_REGS) {
2421 /* we will change delayed vars, and that also means the trail */
2422 tr_fr_ptr tr0 = TR;
2423
2424 while (TRUE) {
2425 /* store away in case there is an overflow */
2426
2427 if (GLOBAL_attas[IntegerOfTerm(ts[2])].term_to_op(ts[1], ts[0] PASS_REGS) ==
2428 FALSE) {
2429 /* oops, we did not have enough space to copy the elements */
2430 /* reset queue of woken up goals */
2431 TR = tr0;
2432 return FALSE;
2433 }
2434 if (ts[3] == TermNil)
2435 return TRUE;
2436 ts = RepAppl(ts[3]) + 1;
2437 }
2438}
2439#endif
2440
2441static Term GetDBLUKey(PredEntry *ap) {
2442 PELOCK(63, ap);
2443 if (ap->PredFlags & NumberDBPredFlag) {
2444 CACHE_REGS
2445 Int id = ap->src.IndxId;
2446 UNLOCK(ap->PELock);
2447 return MkIntegerTerm(id);
2448 } else if (ap->PredFlags & AtomDBPredFlag ||
2449 (ap->ModuleOfPred != IDB_MODULE && ap->ArityOfPE == 0)) {
2450 Atom at = (Atom)ap->FunctorOfPred;
2451 UNLOCK(ap->PELock);
2452 return MkAtomTerm(at);
2453 } else {
2454 Functor f = ap->FunctorOfPred;
2455 UNLOCK(ap->PELock);
2456 return Yap_MkNewApplTerm(f, ArityOfFunctor(f));
2457 }
2458}
2459
2460static int UnifyDBKey(DBRef DBSP, PropFlags flags, Term t) {
2461 DBProp p = DBSP->Parent;
2462 Term t1, tf;
2463
2464 READ_LOCK(p->DBRWLock);
2465 /* get the key */
2466 if (p->ArityOfDB == 0) {
2467 t1 = MkAtomTerm((Atom)(p->FunctorOfDB));
2468 } else {
2469 t1 = Yap_MkNewApplTerm(p->FunctorOfDB, p->ArityOfDB);
2470 }
2471 if ((p->KindOfPE & CodeDBBit) && (flags & CodeDBBit)) {
2472 Term t[2];
2473 if (p->ModuleOfDB)
2474 t[0] = p->ModuleOfDB;
2475 else
2476 t[0] = TermProlog;
2477 t[1] = t1;
2478 tf = Yap_MkApplTerm(FunctorModule, 2, t);
2479 } else if (!(flags & CodeDBBit)) {
2480 tf = t1;
2481 } else {
2482 return FALSE;
2483 }
2484 READ_UNLOCK(p->DBRWLock);
2485 return Yap_unify(tf, t);
2486}
2487
2488static int UnifyDBNumber(DBRef DBSP, Term t) {
2489 CACHE_REGS
2490 DBProp p = DBSP->Parent;
2491 DBRef ref;
2492 Int i = 1;
2493
2494 READ_LOCK(p->DBRWLock);
2495 ref = p->First;
2496 while (ref != NIL) {
2497 if (ref == DBSP)
2498 break;
2499 if (!DEAD_REF(ref))
2500 i++;
2501 ref = ref->Next;
2502 }
2503 if (ref == NIL)
2504 return FALSE;
2505 READ_UNLOCK(p->DBRWLock);
2506 return Yap_unify(MkIntegerTerm(i), t);
2507}
2508
2509Int Yap_unify_immediate_ref(DBRef ref USES_REGS) {
2510 // old immediate semantics style
2511 LOCK(ref->lock);
2512 if (ref == NULL || DEAD_REF(ref) || !UnifyDBKey(ref, 0, ARG1) ||
2513 !UnifyDBNumber(ref, ARG2)) {
2514 UNLOCK(ref->lock);
2515 return FALSE;
2516 } else {
2517 UNLOCK(ref->lock);
2518 return TRUE;
2519 }
2520}
2521
2522static Term GetDBTerm(DBTerm *DBSP, int src USES_REGS) {
2523 Term t = DBSP->Entry;
2524
2525 if (IsVarTerm(t)
2526#if COROUTINING
2527 && !DBSP->ag.attachments
2528#endif
2529 ) {
2530 return MkVarTerm();
2531 } else if (IsAtomOrIntTerm(t)) {
2532 return t;
2533 } else {
2534 CELL *HOld = HR;
2535 CELL *HeapPtr;
2536 CELL *pt;
2537 CELL NOf;
2538
2539 if (!(NOf = DBSP->NOfCells)) {
2540 return t;
2541 }
2542 pt = CellPtr(DBSP->Contents);
2543 CalculateStackGap(PASS_REGS1);
2544 if (HR + NOf > ASP - EventFlag / sizeof(CELL)) {
2545 if (LOCAL_PrologMode & InErrorMode) {
2546 LOCAL_PrologMode &= ~InErrorMode;
2547 if (HR + NOf > ASP)
2548 fprintf(stderr,
2549 "\n\n [ FATAL ERROR: No Stack for Error Handling ]\n");
2550 Yap_exit(1);
2551 } else {
2552 LOCAL_Error_TYPE = RESOURCE_ERROR_STACK;
2553 LOCAL_Error_Size = NOf * sizeof(CELL);
2554 return (Term)0;
2555 }
2556 }
2557 HeapPtr = cpcells(HOld, pt, NOf);
2558 pt += HeapPtr - HOld;
2559 HR = HeapPtr;
2560 {
2561 link_entry *lp = (link_entry *)pt;
2562 linkblk(lp, HOld - 1, (CELL)HOld - (CELL)(DBSP->Contents));
2563 }
2564#ifdef COROUTINING
2565 if (DBSP->ag.attachments != 0L && !src) {
2566 if (!copy_attachments((CELL *)AdjustIDBPtr(
2567 DBSP->ag.attachments, (CELL)HOld - (CELL)(DBSP->Contents))
2568 PASS_REGS)) {
2569 HR = HOld;
2570 LOCAL_Error_TYPE = RESOURCE_ERROR_ATTRIBUTED_VARIABLES;
2571 LOCAL_Error_Size = 0;
2572 return (Term)0;
2573 }
2574 }
2575#endif
2576 return AdjustIDBPtr(t, Unsigned(HOld) - (CELL)(DBSP->Contents));
2577 }
2578}
2579
2580static Term GetDBTermFromDBEntry(DBRef DBSP USES_REGS) {
2581 if (DBSP->Flags & (DBNoVars | DBAtomic))
2582 return DBSP->DBT.Entry;
2583 return GetDBTerm(&(DBSP->DBT), FALSE PASS_REGS);
2584}
2585
2586static void init_int_keys(void) {
2587 INT_KEYS = (Prop *)Yap_AllocCodeSpace(sizeof(Prop) * INT_KEYS_SIZE);
2588 if (INT_KEYS != NULL) {
2589 UInt i = 0;
2590 Prop *p = INT_KEYS;
2591 for (i = 0; i < INT_KEYS_SIZE; i++) {
2592 p[0] = NIL;
2593 p++;
2594 }
2595 Yap_LUClauseSpace += sizeof(Prop) * INT_KEYS_SIZE;
2596 }
2597}
2598
2599static void init_int_lu_keys(void) {
2600 INT_LU_KEYS = (Prop *)Yap_AllocCodeSpace(sizeof(Prop) * INT_KEYS_SIZE);
2601 if (INT_LU_KEYS != NULL) {
2602 UInt i = 0;
2603 Prop *p = INT_LU_KEYS;
2604 for (i = 0; i < INT_KEYS_SIZE; i++) {
2605 p[0] = NULL;
2606 p++;
2607 }
2608 Yap_LUClauseSpace += sizeof(Prop) * INT_KEYS_SIZE;
2609 }
2610}
2611
2612static int resize_int_keys(UInt new_size) {
2613 CACHE_REGS
2614 Prop *new;
2615 UInt i;
2616 UInt old_size = INT_KEYS_SIZE;
2617
2618 YAPEnterCriticalSection();
2619 if (INT_KEYS == NULL) {
2620 INT_KEYS_SIZE = new_size;
2621 YAPLeaveCriticalSection();
2622 return TRUE;
2623 }
2624 new = (Prop *)Yap_AllocCodeSpace(sizeof(Prop) * new_size);
2625 if (new == NULL) {
2626 YAPLeaveCriticalSection();
2627 LOCAL_Error_TYPE = RESOURCE_ERROR_HEAP;
2628 LOCAL_ErrorMessage = "could not allocate space";
2629 return FALSE;
2630 }
2631 Yap_LUClauseSpace += sizeof(Prop) * new_size;
2632 for (i = 0; i < new_size; i++) {
2633 new[i] = NIL;
2634 }
2635 for (i = 0; i < INT_KEYS_SIZE; i++) {
2636 if (INT_KEYS[i] != NIL) {
2637 Prop p0 = INT_KEYS[i];
2638 while (p0 != NIL) {
2639 DBProp p = RepDBProp(p0);
2640 CELL key = (CELL)(p->FunctorOfDB);
2641 UInt hash_key = (CELL)key % new_size;
2642 p0 = p->NextOfPE;
2643 p->NextOfPE = new[hash_key];
2644 new[hash_key] = AbsDBProp(p);
2645 }
2646 }
2647 }
2648 Yap_LUClauseSpace -= sizeof(Prop) * old_size;
2649 Yap_FreeCodeSpace((char *)INT_KEYS);
2650 INT_KEYS = new;
2651 INT_KEYS_SIZE = new_size;
2652 INT_KEYS_TIMESTAMP++;
2653 if (INT_KEYS_TIMESTAMP == MAX_ABS_INT)
2654 INT_KEYS_TIMESTAMP = 0;
2655 YAPLeaveCriticalSection();
2656 return TRUE;
2657}
2658
2659static PredEntry *find_lu_int_key(Int key) {
2660 UInt hash_key = (CELL)key % INT_KEYS_SIZE;
2661 Prop p0;
2662
2663 if (INT_LU_KEYS != NULL) {
2664 p0 = INT_LU_KEYS[hash_key];
2665 while (p0) {
2666 PredEntry *pe = RepPredProp(p0);
2667 if (pe->src.IndxId == key) {
2668 return pe;
2669 }
2670 p0 = pe->NextOfPE;
2671 }
2672 }
2673 if (UPDATE_MODE == UPDATE_MODE_LOGICAL && find_int_key(key) == NULL) {
2674 return new_lu_int_key(key);
2675 }
2676 return NULL;
2677}
2678
2679PredEntry *Yap_FindLUIntKey(Int key) { return find_lu_int_key(key); }
2680
2681static DBProp find_int_key(Int key) {
2682 UInt hash_key = (CELL)key % INT_KEYS_SIZE;
2683 Prop p0;
2684
2685 if (INT_KEYS == NULL) {
2686 return NULL;
2687 }
2688 p0 = INT_KEYS[hash_key];
2689 while (p0) {
2690 DBProp p = RepDBProp(p0);
2691 if (p->FunctorOfDB == (Functor)key)
2692 return p;
2693 p0 = p->NextOfPE;
2694 }
2695 return NULL;
2696}
2697
2698static PredEntry *new_lu_int_key(Int key) {
2699 UInt hash_key = (CELL)key % INT_KEYS_SIZE;
2700 PredEntry *p;
2701 Prop p0;
2702 Atom ae;
2703
2704 if (INT_LU_KEYS == NULL) {
2705 init_int_lu_keys();
2706 if (INT_LU_KEYS == NULL) {
2707 CACHE_REGS
2708 LOCAL_Error_TYPE = RESOURCE_ERROR_HEAP;
2709 LOCAL_ErrorMessage = "could not allocate space";
2710 return NULL;
2711 }
2712 }
2713 ae = AtomDInteger;
2714 WRITE_LOCK(ae->ARWLock);
2715 p0 = Yap_NewPredPropByAtom(ae, IDB_MODULE);
2716 p = RepPredProp(p0);
2717 p->NextOfPE = INT_LU_KEYS[hash_key];
2718 p->src.IndxId = key;
2719 p->PredFlags |= LogUpdatePredFlag | NumberDBPredFlag;
2720 p->ArityOfPE = 3;
2721 p->OpcodeOfPred = Yap_opcode(_op_fail);
2722 p->cs.p_code.TrueCodeOfPred = p->CodeOfPred = FAILCODE;
2723 if (p->PredFlags & ProfiledPredFlag) {
2724 if (!Yap_initProfiler(p)) {
2725 return NULL;
2726 }
2727 }
2728 INT_LU_KEYS[hash_key] = p0;
2729 return p;
2730}
2731
2732static PredEntry *new_lu_entry(Term t) {
2733 CACHE_REGS
2734 Prop p0;
2735 PredEntry *pe;
2736
2737 if (IsApplTerm(t)) {
2738 Functor f = FunctorOfTerm(t);
2739
2740 FUNC_WRITE_LOCK(f);
2741 p0 = Yap_NewPredPropByFunctor(f, IDB_MODULE);
2742 } else if (IsAtomTerm(t)) {
2743 Atom at = AtomOfTerm(t);
2744
2745 WRITE_LOCK(RepAtom(at)->ARWLock);
2746 p0 = Yap_NewPredPropByAtom(at, IDB_MODULE);
2747 } else {
2748 FUNC_WRITE_LOCK(FunctorList);
2749 p0 = Yap_NewPredPropByFunctor(FunctorList, IDB_MODULE);
2750 }
2751 pe = RepPredProp(p0);
2752 pe->PredFlags |= LogUpdatePredFlag;
2753 if (IsAtomTerm(t)) {
2754 pe->PredFlags |= AtomDBPredFlag;
2755 pe->FunctorOfPred = (Functor)AtomOfTerm(t);
2756 } else {
2757 pe->FunctorOfPred = FunctorOfTerm(t);
2758 }
2759 pe->ArityOfPE = 3;
2760 pe->OpcodeOfPred = Yap_opcode(_op_fail);
2761 if (CurrentModule == PROLOG_MODULE)
2762 pe->PredFlags |= StandardPredFlag;
2763 pe->cs.p_code.TrueCodeOfPred = pe->CodeOfPred = FAILCODE;
2764 if (pe->PredFlags & ProfiledPredFlag) {
2765 if (!Yap_initProfiler(pe)) {
2766 return NULL;
2767 }
2768 }
2769 return pe;
2770}
2771
2772static DBProp find_entry(Term t) {
2773 Atom at;
2774 UInt arity;
2775
2776 if (IsVarTerm(t)) {
2777 return RepDBProp(NIL);
2778 } else if (IsAtomTerm(t)) {
2779 at = AtomOfTerm(t);
2780 arity = 0;
2781
2782 } else if (IsIntegerTerm(t)) {
2783 return find_int_key(IntegerOfTerm(t));
2784 } else if (IsApplTerm(t)) {
2785 Functor f = FunctorOfTerm(t);
2786
2787 at = NameOfFunctor(f);
2788 arity = ArityOfFunctor(f);
2789 } else {
2790 at = AtomDot;
2791 arity = 2;
2792 }
2793 DBProp rc = RepDBProp(FindDBProp(RepAtom(at), 0, arity, 0));
2794 return rc;
2795}
2796
2797static PredEntry *find_lu_entry(Term t) {
2798 Prop p;
2799
2800 if (IsVarTerm(t)) {
2801 Yap_ThrowError(INSTANTIATION_ERROR, t, "while accessing database key");
2802 return NULL;
2803 }
2804 if (IsIntegerTerm(t)) {
2805 return find_lu_int_key(IntegerOfTerm(t));
2806 } else if (IsApplTerm(t)) {
2807 Functor f = FunctorOfTerm(t);
2808
2809 if (IsExtensionFunctor(f)) {
2810 Yap_ThrowError(TYPE_ERROR_KEY, t, "while accessing database key");
2811 return NULL;
2812 }
2813 p = Yap_GetPredPropByFuncInThisModule(FunctorOfTerm(t), IDB_MODULE);
2814 } else if (IsAtomTerm(t)) {
2815 p = Yap_GetPredPropByAtomInThisModule(AtomOfTerm(t), IDB_MODULE);
2816 } else {
2817 p = Yap_GetPredPropByFuncInThisModule(FunctorList, IDB_MODULE);
2818 }
2819 if (p == NIL) {
2820 if (UPDATE_MODE == UPDATE_MODE_LOGICAL && !find_entry(t)) {
2821 return new_lu_entry(t);
2822 } else {
2823 return NULL;
2824 }
2825 }
2826 return RepPredProp(p);
2827}
2828
2829static DBProp FetchIntDBPropFromKey(Int key, int flag, int new,
2830 char *error_mssg) {
2831 Functor fun = (Functor)key;
2832 UInt hash_key = (CELL)key % INT_KEYS_SIZE;
2833 Prop p0;
2834
2835 if (INT_KEYS == NULL) {
2836 init_int_keys();
2837 if (INT_KEYS == NULL) {
2838 CACHE_REGS
2839 LOCAL_Error_TYPE = RESOURCE_ERROR_HEAP;
2840 LOCAL_ErrorMessage = "could not allocate space";
2841 return NULL;
2842 }
2843 }
2844 p0 = INT_KEYS[hash_key];
2845 while (p0 != NIL) {
2846 DBProp p = RepDBProp(p0);
2847 if (p->FunctorOfDB == fun)
2848 return p;
2849 p0 = p->NextOfPE;
2850 }
2851 /* p is NULL, meaning we did not find the functor */
2852 if (new) {
2853 DBProp p;
2854 /* create a new DBProp */
2855 p = (DBProp)Yap_AllocAtomSpace(sizeof(*p));
2856 p->KindOfPE = DBProperty | flag;
2857 p->F0 = p->L0 = NULL;
2858 p->ArityOfDB = 0;
2859 p->First = p->Last = NULL;
2860 p->ModuleOfDB = 0;
2861 p->FunctorOfDB = fun;
2862 p->NextOfPE = INT_KEYS[hash_key];
2863 INIT_RWLOCK(p->DBRWLock);
2864 INT_KEYS[hash_key] = AbsDBProp(p);
2865 return p;
2866 } else {
2867 return RepDBProp(NULL);
2868 }
2869}
2870
2871static DBProp FetchDBPropFromKey(Term twork, int flag, int new,
2872 char *error_mssg) {
2873 Atom At;
2874 Int arity;
2875 Term dbmod;
2876
2877 if (flag & MkCode) {
2878 if (IsVarTerm(twork)) {
2879 Yap_ThrowError(INSTANTIATION_ERROR, twork, error_mssg);
2880 return RepDBProp(NULL);
2881 }
2882 if (!IsApplTerm(twork)) {
2883 Yap_ThrowError(SYSTEM_ERROR_INTERNAL, twork, "missing module");
2884 return RepDBProp(NULL);
2885 } else {
2886 Functor f = FunctorOfTerm(twork);
2887 if (f != FunctorModule) {
2888 Yap_ThrowError(SYSTEM_ERROR_INTERNAL, twork, "missing module");
2889 return RepDBProp(NULL);
2890 }
2891 dbmod = ArgOfTerm(1, twork);
2892 if (IsVarTerm(dbmod)) {
2893 Yap_ThrowError(INSTANTIATION_ERROR, twork, "var in module");
2894 return RepDBProp(NIL);
2895 }
2896 if (!IsAtomTerm(dbmod)) {
2897 Yap_ThrowError(TYPE_ERROR_ATOM, twork, "not atom in module");
2898 return RepDBProp(NIL);
2899 }
2900 twork = ArgOfTerm(2, twork);
2901 }
2902 } else {
2903 dbmod = TermIDB;
2904 }
2905 if (IsVarTerm(twork)) {
2906 Yap_ThrowError(INSTANTIATION_ERROR, twork, error_mssg);
2907 return RepDBProp(NIL);
2908 } else if (IsAtomTerm(twork)) {
2909 arity = 0, At = AtomOfTerm(twork);
2910 } else if (IsIntegerTerm(twork)) {
2911 return FetchIntDBPropFromKey(IntegerOfTerm(twork), flag, new, error_mssg);
2912 } else if (IsApplTerm(twork)) {
2913 Register Functor f = FunctorOfTerm(twork);
2914 if (IsExtensionFunctor(f)) {
2915 Yap_ThrowError(TYPE_ERROR_KEY, twork, error_mssg);
2916 return RepDBProp(NIL);
2917 }
2918 At = NameOfFunctor(f);
2919 arity = ArityOfFunctor(f);
2920 } else if (IsPairTerm(twork)) {
2921 At = AtomDot;
2922 arity = 2;
2923 } else {
2924 Yap_ThrowError(TYPE_ERROR_KEY, twork, error_mssg);
2925 return RepDBProp(NIL);
2926 }
2927 if (new) {
2928 DBProp p;
2929 AtomEntry *ae = RepAtom(At);
2930
2931 WRITE_LOCK(ae->ARWLock);
2932 if (EndOfPAEntr(
2933 p = RepDBProp(FindDBPropHavingLock(ae, flag, arity, dbmod)))) {
2934 /* create a new DBProp */
2935 int OLD_UPDATE_MODE = UPDATE_MODE;
2936 if (flag & MkCode) {
2937 PredEntry *pp;
2938 pp = RepPredProp(Yap_GetPredPropHavingLock(At, arity, dbmod));
2939
2940 if (!EndOfPAEntr(pp)) {
2941 PELOCK(64, pp);
2942 if (pp->PredFlags & LogUpdatePredFlag)
2943 UPDATE_MODE = UPDATE_MODE_LOGICAL;
2944 UNLOCK(pp->PELock);
2945 }
2946 }
2947 p = (DBProp)Yap_AllocAtomSpace(sizeof(*p));
2948 p->KindOfPE = DBProperty | flag;
2949 p->F0 = p->L0 = NULL;
2950 UPDATE_MODE = OLD_UPDATE_MODE;
2951 p->ArityOfDB = arity;
2952 p->First = p->Last = NIL;
2953 p->ModuleOfDB = dbmod;
2954 /* This is NOT standard but is QUITE convenient */
2955 INIT_RWLOCK(p->DBRWLock);
2956 if (arity == 0)
2957 p->FunctorOfDB = (Functor)At;
2958 else
2959 p->FunctorOfDB = Yap_UnlockedMkFunctor(ae, arity);
2960 AddPropToAtom(ae, (PropEntry *)p);
2961 }
2962 WRITE_UNLOCK(ae->ARWLock);
2963 return p;
2964 } else
2965 return RepDBProp(FindDBProp(RepAtom(At), flag, arity, dbmod));
2966}
2967
2968static Int lu_nth_recorded(PredEntry *pe, Int Count USES_REGS) {
2969 LogUpdClause *cl;
2970
2971 XREGS[2] = MkVarTerm();
2972 cl = Yap_NthClause(pe, Count);
2973 if (cl == NULL)
2974 return FALSE;
2975#if MULTIPLE_STACKS
2976 TRAIL_CLREF(cl); /* So that fail will erase it */
2977 INC_CLREF_COUNT(cl);
2978#else
2979 if (!(cl->ClFlags & InUseMask)) {
2980 cl->ClFlags |= InUseMask;
2981 TRAIL_CLREF(cl); /* So that fail will erase it */
2982 }
2983#endif
2984 UNLOCK(pe->PELock);
2985 return Yap_unify(MkDBRefTerm((DBRef)cl), ARG4);
2986}
2987
2988/* Finds a term recorded under the key ARG1 */
2989static Int nth_recorded(DBProp AtProp, Int Count USES_REGS) {
2990 Register DBRef ref;
2991
2992 READ_LOCK(AtProp->DBRWLock);
2993 ref = AtProp->First;
2994 Count--;
2995 while (ref != NULL && DEAD_REF(ref))
2996 ref = NextDBRef(ref);
2997 if (ref == NULL) {
2998 READ_UNLOCK(AtProp->DBRWLock);
2999 return FALSE;
3000 }
3001 while (Count) {
3002 Count--;
3003 ref = NextDBRef(ref);
3004 while (ref != NULL && DEAD_REF(ref))
3005 ref = NextDBRef(ref);
3006 if (ref == NULL) {
3007 READ_UNLOCK(AtProp->DBRWLock);
3008 return FALSE;
3009 }
3010 }
3011#if MULTIPLE_STACKS
3012 LOCK(ref->lock);
3013 READ_UNLOCK(AtProp->DBRWLock);
3014 TRAIL_REF(ref); /* So that fail will erase it */
3015 INC_DBREF_COUNT(ref);
3016 UNLOCK(ref->lock);
3017#else
3018 if (!(ref->Flags & InUseMask)) {
3019 ref->Flags |= InUseMask;
3020 TRAIL_REF(ref); /* So that fail will erase it */
3021 }
3022 READ_UNLOCK(AtProp->DBRWLock);
3023#endif
3024 return Yap_unify(MkDBRefTerm(ref), ARG4);
3025}
3026
3027Int Yap_db_nth_recorded(PredEntry *pe, Int Count USES_REGS) {
3028 DBProp AtProp;
3029
3030 if (pe == NULL) {
3031 return lu_nth_recorded(pe, Count PASS_REGS);
3032 }
3033 if (EndOfPAEntr(AtProp = FetchDBPropFromKey(Deref(ARG1), 0, FALSE,
3034 "nth_instance/3"))) {
3035 UNLOCK(pe->PELock);
3036 return FALSE;
3037 }
3038 return nth_recorded(AtProp, Count PASS_REGS);
3039}
3040
3041static Int p_db_key(USES_REGS1) {
3042 Register Term twork = Deref(ARG1); /* fetch the key */
3043 DBProp AtProp;
3044
3045 if (EndOfPAEntr(AtProp = FetchDBPropFromKey(twork, 0, TRUE, "db_key/3"))) {
3046 /* should never happen */
3047 return FALSE;
3048 }
3049 return Yap_unify(ARG2, MkIntegerTerm((Int)AtProp));
3050}
3051
3052/* Finds a term recorded under the key ARG1 */
3053static Int i_recorded(DBProp AtProp, Term t3 USES_REGS) {
3054 Term TermDB, TRef;
3055 Register DBRef ref;
3056 Term twork;
3057
3058 READ_LOCK(AtProp->DBRWLock);
3059 ref = AtProp->First;
3060 while (ref != NULL && DEAD_REF(ref))
3061 ref = NextDBRef(ref);
3062 READ_UNLOCK(AtProp->DBRWLock);
3063 if (ref == NULL) {
3064 cut_fail();
3065 }
3066 twork = Deref(ARG2); /* now working with ARG2 */
3067 if (IsVarTerm(twork)) {
3068 EXTRA_CBACK_ARG(3, 2) = MkIntegerTerm(0);
3069 EXTRA_CBACK_ARG(3, 3) = MkIntegerTerm(0);
3070 B->cp_h = HR;
3071 while ((TermDB = GetDBTermFromDBEntry(ref PASS_REGS)) == (CELL)0) {
3072 /* make sure the garbage collector sees what we want it to see! */
3073 EXTRA_CBACK_ARG(3, 1) = (CELL)ref;
3074 /* oops, we are in trouble, not enough stack space */
3075 if (LOCAL_Error_TYPE == RESOURCE_ERROR_ATTRIBUTED_VARIABLES) {
3076 LOCAL_Error_TYPE = YAP_NO_ERROR;
3077 if (!Yap_growglobal(NULL)) {
3078 Yap_ThrowError(RESOURCE_ERROR_ATTRIBUTED_VARIABLES, TermNil,
3079 LOCAL_ErrorMessage);
3080 return FALSE;
3081 }
3082 } else {
3083 LOCAL_Error_TYPE = YAP_NO_ERROR;
3084 if (!Yap_dogc()) {
3085 Yap_ThrowError(RESOURCE_ERROR_STACK, TermNil, LOCAL_ErrorMessage);
3086 return FALSE;
3087 }
3088 }
3089 LOCAL_Error_Size = 0;
3090 twork = Deref(ARG2);
3091 t3 = Deref(ARG3);
3092 }
3093 if (!Yap_unify(twork, TermDB)) {
3094 cut_fail();
3095 }
3096 } else if (IsAtomOrIntTerm(twork)) {
3097 EXTRA_CBACK_ARG(3, 2) = MkIntegerTerm(0);
3098 EXTRA_CBACK_ARG(3, 3) = MkIntegerTerm((Int)twork);
3099 B->cp_h = HR;
3100 READ_LOCK(AtProp->DBRWLock);
3101 do {
3102 if (((twork == ref->DBT.Entry) || IsVarTerm(ref->DBT.Entry)) &&
3103 !DEAD_REF(ref))
3104 break;
3105 ref = NextDBRef(ref);
3106 if (ref == NIL) {
3107 READ_UNLOCK(AtProp->DBRWLock);
3108 cut_fail();
3109 }
3110 } while (TRUE);
3111 READ_UNLOCK(AtProp->DBRWLock);
3112 } else {
3113 CELL key;
3114 CELL mask = EvalMasks(twork, &key);
3115
3116 B->cp_h = HR;
3117 READ_LOCK(AtProp->DBRWLock);
3118 do {
3119 while ((mask & ref->Key) != (key & ref->Mask) && !DEAD_REF(ref)) {
3120 ref = NextDBRef(ref);
3121 if (ref == NULL) {
3122 READ_UNLOCK(AtProp->DBRWLock);
3123 cut_fail();
3124 }
3125 }
3126 if ((TermDB = GetDBTermFromDBEntry(ref PASS_REGS)) != (CELL)0) {
3127 if (Yap_unify(TermDB, ARG2)) {
3128 /* success */
3129 EXTRA_CBACK_ARG(3, 2) = MkIntegerTerm(((Int)mask));
3130 EXTRA_CBACK_ARG(3, 3) = MkIntegerTerm(((Int)key));
3131 B->cp_h = HR;
3132 break;
3133 } else {
3134 while ((ref = NextDBRef(ref)) != NULL && DEAD_REF(ref))
3135 ;
3136 if (ref == NULL) {
3137 READ_UNLOCK(AtProp->DBRWLock);
3138 cut_fail();
3139 }
3140 }
3141 } else {
3142 /* make sure the garbage collector sees what we want it to see! */
3143 EXTRA_CBACK_ARG(3, 1) = (CELL)ref;
3144 READ_UNLOCK(AtProp->DBRWLock);
3145 EXTRA_CBACK_ARG(3, 2) = MkIntegerTerm(((Int)mask));
3146 EXTRA_CBACK_ARG(3, 3) = MkIntegerTerm(((Int)key));
3147 /* oops, we are in trouble, not enough stack space */
3148 if (LOCAL_Error_TYPE == RESOURCE_ERROR_ATTRIBUTED_VARIABLES) {
3149 LOCAL_Error_TYPE = YAP_NO_ERROR;
3150 if (!Yap_growglobal(NULL)) {
3151 Yap_ThrowError(RESOURCE_ERROR_ATTRIBUTED_VARIABLES, TermNil,
3152 LOCAL_ErrorMessage);
3153 return FALSE;
3154 }
3155 } else {
3156 LOCAL_Error_TYPE = YAP_NO_ERROR;
3157 if (!Yap_dogc()) {
3158 Yap_ThrowError(RESOURCE_ERROR_STACK, TermNil, LOCAL_ErrorMessage);
3159 return FALSE;
3160 }
3161 }
3162 READ_LOCK(AtProp->DBRWLock);
3163 }
3164 } while (TRUE);
3165 READ_UNLOCK(AtProp->DBRWLock);
3166 }
3167 EXTRA_CBACK_ARG(3, 1) = (CELL)ref;
3168 /* This should be after any non-tagged terms, because the routines in grow.c
3169 go from upper to lower addresses */
3170 TRef = MkDBRefTerm(ref);
3171#if MULTIPLE_STACKS
3172 LOCK(ref->lock);
3173 TRAIL_REF(ref); /* So that fail will erase it */
3174 INC_DBREF_COUNT(ref);
3175 UNLOCK(ref->lock);
3176#else
3177 if (!(ref->Flags & InUseMask)) {
3178 ref->Flags |= InUseMask;
3179 TRAIL_REF(ref); /* So that fail will erase it */
3180 }
3181#endif
3182 return (Yap_unify(ARG3, TRef));
3183}
3184
3185static Int c_recorded(int flags USES_REGS) {
3186 Term TermDB, TRef;
3187 Register DBRef ref, ref0;
3188 CELL *PreviousHeap = HR;
3189 CELL mask, key;
3190 Term t1;
3191
3192 t1 = EXTRA_CBACK_ARG(3, 1);
3193 ref0 = (DBRef)t1;
3194 READ_LOCK(ref0->Parent->DBRWLock);
3195 ref = NextDBRef(ref0);
3196 if (ref == NIL) {
3197 if (ref0->Flags & ErasedMask) {
3198 ref = ref0;
3199 while ((ref = ref->n) != NULL) {
3200 if (!(ref->Flags & ErasedMask))
3201 break;
3202 }
3203 /* we have used the DB entry, so we can remove it now, although
3204 first we have to make sure noone is pointing to it */
3205 if (ref == NULL) {
3206 READ_UNLOCK(ref0->Parent->DBRWLock);
3207 cut_fail();
3208 }
3209 } else {
3210 READ_UNLOCK(ref0->Parent->DBRWLock);
3211 cut_fail();
3212 }
3213 }
3214
3215 {
3216 Term ttmp = EXTRA_CBACK_ARG(3, 2);
3217 if (IsLongIntTerm(ttmp))
3218 mask = (CELL)LongIntOfTerm(ttmp);
3219 else
3220 mask = (CELL)IntOfTerm(ttmp);
3221 }
3222 {
3223 Term ttmp = EXTRA_CBACK_ARG(3, 3);
3224 if (IsLongIntTerm(ttmp))
3225 key = (CELL)LongIntOfTerm(ttmp);
3226 else
3227 key = (CELL)IntOfTerm(ttmp);
3228 }
3229 while (ref != NIL && DEAD_REF(ref))
3230 ref = NextDBRef(ref);
3231 if (ref == NIL) {
3232 READ_UNLOCK(ref0->Parent->DBRWLock);
3233 cut_fail();
3234 }
3235 if (mask == 0 && key == 0) { /* ARG2 is a variable */
3236 while ((TermDB = GetDBTermFromDBEntry(ref PASS_REGS)) == (CELL)0) {
3237 /* make sure the garbage collector sees what we want it to see! */
3238 EXTRA_CBACK_ARG(3, 1) = (CELL)ref;
3239 /* oops, we are in trouble, not enough stack space */
3240 if (LOCAL_Error_TYPE == RESOURCE_ERROR_ATTRIBUTED_VARIABLES) {
3241 LOCAL_Error_TYPE = YAP_NO_ERROR;
3242 if (!Yap_growglobal(NULL)) {
3243 Yap_ThrowError(RESOURCE_ERROR_ATTRIBUTED_VARIABLES, TermNil,
3244 LOCAL_ErrorMessage);
3245 return FALSE;
3246 }
3247 } else {
3248 LOCAL_Error_TYPE = YAP_NO_ERROR;
3249 if (!Yap_dogc()) {
3250 Yap_ThrowError(RESOURCE_ERROR_STACK, TermNil, LOCAL_ErrorMessage);
3251 return FALSE;
3252 }
3253 }
3254 LOCAL_Error_Size = 0;
3255 PreviousHeap = HR;
3256 }
3257 Yap_unify(ARG2, TermDB);
3258 } else if (mask == 0) { /* ARG2 is a constant */
3259 do {
3260 if (((key == Unsigned(ref->DBT.Entry)) || (ref->Flags & DBVar)) &&
3261 !DEAD_REF(ref))
3262 break;
3263 ref = NextDBRef(ref);
3264 } while (ref != NIL);
3265 if (ref == NIL) {
3266 READ_UNLOCK(ref0->Parent->DBRWLock);
3267 cut_fail();
3268 }
3269 } else
3270 do { /* ARG2 is a structure */
3271 HR = PreviousHeap;
3272 while ((mask & ref->Key) != (key & ref->Mask)) {
3273 while ((ref = NextDBRef(ref)) != NIL && DEAD_REF(ref))
3274 ;
3275 if (ref == NIL) {
3276 READ_UNLOCK(ref0->Parent->DBRWLock);
3277 cut_fail();
3278 }
3279 }
3280 while ((TermDB = GetDBTermFromDBEntry(ref PASS_REGS)) == (CELL)0) {
3281 /* make sure the garbage collector sees what we want it to see! */
3282 EXTRA_CBACK_ARG(3, 1) = (CELL)ref;
3283 /* oops, we are in trouble, not enough stack space */
3284 if (LOCAL_Error_TYPE == RESOURCE_ERROR_ATTRIBUTED_VARIABLES) {
3285 LOCAL_Error_TYPE = YAP_NO_ERROR;
3286 if (!Yap_growglobal(NULL)) {
3287 Yap_ThrowError(RESOURCE_ERROR_ATTRIBUTED_VARIABLES, TermNil,
3288 LOCAL_ErrorMessage);
3289 return FALSE;
3290 }
3291 } else {
3292 LOCAL_Error_TYPE = YAP_NO_ERROR;
3293 if (!Yap_dogc()) {
3294 Yap_ThrowError(RESOURCE_ERROR_STACK, TermNil, LOCAL_ErrorMessage);
3295 return FALSE;
3296 }
3297 }
3298 LOCAL_Error_Size = 0;
3299 PreviousHeap = HR;
3300 }
3301 if (Yap_unify(ARG2, TermDB))
3302 break;
3303 while ((ref = NextDBRef(ref)) != NIL && DEAD_REF(ref))
3304 ;
3305 if (ref == NIL) {
3306 READ_UNLOCK(ref0->Parent->DBRWLock);
3307 cut_fail();
3308 }
3309 } while (1);
3310 READ_UNLOCK(ref0->Parent->DBRWLock);
3311 TRef = MkDBRefTerm(ref);
3312 EXTRA_CBACK_ARG(3, 1) = (CELL)ref;
3313#if MULTIPLE_STACKS
3314 LOCK(ref->lock);
3315 TRAIL_REF(ref); /* So that fail will erase it */
3316 INC_DBREF_COUNT(ref);
3317 UNLOCK(ref->lock);
3318#else
3319 if (!(ref->Flags & InUseMask)) {
3320 ref->Flags |= InUseMask;
3321 TRAIL_REF(ref); /* So that fail will erase it */
3322 }
3323#endif
3324 return (Yap_unify(ARG3, TRef));
3325}
3326
3327/*
3328 * The arguments for this 4 functions are the flags for terms which should be
3329 * skipped
3330 */
3331
3332static Int lu_recorded(PredEntry *pe USES_REGS) {
3333 op_numbers opc = Yap_op_from_opcode(P->opc);
3334
3335#if defined(YAPOR) || defined(THREADS)
3336 PELOCK(66, pe);
3337 PP = pe;
3338#endif
3339 if (opc == _procceed) {
3340 P = pe->CodeOfPred;
3341 } else {
3342 if (P->opc != Yap_opcode(_execute_cpred)) {
3343 CP = P;
3344 ENV = YENV;
3345 YENV = ASP;
3346 YENV[E_CB] = (CELL)B;
3347 }
3348 P = pe->CodeOfPred;
3349#if defined(YAPOR) || defined(THREADS)
3350 /* avoid holding a lock if we don't have anything in the database */
3351 if (P == FAILCODE) {
3352 UNLOCK(pe->PELock);
3353 PP = NULL;
3354 }
3355#endif
3356 }
3357 if (pe->PredFlags & ProfiledPredFlag) {
3358 LOCK(pe->StatisticsForPred->lock);
3359
3360 pe->StatisticsForPred->NOfEntries++;
3361 UNLOCK(pe->StatisticsForPred->lock);
3362 }
3363 return TRUE;
3364}
3365
3366/* recorded(+Functor,+Term,-Ref) */
3367static Int in_rded_with_key(USES_REGS1) {
3368 DBProp AtProp = (DBProp)IntegerOfTerm(Deref(ARG1));
3369
3370 return (i_recorded(AtProp, Deref(ARG3) PASS_REGS));
3371}
3372
3373/* recorded(+Functor,+Term,-Ref) */
3374static Int p_recorded(USES_REGS1) {
3375 DBProp AtProp;
3376 Register Term twork = Deref(ARG1); /* initially working with
3377 * ARG1 */
3378 Term t3 = Deref(ARG3);
3379 PredEntry *pe;
3380
3381 if (!IsVarTerm(t3)) {
3382 DBRef ref = DBRefOfTerm(t3);
3383 if (!IsDBRefTerm(t3)) {
3384 return FALSE;
3385 } else {
3386 ref = DBRefOfTerm(t3);
3387 }
3388 ref = DBRefOfTerm(t3);
3389 if (ref == NULL)
3390 return FALSE;
3391 if (DEAD_REF(ref)) {
3392 return FALSE;
3393 }
3394 if (ref->Flags & LogUpdMask) {
3395 LogUpdClause *cl = (LogUpdClause *)ref;
3396 PredEntry *ap = cl->ClPred;
3397 op_numbers opc = Yap_op_from_opcode(P->opc);
3398
3399 if (!Yap_unify(GetDBLUKey(ap), ARG1))
3400 return FALSE;
3401
3402 if (opc == _procceed) {
3403 P = cl->ClCode;
3404 } else {
3405 CP = P;
3406#if defined(YAPOR) || defined(THREADS)
3407 PP = cl->ClPred;
3408#endif
3409 P = cl->ClCode;
3410 ENV = YENV;
3411 YENV = ASP;
3412 YENV[E_CB] = (CELL)B;
3413 }
3414 return TRUE;
3415 } else {
3416 Term TermDB;
3417 while ((TermDB = GetDBTermFromDBEntry(ref PASS_REGS)) == (CELL)0) {
3418 /* oops, we are in trouble, not enough stack space */
3419 if (LOCAL_Error_TYPE == RESOURCE_ERROR_ATTRIBUTED_VARIABLES) {
3420 LOCAL_Error_TYPE = YAP_NO_ERROR;
3421 if (!Yap_growglobal(NULL)) {
3422 Yap_ThrowError(RESOURCE_ERROR_ATTRIBUTED_VARIABLES, TermNil,
3423 LOCAL_ErrorMessage);
3424 return FALSE;
3425 }
3426 } else {
3427 LOCAL_Error_TYPE = YAP_NO_ERROR;
3428 if (!Yap_dogc()) {
3429 Yap_ThrowError(RESOURCE_ERROR_STACK, TermNil, LOCAL_ErrorMessage);
3430 return FALSE;
3431 }
3432 }
3433 }
3434 if (!Yap_unify(ARG2, TermDB) || !UnifyDBKey(ref, 0, ARG1)) {
3435 return FALSE;
3436 } else {
3437 return TRUE;
3438 }
3439 }
3440 }
3441 if ((pe = find_lu_entry(twork)) != NULL) {
3442 return lu_recorded(pe PASS_REGS);
3443 }
3444 if (EndOfPAEntr(AtProp = FetchDBPropFromKey(twork, 0, FALSE, "recorded/3"))) {
3445 return FALSE;
3446 }
3447 ARG1 = MkIntegerTerm((Int)AtProp);
3448 P = PredRecordedWithKey->CodeOfPred;
3449 return (i_recorded(AtProp, t3 PASS_REGS));
3450}
3451
3452static Int co_rded(USES_REGS1) { return (c_recorded(0 PASS_REGS)); }
3453
3454/* '$recordedp'(+Functor,+Term,-Ref) */
3455static Int in_rdedp(USES_REGS1) {
3456 DBProp AtProp;
3457 register choiceptr b0 = B;
3458 Register Term twork = Deref(ARG1); /* initially working with
3459 * ARG1 */
3460
3461 Term t3 = Deref(ARG3);
3462 if (!IsVarTerm(t3)) {
3463 if (!IsDBRefTerm(t3)) {
3464 cut_fail();
3465 } else {
3466 DBRef ref = DBRefOfTerm(t3);
3467 LOCK(ref->lock);
3468 if (ref == NULL || DEAD_REF(ref) ||
3469 !Yap_unify(ARG2, GetDBTermFromDBEntry(ref PASS_REGS)) ||
3470 !UnifyDBKey(ref, CodeDBBit, ARG1)) {
3471 UNLOCK(ref->lock);
3472 cut_fail();
3473 } else {
3474 UNLOCK(ref->lock);
3475 cut_succeed();
3476 }
3477 }
3478 }
3479 if (EndOfPAEntr(AtProp =
3480 FetchDBPropFromKey(twork, MkCode, FALSE, "recorded/3"))) {
3481 if (b0 == B)
3482 cut_fail();
3483 else
3484 return FALSE;
3485 }
3486 return (i_recorded(AtProp, t3 PASS_REGS));
3487}
3488
3489static Int co_rdedp(USES_REGS1) { return (c_recorded(MkCode PASS_REGS)); }
3490
3491/* '$some_recordedp'(Functor) */
3492static Int p_somercdedp(USES_REGS1) {
3493 Register DBRef ref;
3494 DBProp AtProp;
3495 Register Term twork = Deref(ARG1); /* initially working with
3496 * ARG1 */
3497 if (EndOfPAEntr(AtProp = FetchDBPropFromKey(twork, MkCode, FALSE,
3498 "some_recorded/3"))) {
3499 return FALSE;
3500 }
3501 READ_LOCK(AtProp->DBRWLock);
3502 ref = FrstDBRef(AtProp);
3503 while (ref != NIL && (ref->Flags & (DBNoCode | ErasedMask)))
3504 ref = NextDBRef(ref);
3505 READ_UNLOCK(AtProp->DBRWLock);
3506 if (ref == NIL)
3507 return (FALSE);
3508 else
3509 return (TRUE);
3510}
3511
3512/* Finds the first instance recorded under key ARG1 */
3513static Int p_first_instance(USES_REGS1) {
3514 Term TRef;
3515 Register DBRef ref;
3516 DBProp AtProp;
3517 Register Term twork = Deref(ARG1); /* initially working with
3518 * ARG1 */
3519 Term TermDB;
3520
3521 ARG3 = Deref(ARG3);
3522 if (!IsVarTerm(ARG3)) {
3523 cut_fail();
3524 }
3525 if (EndOfPAEntr(
3526 AtProp = FetchDBPropFromKey(twork, 0, FALSE, "first_instance/3"))) {
3527 return FALSE;
3528 }
3529 READ_LOCK(AtProp->DBRWLock);
3530 ref = AtProp->First;
3531 while (ref != NIL && (ref->Flags & (DBCode | ErasedMask)))
3532 ref = NextDBRef(ref);
3533 READ_UNLOCK(AtProp->DBRWLock);
3534 if (ref == NIL) {
3535 cut_fail();
3536 }
3537 TRef = MkDBRefTerm(ref);
3538 /* we have a pointer to the term available */
3539 LOCK(ref->lock);
3540#if MULTIPLE_STACKS
3541 TRAIL_REF(ref); /* So that fail will erase it */
3542 INC_DBREF_COUNT(ref);
3543#else
3544 if (!(ref->Flags & InUseMask)) {
3545 ref->Flags |= InUseMask;
3546 TRAIL_REF(ref); /* So that fail will erase it */
3547 }
3548#endif
3549 UNLOCK(ref->lock);
3550 while ((TermDB = GetDBTermFromDBEntry(ref PASS_REGS)) == (CELL)0) {
3551 /* oops, we are in trouble, not enough stack space */
3552 if (LOCAL_Error_TYPE == RESOURCE_ERROR_ATTRIBUTED_VARIABLES) {
3553 LOCAL_Error_TYPE = YAP_NO_ERROR;
3554 if (!Yap_growglobal(NULL)) {
3555 Yap_ThrowError(RESOURCE_ERROR_ATTRIBUTED_VARIABLES, TermNil,
3556 LOCAL_ErrorMessage);
3557 return FALSE;
3558 }
3559 } else {
3560 LOCAL_Error_TYPE = YAP_NO_ERROR;
3561 if (!Yap_dogc()) {
3562 Yap_ThrowError(RESOURCE_ERROR_STACK, TermNil, LOCAL_ErrorMessage);
3563 return FALSE;
3564 }
3565 }
3566 }
3567 if (IsVarTerm(TermDB)) {
3568 Yap_unify(TermDB, ARG2);
3569 } else {
3570 return Yap_unify(ARG2, TermDB);
3571 }
3572 return Yap_unify(ARG3, TRef);
3573}
3574
3575static UInt index_sz(LogUpdIndex *x) {
3576 UInt sz = x->ClSize;
3577 yamop *start = x->ClCode;
3578 op_numbers op = Yap_op_from_opcode(start->opc);
3579
3580 /* add try-retry-trust children */
3581 while (op == _jump_if_nonvar) {
3582 start = NEXTOP(start, xll);
3583 op = Yap_op_from_opcode(start->opc);
3584 }
3585 if (op == _enter_lu_pred) {
3586 PredEntry *ap = x->ClPred;
3587 OPCODE endop, op1;
3588 UInt count = 0, dead = 0;
3589
3590 if (ap->PredFlags & CountPredFlag)
3591 endop = Yap_opcode(_count_trust_logical);
3592 else if (ap->PredFlags & ProfiledPredFlag)
3593 endop = Yap_opcode(_profiled_trust_logical);
3594 else
3595 endop = Yap_opcode(_trust_logical);
3596 start = start->y_u.Illss.l1;
3597 if (start->y_u.Illss.s)
3598 do {
3599 sz += (UInt)NEXTOP((yamop *)NULL, OtaLl);
3600 op1 = start->opc;
3601 count++;
3602 if (start->y_u.OtaLl.d->ClFlags & ErasedMask)
3603 dead++;
3604 start = start->y_u.OtaLl.n;
3605 } while (op1 != endop);
3606 }
3607 x = x->ChildIndex;
3608 while (x != NULL) {
3609 sz += index_sz(x);
3610 x = x->SiblingIndex;
3611 }
3612 return sz;
3613}
3614
3615static Int lu_statistics(PredEntry *pe USES_REGS) {
3616 UInt sz = sizeof(PredEntry), cls = 0, isz = 0;
3617
3618 /* count number of clauses and size */
3619 LogUpdClause *x;
3620
3621 if (pe->cs.p_code.FirstClause == NULL) {
3622 cls = 0;
3623 sz = 0;
3624 } else {
3625 x = ClauseCodeToLogUpdClause(pe->cs.p_code.FirstClause);
3626 while (x != NULL) {
3627 cls++;
3628 sz += x->ClSize;
3629 x = x->ClNext;
3630 }
3631 }
3632 isz = 0;
3633 if (pe->PredFlags & IndexedPredFlag) {
3634 /* expand clause blocks */
3635 yamop *ep = ExpandClausesFirst;
3636 while (ep) {
3637 if (ep->y_u.sssllp.p == pe)
3638 isz += (UInt)NEXTOP((yamop *)NULL, sssllp) +
3639 ep->y_u.sssllp.s1 * sizeof(yamop *);
3640 ep = ep->y_u.sssllp.snext;
3641 }
3642 isz += index_sz(ClauseCodeToLogUpdIndex(pe->cs.p_code.TrueCodeOfPred));
3643 }
3644 return Yap_unify(ARG2, MkIntegerTerm(cls)) &&
3645 Yap_unify(ARG3, MkIntegerTerm(sz)) &&
3646 Yap_unify(ARG4, MkIntegerTerm(isz));
3647}
3648
3659static Int p_key_statistics(USES_REGS1) {
3660 Register DBProp p;
3661 Register DBRef x;
3662 UInt sz = 0, cls = 0;
3663 Term twork = Deref(ARG1);
3664 PredEntry *pe;
3665
3666 if ((pe = find_lu_entry(twork)) != NULL) {
3667 return lu_statistics(pe PASS_REGS);
3668 }
3669 if (EndOfPAEntr(p = FetchDBPropFromKey(twork, 0, TRUE, "key_statistics/4"))) {
3670 /* This is not a key property */
3671 return FALSE;
3672 }
3673 /* count number of clauses and size */
3674 x = p->First;
3675 while (x != NULL) {
3676 cls++;
3677 sz += sizeof(DBStruct) + sizeof(CELL) * x->DBT.NOfCells;
3678 if (x->Code) {
3679 DynamicClause *cl = ClauseCodeToDynamicClause(x->Code);
3680 sz += cl->ClSize;
3681 }
3682 x = NextDBRef(x);
3683 }
3684 return Yap_unify(ARG2, MkIntegerTerm(cls)) &&
3685 Yap_unify(ARG3, MkIntegerTerm(sz)) && Yap_unify(ARG4, MkIntTerm(0));
3686}
3687
3688static Int p_lu_statistics(USES_REGS1) {
3689 Term t = Deref(ARG1);
3690 Term mod = Deref(ARG5);
3691 PredEntry *pe;
3692 if (IsVarTerm(t)) {
3693 return (FALSE);
3694 } else if (IsAtomTerm(t)) {
3695 Atom at = AtomOfTerm(t);
3696 pe = RepPredProp(Yap_GetPredPropByAtom(at, mod));
3697 } else if (IsIntegerTerm(t) && mod == IDB_MODULE) {
3698 pe = find_lu_int_key(IntegerOfTerm(t));
3699 } else if (IsApplTerm(t)) {
3700 Functor fun = FunctorOfTerm(t);
3701 pe = RepPredProp(Yap_GetPredPropByFunc(fun, mod));
3702 } else
3703 return FALSE;
3704 if (pe == NIL)
3705 return FALSE;
3706 if (!(pe->PredFlags & LogUpdatePredFlag)) {
3707 /* should use '$recordedp' in this case */
3708 return FALSE;
3709 }
3710 return lu_statistics(pe PASS_REGS);
3711}
3712
3713static Int p_total_erased(USES_REGS1) {
3714 UInt sz = 0, cls = 0;
3715 UInt isz = 0, icls = 0;
3716 LogUpdClause *cl = DBErasedList;
3717 LogUpdIndex *icl = DBErasedIList;
3718
3719 /* only for log upds */
3720 while (cl) {
3721 cls++;
3722 sz += cl->ClSize;
3723 cl = cl->ClNext;
3724 }
3725 while (icl) {
3726 icls++;
3727 isz += icl->ClSize;
3728 icl = icl->SiblingIndex;
3729 }
3730 return Yap_unify(ARG1, MkIntegerTerm(cls)) &&
3731 Yap_unify(ARG2, MkIntegerTerm(sz)) &&
3732 Yap_unify(ARG3, MkIntegerTerm(icls)) &&
3733 Yap_unify(ARG4, MkIntegerTerm(isz));
3734}
3735
3736static Int lu_erased_statistics(PredEntry *pe USES_REGS) {
3737 UInt sz = 0, cls = 0;
3738 UInt isz = 0, icls = 0;
3739 LogUpdClause *cl = DBErasedList;
3740 LogUpdIndex *icl = DBErasedIList;
3741
3742 while (cl) {
3743 if (cl->ClPred == pe) {
3744 cls++;
3745 sz += cl->ClSize;
3746 }
3747 cl = cl->ClNext;
3748 }
3749 while (icl) {
3750 if (pe == icl->ClPred) {
3751 icls++;
3752 isz += icl->ClSize;
3753 }
3754 icl = icl->SiblingIndex;
3755 }
3756 return Yap_unify(ARG2, MkIntegerTerm(cls)) &&
3757 Yap_unify(ARG3, MkIntegerTerm(sz)) &&
3758 Yap_unify(ARG4, MkIntegerTerm(icls)) &&
3759 Yap_unify(ARG5, MkIntegerTerm(isz));
3760}
3761
3762static Int p_key_erased_statistics(USES_REGS1) {
3763 Term twork = Deref(ARG1);
3764 PredEntry *pe;
3765
3766 /* only for log upds */
3767 if ((pe = find_lu_entry(twork)) == NULL)
3768 return FALSE;
3769 return lu_erased_statistics(pe PASS_REGS);
3770}
3771
3772static Int p_heap_space_info(USES_REGS1) {
3773 return Yap_unify(ARG1, MkIntegerTerm(HeapUsed)) &&
3774 Yap_unify(ARG2, MkIntegerTerm(HeapMax - HeapUsed)) &&
3775 Yap_unify(ARG3, MkIntegerTerm(Yap_expand_clauses_sz));
3776}
3777
3778/*
3779 * This is called when we are erasing a data base clause, because we may have
3780 * pending references
3781 */
3782static void ErasePendingRefs(DBTerm *entryref USES_REGS) {
3783 DBRef *cp;
3784 DBRef ref;
3785
3786 cp = entryref->DBRefs;
3787 if (entryref->DBRefs == NULL)
3788 return;
3789 while ((ref = *--cp) != NULL) {
3790 if ((ref->Flags & DBClMask) && (--(ref->NOfRefsTo) == 0) &&
3791 (ref->Flags & ErasedMask))
3792 ErDBE(ref PASS_REGS);
3793 }
3794}
3795
3796inline static void RemoveDBEntry(DBRef entryref USES_REGS) {
3797
3798 ErasePendingRefs(&(entryref->DBT)PASS_REGS);
3799 /* We may be backtracking back to a deleted entry. If we just remove
3800 the space then the info on the entry may be corrupt. */
3801 if ((B->cp_ap == RETRY_C_RECORDED_K_CODE ||
3802 B->cp_ap == RETRY_C_RECORDEDP_CODE) &&
3803 EXTRA_CBACK_ARG(3, 1) == (CELL)entryref) {
3804/* make it clear the entry has been released */
3805#if MULTIPLE_STACKS
3806 DEC_DBREF_COUNT(entryref);
3807#else
3808 entryref->Flags &= ~InUseMask;
3809#endif
3810 DBErasedMarker->Next = NULL;
3811 DBErasedMarker->Parent = entryref->Parent;
3812 DBErasedMarker->n = entryref->n;
3813 EXTRA_CBACK_ARG(3, 1) = (CELL)DBErasedMarker;
3814 }
3815 if (entryref->p != NULL)
3816 entryref->p->n = entryref->n;
3817 else
3818 entryref->Parent->F0 = entryref->n;
3819 if (entryref->n != NULL)
3820 entryref->n->p = entryref->p;
3821 else
3822 entryref->Parent->L0 = entryref->p;
3823 /* Yap_LUClauseSpace -= entryref->Size; */
3824 FreeDBSpace((char *)entryref);
3825}
3826
3827static yamop *find_next_clause(DBRef ref0 USES_REGS) {
3828 Register DBRef ref;
3829 yamop *newp;
3830
3831/* fetch ref0 from the instruction we just started executing */
3832#ifdef DEBUG
3833 if (!(ref0->Flags & ErasedMask)) {
3834 Yap_ThrowError(SYSTEM_ERROR_INTERNAL, TermNil,
3835 "find_next_clause (dead clause %x)", ref0);
3836 return NULL;
3837 }
3838#endif
3839 /* search for an newer entry that is to the left and points to code */
3840 ref = ref0;
3841 while ((ref = ref->n) != NULL) {
3842 if (!(ref->Flags & ErasedMask))
3843 break;
3844 }
3845 /* no extra alternatives to try, let us leave gracefully */
3846 if (ref == NULL) {
3847 return NULL;
3848 } else {
3849 /* OK, we found a clause we can jump to, do a bit of hanky pancking with
3850 the choice-point, so that it believes we are actually working from that
3851 clause */
3852 newp = ref->Code;
3853/* and next let's tell the world this clause is being used, just
3854 like if we were executing a standard retry_and_mark */
3855#if MULTIPLE_STACKS
3856 {
3857 DynamicClause *cl = ClauseCodeToDynamicClause(newp);
3858
3859 LOCK(cl->ClLock);
3860 TRAIL_CLREF(cl);
3861 INC_CLREF_COUNT(cl);
3862 UNLOCK(cl->ClLock);
3863 }
3864#else
3865 if (!(DynamicFlags(newp) & InUseMask)) {
3866 DynamicFlags(newp) |= InUseMask;
3867 TRAIL_CLREF(ClauseCodeToDynamicClause(newp));
3868 }
3869#endif
3870 return newp;
3871 }
3872}
3873
3874/* This procedure is called when a clause is officialy deleted. Its job
3875 is to find out where the code can go next, if it can go anywhere */
3876static Int p_jump_to_next_dynamic_clause(USES_REGS1) {
3877 DBRef ref =
3878 (DBRef)(((yamop *)((CODEADDR)P - (CELL)NEXTOP((yamop *)NULL, Osbpp)))
3879 ->y_u.Osbpp.bmap);
3880 yamop *newp = find_next_clause(ref PASS_REGS);
3881
3882 if (newp == NULL) {
3883 cut_fail();
3884 }
3885 /* the next alternative to try must be obtained from this clause */
3886 B->cp_ap = newp;
3887 /* and next, enter the clause */
3888 P = NEXTOP(newp, Otapl);
3889 /* and return like if nothing had happened. */
3890 return TRUE;
3891}
3892
3893static void complete_lu_erase(LogUpdClause *clau) {
3894 DBRef *cp;
3895
3896 if (clau->ClFlags & FactMask)
3897 cp = NULL;
3898 else
3899 cp = clau->lusl.ClSource->DBRefs;
3900 if (CL_IN_USE(clau)) {
3901 return;
3902 }
3903#ifndef THREADS
3904 if (clau->ClNext)
3905 clau->ClNext->ClPrev = clau->ClPrev;
3906 if (clau->ClPrev) {
3907 clau->ClPrev->ClNext = clau->ClNext;
3908 } else {
3909 DBErasedList = clau->ClNext;
3910 }
3911#endif
3912 if (cp != NULL) {
3913 DBRef ref;
3914 while ((ref = *--cp) != NIL) {
3915 if (ref->Flags & LogUpdMask) {
3916 LogUpdClause *cl = (LogUpdClause *)ref;
3917 cl->ClRefCount--;
3918 if (cl->ClFlags & ErasedMask && !(cl->ClFlags & InUseMask) &&
3919 !(cl->ClRefCount)) {
3920 EraseLogUpdCl(cl);
3921 }
3922 } else {
3923 LOCK(ref->lock);
3924 ref->NOfRefsTo--;
3925 if (ref->Flags & ErasedMask && !(ref->Flags & InUseMask) &&
3926 ref->NOfRefsTo) {
3927 CACHE_REGS
3928 UNLOCK(ref->lock);
3929 ErDBE(ref PASS_REGS);
3930 } else {
3931 UNLOCK(ref->lock);
3932 }
3933 }
3934 }
3935 }
3936 Yap_InformOfRemoval(clau);
3937 Yap_LUClauseSpace -= clau->ClSize;
3938 Yap_FreeCodeSpace((char *)clau);
3939}
3940
3941static void EraseLogUpdCl(LogUpdClause *clau) {
3942 PredEntry *ap;
3943
3944 ap = clau->ClPred;
3945 /* no need to erase what has been erased */
3946 if (!(clau->ClFlags & ErasedMask)) {
3947 /* get ourselves out of the list */
3948 if (clau->ClNext != NULL) {
3949 clau->ClNext->ClPrev = clau->ClPrev;
3950 }
3951 if (clau->ClPrev != NULL) {
3952 clau->ClPrev->ClNext = clau->ClNext;
3953 }
3954 if (ap) {
3955 if (clau->ClCode == ap->cs.p_code.FirstClause) {
3956 if (clau->ClNext == NULL) {
3957 ap->cs.p_code.FirstClause = NULL;
3958 } else {
3959 ap->cs.p_code.FirstClause = clau->ClNext->ClCode;
3960 }
3961 }
3962 if (clau->ClCode == ap->cs.p_code.LastClause) {
3963 if (clau->ClPrev == NULL) {
3964 ap->cs.p_code.LastClause = NULL;
3965 } else {
3966 ap->cs.p_code.LastClause = clau->ClPrev->ClCode;
3967 }
3968 }
3969 ap->cs.p_code.NOfClauses--;
3970 }
3971 clau->ClFlags |= ErasedMask;
3972#ifndef THREADS
3973 {
3974 LogUpdClause *er_head = DBErasedList;
3975 if (er_head == NULL) {
3976 clau->ClPrev = clau->ClNext = NULL;
3977 } else {
3978 clau->ClNext = er_head;
3979 er_head->ClPrev = clau;
3980 clau->ClPrev = NULL;
3981 }
3982 DBErasedList = clau;
3983 }
3984#endif
3985 /* we are holding a reference to the clause */
3986 clau->ClRefCount++;
3987 if (ap) {
3988 /* mark it as erased */
3989 if (ap->LastCallOfPred != LUCALL_RETRACT) {
3990 if (ap->cs.p_code.NOfClauses > 1) {
3991 if (ap->TimeStampOfPred >= TIMESTAMP_RESET)
3992 Yap_UpdateTimestamps(ap);
3993 ++ap->TimeStampOfPred;
3994 /* fprintf(stderr,"-
3995 * %x--%d--%ul\n",ap,ap->TimeStampOfPred,ap->ArityOfPE);*/
3996 ap->LastCallOfPred = LUCALL_RETRACT;
3997 } else {
3998/* OK, there's noone left */
3999#ifndef THREADS
4000 if (ap->cs.p_code.NOfClauses == 0) {
4001 /* Other threads may hold refs to clauses */
4002 ap->TimeStampOfPred = 0L;
4003 }
4004#endif
4005 /* fprintf(stderr,"-
4006 * %x--%d--%ul\n",ap,ap->TimeStampOfPred,ap->ArityOfPE);*/
4007 ap->LastCallOfPred = LUCALL_ASSERT;
4008 }
4009 }
4010 clau->ClTimeEnd = ap->TimeStampOfPred;
4011 Yap_RemoveClauseFromIndex(ap, clau->ClCode);
4012 /* release the extra reference */
4013 }
4014 clau->ClRefCount--;
4015 }
4016 complete_lu_erase(clau);
4017}
4018
4019static void MyEraseClause(DynamicClause *clau USES_REGS) {
4020 DBRef ref;
4021
4022 if (CL_IN_USE(clau))
4023 return;
4024 /*
4025 I don't need to lock the clause at this point because
4026 I am the last one using it anyway.
4027 */
4028 ref = (DBRef)NEXTOP(clau->ClCode, Otapl)->y_u.Osbpp.bmap;
4029 /* don't do nothing if the reference is still in use */
4030 if (DBREF_IN_USE(ref))
4031 return;
4032 if (P == clau->ClCode) {
4033 yamop *np = RTRYCODE;
4034 /* make it the next alternative */
4035 np->y_u.Otapl.d =
4036 find_next_clause((DBRef)(NEXTOP(P, Otapl)->y_u.Osbpp.bmap)PASS_REGS);
4037 if (np->y_u.Otapl.d == NULL)
4038 P = (yamop *)FAILCODE;
4039 else {
4040 /* with same arity as before */
4041 np->y_u.Otapl.s = P->y_u.Otapl.s;
4042 np->y_u.Otapl.p = P->y_u.Otapl.p;
4043 /* go ahead and try this code */
4044 P = np;
4045 }
4046 } else {
4047 Yap_InformOfRemoval(clau);
4048 Yap_LUClauseSpace -= clau->ClSize;
4049 Yap_FreeCodeSpace((char *)clau);
4050#ifdef DEBUG
4051 if (ref->NOfRefsTo)
4052 fprintf(stderr, "Error: references to dynamic clause\n");
4053#endif
4054 RemoveDBEntry(ref PASS_REGS);
4055 }
4056}
4057
4058/*
4059 This predicate is supposed to be called with a
4060 lock on the current predicate
4061*/
4062void Yap_ErLogUpdCl(LogUpdClause *clau) { EraseLogUpdCl(clau); }
4063
4064/*
4065 This predicate is supposed to be called with a
4066 lock on the current predicate
4067*/
4068void Yap_ErCl(DynamicClause *clau) {
4069 CACHE_REGS
4070 MyEraseClause(clau PASS_REGS);
4071}
4072
4073static void PrepareToEraseLogUpdClause(LogUpdClause *clau, DBRef dbr) {
4074 yamop *code_p = clau->ClCode;
4075 PredEntry *p = clau->ClPred;
4076 yamop *cl = code_p;
4077
4078 if (clau->ClFlags & ErasedMask) {
4079 return;
4080 }
4081 clau->ClFlags |= ErasedMask;
4082 if (p->cs.p_code.FirstClause != cl) {
4083 /* we are not the first clause... */
4084 yamop *prev_code_p = (yamop *)(dbr->Prev->Code);
4085 prev_code_p->y_u.Otapl.d = code_p->y_u.Otapl.d;
4086 /* are we the last? */
4087 if (p->cs.p_code.LastClause == cl)
4088 p->cs.p_code.LastClause = prev_code_p;
4089 } else {
4090 /* we are the first clause, what about the last ? */
4091 if (p->cs.p_code.LastClause == p->cs.p_code.FirstClause) {
4092 p->cs.p_code.LastClause = p->cs.p_code.FirstClause = NULL;
4093 } else {
4094 p->cs.p_code.FirstClause = code_p->y_u.Otapl.d;
4095 p->cs.p_code.FirstClause->opc = Yap_opcode(_try_me);
4096 }
4097 }
4098 dbr->Code = NULL; /* unlink the two now */
4099 if (p->PredFlags & IndexedPredFlag) {
4100 p->cs.p_code.NOfClauses--;
4101 Yap_RemoveIndexation(p);
4102 } else {
4103 EraseLogUpdCl(clau);
4104 }
4105 if (p->cs.p_code.FirstClause == p->cs.p_code.LastClause) {
4106 if (p->cs.p_code.FirstClause != NULL) {
4107 code_p = p->cs.p_code.FirstClause;
4108 code_p->y_u.Otapl.d = p->cs.p_code.FirstClause;
4109 p->cs.p_code.TrueCodeOfPred = NEXTOP(code_p, Otapl);
4110 if (p->PredFlags & (SpiedPredFlag | CountPredFlag | ProfiledPredFlag)) {
4111 p->OpcodeOfPred = Yap_opcode(_spy_pred);
4112 p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
4113#if defined(YAPOR) || defined(THREADS)
4114 } else if (p->ModuleOfPred != IDB_MODULE &&
4115 !(p->PredFlags & ThreadLocalPredFlag)) {
4116 p->OpcodeOfPred = LOCKPRED_OPCODE;
4117 p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
4118#endif
4119 } else {
4120 p->CodeOfPred = p->cs.p_code.TrueCodeOfPred;
4121 p->OpcodeOfPred = p->cs.p_code.TrueCodeOfPred->opc;
4122 }
4123#if defined(YAPOR) || defined(THREADS)
4124 } else if (p->ModuleOfPred != IDB_MODULE &&
4125 !(p->PredFlags & ThreadLocalPredFlag)) {
4126 p->OpcodeOfPred = LOCKPRED_OPCODE;
4127 p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
4128#endif
4129 } else {
4130 p->OpcodeOfPred = FAIL_OPCODE;
4131 p->cs.p_code.TrueCodeOfPred = p->CodeOfPred =
4132 (yamop *)(&(p->OpcodeOfPred));
4133 }
4134 } else {
4135 if (p->PredFlags & (SpiedPredFlag | CountPredFlag | ProfiledPredFlag)) {
4136 p->OpcodeOfPred = Yap_opcode(_spy_pred);
4137 p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
4138#if defined(YAPOR) || defined(THREADS)
4139 } else if (p->ModuleOfPred != IDB_MODULE &&
4140 !(p->PredFlags & ThreadLocalPredFlag)) {
4141 p->OpcodeOfPred = LOCKPRED_OPCODE;
4142 p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
4143#endif
4144 } else {
4145 p->OpcodeOfPred = INDEX_OPCODE;
4146 p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
4147 }
4148 }
4149}
4150
4151static void PrepareToEraseClause(DynamicClause *clau, DBRef dbr) {}
4152
4153static void ErDBE(DBRef entryref USES_REGS) {
4154
4155 if ((entryref->Flags & DBCode) && entryref->Code) {
4156 if (entryref->Flags & LogUpdMask) {
4157 LogUpdClause *clau = ClauseCodeToLogUpdClause(entryref->Code);
4158 if (CL_IN_USE(clau) || entryref->NOfRefsTo != 0) {
4159 PrepareToEraseLogUpdClause(clau, entryref);
4160 } else {
4161 if (!(clau->ClFlags & ErasedMask))
4162 PrepareToEraseLogUpdClause(clau, entryref);
4163 /* the clause must have left the chain */
4164 EraseLogUpdCl(clau);
4165 }
4166 } else {
4167 DynamicClause *clau = ClauseCodeToDynamicClause(entryref->Code);
4168 if (CL_IN_USE(clau) || entryref->NOfRefsTo != 0) {
4169 PrepareToEraseClause(clau, entryref);
4170 } else {
4171 if (!(clau->ClFlags & ErasedMask))
4172 PrepareToEraseClause(clau, entryref);
4173 /* the clause must have left the chain */
4174 MyEraseClause(clau PASS_REGS);
4175 }
4176 }
4177 } else if (!(DBREF_IN_USE(entryref))) {
4178 if (entryref->NOfRefsTo == 0)
4179 RemoveDBEntry(entryref PASS_REGS);
4180 else if (!(entryref->Flags & ErasedMask)) {
4181 /* oops, I cannot remove it, but I at least have to tell
4182 the world what's going on */
4183 entryref->Flags |= ErasedMask;
4184 entryref->Next = entryref->Prev = NIL;
4185 }
4186 }
4187}
4188
4189void Yap_ErDBE(DBRef entryref) {
4190 CACHE_REGS
4191 ErDBE(entryref PASS_REGS);
4192}
4193
4194static void EraseEntry(DBRef entryref) {
4195 DBProp p;
4196
4197 if (entryref->Flags & ErasedMask)
4198 return;
4199 if (entryref->Flags & LogUpdMask && !(entryref->Flags & DBClMask)) {
4200 LogUpdClause *luclause = (LogUpdClause *)entryref;
4201 PELOCK(67, luclause->ClPred);
4202 EraseLogUpdCl(luclause);
4203 UNLOCK(luclause->ClPred->PELock);
4204 return;
4205 }
4206 entryref->Flags |= ErasedMask;
4207 /* update FirstNEr */
4208 p = entryref->Parent;
4209 /* exit the db chain */
4210 if (entryref->Next != NIL) {
4211 entryref->Next->Prev = entryref->Prev;
4212 } else {
4213 p->Last = entryref->Prev;
4214 }
4215 if (entryref->Prev != NIL)
4216 entryref->Prev->Next = entryref->Next;
4217 else
4218 p->First = entryref->Next;
4219 /* make sure we know the entry has been removed from the list */
4220 entryref->Next = NIL;
4221 if (!DBREF_IN_USE(entryref)) {
4222 CACHE_REGS
4223 ErDBE(entryref PASS_REGS);
4224 } else if ((entryref->Flags & DBCode) && entryref->Code) {
4225 PrepareToEraseClause(ClauseCodeToDynamicClause(entryref->Code), entryref);
4226 }
4227}
4228
4229/* erase(+Ref) */
4230static Int p_erase(USES_REGS1) {
4231 Term t1 = Deref(ARG1);
4232
4233 if (IsVarTerm(t1)) {
4234 Yap_ThrowError(INSTANTIATION_ERROR, t1, "erase");
4235 return FALSE;
4236 }
4237 if (!IsDBRefTerm(t1)) {
4238 Yap_ThrowError(TYPE_ERROR_DBREF, t1, "erase");
4239 return FALSE;
4240 }
4241 EraseEntry(DBRefOfTerm(t1));
4242 return TRUE;
4243}
4244
4245/* increase_reference_counter(+Ref) */
4246static Int p_increase_reference_counter(USES_REGS1) {
4247 Term t1 = Deref(ARG1);
4248 LogUpdClause *cl;
4249
4250 if (IsVarTerm(t1)) {
4251 Yap_ThrowError(INSTANTIATION_ERROR, t1, "increase_reference_counter/1");
4252 return FALSE;
4253 }
4254 if (!IsDBRefTerm(t1)) {
4255 Yap_ThrowError(TYPE_ERROR_DBREF, t1, "increase_reference_counter");
4256 return FALSE;
4257 }
4258 cl = (LogUpdClause *)DBRefOfTerm(t1);
4259 PELOCK(67, cl->ClPred);
4260 cl->ClRefCount++;
4261 UNLOCK(cl->ClPred->PELock);
4262 return TRUE;
4263}
4264
4265/* increase_reference_counter(+Ref) */
4266static Int p_decrease_reference_counter(USES_REGS1) {
4267 Term t1 = Deref(ARG1);
4268 LogUpdClause *cl;
4269
4270 if (IsVarTerm(t1)) {
4271 Yap_ThrowError(INSTANTIATION_ERROR, t1, "increase_reference_counter/1");
4272 return FALSE;
4273 }
4274 if (!IsDBRefTerm(t1)) {
4275 Yap_ThrowError(TYPE_ERROR_DBREF, t1, "increase_reference_counter");
4276 return FALSE;
4277 }
4278 cl = (LogUpdClause *)DBRefOfTerm(t1);
4279 PELOCK(67, cl->ClPred);
4280 if (cl->ClRefCount) {
4281 cl->ClRefCount--;
4282 UNLOCK(cl->ClPred->PELock);
4283 return TRUE;
4284 }
4285 UNLOCK(cl->ClPred->PELock);
4286 return FALSE;
4287}
4288
4289/* erase(+Ref) */
4298static Int p_current_reference_counter(USES_REGS1) {
4299 Term t1 = Deref(ARG1);
4300 LogUpdClause *cl;
4301
4302 if (IsVarTerm(t1)) {
4303 Yap_ThrowError(INSTANTIATION_ERROR, t1, "increase_reference_counter/1");
4304 return FALSE;
4305 }
4306 if (!IsDBRefTerm(t1)) {
4307 Yap_ThrowError(TYPE_ERROR_DBREF, t1, "increase_reference_counter");
4308 return FALSE;
4309 }
4310 cl = (LogUpdClause *)DBRefOfTerm(t1);
4311 return Yap_unify(ARG2, MkIntegerTerm(cl->ClRefCount));
4312}
4313
4314static Int p_erase_clause(USES_REGS1) {
4315 Term t1 = Deref(ARG1), t2;;
4316 DBRef entryref;
4317
4318 if (IsVarTerm(t1)) {
4319 Yap_ThrowError(INSTANTIATION_ERROR, t1, "erase");
4320 return FALSE;
4321 }
4322 if (!IsDBRefTerm(t1)) {
4323 if (IsApplTerm(t1)) {
4324 if (FunctorOfTerm(t1) == FunctorStaticClause &&
4325 IsIntegerTerm((t2=ArgOfTerm(2,t1)))) {
4326 Yap_EraseStaticClause(Yap_ClauseFromTerm(t1),
4327 (PredEntry *)IntegerOfTerm(ArgOfTerm(2, t1)),
4328 Deref(ARG2));
4329 return true;
4330 }
4331 if (FunctorOfTerm(t1) == FunctorMegaClause) {
4332 Yap_EraseMegaClause(Yap_MegaClauseFromTerm(t1),
4333 Yap_MegaClausePredicateFromTerm(t1));
4334 return TRUE;
4335 }
4336 if (FunctorOfTerm(t1) == FunctorExoClause) {
4337 Yap_ThrowError(TYPE_ERROR_DBREF, t1, "erase exo clause");
4338 return FALSE;
4339 }
4340 }
4341 Yap_ThrowError(TYPE_ERROR_DBREF, t1, "erase");
4342 return FALSE;
4343 } else {
4344 entryref = DBRefOfTerm(t1);
4345 }
4346 EraseEntry(entryref);
4347 return TRUE;
4348}
4349
4350/* eraseall(+Key) */
4357static Int p_eraseall(USES_REGS1) {
4358 Register Term twork = Deref(ARG1);
4359 Register DBRef entryref;
4360 DBProp p;
4361 PredEntry *pe;
4362
4363 if ((pe = find_lu_entry(twork)) != NULL) {
4364 LogUpdClause *cl;
4365
4366 if (!pe->cs.p_code.NOfClauses)
4367 return TRUE;
4368 if (pe->PredFlags & IndexedPredFlag)
4369 Yap_RemoveIndexation(pe);
4370 cl = ClauseCodeToLogUpdClause(pe->cs.p_code.FirstClause);
4371 do {
4372 LogUpdClause *ncl = cl->ClNext;
4373 Yap_ErLogUpdCl(cl);
4374 cl = ncl;
4375 } while (cl != NULL);
4376 return TRUE;
4377 }
4378 if (EndOfPAEntr(p = FetchDBPropFromKey(twork, 0, FALSE, "eraseall/3"))) {
4379 return TRUE;
4380 }
4381 WRITE_LOCK(p->DBRWLock);
4382 entryref = FrstDBRef(p);
4383 do {
4384 DBRef next_entryref;
4385
4386 while (entryref != NIL && (entryref->Flags & (DBCode | ErasedMask)))
4387 entryref = NextDBRef(entryref);
4388 if (entryref == NIL)
4389 break;
4390 next_entryref = NextDBRef(entryref);
4391 /* exit the db chain */
4392 if (entryref->Next != NIL) {
4393 entryref->Next->Prev = entryref->Prev;
4394 } else {
4395 p->Last = entryref->Prev;
4396 }
4397 if (entryref->Prev != NIL)
4398 entryref->Prev->Next = entryref->Next;
4399 else
4400 p->First = entryref->Next;
4401 /* make sure we know the entry has been removed from the list */
4402 entryref->Next = entryref->Prev = NIL;
4403 if (!DBREF_IN_USE(entryref))
4404 ErDBE(entryref PASS_REGS);
4405 else {
4406 entryref->Flags |= ErasedMask;
4407 }
4408 entryref = next_entryref;
4409 } while (entryref != NIL);
4410 WRITE_UNLOCK(p->DBRWLock);
4411 return (TRUE);
4412}
4413
4414/* erased(+Ref) */
4423static Int p_erased(USES_REGS1) {
4424 Term t = Deref(ARG1);
4425
4426 if (IsVarTerm(t)) {
4427 Yap_ThrowError(INSTANTIATION_ERROR, t, "erased");
4428 return (FALSE);
4429 }
4430 if (!IsDBRefTerm(t)) {
4431 Yap_ThrowError(TYPE_ERROR_DBREF, t, "erased");
4432 return (FALSE);
4433 }
4434 return (DBRefOfTerm(t)->Flags & ErasedMask);
4435}
4436
4437static Int static_instance(StaticClause *cl, PredEntry *ap USES_REGS) {
4438 if (cl->ClFlags & ErasedMask) {
4439 return FALSE;
4440 }
4441 if (cl->ClFlags & FactMask) {
4442 if (ap->ArityOfPE == 0) {
4443 return Yap_unify(ARG2, MkAtomTerm((Atom)ap->FunctorOfPred));
4444 } else {
4445 Functor f = ap->FunctorOfPred;
4446 UInt arity = ArityOfFunctor(ap->FunctorOfPred), i;
4447 Term t2 = Deref(ARG2);
4448 CELL *ptr;
4449
4450 if (IsVarTerm(t2)) {
4451 Yap_unify(ARG2, (t2 = Yap_MkNewApplTerm(f, arity)));
4452 } else if (!IsApplTerm(t2) || FunctorOfTerm(t2) != f) {
4453 return FALSE;
4454 }
4455 ptr = RepAppl(t2) + 1;
4456 for (i = 0; i < arity; i++) {
4457 XREGS[i + 1] = ptr[i];
4458 }
4459 CP = P;
4460 YENV = ASP;
4461 YENV[E_CB] = (CELL)B;
4462 P = cl->ClCode;
4463 return TRUE;
4464 }
4465 } else {
4466 Term TermDB;
4467
4468 while ((TermDB = GetDBTerm(cl->usc.ClSource, TRUE PASS_REGS)) == 0L) {
4469 /* oops, we are in trouble, not enough stack space */
4470 if (LOCAL_Error_TYPE == RESOURCE_ERROR_ATTRIBUTED_VARIABLES) {
4471 LOCAL_Error_TYPE = YAP_NO_ERROR;
4472 if (!Yap_growglobal(NULL)) {
4473 Yap_ThrowError(RESOURCE_ERROR_ATTRIBUTED_VARIABLES, TermNil,
4474 LOCAL_ErrorMessage);
4475 return FALSE;
4476 }
4477 } else {
4478 LOCAL_Error_TYPE = YAP_NO_ERROR;
4479 if (!Yap_dogc()) {
4480 Yap_ThrowError(RESOURCE_ERROR_STACK, TermNil, LOCAL_ErrorMessage);
4481 return FALSE;
4482 }
4483 }
4484 }
4485 return Yap_unify(ARG2, TermDB);
4486 }
4487}
4488
4489static Int exo_instance(Int i, PredEntry *ap USES_REGS) {
4490 if (ap->ArityOfPE == 0) {
4491 return Yap_unify(ARG2, MkAtomTerm((Atom)ap->FunctorOfPred));
4492 } else {
4493 MegaClause *mcl = ClauseCodeToMegaClause(ap->cs.p_code.FirstClause);
4494 Functor f = ap->FunctorOfPred;
4495 UInt arity = ArityOfFunctor(ap->FunctorOfPred);
4496 Term t2 = Deref(ARG2);
4497 CELL *ptr = (CELL *)((ADDR)mcl->ClCode + 2 * sizeof(struct index_t *) +
4498 i * (mcl->ClItemSize));
4499 if (IsVarTerm(t2)) {
4500 // fresh slate
4501 t2 = Yap_MkApplTerm(f, arity, ptr);
4502 Yap_unify(ARG2, t2);
4503 } else if (!IsApplTerm(t2) || FunctorOfTerm(t2) != f) {
4504 return FALSE;
4505 }
4506 for (i = 0; i < arity; i++) {
4507 XREGS[i + 1] = ptr[i];
4508 }
4509 S = ptr;
4510 CP = P;
4511 YENV = ASP;
4512 YENV[E_CB] = (CELL)B;
4513 P = mcl->ClCode;
4514 return TRUE;
4515 }
4516}
4517
4518static Int mega_instance(yamop *code, PredEntry *ap USES_REGS) {
4519 if (ap->ArityOfPE == 0) {
4520 return Yap_unify(ARG2, MkAtomTerm((Atom)ap->FunctorOfPred));
4521 } else {
4522 Functor f = ap->FunctorOfPred;
4523 UInt arity = ArityOfFunctor(ap->FunctorOfPred), i;
4524 Term t2 = Deref(ARG2);
4525 CELL *ptr;
4526
4527 if (IsVarTerm(t2)) {
4528 t2 = Yap_MkNewApplTerm(f, arity);
4529 Yap_unify(ARG2, t2);
4530 } else if (!IsApplTerm(t2) || FunctorOfTerm(t2) != f) {
4531 return FALSE;
4532 }
4533 ptr = RepAppl(t2) + 1;
4534 for (i = 0; i < arity; i++) {
4535 XREGS[i + 1] = ptr[i];
4536 }
4537 CP = P;
4538 YENV = ASP;
4539 YENV[E_CB] = (CELL)B;
4540 P = code;
4541 return TRUE;
4542 }
4543}
4544
4545/* instance(+Ref,?Term) */
4557static Int p_instance(USES_REGS1) {
4558 Term t1 = Deref(ARG1);
4559 DBRef dbr;
4560
4561 if (IsVarTerm(t1) || !IsDBRefTerm(t1)) {
4562 if (IsApplTerm(t1)) {
4563 if (FunctorOfTerm(t1) == FunctorStaticClause) {
4564 return static_instance(Yap_ClauseFromTerm(t1),
4565 (PredEntry *)IntegerOfTerm(ArgOfTerm(2, t1))
4566 PASS_REGS);
4567 }
4568 if (FunctorOfTerm(t1) == FunctorMegaClause) {
4569 return mega_instance(Yap_MegaClauseFromTerm(t1),
4570 Yap_MegaClausePredicateFromTerm(t1) PASS_REGS);
4571 }
4572 if (FunctorOfTerm(t1) == FunctorExoClause) {
4573 return exo_instance(Yap_ExoClauseFromTerm(t1),
4574 Yap_ExoClausePredicateFromTerm(t1) PASS_REGS);
4575 }
4576 }
4577 return FALSE;
4578 } else {
4579 dbr = DBRefOfTerm(t1);
4580 }
4581 if (dbr->Flags & LogUpdMask) {
4582 op_numbers opc;
4583 LogUpdClause *cl = (LogUpdClause *)dbr;
4584 PredEntry *ap = cl->ClPred;
4585
4586 PELOCK(68, ap);
4587 if (cl->ClFlags & ErasedMask) {
4588 UNLOCK(ap->PELock);
4589 return FALSE;
4590 }
4591 if (cl->ClFlags & FactMask) {
4592 if (ap->ArityOfPE == 0) {
4593 UNLOCK(ap->PELock);
4594 return Yap_unify(ARG2, MkAtomTerm((Atom)ap->FunctorOfPred));
4595 } else {
4596 Functor f = ap->FunctorOfPred;
4597 UInt arity = ArityOfFunctor(ap->FunctorOfPred), i;
4598 Term t2 = Deref(ARG2);
4599 CELL *ptr;
4600
4601 if (IsVarTerm(t2)) {
4602 Yap_unify(ARG2, (t2 = Yap_MkNewApplTerm(f, arity)));
4603 } else if (!IsApplTerm(t2) || FunctorOfTerm(t2) != f) {
4604 UNLOCK(ap->PELock);
4605 return FALSE;
4606 }
4607 ptr = RepAppl(t2) + 1;
4608 for (i = 0; i < arity; i++) {
4609 XREGS[i + 1] = ptr[i];
4610 }
4611 CP = P;
4612 YENV = ASP;
4613 YENV[E_CB] = (CELL)B;
4614 P = cl->ClCode;
4615#if defined(YAPOR) || defined(THREADS)
4616 if (ap->PredFlags & ThreadLocalPredFlag) {
4617 UNLOCK(ap->PELock);
4618 } else {
4619 PP = ap;
4620 }
4621#endif
4622 return TRUE;
4623 }
4624 }
4625 opc = Yap_op_from_opcode(cl->ClCode->opc);
4626 if (opc == _unify_idb_term) {
4627 UNLOCK(ap->PELock);
4628 return Yap_unify(ARG2, cl->lusl.ClSource->Entry);
4629 } else {
4630 Term TermDB;
4631 int in_cl = (opc != _copy_idb_term);
4632
4633 while ((TermDB = GetDBTerm(cl->lusl.ClSource, in_cl PASS_REGS)) == 0L) {
4634 /*fdb/h oops, we are in trouble, not enough stack space */
4635 if (LOCAL_Error_TYPE == RESOURCE_ERROR_ATTRIBUTED_VARIABLES) {
4636 LOCAL_Error_TYPE = YAP_NO_ERROR;
4637 if (!Yap_growglobal(NULL)) {
4638 Yap_ThrowError(RESOURCE_ERROR_ATTRIBUTED_VARIABLES, TermNil,
4639 LOCAL_ErrorMessage);
4640 UNLOCK(ap->PELock);
4641 return FALSE;
4642 }
4643 } else {
4644 LOCAL_Error_TYPE = YAP_NO_ERROR;
4645 if (!Yap_dogc()) {
4646 Yap_ThrowError(RESOURCE_ERROR_STACK, TermNil, LOCAL_ErrorMessage);
4647 UNLOCK(ap->PELock);
4648 return FALSE;
4649 }
4650 }
4651 }
4652 UNLOCK(ap->PELock);
4653 return Yap_unify(ARG2, TermDB);
4654 }
4655 } else {
4656 Term TermDB;
4657 while ((TermDB = GetDBTermFromDBEntry(dbr PASS_REGS)) == 0L) {
4658 /* oops, we are in trouble, not enough stack space */
4659 if (LOCAL_Error_TYPE == RESOURCE_ERROR_ATTRIBUTED_VARIABLES) {
4660 LOCAL_Error_TYPE = YAP_NO_ERROR;
4661 if (!Yap_growglobal(NULL)) {
4662 Yap_ThrowError(RESOURCE_ERROR_ATTRIBUTED_VARIABLES, TermNil,
4663 LOCAL_ErrorMessage);
4664 return FALSE;
4665 }
4666 } else {
4667 LOCAL_Error_TYPE = YAP_NO_ERROR;
4668 if (!Yap_dogc()) {
4669 Yap_ThrowError(RESOURCE_ERROR_STACK, TermNil, LOCAL_ErrorMessage);
4670 return FALSE;
4671 }
4672 }
4673 t1 = Deref(ARG1);
4674 }
4675 return Yap_unify(ARG2, TermDB);
4676 }
4677}
4678
4679Term Yap_LUInstance(LogUpdClause *cl, UInt arity) {
4680 CACHE_REGS
4681 Term TermDB;
4682 op_numbers opc = Yap_op_from_opcode(cl->ClCode->opc);
4683
4684 if (opc == _unify_idb_term) {
4685 TermDB = cl->lusl.ClSource->Entry;
4686 } else {
4687 CACHE_REGS
4688 int in_src;
4689
4690 in_src = (opc != _copy_idb_term);
4691 while ((TermDB = GetDBTerm(cl->lusl.ClSource, in_src PASS_REGS)) == 0L) {
4692 /* oops, we are in trouble, not enough stack space */
4693 if (LOCAL_Error_TYPE == RESOURCE_ERROR_ATTRIBUTED_VARIABLES) {
4694 LOCAL_Error_TYPE = YAP_NO_ERROR;
4695 if (!Yap_growglobal(NULL)) {
4696 Yap_ThrowError(RESOURCE_ERROR_ATTRIBUTED_VARIABLES, TermNil,
4697 LOCAL_ErrorMessage);
4698 return 0L;
4699 }
4700 } else {
4701 LOCAL_Error_TYPE = YAP_NO_ERROR;
4702 if (!Yap_dogc()) {
4703 Yap_ThrowError(RESOURCE_ERROR_STACK, TermNil, LOCAL_ErrorMessage);
4704 return 0L;
4705 }
4706 }
4707 }
4708 }
4709#if MULTIPLE_STACKS
4710 cl->ClRefCount++;
4711 TRAIL_CLREF(cl); /* So that fail will erase it */
4712#else
4713 if (!(cl->ClFlags & InUseMask)) {
4714 cl->ClFlags |= InUseMask;
4715 TRAIL_CLREF(cl);
4716 }
4717#endif
4718 return TermDB;
4719}
4720
4721/* instance(+Ref,?Term) */
4722static Int p_instance_module(USES_REGS1) {
4723 Term t1 = Deref(ARG1);
4724 DBRef dbr;
4725
4726 if (IsVarTerm(t1)) {
4727 return FALSE;
4728 }
4729 if (IsDBRefTerm(t1)) {
4730 dbr = DBRefOfTerm(t1);
4731 } else {
4732 return FALSE;
4733 }
4734 if (dbr->Flags & LogUpdMask) {
4735 LogUpdClause *cl = (LogUpdClause *)dbr;
4736
4737 if (cl->ClFlags & ErasedMask) {
4738 return FALSE;
4739 }
4740 if (cl->ClPred->ModuleOfPred)
4741 return Yap_unify(ARG2, cl->ClPred->ModuleOfPred);
4742 else
4743 return Yap_unify(ARG2, TermProlog);
4744 } else {
4745 return Yap_unify(ARG2, dbr->Parent->ModuleOfDB);
4746 }
4747}
4748
4749inline static int NotActiveDB(DBRef my_dbref) {
4750 while (my_dbref && (my_dbref->Flags & (DBCode | ErasedMask)))
4751 my_dbref = my_dbref->Next;
4752 return (my_dbref == NIL);
4753}
4754
4755inline static DBEntry *NextDBProp(PropEntry *pp) {
4756 while (!EndOfPAEntr(pp) && (((pp->KindOfPE & ~0x1) != DBProperty) ||
4757 NotActiveDB(((DBProp)pp)->First)))
4758 pp = RepProp(pp->NextOfPE);
4759 return ((DBEntry *)pp);
4760}
4761
4762static Int init_current_key(USES_REGS1) { /* current_key(+Atom,?key) */
4763 Int i = 0;
4764 DBEntry *pp;
4765 Atom a;
4766 Term t1 = ARG1;
4767
4768 t1 = Deref(ARG1);
4769 if (!IsVarTerm(t1)) {
4770 if (IsAtomTerm(t1))
4771 a = AtomOfTerm(t1);
4772 else {
4773 cut_fail();
4774 }
4775 } else {
4776 /* ask for the first hash line */
4777 while (TRUE) {
4778 READ_LOCK(HashChain[i].AERWLock);
4779 a = HashChain[i].Entry;
4780 if (a != NIL) {
4781 break;
4782 }
4783 READ_UNLOCK(HashChain[i].AERWLock);
4784 i++;
4785 }
4786 READ_UNLOCK(HashChain[i].AERWLock);
4787 }
4788 READ_LOCK(RepAtom(a)->ARWLock);
4789 pp = NextDBProp(RepProp(RepAtom(a)->PropsOfAE));
4790 READ_UNLOCK(RepAtom(a)->ARWLock);
4791 EXTRA_CBACK_ARG(2, 3) = MkAtomTerm(a);
4792 EXTRA_CBACK_ARG(2, 2) = MkIntTerm(i);
4793 EXTRA_CBACK_ARG(2, 1) = MkIntegerTerm((Int)pp);
4794 return cont_current_key(PASS_REGS1);
4795}
4796
4797static Int cont_current_key(USES_REGS1) {
4798 unsigned int arity;
4799 Functor functor;
4800 Term term, AtT;
4801 Atom a;
4802 Int i = IntegerOfTerm(EXTRA_CBACK_ARG(2, 2));
4803 Term first = Deref(ARG1);
4804 DBEntry *pp = (DBEntry *)IntegerOfTerm(EXTRA_CBACK_ARG(2, 1));
4805
4806 if (IsIntTerm(term = EXTRA_CBACK_ARG(2, 3)))
4807 return cont_current_key_integer(PASS_REGS1);
4808 a = AtomOfTerm(term);
4809 if (EndOfPAEntr(pp) && IsAtomTerm(first)) {
4810 cut_fail();
4811 }
4812 while (EndOfPAEntr(pp)) {
4813 UInt j;
4814
4815 if ((a = RepAtom(a)->NextOfAE) == NIL) {
4816 i++;
4817 while (i < AtomHashTableSize) {
4818 /* protect current hash table line, notice that the current
4819 LOCK/UNLOCK algorithm assumes new entries are added to
4820 the *front* of the list, otherwise I should have locked
4821 earlier.
4822 */
4823 READ_LOCK(HashChain[i].AERWLock);
4824 a = HashChain[i].Entry;
4825 if (a != NIL) {
4826 break;
4827 }
4828 /* move to next entry */
4829 READ_UNLOCK(HashChain[i].AERWLock);
4830 i++;
4831 }
4832 if (i == AtomHashTableSize) {
4833 /* we have left the atom hash table */
4834 /* we don't have a lock over the hash table any longer */
4835 if (IsAtomTerm(first)) {
4836 cut_fail();
4837 }
4838 j = 0;
4839 if (INT_KEYS == NULL) {
4840 cut_fail();
4841 }
4842 for (j = 0; j < INT_KEYS_SIZE; j++) {
4843 if (INT_KEYS[j] != NIL) {
4844 DBProp pptr = RepDBProp(INT_KEYS[j]);
4845 EXTRA_CBACK_ARG(2, 1) = MkIntegerTerm((Int)(pptr->NextOfPE));
4846 EXTRA_CBACK_ARG(2, 2) = MkIntegerTerm(j + 1);
4847 EXTRA_CBACK_ARG(2, 3) = MkIntTerm(INT_KEYS_TIMESTAMP);
4848 term = MkIntegerTerm((Int)(pptr->FunctorOfDB));
4849 return Yap_unify(term, ARG1) && Yap_unify(term, ARG2);
4850 }
4851 }
4852 if (j == INT_KEYS_SIZE) {
4853 cut_fail();
4854 }
4855 return cont_current_key_integer(PASS_REGS1);
4856 } else {
4857 /* release our lock over the hash table */
4858 READ_UNLOCK(HashChain[i].AERWLock);
4859 EXTRA_CBACK_ARG(2, 2) = MkIntTerm(i);
4860 }
4861 }
4862 READ_LOCK(RepAtom(a)->ARWLock);
4863 if (!EndOfPAEntr(pp = NextDBProp(RepProp(RepAtom(a)->PropsOfAE))))
4864 EXTRA_CBACK_ARG(2, 3) = (CELL)MkAtomTerm(a);
4865 READ_UNLOCK(RepAtom(a)->ARWLock);
4866 }
4867 READ_LOCK(RepAtom(a)->ARWLock);
4868 EXTRA_CBACK_ARG(2, 1) = MkIntegerTerm((Int)NextDBProp(RepProp(pp->NextOfPE)));
4869 READ_UNLOCK(RepAtom(a)->ARWLock);
4870 arity = (unsigned int)(pp->ArityOfDB);
4871 if (arity == 0) {
4872 term = AtT = MkAtomTerm(a);
4873 } else {
4874 unsigned int j;
4875 CELL *p = HR;
4876
4877 for (j = 0; j < arity; j++) {
4878 p[j] = MkVarTerm();
4879 }
4880 functor = Yap_MkFunctor(a, arity);
4881 term = Yap_MkApplTerm(functor, arity, p);
4882 AtT = MkAtomTerm(a);
4883 }
4884 return (Yap_unify_constant(ARG1, AtT) && Yap_unify(ARG2, term));
4885}
4886
4887static Int cont_current_key_integer(USES_REGS1) {
4888 Term term;
4889 UInt i = IntOfTerm(EXTRA_CBACK_ARG(2, 2));
4890 Prop pp = (Prop)IntegerOfTerm(EXTRA_CBACK_ARG(2, 1));
4891 UInt tstamp = (UInt)IntOfTerm(EXTRA_CBACK_ARG(2, 3));
4892 DBProp pptr;
4893
4894 if (tstamp != INT_KEYS_TIMESTAMP) {
4895 cut_fail();
4896 }
4897 while (pp == NIL) {
4898 for (; i < INT_KEYS_SIZE; i++) {
4899 if (INT_KEYS[i] != NIL) {
4900 EXTRA_CBACK_ARG(2, 2) = MkIntTerm(i + 1);
4901 pp = INT_KEYS[i];
4902 break;
4903 }
4904 }
4905 if (i == INT_KEYS_SIZE) {
4906 cut_fail();
4907 }
4908 }
4909 pptr = RepDBProp(pp);
4910 EXTRA_CBACK_ARG(2, 1) = MkIntegerTerm((Int)(pptr->NextOfPE));
4911 term = MkIntegerTerm((Int)(pptr->FunctorOfDB));
4912 return Yap_unify(term, ARG1) && Yap_unify(term, ARG2);
4913}
4914
4915Term Yap_FetchTermFromDB(void *ref) {
4916 CACHE_REGS
4917 if (ref == NULL)
4918 return 0;
4919 return GetDBTerm(ref, FALSE PASS_REGS);
4920}
4921
4922Term Yap_FetchClauseTermFromDB(void *ref) {
4923 CACHE_REGS
4924 if (ref == NULL)
4925 return 0;
4926 return GetDBTerm(ref, TRUE PASS_REGS);
4927}
4928
4929Term Yap_PopTermFromDB(void *ref) {
4930 CACHE_REGS
4931
4932 Term t = GetDBTerm(ref, FALSE PASS_REGS);
4933 if (t != 0L)
4934 ReleaseTermFromDB(ref PASS_REGS);
4935 return t;
4936}
4937
4938static DBTerm *StoreTermInDB(Term t, int nargs USES_REGS) {
4939 DBTerm *x;
4940 int needs_vars;
4941 struct db_globs dbg;
4942
4943 LOCAL_Error_Size = 0;
4944 while ((x = (DBTerm *)CreateDBStruct(t, (DBProp)NULL, InQueue, &needs_vars, 0,
4945 &dbg)) == NULL) {
4946 if (LOCAL_Error_TYPE == YAP_NO_ERROR) {
4947 break;
4948 } else if (nargs == -1) {
4949 return NULL;
4950 } else {
4951 XREGS[nargs + 1] = t;
4952 if (recover_from_record_error(nargs + 1)) {
4953 t = Deref(XREGS[nargs + 1]);
4954 } else {
4955 return NULL;
4956 }
4957 }
4958 }
4959 return x;
4960}
4961
4962DBTerm *Yap_StoreTermInDB(Term t, int nargs) {
4963 CACHE_REGS
4964 return StoreTermInDB(t, nargs PASS_REGS);
4965}
4966
4967DBTerm *Yap_StoreTermInDBPlusExtraSpace(Term t, UInt extra_size, UInt *sz) {
4968 CACHE_REGS
4969 int needs_vars;
4970 struct db_globs dbg;
4971 DBTerm *o;
4972
4973 o = (DBTerm *)CreateDBStruct(t, (DBProp)NULL, InQueue, &needs_vars,
4974 extra_size, &dbg);
4975 *sz = dbg.sz;
4976 return o;
4977}
4978
4979void Yap_init_tqueue(db_queue *dbq) {
4980 dbq->id = FunctorDBRef;
4981 dbq->Flags = DBClMask;
4982 dbq->FirstInQueue = dbq->LastInQueue = NULL;
4983 INIT_RWLOCK(dbq->QRWLock);
4984}
4985
4986void Yap_destroy_tqueue(db_queue *dbq USES_REGS) {
4987 QueueEntry *cur_instance = dbq->FirstInQueue;
4988 while (cur_instance) {
4989 /* release space for cur_instance */
4990 keepdbrefs(cur_instance->DBT PASS_REGS);
4991 ErasePendingRefs(cur_instance->DBT PASS_REGS);
4992 FreeDBSpace((char *)cur_instance->DBT);
4993 FreeDBSpace((char *)cur_instance);
4994 }
4995 dbq->FirstInQueue = dbq->LastInQueue = NULL;
4996}
4997
4998bool Yap_enqueue_tqueue(db_queue *father_key, Term t USES_REGS) {
4999 QueueEntry *x;
5000 while ((x = (QueueEntry *)AllocDBSpace(sizeof(QueueEntry))) == NULL) {
5001 if (!Yap_growheap(FALSE, sizeof(QueueEntry), NULL)) {
5002 Yap_ThrowError(RESOURCE_ERROR_HEAP, TermNil, "in findall");
5003 return false;
5004 }
5005 }
5006 /* Yap_LUClauseSpace += sizeof(QueueEntry); */
5007 x->DBT = StoreTermInDB(Deref(t), 2 PASS_REGS);
5008 if (x->DBT == NULL) {
5009 return false;
5010 }
5011 x->next = NULL;
5012 if (father_key->LastInQueue != NULL)
5013 father_key->LastInQueue->next = x;
5014 father_key->LastInQueue = x;
5015 if (father_key->FirstInQueue == NULL) {
5016 father_key->FirstInQueue = x;
5017 }
5018 return true;
5019}
5020
5021bool Yap_dequeue_tqueue(db_queue *father_key, Term t, bool first,
5022 bool release USES_REGS) {
5023 Term TDB;
5024 CELL *oldH = HR;
5025 tr_fr_ptr oldTR = TR;
5026 QueueEntry *cur_instance = father_key->FirstInQueue, *prev = NULL;
5027 while (cur_instance) {
5028 HR = oldH;
5029 HB = LCL0;
5030 while ((TDB = GetDBTerm(cur_instance->DBT, false PASS_REGS)) == 0L) {
5031 if (LOCAL_Error_TYPE == RESOURCE_ERROR_ATTRIBUTED_VARIABLES) {
5032 LOCAL_Error_TYPE = YAP_NO_ERROR;
5033 if (!Yap_growglobal(NULL)) {
5034 Yap_ThrowError(RESOURCE_ERROR_ATTRIBUTED_VARIABLES, TermNil,
5035 LOCAL_ErrorMessage);
5036 return false;
5037 }
5038 } else {
5039 LOCAL_Error_TYPE = YAP_NO_ERROR;
5040 if (!Yap_dogc()) {
5041 Yap_ThrowError(RESOURCE_ERROR_STACK, TermNil, LOCAL_ErrorMessage);
5042 return false;
5043 }
5044 }
5045 oldTR = TR;
5046 oldH = HR;
5047 }
5048 if (Yap_unify(t, TDB)) {
5049 if (release) {
5050 if (cur_instance == father_key->FirstInQueue) {
5051 father_key->FirstInQueue = cur_instance->next;
5052 }
5053 if (cur_instance == father_key->LastInQueue) {
5054 father_key->LastInQueue = prev;
5055 }
5056 if (prev) {
5057 prev->next = cur_instance->next;
5058 }
5059 /* release space for cur_instance */
5060 keepdbrefs(cur_instance->DBT PASS_REGS);
5061 ErasePendingRefs(cur_instance->DBT PASS_REGS);
5062 FreeDBSpace((char *)cur_instance->DBT);
5063 FreeDBSpace((char *)cur_instance);
5064 } else {
5065 // undo if you'rejust peeking
5066 while (oldTR < TR) {
5067 CELL d1 = TrailTerm(TR - 1);
5068 TR--;
5069 /* normal variable */
5070 RESET_VARIABLE(d1);
5071 }
5072 }
5073 return true;
5074 } else {
5075 // just getting the first
5076 if (first)
5077 return false;
5078 // but keep on going, if we want to check everything.
5079 prev = cur_instance;
5080 cur_instance = cur_instance->next;
5081 }
5082 }
5083 return false;
5084}
5085
5086static Int p_init_queue(USES_REGS1) {
5087 db_queue *dbq;
5088 Term t;
5089
5090 while ((dbq = (db_queue *)AllocDBSpace(sizeof(db_queue))) == NULL) {
5091 if (!Yap_growheap(FALSE, sizeof(db_queue), NULL)) {
5092 Yap_ThrowError(RESOURCE_ERROR_HEAP, TermNil, "in findall");
5093 return FALSE;
5094 }
5095 }
5096 /* Yap_LUClauseSpace += sizeof(db_queue); */
5097 Yap_init_tqueue(dbq);
5098 t = MkIntegerTerm((Int)dbq);
5099 return Yap_unify(ARG1, t);
5100}
5101
5102static Int p_enqueue(USES_REGS1) {
5103 Term Father = Deref(ARG1);
5104 db_queue *father_key;
5105 bool rc;
5106
5107 if (IsVarTerm(Father)) {
5108 Yap_ThrowError(INSTANTIATION_ERROR, Father, "enqueue");
5109 return FALSE;
5110 } else if (!IsIntegerTerm(Father)) {
5111 Yap_ThrowError(TYPE_ERROR_INTEGER, Father, "enqueue");
5112 return FALSE;
5113 } else
5114 father_key = (db_queue *)IntegerOfTerm(Father);
5115 WRITE_LOCK(father_key->QRWLock);
5116 rc = Yap_enqueue_tqueue(father_key, Deref(ARG2) PASS_REGS);
5117 WRITE_UNLOCK(father_key->QRWLock);
5118 return rc;
5119}
5120
5121static Int p_enqueue_unlocked(USES_REGS1) {
5122 Term Father = Deref(ARG1);
5123 db_queue *father_key;
5124
5125 if (IsVarTerm(Father)) {
5126 Yap_ThrowError(INSTANTIATION_ERROR, Father, "enqueue");
5127 return FALSE;
5128 } else if (!IsIntegerTerm(Father)) {
5129 Yap_ThrowError(TYPE_ERROR_INTEGER, Father, "enqueue");
5130 return FALSE;
5131 } else
5132 father_key = (db_queue *)IntegerOfTerm(Father);
5133 return Yap_enqueue_tqueue(father_key, Deref(ARG2) PASS_REGS);
5134}
5135
5136/* when reading an entry in the data base we are making it accessible from
5137 the outside. If the entry was removed, and this was the last pointer, the
5138 target entry would be immediately removed, leading to dangling pointers.
5139 We avoid this problem by making every entry accessible.
5140
5141 Note that this could not happen with recorded, because the original db
5142 entry itself is still accessible from a trail entry, so we could not remove
5143 the target entry,
5144 */
5145static void keepdbrefs(DBTerm *entryref USES_REGS) {
5146 DBRef *cp;
5147 DBRef ref;
5148
5149 cp = entryref->DBRefs;
5150 if (cp == NULL) {
5151 return;
5152 }
5153 while ((ref = *--cp) != NIL) {
5154 if (!(ref->Flags & LogUpdMask)) {
5155 LOCK(ref->lock);
5156 if (!(ref->Flags & InUseMask)) {
5157 ref->Flags |= InUseMask;
5158 TRAIL_REF(ref); /* So that fail will erase it */
5159 }
5160 UNLOCK(ref->lock);
5161 }
5162 }
5163}
5164
5165static Int p_dequeue(USES_REGS1) {
5166 db_queue *father_key;
5167 QueueEntry *cur_instance;
5168 Term Father = Deref(ARG1);
5169 Int rc;
5170
5171 if (IsVarTerm(Father)) {
5172 Yap_ThrowError(INSTANTIATION_ERROR, Father, "dequeue");
5173 return FALSE;
5174 } else if (!IsIntegerTerm(Father)) {
5175 Yap_ThrowError(TYPE_ERROR_INTEGER, Father, "dequeue");
5176 return FALSE;
5177 } else {
5178 father_key = (db_queue *)IntegerOfTerm(Father);
5179 WRITE_LOCK(father_key->QRWLock);
5180 if ((cur_instance = father_key->FirstInQueue) == NULL) {
5181 /* an empty queue automatically goes away */
5182 WRITE_UNLOCK(father_key->QRWLock);
5183 FreeDBSpace((char *)father_key);
5184 return false;
5185 }
5186 rc = Yap_dequeue_tqueue(father_key, ARG2, true, true PASS_REGS);
5187 WRITE_UNLOCK(father_key->QRWLock);
5188 return rc;
5189 }
5190}
5191
5192static Int p_dequeue_unlocked(USES_REGS1) {
5193 db_queue *father_key;
5194 QueueEntry *cur_instance;
5195 Term Father = Deref(ARG1);
5196
5197 if (IsVarTerm(Father)) {
5198 Yap_ThrowError(INSTANTIATION_ERROR, Father, "dequeue");
5199 return FALSE;
5200 } else if (!IsIntegerTerm(Father)) {
5201 Yap_ThrowError(TYPE_ERROR_INTEGER, Father, "dequeue");
5202 return FALSE;
5203 } else {
5204 father_key = (db_queue *)IntegerOfTerm(Father);
5205 if ((cur_instance = father_key->FirstInQueue) == NULL) {
5206 /* an empty queue automatically goes away */
5207 FreeDBSpace((char *)father_key);
5208 return FALSE;
5209 }
5210 return Yap_dequeue_tqueue(father_key, ARG2, true, true PASS_REGS);
5211 }
5212}
5213
5214static Int p_peek_queue(USES_REGS1) {
5215 db_queue *father_key;
5216 QueueEntry *cur_instance;
5217 Term Father = Deref(ARG1);
5218
5219 if (IsVarTerm(Father)) {
5220 Yap_ThrowError(INSTANTIATION_ERROR, Father, "dequeue");
5221 return FALSE;
5222 } else if (!IsIntegerTerm(Father)) {
5223 Yap_ThrowError(TYPE_ERROR_INTEGER, Father, "dequeue");
5224 return FALSE;
5225 } else {
5226 father_key = (db_queue *)IntegerOfTerm(Father);
5227 if ((cur_instance = father_key->FirstInQueue) == NULL) {
5228 /* an empty queue automatically goes away */
5229 FreeDBSpace((char *)father_key);
5230 return FALSE;
5231 }
5232 if (!Yap_dequeue_tqueue(father_key, ARG2, true, false PASS_REGS))
5233 return FALSE;
5234 if (cur_instance == father_key->LastInQueue)
5235 father_key->FirstInQueue = father_key->LastInQueue = NULL;
5236 else
5237 father_key->FirstInQueue = cur_instance->next;
5238 return TRUE;
5239 }
5240}
5241
5242static Int p_clean_queues(USES_REGS1) { return TRUE; }
5243
5244/* set the logical updates flag */
5245static Int p_slu(USES_REGS1) {
5246 Term t = Deref(ARG1);
5247 if (IsVarTerm(t)) {
5248 Yap_ThrowError(INSTANTIATION_ERROR, t, "switch_logical_updates/1");
5249 return FALSE;
5250 }
5251 if (!IsIntTerm(t)) {
5252 Yap_ThrowError(TYPE_ERROR_INTEGER, t, "switch_logical_updates/1");
5253 return FALSE;
5254 }
5255 UPDATE_MODE = IntOfTerm(t);
5256 return TRUE;
5257}
5258
5259/* get a hold over the index table for logical update predicates */
5260static Int p_hold_index(USES_REGS1) {
5261 Yap_ThrowError(SYSTEM_ERROR_INTERNAL, TermNil, "hold_index in debugger");
5262 return FALSE;
5263}
5264
5265static Int p_fetch_reference_from_index(USES_REGS1) {
5266 Term t1 = Deref(ARG1), t2 = Deref(ARG2);
5267 DBRef table, el;
5268 Int pos;
5269
5270 if (IsVarTerm(t1) || !IsDBRefTerm(t1))
5271 return FALSE;
5272 table = DBRefOfTerm(t1);
5273
5274 if (IsVarTerm(t2) || !IsIntTerm(t2))
5275 return FALSE;
5276 pos = IntOfTerm(t2);
5277 el = (DBRef)(table->DBT.Contents[pos]);
5278 LOCK(el->lock);
5279#if MULTIPLE_STACKS
5280 TRAIL_REF(el); /* So that fail will erase it */
5281 INC_DBREF_COUNT(el);
5282#else
5283 if (!(el->Flags & InUseMask)) {
5284 el->Flags |= InUseMask;
5285 TRAIL_REF(el);
5286 }
5287#endif
5288 UNLOCK(el->lock);
5289 return Yap_unify(ARG3, MkDBRefTerm(el));
5290}
5291
5292static Int p_resize_int_keys(USES_REGS1) {
5293 Term t1 = Deref(ARG1);
5294 if (IsVarTerm(t1)) {
5295 return Yap_unify(ARG1, MkIntegerTerm((Int)INT_KEYS_SIZE));
5296 }
5297 if (!IsIntegerTerm(t1)) {
5298 Yap_ThrowError(TYPE_ERROR_INTEGER, t1, "yap_flag(resize_db_int_keys,T)");
5299 return FALSE;
5300 }
5301 return resize_int_keys(IntegerOfTerm(t1));
5302}
5303
5304static void ReleaseTermFromDB(DBTerm *ref USES_REGS) {
5305 if (!ref)
5306 return;
5307 keepdbrefs(ref PASS_REGS);
5308 ErasePendingRefs(ref PASS_REGS);
5309 FreeDBSpace((char *)ref);
5310}
5311
5312void Yap_ReleaseTermFromDB(void *ref) {
5313 CACHE_REGS
5314 ReleaseTermFromDB(ref PASS_REGS);
5315}
5316
5317static Int p_install_thread_local(USES_REGS1) { /* '$is_dynamic'(+P) */
5318 PredEntry *pe;
5319 Term t = Deref(ARG1);
5320 Term mod = Deref(ARG2);
5321
5322 if (IsVarTerm(t)) {
5323 return (FALSE);
5324 }
5325 if (mod == IDB_MODULE) {
5326 pe = find_lu_entry(t);
5327 if (!pe->cs.p_code.NOfClauses) {
5328 if (IsIntegerTerm(t))
5329 pe->PredFlags |= LogUpdatePredFlag | NumberDBPredFlag;
5330 else if (IsAtomTerm(t))
5331 pe->PredFlags |= LogUpdatePredFlag | AtomDBPredFlag;
5332 else
5333 pe->PredFlags |= LogUpdatePredFlag;
5334 }
5335 } else if (IsAtomTerm(t)) {
5336 Atom at = AtomOfTerm(t);
5337 pe = RepPredProp(PredPropByAtom(at, mod));
5338 } else if (IsApplTerm(t)) {
5339 Functor fun = FunctorOfTerm(t);
5340 pe = RepPredProp(PredPropByFunc(fun, mod));
5341 } else {
5342 return FALSE;
5343 }
5344 PELOCK(69, pe);
5345 if (pe->PredFlags & (ThreadLocalPredFlag | LogUpdatePredFlag)) {
5346 // second declaration, just ignore
5347 UNLOCK(pe->PELock);
5348 return TRUE;
5349 }
5350 if (pe->PredFlags &
5351 (UserCPredFlag | HiddenPredFlag | CArgsPredFlag | SyncPredFlag |
5352 TestPredFlag | AsmPredFlag | StandardPredFlag | CPredFlag |
5353 SafePredFlag | IndexedPredFlag | BinaryPredFlag) ||
5354 pe->cs.p_code.NOfClauses) {
5355 UNLOCK(pe->PELock);
5356 return FALSE;
5357 }
5358#if THREADS
5359 pe->PredFlags |= ThreadLocalPredFlag | LogUpdatePredFlag;
5360 pe->OpcodeOfPred = Yap_opcode(_thread_local);
5361 pe->CodeOfPred = (yamop *)&pe->OpcodeOfPred;
5362#else
5363 pe->PredFlags |= LogUpdatePredFlag;
5364#endif
5365 UNLOCK(pe->PELock);
5366 return TRUE;
5367}
5368
5369void Yap_InitDBPreds(void) {
5370 Yap_InitCPred("$set_pred_flags", 2, p_rcdz, SyncPredFlag);
5386 Yap_InitCPred("recorded", 3, p_recorded, SyncPredFlag);
5387 Yap_InitCPred("recorda", 3, p_rcda, SyncPredFlag);
5396 Yap_InitCPred("recordz", 3, p_rcdz, SyncPredFlag);
5397 Yap_InitCPred("$still_variant", 2, p_still_variant, SyncPredFlag);
5398 Yap_InitCPred("recorda_at", 3, p_rcda_at, SyncPredFlag);
5399 Yap_InitCPred("recordz_at", 3, p_rcdz_at, SyncPredFlag);
5400 Yap_InitCPred("$recordap", 3, p_rcdap, SyncPredFlag);
5401 Yap_InitCPred("$recordzp", 3, p_rcdzp, SyncPredFlag);
5402 Yap_InitCPred("$recordap", 4, p_drcdap, SyncPredFlag);
5403 Yap_InitCPred("$recordzp", 4, p_drcdzp, SyncPredFlag);
5404 Yap_InitCPred("erase", 1, p_erase, SafePredFlag | SyncPredFlag);
5405 Yap_InitCPred("$erase_clause", 2, p_erase_clause,
5406 0);
5407 Yap_InitCPred("increase_reference_count", 1, p_increase_reference_counter,
5408 SafePredFlag | SyncPredFlag);
5409 Yap_InitCPred("decrease_reference_count", 1, p_decrease_reference_counter,
5410 SafePredFlag | SyncPredFlag);
5411 Yap_InitCPred("current_reference_count", 2, p_current_reference_counter,
5412 SafePredFlag | SyncPredFlag);
5413 Yap_InitCPred("erased", 1, p_erased,
5414 TestPredFlag | SafePredFlag | SyncPredFlag);
5415 Yap_InitCPred("instance", 2, p_instance, SyncPredFlag);
5416 Yap_InitCPred("$instance_module", 2, p_instance_module, SyncPredFlag);
5417 Yap_InitCPred("eraseall", 1, p_eraseall, SafePredFlag | SyncPredFlag);
5418 Yap_InitCPred("$record_stat_source", 4, p_rcdstatp,
5419 SafePredFlag | SyncPredFlag);
5420 Yap_InitCPred("$some_recordedp", 1, p_somercdedp,
5421 SafePredFlag | SyncPredFlag);
5422 Yap_InitCPred("$first_instance", 3, p_first_instance,
5423 SafePredFlag | SyncPredFlag);
5424 Yap_InitCPred("$init_db_queue", 1, p_init_queue, SafePredFlag | SyncPredFlag);
5425 Yap_InitCPred("$db_key", 2, p_db_key, 0L);
5426 Yap_InitCPred("$db_enqueue", 2, p_enqueue, SyncPredFlag);
5427 Yap_InitCPred("$db_enqueue_unlocked", 2, p_enqueue_unlocked, SyncPredFlag);
5428 Yap_InitCPred("$db_dequeue", 2, p_dequeue, SyncPredFlag);
5429 Yap_InitCPred("$db_dequeue_unlocked", 2, p_dequeue_unlocked, SyncPredFlag);
5430 Yap_InitCPred("$db_peek_queue", 2, p_peek_queue, SyncPredFlag);
5431 Yap_InitCPred("$db_clean_queues", 1, p_clean_queues, SyncPredFlag);
5432 Yap_InitCPred("$switch_log_upd", 1, p_slu, SafePredFlag | SyncPredFlag);
5433 Yap_InitCPred("$hold_index", 3, p_hold_index, SafePredFlag | SyncPredFlag);
5434 Yap_InitCPred("$fetch_reference_from_index", 3, p_fetch_reference_from_index,
5435 SafePredFlag | SyncPredFlag);
5436 Yap_InitCPred("$resize_int_keys", 1, p_resize_int_keys,
5437 SafePredFlag | SyncPredFlag);
5438 Yap_InitCPred("key_statistics", 4, p_key_statistics, SyncPredFlag);
5439 Yap_InitCPred("$lu_statistics", 5, p_lu_statistics, SyncPredFlag);
5440 Yap_InitCPred("total_erased", 4, p_total_erased, SyncPredFlag);
5441 Yap_InitCPred("key_erased_statistics", 5, p_key_erased_statistics,
5442 SyncPredFlag);
5443 Yap_InitCPred("heap_space_info", 3, p_heap_space_info, SyncPredFlag);
5444 Yap_InitCPred("$jump_to_next_dynamic_clause", 0,
5445 p_jump_to_next_dynamic_clause, SyncPredFlag);
5446 Yap_InitCPred("$install_thread_local", 2, p_install_thread_local,
5447 SafePredFlag);
5448}
5449
5450void Yap_InitBackDB(void) {
5451 Yap_InitCPredBack("$recorded_with_key", 3, 3, in_rded_with_key, co_rded,
5452 SyncPredFlag);
5453 RETRY_C_RECORDED_K_CODE =
5454 NEXTOP(PredRecordedWithKey->cs.p_code.FirstClause, OtapFs);
5455 Yap_InitCPredBack("$recordedp", 3, 3, in_rdedp, co_rdedp, SyncPredFlag);
5456 RETRY_C_RECORDEDP_CODE =
5457 NEXTOP(RepPredProp(PredPropByFunc(Yap_MkFunctor(AtomRecordedP, 3), 0))
5458 ->cs.p_code.FirstClause,
5459 OtapFs);
5460 Yap_InitCPredBack("$current_immediate_key", 2, 4, init_current_key,
5461 cont_current_key, SyncPredFlag);
5462}
5463
Main definitions.
Definition: dbase.c:585
Definition: Yatom.h:689
Definition: heapgc.c:75
Definition: Yap.h:606
Definition: Yatom.h:544
Definition: Yap.h:601
Definition: amidefs.h:264