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