diogo/yap-6.3
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
This repository has been archived on 2023-08-20. You can view files and clone it, but cannot push or open issues or pull requests.
Files
1d76cfc7cb9bf0f9ddc9b8b1fb72657314d6c6e5
yap-6.3/C/dbase.c
Vítor Santos Costa 1a23e47316 current_predicate
2016-01-08 03:18:36 +00:00

5410 lines
148 KiB
C
Raw Blame History

/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: dbase.c *
* Last rev: 8/2/88 *
* mods: *
* comments: YAP's internal data base *
* *
*************************************************************************/
#ifdef SCCS
static char SccsId[] = "%W% %G%";
#endif
/** @defgroup Internal_Database Internal Data Base
@ingroup builtins
@{
Some programs need global information for, e.g. counting or collecting
data obtained by backtracking. As a rule, to keep this information, the
internal data base should be used instead of asserting and retracting
clauses (as most novice programmers do), .
In YAP (as in some other Prolog systems) the internal data base (i.d.b.
for short) is faster, needs less space and provides a better insulation of
program and data than using asserted/retracted clauses.
The i.d.b. is implemented as a set of terms, accessed by keys that
unlikely what happens in (non-Prolog) data bases are not part of the
term. Under each key a list of terms is kept. References are provided so that
terms can be identified: each term in the i.d.b. has a unique reference
(references are also available for clauses of dynamic predicates).
There is a strong analogy between the i.d.b. and the way dynamic
predicates are stored. In fact, the main i.d.b. predicates might be
implemented using dynamic predicates:
~~~~~
recorda(X,T,R) :- asserta(idb(X,T),R).
recordz(X,T,R) :- assertz(idb(X,T),R).
recorded(X,T,R) :- clause(idb(X,T),R).
~~~~~
We can take advantage of this, the other way around, as it is quite
easy to write a simple Prolog interpreter, using the i.d.b.:
~~~~~
asserta(G) :- recorda(interpreter,G,_).
assertz(G) :- recordz(interpreter,G,_).
retract(G) :- recorded(interpreter,G,R), !, erase(R).
call(V) :- var(V), !, fail.
call((H :- B)) :- !, recorded(interpreter,(H :- B),_), call(B).
call(G) :- recorded(interpreter,G,_).
~~~~~
In YAP, much attention has been given to the implementation of the
i.d.b., especially to the problem of accelerating the access to terms kept in
a large list under the same key. Besides using the key, YAP uses an internal
lookup function, transparent to the user, to find only the terms that might
unify. For instance, in a data base containing the terms
~~~~~
b
b(a)
c(d)
e(g)
b(X)
e(h)
~~~~~
stored under the key k/1, when executing the query
~~~~~
:- recorded(k(_),c(_),R).
~~~~~
`recorded` would proceed directly to the third term, spending almost the
time as if `a(X)` or `b(X)` was being searched.
The lookup function uses the functor of the term, and its first three
arguments (when they exist). So, `recorded(k(_),e(h),_)` would go
directly to the last term, while `recorded(k(_),e(_),_)` would find
first the fourth term, and then, after backtracking, the last one.
This mechanism may be useful to implement a sort of hierarchy, where
the functors of the terms (and eventually the first arguments) work as
secondary keys.
In the YAP's i.d.b. an optimized representation is used for
terms without free variables. This results in a faster retrieval of terms
and better space usage. Whenever possible, avoid variables in terms in terms
stored in the i.d.b.
*/
#include "Yap.h"
#include "clause.h"
#include "yapio.h"
#include "attvar.h"
#include "heapgc.h"
#if HAVE_STRING_H
#include <string.h>
#endif
#if HAVE_STRING_H
#include <string.h>
#endif
#include <stdlib.h>
/* There are two options to implement traditional immediate update semantics.
- In the first option, we only remove an element of the chain when
it is physically disposed of. This simplifies things, because
pointers are always valid, but it complicates some stuff a bit:
o You may have go through long lines of deleted db entries before you
actually reach the one you want.
o Deleted clauses are also not removed of the chain. The solution
was to place a fail in every clause, but you still have to
backtrack through failed clauses.
An alternative solution is to remove clauses from the chain, even
if they are still phisically present. Unfortunately this creates
problems because immediate update semantics means you have to
backtrack clauses or see the db entries stored later.
There are several solutions. One of the simplest is to use an age
counter. When you backtrack to a removed clause or to a deleted db
entry you use the age to find newly entered clauses in the DB.
This still causes a problem when you backtrack to a deleted
clause, because clauses are supposed to point to the next
alternative, and having been removed from the chain you cannot
point there directly. One solution is to have a predicate in C that
recovers the place where to go to and then gets rid of the clause.
*/
#define DISCONNECT_OLD_ENTRIES 1
#ifdef MACYAPBUG
#define Register
#else
#define Register register
#endif
/* Flags for recorda or recordz */
/* MkCode should be the same as CodeDBProperty */
#define MkFirst 1
#define MkCode CodeDBBit
#define MkLast 4
#define WithRef 8
#define MkIfNot 16
#define InQueue 32
#define FrstDBRef(V) ((V)->First)
#define NextDBRef(V) ((V)->Next)
#define DBLength(V) (sizeof(DBStruct) + (Int)(V) + CellSize)
#define AllocDBSpace(V) ((DBRef)Yap_AllocCodeSpace(V))
#define FreeDBSpace(V) Yap_FreeCodeSpace(V)
#if SIZEOF_INT_P == 4
#define ToSmall(V) ((link_entry)(Unsigned(V) >> 2))
#else
#define ToSmall(V) ((link_entry)(Unsigned(V) >> 3))
#endif
#ifdef SFUNC
#define MaxSFs 256
typedef struct {
Term SName; /* The culprit */
CELL *SFather; /* and his father's position */
} SFKeep;
#endif
#define HashFieldMask ((CELL)0xffL)
#define DualHashFieldMask ((CELL)0xffffL)
#define TripleHashFieldMask ((CELL)0xffffffL)
#define FourHashFieldMask ((CELL)0xffffffffL)
#define ONE_FIELD_SHIFT 8
#define TWO_FIELDS_SHIFT 16
#define THREE_FIELDS_SHIFT 24
#define AtomHash(t) (Unsigned(t) >> 4)
#define FunctorHash(t) (Unsigned(t) >> 4)
#define NumberHash(t) (Unsigned(IntOfTerm(t)))
#define LARGE_IDB_LINK_TABLE 1
/* traditionally, YAP used a link table to recover IDB terms*/
#if LARGE_IDB_LINK_TABLE
typedef BITS32 link_entry;
#define SIZEOF_LINK_ENTRY 4
#else
typedef BITS16 link_entry;
#define SIZEOF_LINK_ENTRY 2
#endif
/* These global variables are necessary to build the data base
structure */
typedef struct db_globs {
link_entry *lr, *LinkAr;
/* we cannot call Error directly from within recorded(). These flags are used
to delay for a while
*/
DBRef *tofref; /* place the refs also up */
#ifdef SFUNC
CELL *FathersPlace; /* Where the father was going when the term
* was reached */
SFKeep *SFAr, *TopSF; /* Where are we putting our SFunctors */
#endif
DBRef found_one; /* Place where we started recording */
UInt sz; /* total size */
} dbglobs;
#ifdef SUPPORT_HASH_TABLES
typedef struct {
CELL key;
DBRef entry;
} hash_db_entry;
typedef table {
Int NOfEntries;
Int HashArg;
hash_db_entry *table;
}
hash_db_table;
#endif
static CELL *cpcells(CELL *, CELL *, Int);
static void linkblk(link_entry *, CELL *, CELL);
static Int cmpclls(CELL *, CELL *, Int);
static Prop FindDBProp(AtomEntry *, int, unsigned int, Term);
static CELL CalcKey(Term);
#ifdef COROUTINING
static CELL *MkDBTerm(CELL *, CELL *, CELL *, CELL *, CELL *, CELL *, int *,
struct db_globs *);
#else
static CELL *MkDBTerm(CELL *, CELL *, CELL *, CELL *, CELL *, int *,
struct db_globs *);
#endif
static DBRef CreateDBStruct(Term, DBProp, int, int *, UInt, struct db_globs *);
static DBRef record(int, Term, Term, Term CACHE_TYPE);
static DBRef check_if_cons(DBRef, Term);
static DBRef check_if_var(DBRef);
static DBRef check_if_wvars(DBRef, unsigned int, CELL *);
static int scheckcells(int, CELL *, CELL *, link_entry *, CELL);
static DBRef check_if_nvars(DBRef, unsigned int, CELL *, struct db_globs *);
static Int p_rcda(USES_REGS1);
static Int p_rcdap(USES_REGS1);
static Int p_rcdz(USES_REGS1);
static Int p_rcdzp(USES_REGS1);
static Int p_drcdap(USES_REGS1);
static Int p_drcdzp(USES_REGS1);
static Term GetDBTerm(DBTerm *, int src CACHE_TYPE);
static DBProp FetchDBPropFromKey(Term, int, int, char *);
static Int i_recorded(DBProp, Term CACHE_TYPE);
static Int c_recorded(int CACHE_TYPE);
static Int co_rded(USES_REGS1);
static Int in_rdedp(USES_REGS1);
static Int co_rdedp(USES_REGS1);
static Int p_first_instance(USES_REGS1);
static void ErasePendingRefs(DBTerm *CACHE_TYPE);
static void RemoveDBEntry(DBRef CACHE_TYPE);
static void EraseLogUpdCl(LogUpdClause *);
static void MyEraseClause(DynamicClause *CACHE_TYPE);
static void PrepareToEraseClause(DynamicClause *, DBRef);
static void EraseEntry(DBRef);
static Int p_erase(USES_REGS1);
static Int p_eraseall(USES_REGS1);
static Int p_erased(USES_REGS1);
static Int p_instance(USES_REGS1);
static int NotActiveDB(DBRef);
static DBEntry *NextDBProp(PropEntry *);
static Int init_current_key(USES_REGS1);
static Int cont_current_key(USES_REGS1);
static Int cont_current_key_integer(USES_REGS1);
static Int p_rcdstatp(USES_REGS1);
static Int p_somercdedp(USES_REGS1);
static yamop *find_next_clause(DBRef USES_REGS);
static Int p_jump_to_next_dynamic_clause(USES_REGS1);
#ifdef SFUNC
static void SFVarIn(Term);
static void sf_include(SFKeep *);
#endif
static Int p_init_queue(USES_REGS1);
static Int p_enqueue(USES_REGS1);
static void keepdbrefs(DBTerm *CACHE_TYPE);
static Int p_dequeue(USES_REGS1);
static void ErDBE(DBRef CACHE_TYPE);
static void ReleaseTermFromDB(DBTerm *CACHE_TYPE);
static PredEntry *new_lu_entry(Term);
static PredEntry *new_lu_int_key(Int);
static PredEntry *find_lu_entry(Term);
static DBProp find_int_key(Int);
#define db_check_trail(x) \
{ \
if (Unsigned(dbg->tofref) == Unsigned(x)) { \
goto error_tr_overflow; \
} \
}
static UInt new_trail_size(void) {
CACHE_REGS
UInt sz = (LOCAL_TrailTop - (ADDR)TR) / 2;
if (sz < K64)
return K64;
if (sz > M1)
return M1;
return sz;
}
static int recover_from_record_error(int nargs) {
CACHE_REGS
switch (LOCAL_Error_TYPE) {
case RESOURCE_ERROR_STACK:
if (!Yap_gcl(LOCAL_Error_Size, nargs, ENV, gc_P(P, CP))) {
Yap_Error(RESOURCE_ERROR_STACK, TermNil, LOCAL_ErrorMessage);
return FALSE;
}
goto recover_record;
case RESOURCE_ERROR_TRAIL:
if (!Yap_growtrail(new_trail_size(), FALSE)) {
Yap_Error(RESOURCE_ERROR_TRAIL, TermNil,
"YAP could not grow trail in recorda/3");
return FALSE;
}
goto recover_record;
case RESOURCE_ERROR_HEAP:
if (!Yap_growheap(FALSE, LOCAL_Error_Size, NULL)) {
Yap_Error(RESOURCE_ERROR_HEAP, LOCAL_Error_Term, LOCAL_ErrorMessage);
return FALSE;
}
goto recover_record;
case RESOURCE_ERROR_AUXILIARY_STACK:
if (!Yap_ExpandPreAllocCodeSpace(LOCAL_Error_Size, NULL, TRUE)) {
Yap_Error(RESOURCE_ERROR_AUXILIARY_STACK, LOCAL_Error_Term,
LOCAL_ErrorMessage);
return FALSE;
}
goto recover_record;
default:
Yap_Error(LOCAL_Error_TYPE, LOCAL_Error_Term, LOCAL_ErrorMessage);
return FALSE;
}
recover_record:
LOCAL_Error_Size = 0;
LOCAL_Error_TYPE = YAP_NO_ERROR;
return TRUE;
}
#ifdef SUPPORT_HASH_TABLES
/* related property and hint on number of entries */
static void create_hash_table(DBProp p, Int hint) {
int off = sizeof(CELL) * 4, out;
Int size;
if (hint < p->NOfEntries)
hint = p->NOfEntries;
while (off) {
Int limit = ((CELL)1) << (off);
if (inp >= limit) {
out += off;
inp >>= off;
}
off >>= 1;
}
if ((size = ((CELL)1) << out) < hint)
hint <<= 1;
/* clean up the table */
pt = tbl = (hash_db_entry *)AllocDBSpace(hint * sizeof(hash_db_entry));
Yap_LUClauseSpace += hint * sizeof(hash_db_entry);
for (i = 0; i < hint; i++) {
pt->key = NULL;
pt++;
}
/* next insert the entries */
}
static void insert_in_table() {}
static void remove_from_table() {}
#endif
inline static CELL *cpcells(CELL *to, CELL *from, Int n) {
#if HAVE_MEMMOVE
memmove((void *)to, (void *)from, (size_t)(n * sizeof(CELL)));
return (to + n);
#else
while (n-- >= 0) {
*to++ = *from++;
}
return (to);
#endif
}
static void linkblk(link_entry *r, CELL *c, CELL offs) {
CELL p;
while ((p = (CELL)*r) != 0) {
Term t = c[p];
r++;
c[p] = AdjustIDBPtr(t, offs);
}
}
static Int cmpclls(CELL *a, CELL *b, Int n) {
while (n-- > 0) {
if (*a++ != *b++)
return FALSE;
}
return TRUE;
}
#if !THREADS
int Yap_DBTrailOverflow() {
return ((CELL *)LOCAL_s_dbg->lr > (CELL *)LOCAL_s_dbg->tofref - 2048);
}
#endif
/* get DB entry for ap/arity; */
static Prop FindDBPropHavingLock(AtomEntry *ae, int CodeDB, unsigned int arity,
Term dbmod) {
Prop p0;
DBProp p;
p = RepDBProp(p0 = ae->PropsOfAE);
while (p0 &&
(((p->KindOfPE & ~0x1) != (CodeDB | DBProperty)) ||
(p->ArityOfDB != arity) ||
((CodeDB & MkCode) && p->ModuleOfDB && p->ModuleOfDB != dbmod))) {
p = RepDBProp(p0 = p->NextOfPE);
}
return p0;
}
/* get DB entry for ap/arity; */
static Prop FindDBProp(AtomEntry *ae, int CodeDB, unsigned int arity,
Term dbmod) {
Prop out;
READ_LOCK(ae->ARWLock);
out = FindDBPropHavingLock(ae, CodeDB, arity, dbmod);
READ_UNLOCK(ae->ARWLock);
return (out);
}
/* These two functions allow us a fast lookup method in the data base */
/* PutMasks builds the mask and hash for a single argument */
inline static CELL CalcKey(Term tw) {
/* The first argument is known to be instantiated */
if (IsApplTerm(tw)) {
Functor f = FunctorOfTerm(tw);
if (IsExtensionFunctor(f)) {
if (f == FunctorDBRef) {
return (FunctorHash(tw)); /* Ref */
} /* if (f == FunctorLongInt || f == FunctorDouble) */
return (NumberHash(RepAppl(tw)[1]));
}
return (FunctorHash(f));
} else if (IsAtomOrIntTerm(tw)) {
if (IsAtomTerm(tw)) {
return (AtomHash(tw));
}
return (NumberHash(tw));
}
return (FunctorHash(FunctorList));
}
/* EvalMasks builds the mask and hash for up to three arguments of a term */
static CELL EvalMasks(register Term tm, CELL *keyp) {
if (IsVarTerm(tm)) {
*keyp = 0L;
return (0L);
} else if (IsApplTerm(tm)) {
Functor fun = FunctorOfTerm(tm);
if (IsExtensionFunctor(fun)) {
if (fun == FunctorDBRef) {
*keyp = FunctorHash(tm); /* Ref */
} else /* if (f == FunctorLongInt || f == FunctorDouble) */ {
*keyp = NumberHash(RepAppl(tm)[1]);
}
return (FourHashFieldMask);
} else {
unsigned int arity;
arity = ArityOfFunctor(fun);
#ifdef SFUNC
if (arity == SFArity) { /* do not even try to calculate masks */
*keyp = key;
return (FourHashFieldMask);
}
#endif
switch (arity) {
case 1: {
Term tw = ArgOfTerm(1, tm);
if (IsNonVarTerm(tw)) {
*keyp = (FunctorHash(fun) & DualHashFieldMask) |
(CalcKey(tw) << TWO_FIELDS_SHIFT);
return (FourHashFieldMask);
} else {
*keyp = (FunctorHash(fun) & DualHashFieldMask);
return (DualHashFieldMask);
}
}
case 2: {
Term tw1, tw2;
CELL key, mask;
key = FunctorHash(fun) & DualHashFieldMask;
mask = DualHashFieldMask;
tw1 = ArgOfTerm(1, tm);
if (IsNonVarTerm(tw1)) {
key |= ((CalcKey(tw1) & HashFieldMask) << TWO_FIELDS_SHIFT);
mask |= (HashFieldMask << TWO_FIELDS_SHIFT);
}
tw2 = ArgOfTerm(2, tm);
if (IsNonVarTerm(tw2)) {
*keyp = key | (CalcKey(tw2) << THREE_FIELDS_SHIFT);
return (mask | (HashFieldMask << THREE_FIELDS_SHIFT));
} else {
*keyp = key;
return (mask);
}
}
default: {
Term tw1, tw2, tw3;
CELL key, mask;
key = FunctorHash(fun) & HashFieldMask;
mask = HashFieldMask;
tw1 = ArgOfTerm(1, tm);
if (IsNonVarTerm(tw1)) {
key |= (CalcKey(tw1) & HashFieldMask) << ONE_FIELD_SHIFT;
mask |= HashFieldMask << ONE_FIELD_SHIFT;
}
tw2 = ArgOfTerm(2, tm);
if (IsNonVarTerm(tw2)) {
key |= (CalcKey(tw2) & HashFieldMask) << TWO_FIELDS_SHIFT;
mask |= HashFieldMask << TWO_FIELDS_SHIFT;
}
tw3 = ArgOfTerm(3, tm);
if (IsNonVarTerm(tw3)) {
*keyp = key | (CalcKey(tw3) << THREE_FIELDS_SHIFT);
return (mask | (HashFieldMask << THREE_FIELDS_SHIFT));
} else {
*keyp = key;
return (mask);
}
}
}
}
} else {
CELL key = (FunctorHash(FunctorList) & DualHashFieldMask);
CELL mask = DualHashFieldMask;
Term th = HeadOfTerm(tm), tt;
if (IsNonVarTerm(th)) {
mask |= (HashFieldMask << TWO_FIELDS_SHIFT);
key |= (CalcKey(th) << TWO_FIELDS_SHIFT);
}
tt = TailOfTerm(tm);
if (IsNonVarTerm(tt)) {
*keyp = key | (CalcKey(tt) << THREE_FIELDS_SHIFT);
return (mask | (HashFieldMask << THREE_FIELDS_SHIFT));
}
*keyp = key;
return (mask);
}
}
CELL Yap_EvalMasks(register Term tm, CELL *keyp) { return EvalMasks(tm, keyp); }
/* Called to inform that a new pointer to a data base entry has been added */
#define MarkThisRef(Ref) ((Ref)->NOfRefsTo++)
/* From a term, builds its representation in the data base */
/* otherwise, we just need to restore variables*/
typedef struct { CELL *addr; } visitel;
#define DB_UNWIND_CUNIF() \
while (visited < (visitel *)AuxSp) { \
RESET_VARIABLE(visited->addr); \
visited++; \
}
/* no checking for overflow while building DB terms yet */
#define CheckDBOverflow(X) \
if (CodeMax + X >= (CELL *)visited - 1024) { \
goto error; \
}
/* no checking for overflow while building DB terms yet */
#define CheckVisitOverflow() \
if ((CELL *)to_visit + 1024 >= ASP) { \
goto error2; \
}
static CELL *copy_long_int(CELL *st, CELL *pt) {
/* first thing, store a link to the list before we move on */
st[0] = (CELL)FunctorLongInt;
st[1] = pt[1];
st[2] = EndSpecials;
/* now reserve space */
return st + 3;
}
static CELL *copy_double(CELL *st, CELL *pt) {
/* first thing, store a link to the list before we move on */
st[0] = (CELL)FunctorDouble;
st[1] = pt[1];
#if SIZEOF_DOUBLE == 2 * SIZEOF_INT_P
st[2] = pt[2];
st[3] = EndSpecials;
#else
st[2] = EndSpecials;
#endif
/* now reserve space */
return st + (2 + SIZEOF_DOUBLE / SIZEOF_INT_P);
}
static CELL *copy_string(CELL *st, CELL *pt) {
UInt sz = pt[1] + 3;
/* first thing, store a link to the list before we move on */
memcpy(st, pt, sizeof(CELL) * sz);
/* now reserve space */
return st + sz;
}
#ifdef USE_GMP
static CELL *copy_big_int(CELL *st, CELL *pt) {
Int sz =
sizeof(MP_INT) + (((MP_INT *)(pt + 2))->_mp_alloc * sizeof(mp_limb_t));
/* first functor */
st[0] = (CELL)FunctorBigInt;
st[1] = pt[1];
/* then the actual number */
memcpy((void *)(st + 2), (void *)(pt + 2), sz);
st = st + 2 + sz / CellSize;
/* then the tail for gc */
st[0] = EndSpecials;
return st + 1;
}
#endif /* BIG_INT */
#define DB_MARKED(d0) ((CELL *)(d0) < CodeMax && (CELL *)(d0) >= tbase)
/* This routine creates a complex term in the heap. */
static CELL *MkDBTerm(register CELL *pt0, register CELL *pt0_end,
register CELL *StoPoint, CELL *CodeMax, CELL *tbase,
#ifdef COROUTINING
CELL *attachmentsp,
#endif
int *vars_foundp, struct db_globs *dbg) {
CACHE_REGS
#if THREADS
#undef Yap_REGS
register REGSTORE *regp = Yap_regp;
#define Yap_REGS (*regp)
#endif
register visitel *visited = (visitel *)AuxSp;
/* store this in H */
register CELL **to_visit = (CELL **)HR;
CELL **to_visit_base = to_visit;
/* where we are going to add a new pair */
int vars_found = 0;
#ifdef COROUTINING
Term ConstraintsTerm = TermNil;
CELL *origH = HR;
#endif
CELL *CodeMaxBase = CodeMax;
loop:
while (pt0 <= pt0_end) {
CELL *ptd0 = pt0;
CELL d0 = *ptd0;
restart:
if (IsVarTerm(d0))
goto deref_var;
if (IsApplTerm(d0)) {
register Functor f;
register CELL *ap2;
/* we will need to link afterwards */
ap2 = RepAppl(d0);
#ifdef RATIONAL_TREES
if (ap2 >= tbase && ap2 <= StoPoint) {
db_check_trail(dbg->lr + 1);
*dbg->lr++ = ToSmall((CELL)(StoPoint) - (CELL)(tbase));
*StoPoint++ = d0;
++pt0;
continue;
}
#endif
db_check_trail(dbg->lr + 1);
*dbg->lr++ = ToSmall((CELL)(StoPoint) - (CELL)(tbase));
f = (Functor)(*ap2);
if (IsExtensionFunctor(f)) {
switch ((CELL)f) {
case (CELL) FunctorDBRef: {
DBRef dbentry;
/* store now the correct entry */
dbentry = DBRefOfTerm(d0);
*StoPoint++ = d0;
dbg->lr--;
if (dbentry->Flags & LogUpdMask) {
LogUpdClause *cl = (LogUpdClause *)dbentry;
cl->ClRefCount++;
} else {
dbentry->NOfRefsTo++;
}
*--dbg->tofref = dbentry;
db_check_trail(dbg->lr);
/* just continue the loop */
++pt0;
continue;
}
case (CELL) FunctorLongInt:
CheckDBOverflow(3);
*StoPoint++ = AbsAppl(CodeMax);
CodeMax = copy_long_int(CodeMax, ap2);
++pt0;
continue;
#ifdef USE_GMP
case (CELL) FunctorBigInt:
CheckDBOverflow(3 + Yap_SizeOfBigInt(d0));
/* first thing, store a link to the list before we move on */
*StoPoint++ = AbsAppl(CodeMax);
CodeMax = copy_big_int(CodeMax, ap2);
++pt0;
continue;
#endif
case (CELL) FunctorString: {
CELL *st = CodeMax;
CheckDBOverflow(3 + ap2[1]);
/* first thing, store a link to the list before we move on */
*StoPoint++ = AbsAppl(st);
CodeMax = copy_string(CodeMax, ap2);
++pt0;
continue;
}
case (CELL) FunctorDouble: {
CELL *st = CodeMax;
CheckDBOverflow(4);
/* first thing, store a link to the list before we move on */
*StoPoint++ = AbsAppl(st);
CodeMax = copy_double(CodeMax, ap2);
++pt0;
continue;
}
}
}
/* first thing, store a link to the list before we move on */
*StoPoint++ = AbsAppl(CodeMax);
/* next, postpone analysis to the rest of the current list */
CheckVisitOverflow();
#ifdef RATIONAL_TREES
to_visit[0] = pt0 + 1;
to_visit[1] = pt0_end;
to_visit[2] = StoPoint;
to_visit[3] = (CELL *)*pt0;
to_visit += 4;
*pt0 = StoPoint[-1];
#else
if (pt0 < pt0_end) {
to_visit[0] = pt0 + 1;
to_visit[1] = pt0_end;
to_visit[2] = StoPoint;
to_visit += 3;
}
#endif
d0 = ArityOfFunctor(f);
pt0 = ap2 + 1;
pt0_end = ap2 + d0;
CheckDBOverflow(d0 + 1);
/* prepare for our new compound term */
/* first the functor */
*CodeMax++ = (CELL)f;
/* we'll be working here */
StoPoint = CodeMax;
/* now reserve space */
CodeMax += d0;
continue;
} else if (IsPairTerm(d0)) {
/* we will need to link afterwards */
CELL *ap2 = RepPair(d0);
if (ap2 >= tbase && ap2 <= StoPoint) {
db_check_trail(dbg->lr + 1);
*dbg->lr++ = ToSmall((CELL)(StoPoint) - (CELL)(tbase));
*StoPoint++ = d0;
++pt0;
continue;
}
if (IsAtomOrIntTerm(Deref(ap2[0])) && IsPairTerm(Deref(ap2[1]))) {
/* shortcut for [1,2,3,4,5] */
Term tt = Deref(ap2[1]);
Term th = Deref(ap2[0]);
Int direction = RepPair(tt) - ap2;
CELL *OldStoPoint;
CELL *lp;
if (direction < 0)
direction = -1;
else
direction = 1;
db_check_trail(dbg->lr + 1);
*dbg->lr++ = ToSmall((CELL)(StoPoint) - (CELL)(tbase));
*StoPoint++ = AbsPair(CodeMax);
OldStoPoint = StoPoint;
do {
lp = RepPair(tt);
if (lp >= tbase && lp <= StoPoint) {
break;
}
CheckDBOverflow(2);
CodeMax[0] = th;
db_check_trail(dbg->lr + 1);
*dbg->lr++ = ToSmall((CELL)(CodeMax + 1) - (CELL)(tbase));
CodeMax[1] = AbsPair(CodeMax + 2);
CodeMax += 2;
th = Deref(lp[0]);
tt = Deref(lp[1]);
} while (IsAtomOrIntTerm(th) && IsPairTerm(tt) &&
/* have same direction to avoid infinite terms X = [a|X] */
(RepPair(tt) - lp) * direction > 0);
if (lp >= tbase && lp <= StoPoint) {
CodeMax[-1] = tt;
break;
}
if (IsAtomOrIntTerm(th) && IsAtomOrIntTerm(tt)) {
CheckDBOverflow(2);
CodeMax[0] = th;
CodeMax[1] = tt;
CodeMax += 2;
++pt0;
continue;
}
d0 = AbsPair(lp);
StoPoint = OldStoPoint;
} else {
db_check_trail(dbg->lr + 1);
*dbg->lr++ = ToSmall((CELL)(StoPoint) - (CELL)(tbase));
*StoPoint++ = AbsPair(CodeMax);
}
/* next, postpone analysis to the rest of the current list */
#ifdef RATIONAL_TREES
to_visit[0] = pt0 + 1;
to_visit[1] = pt0_end;
to_visit[2] = StoPoint;
to_visit[3] = (CELL *)*pt0;
to_visit += 4;
*pt0 = StoPoint[-1];
#else
if (pt0 < pt0_end) {
to_visit[0] = pt0 + 1;
to_visit[1] = pt0_end;
to_visit[2] = StoPoint;
to_visit += 3;
}
#endif
CheckVisitOverflow();
/* new list */
/* we are working at CodeMax */
StoPoint = CodeMax;
/* set ptr to new term being analysed */
pt0 = RepPair(d0);
pt0_end = RepPair(d0) + 1;
/* reserve space for our new list */
CodeMax += 2;
CheckDBOverflow(2);
continue;
} else if (IsAtomOrIntTerm(d0)) {
*StoPoint++ = d0;
++pt0;
continue;
}
/* the code to dereference a variable */
deref_var:
if (!DB_MARKED(d0)) {
if (
#if YAPOR_SBA
d0 != 0
#else
d0 != (CELL)ptd0
#endif
) {
ptd0 = (Term *)d0;
d0 = *ptd0;
goto restart; /* continue dereferencing */
}
/* else just drop to found_var */
}
/* else just drop to found_var */
{
CELL displacement = (CELL)(StoPoint) - (CELL)(tbase);
pt0++;
/* first time we found this variable! */
if (!DB_MARKED(d0)) {
/* store previous value */
visited--;
visited->addr = ptd0;
CheckDBOverflow(1);
/* variables need to be offset at read time */
*ptd0 = (CELL)StoPoint;
#if YAPOR_SBA
/* the copy we keep will be an empty variable */
*StoPoint++ = 0;
#else
/* the copy we keep will be the current displacement */
*StoPoint = (CELL)StoPoint;
StoPoint++;
db_check_trail(dbg->lr + 1);
*dbg->lr++ = ToSmall(displacement);
#endif
/* indicate we found variables */
vars_found++;
#ifdef COROUTINING
if (SafeIsAttachedTerm((CELL)ptd0)) {
Term t[4];
int sz = to_visit - to_visit_base;
HR = (CELL *)to_visit;
/* store the constraint away for: we need a back pointer to
the variable, the constraint in some cannonical form, what type
of constraint, and a list pointer */
t[0] = (CELL)ptd0;
t[1] = GLOBAL_attas[ExtFromCell(ptd0)].to_term_op(ptd0);
t[2] = MkIntegerTerm(ExtFromCell(ptd0));
t[3] = ConstraintsTerm;
ConstraintsTerm = Yap_MkApplTerm(FunctorClist, 4, t);
if (HR + sz >= ASP) {
goto error2;
}
memcpy((void *)HR, (void *)(to_visit_base), sz * sizeof(CELL *));
to_visit_base = (CELL **)HR;
to_visit = to_visit_base + sz;
}
#endif
continue;
} else {
/* references need to be offset at read time */
db_check_trail(dbg->lr + 1);
*dbg->lr++ = ToSmall(displacement);
/* store the offset */
*StoPoint = d0;
StoPoint++;
continue;
}
}
}
/* Do we still have compound terms to visit */
if (to_visit > to_visit_base) {
#ifdef RATIONAL_TREES
to_visit -= 4;
pt0 = to_visit[0];
pt0_end = to_visit[1];
StoPoint = to_visit[2];
pt0[-1] = (CELL)to_visit[3];
#else
to_visit -= 3;
pt0 = to_visit[0];
pt0_end = to_visit[1];
CheckDBOverflow(1);
StoPoint = to_visit[2];
#endif
goto loop;
}
#ifdef COROUTINING
/* we still may have constraints to do */
if (ConstraintsTerm != TermNil &&
!IN_BETWEEN(tbase, RepAppl(ConstraintsTerm), CodeMax)) {
*attachmentsp = (CELL)(CodeMax + 1);
pt0 = RepAppl(ConstraintsTerm) + 1;
pt0_end = RepAppl(ConstraintsTerm) + 4;
StoPoint = CodeMax;
*StoPoint++ = RepAppl(ConstraintsTerm)[0];
ConstraintsTerm = AbsAppl(CodeMax);
CheckDBOverflow(1);
CodeMax += 5;
goto loop;
}
#endif
/* we're done */
*vars_foundp = vars_found;
DB_UNWIND_CUNIF();
#ifdef COROUTINING
HR = origH;
#endif
return CodeMax;
error:
LOCAL_Error_TYPE = RESOURCE_ERROR_AUXILIARY_STACK;
LOCAL_Error_Size = 1024 + ((char *)AuxSp - (char *)CodeMaxBase);
*vars_foundp = vars_found;
#ifdef RATIONAL_TREES
while (to_visit > to_visit_base) {
to_visit -= 4;
pt0 = to_visit[0];
pt0_end = to_visit[1];
StoPoint = to_visit[2];
pt0[-1] = (CELL)to_visit[3];
}
#endif
DB_UNWIND_CUNIF();
#ifdef COROUTINING
HR = origH;
#endif
return NULL;
error2:
LOCAL_Error_TYPE = RESOURCE_ERROR_STACK;
*vars_foundp = vars_found;
#ifdef RATIONAL_TREES
while (to_visit > to_visit_base) {
to_visit -= 4;
pt0 = to_visit[0];
pt0_end = to_visit[1];
StoPoint = to_visit[2];
pt0[-1] = (CELL)to_visit[3];
}
#endif
DB_UNWIND_CUNIF();
#ifdef COROUTINING
HR = origH;
#endif
return NULL;
error_tr_overflow:
LOCAL_Error_TYPE = RESOURCE_ERROR_TRAIL;
*vars_foundp = vars_found;
#ifdef RATIONAL_TREES
while (to_visit > to_visit_base) {
to_visit -= 4;
pt0 = to_visit[0];
pt0_end = to_visit[1];
StoPoint = to_visit[2];
pt0[-1] = (CELL)to_visit[3];
}
#endif
DB_UNWIND_CUNIF();
#ifdef COROUTINING
HR = origH;
#endif
return NULL;
#if THREADS
#undef Yap_REGS
#define Yap_REGS (*Yap_regp)
#endif /* THREADS */
}
#ifdef SFUNC
/*
* The sparse terms existing in the structure are to be included now. This
* means simple copy for constant terms but, some care about variables If
* they have appeared before, we will know by their position number
*/
static void sf_include(SFKeep *sfp, struct db_globs *dbg) SFKeep *sfp;
{
Term Tm = sfp->SName;
CELL *tp = ArgsOfSFTerm(Tm);
Register Term *StoPoint = ntp;
CELL *displacement = CodeAbs;
CELL arg_no;
Term tvalue;
int j = 3;
if (sfp->SFather != NIL)
*(sfp->SFather) = AbsAppl(displacement);
*StoPoint++ = FunctorOfTerm(Tm);
db_check_trail(dbg->lr + 1);
*dbg->lr++ = ToSmall(displacement + 1);
*StoPoint++ = (Term)(displacement + 1);
while (*tp) {
arg_no = *tp++;
tvalue = Derefa(tp++);
if (IsVarTerm(tvalue)) {
if (((VarKeep *)tvalue)->NOfVars != 0) {
*StoPoint++ = arg_no;
db_check_trail(dbg->lr + 1);
*dbg->lr++ = ToSmall(displacement + j);
if (((VarKeep *)tvalue)->New == 0)
*StoPoint++ = ((VarKeep *)tvalue)->New = Unsigned(displacement + j);
else
*StoPoint++ = ((VarKeep *)tvalue)->New;
j += 2;
}
} else if (IsAtomicTerm(tvalue)) {
*StoPoint++ = arg_no;
*StoPoint++ = tvalue;
j += 2;
} else {
LOCAL_Error_TYPE = TYPE_ERROR_DBTERM;
LOCAL_Error_Term = d0;
LOCAL_ErrorMessage = "wrong term in SF";
return (NULL);
}
}
*StoPoint++ = 0;
ntp = StoPoint;
CodeAbs = displacement + j;
}
#endif
/*
* This function is used to check if one of the terms in the idb is the
* constant to_compare
*/
inline static DBRef check_if_cons(DBRef p, Term to_compare) {
while (p != NIL &&
(p->Flags & (DBCode | ErasedMask | DBVar | DBNoVars | DBComplex) ||
p->DBT.Entry != Unsigned(to_compare)))
p = NextDBRef(p);
return p;
}
/*
* This function is used to check if one of the terms in the idb is a prolog
* variable
*/
static DBRef check_if_var(DBRef p) {
while (p != NIL &&
p->Flags & (DBCode | ErasedMask | DBAtomic | DBNoVars | DBComplex))
p = NextDBRef(p);
return p;
}
/*
* This function is used to check if a Prolog complex term with variables
* already exists in the idb for that key. The comparison is alike ==, but
* only the relative binding of variables, not their position is used. The
* comparison is done using the function cmpclls only. The function could
* only fail if a functor was matched to a Prolog term, but then, it should
* have failed before because the structure of term would have been very
* different
*/
static DBRef check_if_wvars(DBRef p, unsigned int NOfCells, CELL *BTptr) {
CELL *memptr;
do {
while (p != NIL &&
p->Flags & (DBCode | ErasedMask | DBAtomic | DBNoVars | DBVar))
p = NextDBRef(p);
if (p == NIL)
return p;
memptr = CellPtr(&(p->DBT.Contents));
if (NOfCells == p->DBT.NOfCells && cmpclls(memptr, BTptr, NOfCells))
return p;
else
p = NextDBRef(p);
} while (TRUE);
return NIL;
}
static int scheckcells(int NOfCells, register CELL *m1, register CELL *m2,
link_entry *lp, register CELL bp) {
CELL base = Unsigned(m1);
link_entry *lp1;
while (NOfCells-- > 0) {
Register CELL r1, r2;
r1 = *m1++;
r2 = *m2++;
if (r1 == r2)
continue;
else if (r2 + bp == r1) {
/* link pointers may not have been generated in the */
/* same order */
/* make sure r1 is really an offset. */
lp1 = lp;
r1 = m1 - (CELL *)base;
while (*lp1 != r1 && *lp1)
lp1++;
if (!(*lp1))
return FALSE;
/* keep the old link pointer for future search. */
/* vsc: this looks like a bug!!!! */
/* *lp1 = *lp++; */
} else {
return FALSE;
}
}
return TRUE;
}
/*
* the cousin of the previous, but with things a bit more sophisticated.
* mtchcells, if an error was an found, needs to test ........
*/
static DBRef check_if_nvars(DBRef p, unsigned int NOfCells, CELL *BTptr,
struct db_globs *dbg) {
CELL *memptr;
do {
while (p != NIL &&
p->Flags & (DBCode | ErasedMask | DBAtomic | DBComplex | DBVar))
p = NextDBRef(p);
if (p == NIL)
return p;
memptr = CellPtr(p->DBT.Contents);
if (scheckcells(NOfCells, memptr, BTptr, dbg->LinkAr,
Unsigned(p->DBT.Contents - 1)))
return p;
else
p = NextDBRef(p);
} while (TRUE);
return NIL;
}
static DBRef generate_dberror_msg(int errnumb, UInt sz, char *msg) {
CACHE_REGS
LOCAL_Error_Size = sz;
LOCAL_Error_TYPE = errnumb;
LOCAL_Error_Term = TermNil;
LOCAL_ErrorMessage = msg;
return NULL;
}
static DBRef CreateDBWithDBRef(Term Tm, DBProp p, struct db_globs *dbg) {
DBRef pp, dbr = DBRefOfTerm(Tm);
DBTerm *ppt;
if (p == NULL) {
UInt sz = sizeof(DBTerm) + 2 * sizeof(CELL);
ppt = (DBTerm *)AllocDBSpace(sz);
if (ppt == NULL) {
return generate_dberror_msg(RESOURCE_ERROR_HEAP, TermNil,
"could not allocate heap");
}
dbg->sz = sz;
Yap_LUClauseSpace += sz;
pp = (DBRef)ppt;
} else {
UInt sz = DBLength(2 * sizeof(DBRef));
pp = AllocDBSpace(sz);
if (pp == NULL) {
return generate_dberror_msg(RESOURCE_ERROR_HEAP, 0,
"could not allocate space");
}
Yap_LUClauseSpace += sz;
dbg->sz = sz;
pp->id = FunctorDBRef;
pp->Flags = DBNoVars | DBComplex | DBWithRefs;
INIT_LOCK(pp->lock);
INIT_DBREF_COUNT(pp);
ppt = &(pp->DBT);
}
if (dbr->Flags & LogUpdMask) {
LogUpdClause *cl = (LogUpdClause *)dbr;
cl->ClRefCount++;
} else {
dbr->NOfRefsTo++;
}
ppt->Entry = Tm;
ppt->NOfCells = 0;
ppt->Contents[0] = (CELL)NULL;
ppt->Contents[1] = (CELL)dbr;
ppt->DBRefs = (DBRef *)(ppt->Contents + 2);
#ifdef COROUTINING
ppt->ag.attachments = 0L;
#endif
return pp;
}
static DBTerm *CreateDBTermForAtom(Term Tm, UInt extra_size,
struct db_globs *dbg) {
DBTerm *ppt;
ADDR ptr;
UInt sz = extra_size + sizeof(DBTerm);
ptr = (ADDR)AllocDBSpace(sz);
if (ptr == NULL) {
return (DBTerm *)generate_dberror_msg(RESOURCE_ERROR_HEAP, 0,
"could not allocate space");
}
Yap_LUClauseSpace += sz;
dbg->sz = sz;
ppt = (DBTerm *)(ptr + extra_size);
ppt->NOfCells = 0;
ppt->DBRefs = NULL;
#ifdef COROUTINING
ppt->ag.attachments = 0;
#endif
ppt->DBRefs = NULL;
ppt->Entry = Tm;
return ppt;
}
static DBTerm *CreateDBTermForVar(UInt extra_size, struct db_globs *dbg) {
DBTerm *ppt;
ADDR ptr;
UInt sz = extra_size + sizeof(DBTerm);
ptr = (ADDR)AllocDBSpace(sz);
if (ptr == NULL) {
return (DBTerm *)generate_dberror_msg(RESOURCE_ERROR_HEAP, 0,
"could not allocate space");
}
Yap_LUClauseSpace += sz;
dbg->sz = sz;
ppt = (DBTerm *)(ptr + extra_size);
ppt->NOfCells = 0;
ppt->DBRefs = NULL;
#ifdef COROUTINING
ppt->ag.attachments = 0;
#endif
ppt->DBRefs = NULL;
ppt->Entry = (CELL)(&(ppt->Entry));
return ppt;
}
static DBRef CreateDBRefForAtom(Term Tm, DBProp p, int InFlag,
struct db_globs *dbg) {
Register DBRef pp;
SMALLUNSGN flag;
UInt sz = DBLength(NIL);
flag = DBAtomic;
if (InFlag &MkIfNot && (dbg->found_one = check_if_cons(p->First, Tm)))
return dbg->found_one;
pp = AllocDBSpace(sz);
if (pp == NIL) {
return generate_dberror_msg(RESOURCE_ERROR_HEAP, 0,
"could not allocate space");
}
Yap_LUClauseSpace += sz;
dbg->sz = sz;
pp->id = FunctorDBRef;
INIT_LOCK(pp->lock);
INIT_DBREF_COUNT(pp);
pp->Flags = flag;
pp->Code = NULL;
pp->DBT.Entry = Tm;
pp->DBT.DBRefs = NULL;
pp->DBT.NOfCells = 0;
#ifdef COROUTINING
pp->DBT.ag.attachments = 0;
#endif
return (pp);
}
static DBRef CreateDBRefForVar(Term Tm, DBProp p, int InFlag,
struct db_globs *dbg) {
Register DBRef pp;
UInt sz = DBLength(NULL);
if (InFlag &MkIfNot && (dbg->found_one = check_if_var(p->First)))
return dbg->found_one;
pp = AllocDBSpace(sz);
if (pp == NULL) {
return generate_dberror_msg(RESOURCE_ERROR_HEAP, 0,
"could not allocate space");
}
Yap_LUClauseSpace += sz;
dbg->sz = sz;
pp->id = FunctorDBRef;
pp->Flags = DBVar;
pp->DBT.Entry = (CELL)Tm;
pp->Code = NULL;
pp->DBT.NOfCells = 0;
pp->DBT.DBRefs = NULL;
#ifdef COROUTINING
pp->DBT.ag.attachments = 0;
#endif
INIT_LOCK(pp->lock);
INIT_DBREF_COUNT(pp);
return pp;
}
static DBRef CreateDBStruct(Term Tm, DBProp p, int InFlag, int *pstat,
UInt extra_size, struct db_globs *dbg) {
CACHE_REGS
Register Term tt, *nar = NIL;
SMALLUNSGN flag;
int NOfLinks = 0;
/* place DBRefs in ConsultStack */
DBRef *TmpRefBase = (DBRef *)LOCAL_TrailTop;
CELL *CodeAbs; /* how much code did we find */
int vars_found = FALSE;
LOCAL_Error_TYPE = YAP_NO_ERROR;
if (p == NULL) {
if (IsVarTerm(Tm)) {
#ifdef COROUTINING
if (!SafeIsAttachedTerm(Tm)) {
#endif
DBRef out = (DBRef)CreateDBTermForVar(extra_size, dbg);
*pstat = TRUE;
return out;
#ifdef COROUTINING
}
#endif
} else if (IsAtomOrIntTerm(Tm)) {
DBRef out = (DBRef)CreateDBTermForAtom(Tm, extra_size, dbg);
*pstat = FALSE;
return out;
}
} else {
if (IsVarTerm(Tm)
#ifdef COROUTINING
&& !SafeIsAttachedTerm(Tm)
#endif
) {
*pstat = TRUE;
return CreateDBRefForVar(Tm, p, InFlag, dbg);
} else if (IsAtomOrIntTerm(Tm)) {
return CreateDBRefForAtom(Tm, p, InFlag, dbg);
}
}
/* next, let's process a compound term */
{
DBTerm *ppt, *ppt0;
DBRef pp, pp0;
Term *ntp0, *ntp;
unsigned int NOfCells = 0;
#ifdef COROUTINING
CELL attachments = 0;
#endif
dbg->tofref = TmpRefBase;
if (p == NULL) {
ADDR ptr = Yap_PreAllocCodeSpace();
ppt0 = (DBTerm *)(ptr + extra_size);
pp0 = (DBRef)ppt0;
} else {
pp0 = (DBRef)Yap_PreAllocCodeSpace();
ppt0 = &(pp0->DBT);
}
if ((ADDR)ppt0 >= (ADDR)AuxSp - 1024) {
LOCAL_Error_Size = (UInt)(extra_size + sizeof(ppt0));
LOCAL_Error_TYPE = RESOURCE_ERROR_AUXILIARY_STACK;
Yap_ReleasePreAllocCodeSpace((ADDR)pp0);
return NULL;
}
ntp0 = ppt0->Contents;
if ((ADDR)TR >= LOCAL_TrailTop - 1024) {
LOCAL_Error_Size = 0;
LOCAL_Error_TYPE = RESOURCE_ERROR_TRAIL;
Yap_ReleasePreAllocCodeSpace((ADDR)pp0);
return NULL;
}
dbg->lr = dbg->LinkAr = (link_entry *)TR;
#ifdef COROUTINING
/* attachment */
if (IsVarTerm(Tm)) {
tt = (CELL)(ppt0->Contents);
ntp = MkDBTerm(VarOfTerm(Tm), VarOfTerm(Tm), ntp0, ntp0 + 1, ntp0 - 1,
&attachments, &vars_found, dbg);
if (ntp == NULL) {
Yap_ReleasePreAllocCodeSpace((ADDR)pp0);
return NULL;
}
} else
#endif
if (IsPairTerm(Tm)) {
/* avoid null pointers!! */
tt = AbsPair(ppt0->Contents);
ntp = MkDBTerm(RepPair(Tm), RepPair(Tm) + 1, ntp0, ntp0 + 2, ntp0 - 1,
#ifdef COROUTINING
&attachments,
#endif
&vars_found, dbg);
if (ntp == NULL) {
Yap_ReleasePreAllocCodeSpace((ADDR)pp0);
return NULL;
}
} else {
unsigned int arity;
Functor fun;
tt = AbsAppl(ppt0->Contents);
/* we need to store the functor manually */
fun = FunctorOfTerm(Tm);
if (IsExtensionFunctor(fun)) {
switch ((CELL)fun) {
case (CELL) FunctorDouble:
ntp = copy_double(ntp0, RepAppl(Tm));
break;
case (CELL) FunctorString:
ntp = copy_string(ntp0, RepAppl(Tm));
break;
case (CELL) FunctorDBRef:
Yap_ReleasePreAllocCodeSpace((ADDR)pp0);
return CreateDBWithDBRef(Tm, p, dbg);
#ifdef USE_GMP
case (CELL) FunctorBigInt:
ntp = copy_big_int(ntp0, RepAppl(Tm));
break;
#endif
default: /* LongInt */
ntp = copy_long_int(ntp0, RepAppl(Tm));
break;
}
} else {
*ntp0 = (CELL)fun;
arity = ArityOfFunctor(fun);
ntp = MkDBTerm(RepAppl(Tm) + 1, RepAppl(Tm) + arity, ntp0 + 1,
ntp0 + 1 + arity, ntp0 - 1,
#ifdef COROUTINING
&attachments,
#endif
&vars_found, dbg);
if (ntp == NULL) {
Yap_ReleasePreAllocCodeSpace((ADDR)pp0);
return NULL;
}
}
}
CodeAbs = (CELL *)((CELL)ntp - (CELL)ntp0);
if (LOCAL_Error_TYPE) {
Yap_ReleasePreAllocCodeSpace((ADDR)pp0);
return NULL; /* Error Situation */
}
NOfCells = ntp - ntp0; /* End Of Code Info */
*dbg->lr++ = 0;
NOfLinks = (dbg->lr - dbg->LinkAr);
if (vars_found || InFlag & InQueue) {
/*
* Take into account the fact that one needs an entry
* for the number of links
*/
flag = DBComplex;
CodeAbs += (NOfLinks + (sizeof(CELL) / sizeof(BITS32) - 1)) /
(sizeof(CELL) / sizeof(BITS32));
if ((CELL *)((char *)ntp0 + (CELL)CodeAbs) > AuxSp) {
LOCAL_Error_Size = (UInt)DBLength(CodeAbs);
LOCAL_Error_TYPE = RESOURCE_ERROR_AUXILIARY_STACK;
Yap_ReleasePreAllocCodeSpace((ADDR)pp0);
return NULL;
}
if ((InFlag & MkIfNot) &&
(dbg->found_one = check_if_wvars(p->First, NOfCells, ntp0))) {
Yap_ReleasePreAllocCodeSpace((ADDR)pp0);
return dbg->found_one;
}
} else {
flag = DBNoVars;
if ((InFlag & MkIfNot) &&
(dbg->found_one = check_if_nvars(p->First, NOfCells, ntp0, dbg))) {
Yap_ReleasePreAllocCodeSpace((ADDR)pp0);
return dbg->found_one;
}
}
if (dbg->tofref != TmpRefBase) {
CodeAbs += (TmpRefBase - dbg->tofref) + 1;
if ((CELL *)((char *)ntp0 + (CELL)CodeAbs) > AuxSp) {
LOCAL_Error_Size = (UInt)DBLength(CodeAbs);
LOCAL_Error_TYPE = RESOURCE_ERROR_AUXILIARY_STACK;
Yap_ReleasePreAllocCodeSpace((ADDR)pp0);
return NULL;
}
flag |= DBWithRefs;
}
#if SIZEOF_LINK_ENTRY == 2
if (Unsigned(CodeAbs) >= 0x40000) {
Yap_ReleasePreAllocCodeSpace((ADDR)pp0);
return generate_dberror_msg(SYSTEM_ERROR_INTERNAL, 0,
"trying to store term larger than 256KB");
}
#endif
if (p == NULL) {
UInt sz = (CELL)CodeAbs + extra_size + sizeof(DBTerm);
ADDR ptr = Yap_AllocCodeSpace(sz);
ppt = (DBTerm *)(ptr + extra_size);
if (ptr == NULL) {
Yap_ReleasePreAllocCodeSpace((ADDR)pp0);
return generate_dberror_msg(RESOURCE_ERROR_HEAP, sz,
"heap crashed against stacks");
}
Yap_LUClauseSpace += sz;
dbg->sz = sz;
pp = (DBRef)ppt;
} else {
UInt sz = DBLength(CodeAbs);
pp = AllocDBSpace(sz);
if (pp == NULL) {
Yap_ReleasePreAllocCodeSpace((ADDR)pp0);
return generate_dberror_msg(RESOURCE_ERROR_HEAP, sz,
"heap crashed against stacks");
}
Yap_LUClauseSpace += sz;
dbg->sz = sz;
pp->id = FunctorDBRef;
pp->Flags = flag;
INIT_LOCK(pp->lock);
INIT_DBREF_COUNT(pp);
ppt = &(pp->DBT);
}
if (flag & DBComplex) {
link_entry *woar;
ppt->NOfCells = NOfCells;
#ifdef COROUTINING
ppt->ag.attachments = attachments;
#endif
if (pp0 != pp) {
nar = ppt->Contents;
nar = (Term *)cpcells(CellPtr(nar), ntp0, Unsigned(NOfCells));
} else {
nar = ppt->Contents + Unsigned(NOfCells);
}
woar = (link_entry *)nar;
memcpy((void *)woar, (const void *)dbg->LinkAr,
(size_t)(NOfLinks * sizeof(link_entry)));
woar += NOfLinks;
#ifdef ALIGN_LONGS
#if SIZEOF_INT_P == 8
while ((Unsigned(woar) & 7) != 0)
woar++;
#else
if ((Unsigned(woar) & 3) != 0)
woar++;
#endif
#endif
nar = (Term *)(woar);
*pstat = TRUE;
} else if (flag & DBNoVars) {
if (pp0 != pp) {
nar = (Term *)cpcells(CellPtr(ppt->Contents), ntp0, Unsigned(NOfCells));
} else {
nar = ppt->Contents + Unsigned(NOfCells);
}
ppt->NOfCells = NOfCells;
}
if (ppt != ppt0) {
linkblk(dbg->LinkAr, CellPtr(ppt->Contents - 1), (CELL)ppt - (CELL)ppt0);
ppt->Entry = AdjustIDBPtr(tt, (CELL)ppt - (CELL)ppt0);
#ifdef COROUTINING
if (attachments)
ppt->ag.attachments = AdjustIDBPtr(attachments, (CELL)ppt - (CELL)ppt0);
else
ppt->ag.attachments = 0L;
#endif
} else {
ppt->Entry = tt;
#ifdef COROUTINING
ppt->ag.attachments = attachments;
#endif
}
if (flag & DBWithRefs) {
DBRef *ptr = TmpRefBase, *rfnar = (DBRef *)nar;
*rfnar++ = NULL;
while (ptr != dbg->tofref)
*rfnar++ = *--ptr;
ppt->DBRefs = rfnar;
} else {
ppt->DBRefs = NULL;
}
Yap_ReleasePreAllocCodeSpace((ADDR)pp0);
return pp;
}
}
static DBRef record(int Flag, Term key, Term t_data, Term t_code USES_REGS) {
Register Term twork = key;
Register DBProp p;
Register DBRef x;
int needs_vars;
struct db_globs dbg;
LOCAL_s_dbg = &dbg;
dbg.found_one = NULL;
#ifdef SFUNC
FathersPlace = NIL;
#endif
if (EndOfPAEntr(
p = FetchDBPropFromKey(twork, Flag & MkCode, TRUE, "record/3"))) {
return NULL;
}
if ((x = CreateDBStruct(t_data, p, Flag, &needs_vars, 0, &dbg)) == NULL) {
return NULL;
}
if ((Flag & MkIfNot) && dbg.found_one)
return NULL;
TRAIL_REF(x);
if (x->Flags & (DBNoVars | DBComplex))
x->Mask = EvalMasks(t_data, &x->Key);
else
x->Mask = x->Key = 0;
if (Flag & MkCode)
x->Flags |= DBCode;
else
x->Flags |= DBNoCode;
x->Parent = p;
#if MULTIPLE_STACKS
x->Flags |= DBClMask;
x->ref_count = 1;
#else
x->Flags |= (InUseMask | DBClMask);
#endif
x->NOfRefsTo = 0;
WRITE_LOCK(p->DBRWLock);
if (p->F0 == NULL) {
p->F0 = p->L0 = x;
x->p = x->n = NULL;
} else {
if (Flag & MkFirst) {
x->n = p->F0;
p->F0->p = x;
p->F0 = x;
x->p = NULL;
} else {
x->p = p->L0;
p->L0->n = x;
p->L0 = x;
x->n = NULL;
}
}
if (p->First == NIL) {
p->First = p->Last = x;
x->Prev = x->Next = NIL;
} else if (Flag & MkFirst) {
x->Prev = NIL;
(p->First)->Prev = x;
x->Next = p->First;
p->First = x;
} else {
x->Next = NIL;
(p->Last)->Next = x;
x->Prev = p->Last;
p->Last = x;
}
if (Flag & MkCode) {
x->Code = (yamop *)IntegerOfTerm(t_code);
}
WRITE_UNLOCK(p->DBRWLock);
return x;
}
/* add a new entry next to an old one */
static DBRef record_at(int Flag, DBRef r0, Term t_data, Term t_code USES_REGS) {
Register DBProp p;
Register DBRef x;
int needs_vars;
struct db_globs dbg;
LOCAL_s_dbg = &dbg;
#ifdef SFUNC
FathersPlace = NIL;
#endif
p = r0->Parent;
if ((x = CreateDBStruct(t_data, p, Flag, &needs_vars, 0, &dbg)) == NULL) {
return NULL;
}
TRAIL_REF(x);
if (x->Flags & (DBNoVars | DBComplex))
x->Mask = EvalMasks(t_data, &x->Key);
else
x->Mask = x->Key = 0;
if (Flag & MkCode)
x->Flags |= DBCode;
else
x->Flags |= DBNoCode;
x->Parent = p;
#if MULTIPLE_STACKS
x->Flags |= DBClMask;
x->ref_count = 1;
#else
x->Flags |= (InUseMask | DBClMask);
#endif
x->NOfRefsTo = 0;
WRITE_LOCK(p->DBRWLock);
if (Flag & MkFirst) {
x->n = r0;
x->p = r0->p;
if (p->F0 == r0) {
p->F0 = x;
} else {
r0->p->n = x;
}
r0->p = x;
} else {
x->p = r0;
x->n = r0->n;
if (p->L0 == r0) {
p->L0 = x;
} else {
r0->n->p = x;
}
r0->n = x;
}
if (Flag & MkFirst) {
x->Prev = r0->Prev;
x->Next = r0;
if (p->First == r0) {
p->First = x;
} else {
r0->Prev->Next = x;
}
r0->Prev = x;
} else {
x->Next = r0->Next;
x->Prev = r0;
if (p->Last == r0) {
p->Last = x;
} else {
r0->Next->Prev = x;
}
r0->Next = x;
}
if (Flag & WithRef) {
x->Code = (yamop *)IntegerOfTerm(t_code);
}
WRITE_UNLOCK(p->DBRWLock);
return x;
}
static LogUpdClause *new_lu_db_entry(Term t, PredEntry *pe) {
CACHE_REGS
DBTerm *x;
LogUpdClause *cl;
yamop *ipc;
int needs_vars = FALSE;
struct db_globs dbg;
int d_flag = 0;
#if MULTIPLE_STACKS
/* we cannot allow sharing between threads (for now) */
if (!pe || !(pe->PredFlags & ThreadLocalPredFlag))
d_flag |= InQueue;
#endif
LOCAL_s_dbg = &dbg;
ipc = NEXTOP(((LogUpdClause *)NULL)->ClCode, e);
if ((x = (DBTerm *)CreateDBStruct(t, NULL, d_flag, &needs_vars, (UInt)ipc,
&dbg)) == NULL) {
return NULL; /* crash */
}
cl = (LogUpdClause *)((ADDR)x - (UInt)ipc);
ipc = cl->ClCode;
cl->Id = FunctorDBRef;
cl->ClFlags = LogUpdMask;
cl->lusl.ClSource = x;
cl->ClRefCount = 0;
cl->ClPred = pe;
cl->ClExt = NULL;
cl->ClPrev = cl->ClNext = NULL;
cl->ClSize = dbg.sz;
/* Support for timestamps */
if (pe && pe->LastCallOfPred != LUCALL_ASSERT) {
if (pe->TimeStampOfPred >= TIMESTAMP_RESET)
Yap_UpdateTimestamps(pe);
++pe->TimeStampOfPred;
/* fprintf(stderr,"+
* %x--%d--%ul\n",pe,pe->TimeStampOfPred,pe->ArityOfPE);*/
pe->LastCallOfPred = LUCALL_ASSERT;
cl->ClTimeStart = pe->TimeStampOfPred;
} else {
cl->ClTimeStart = 0L;
}
cl->ClTimeEnd = TIMESTAMP_EOT;
#if MULTIPLE_STACKS
// INIT_LOCK(cl->ClLock);
INIT_CLREF_COUNT(cl);
ipc->opc = Yap_opcode(_copy_idb_term);
#else
if (needs_vars)
ipc->opc = Yap_opcode(_copy_idb_term);
else
ipc->opc = Yap_opcode(_unify_idb_term);
#endif
return cl;
}
LogUpdClause *Yap_new_ludbe(Term t, PredEntry *pe, UInt nargs) {
CACHE_REGS
LogUpdClause *x;
LOCAL_Error_Size = 0;
while ((x = new_lu_db_entry(t, pe)) == NULL) {
if (LOCAL_Error_TYPE == YAP_NO_ERROR) {
break;
} else {
XREGS[nargs + 1] = t;
if (recover_from_record_error(nargs + 1)) {
t = Deref(XREGS[nargs + 1]);
} else {
return FALSE;
}
}
}
return x;
}
static LogUpdClause *record_lu(PredEntry *pe, Term t, int position) {
LogUpdClause *cl;
if ((cl = new_lu_db_entry(t, pe)) == NULL) {
return NULL;
}
{
Yap_inform_profiler_of_clause(cl, (char *)cl + cl->ClSize, pe,
GPROF_NEW_LU_CLAUSE);
}
Yap_add_logupd_clause(pe, cl, (position == MkFirst ? 2 : 0));
return cl;
}
static LogUpdClause *record_lu_at(int position, LogUpdClause *ocl, Term t) {
LogUpdClause *cl;
PredEntry *pe;
pe = ocl->ClPred;
PELOCK(62, pe);
if ((cl = new_lu_db_entry(t, pe)) == NULL) {
UNLOCK(pe->PELock);
return NULL;
}
if (pe->cs.p_code.NOfClauses > 1)
Yap_RemoveIndexation(pe);
if (position == MkFirst) {
/* add before current clause */
cl->ClNext = ocl;
if (ocl->ClCode == pe->cs.p_code.FirstClause) {
cl->ClPrev = NULL;
pe->cs.p_code.FirstClause = cl->ClCode;
} else {
cl->ClPrev = ocl->ClPrev;
ocl->ClPrev->ClNext = cl;
}
ocl->ClPrev = cl;
} else {
/* add after current clause */
cl->ClPrev = ocl;
if (ocl->ClCode == pe->cs.p_code.LastClause) {
cl->ClNext = NULL;
pe->cs.p_code.LastClause = cl->ClCode;
} else {
cl->ClNext = ocl->ClNext;
ocl->ClNext->ClPrev = cl;
}
ocl->ClNext = cl;
}
pe->cs.p_code.NOfClauses++;
if (pe->cs.p_code.NOfClauses > 1) {
pe->OpcodeOfPred = INDEX_OPCODE;
pe->CodeOfPred = (yamop *)(&(pe->OpcodeOfPred));
}
UNLOCK(pe->PELock);
return cl;
}
/* recorda(+Functor,+Term,-Ref) */
static Int p_rcda(USES_REGS1) {
/* Idiotic xlc's cpp does not work with ARG1 within MkDBRefTerm */
Term TRef, t1 = Deref(ARG1);
PredEntry *pe = NULL;
if (!IsVarTerm(Deref(ARG3)))
return (FALSE);
pe = find_lu_entry(t1);
LOCAL_Error_Size = 0;
restart_record:
if (pe) {
LogUpdClause *cl;
PELOCK(61, pe);
cl = record_lu(pe, Deref(ARG2), MkFirst);
if (cl != NULL) {
TRAIL_CLREF(cl);
#if MULTIPLE_STACKS
INC_CLREF_COUNT(cl);
#else
cl->ClFlags |= InUseMask;
#endif
TRef = MkDBRefTerm((DBRef)cl);
} else {
TRef = TermNil;
}
UNLOCK(pe->PELock);
} else {
TRef = MkDBRefTerm(record(MkFirst, t1, Deref(ARG2), Unsigned(0) PASS_REGS));
}
if (LOCAL_Error_TYPE != YAP_NO_ERROR) {
if (recover_from_record_error(3)) {
goto restart_record;
} else {
return FALSE;
}
}
if (!pe)
return FALSE;
return Yap_unify(ARG3, TRef);
}
/* '$recordap'(+Functor,+Term,-Ref) */
static Int p_rcdap(USES_REGS1) {
Term TRef, t1 = Deref(ARG1), t2 = Deref(ARG2);
if (!IsVarTerm(Deref(ARG3)))
return FALSE;
LOCAL_Error_Size = 0;
restart_record:
TRef = MkDBRefTerm(record(MkFirst | MkCode, t1, t2, Unsigned(0) PASS_REGS));
if (LOCAL_Error_TYPE != YAP_NO_ERROR) {
if (recover_from_record_error(3)) {
t1 = Deref(ARG1);
t2 = Deref(ARG2);
goto restart_record;
} else {
return FALSE;
}
}
return Yap_unify(ARG3, TRef);
}
/* recorda_at(+DBRef,+Term,-Ref) */
/** @pred recorda_at(+ _R0_, _T_,- _R_)
Makes term _T_ the record preceding record with reference
_R0_, and unifies _R_ with its reference.
*/
static Int p_rcda_at(USES_REGS1) {
/* Idiotic xlc's cpp does not work with ARG1 within MkDBRefTerm */
Term TRef, t1 = Deref(ARG1), t2 = Deref(ARG2);
DBRef dbr;
if (!IsVarTerm(Deref(ARG3)))
return FALSE;
if (IsVarTerm(t1)) {
Yap_Error(INSTANTIATION_ERROR, t1, "recorda_at/3");
return FALSE;
}
if (!IsDBRefTerm(t1)) {
Yap_Error(TYPE_ERROR_DBREF, t1, "recorda_at/3");
return FALSE;
}
LOCAL_Error_Size = 0;
restart_record:
dbr = DBRefOfTerm(t1);
if (dbr->Flags & ErasedMask) {
/* doesn't make sense */
return FALSE;
}
if (dbr->Flags & LogUpdMask) {
TRef = MkDBRefTerm((DBRef)record_lu_at(MkFirst, (LogUpdClause *)dbr, t2));
} else {
TRef = MkDBRefTerm(
record_at(MkFirst, DBRefOfTerm(t1), t2, Unsigned(0) PASS_REGS));
}
if (LOCAL_Error_TYPE != YAP_NO_ERROR) {
if (recover_from_record_error(3)) {
t1 = Deref(ARG1);
t2 = Deref(ARG2);
goto restart_record;
} else {
return FALSE;
}
}
return Yap_unify(ARG3, TRef);
}
/* recordz(+Functor,+Term,-Ref) */
/** @pred recordz(+ _K_, _T_,- _R_)
Makes term _T_ the last record under key _K_ and unifies _R_
with its reference.
*/
static Int p_rcdz(USES_REGS1) {
Term TRef, t1 = Deref(ARG1), t2 = Deref(ARG2);
PredEntry *pe;
if (!IsVarTerm(Deref(ARG3)))
return (FALSE);
pe = find_lu_entry(t1);
LOCAL_Error_Size = 0;
restart_record:
if (pe) {
LogUpdClause *cl;
PELOCK(62, pe);
cl = record_lu(pe, t2, MkLast);
if (cl != NULL) {
TRAIL_CLREF(cl);
#if MULTIPLE_STACKS
INC_CLREF_COUNT(cl);
#else
cl->ClFlags |= InUseMask;
#endif
TRef = MkDBRefTerm((DBRef)cl);
} else {
TRef = TermNil;
}
UNLOCK(pe->PELock);
} else {
TRef = MkDBRefTerm(record(MkLast, t1, t2, Unsigned(0) PASS_REGS));
}
if (LOCAL_Error_TYPE != YAP_NO_ERROR) {
if (recover_from_record_error(3)) {
t1 = Deref(ARG1);
t2 = Deref(ARG2);
goto restart_record;
} else {
return FALSE;
}
}
if (!pe)
return FALSE;
return Yap_unify(ARG3, TRef);
}
/* recordz(+Functor,+Term,-Ref) */
Int Yap_Recordz(Atom at, Term t2) {
CACHE_REGS
PredEntry *pe;
pe = find_lu_entry(MkAtomTerm(at));
LOCAL_Error_Size = 0;
restart_record:
if (pe) {
record_lu(pe, t2, MkLast);
} else {
record(MkLast, MkAtomTerm(at), t2, Unsigned(0) PASS_REGS);
}
if (LOCAL_Error_TYPE != YAP_NO_ERROR) {
ARG1 = t2;
if (recover_from_record_error(1)) {
t2 = ARG1;
goto restart_record;
} else {
return FALSE;
}
}
return TRUE;
}
/* '$recordzp'(+Functor,+Term,-Ref) */
static Int p_rcdzp(USES_REGS1) {
Term TRef, t1 = Deref(ARG1), t2 = Deref(ARG2);
if (!IsVarTerm(Deref(ARG3)))
return (FALSE);
LOCAL_Error_Size = 0;
restart_record:
TRef = MkDBRefTerm(record(MkLast | MkCode, t1, t2, Unsigned(0) PASS_REGS));
if (LOCAL_Error_TYPE != YAP_NO_ERROR) {
if (recover_from_record_error(3)) {
t1 = Deref(ARG1);
t2 = Deref(ARG2);
goto restart_record;
} else {
return FALSE;
}
}
return Yap_unify(ARG3, TRef);
}
/* recordz_at(+Functor,+Term,-Ref) */
/** @pred recordz_at(+ _R0_, _T_,- _R_)
Makes term _T_ the record following record with reference
_R0_, and unifies _R_ with its reference.
*/
static Int p_rcdz_at(USES_REGS1) {
/* Idiotic xlc's cpp does not work with ARG1 within MkDBRefTerm */
Term TRef, t1 = Deref(ARG1), t2 = Deref(ARG2);
DBRef dbr;
if (!IsVarTerm(Deref(ARG3)))
return (FALSE);
if (IsVarTerm(t1)) {
Yap_Error(INSTANTIATION_ERROR, t1, "recordz_at/3");
return FALSE;
}
if (!IsDBRefTerm(t1)) {
Yap_Error(TYPE_ERROR_DBREF, t1, "recordz_at/3");
return FALSE;
}
LOCAL_Error_Size = 0;
restart_record:
dbr = DBRefOfTerm(t1);
if (dbr->Flags & ErasedMask) {
/* doesn't make sense */
return FALSE;
}
if (dbr->Flags & LogUpdMask) {
TRef = MkDBRefTerm((DBRef)record_lu_at(MkLast, (LogUpdClause *)dbr, t2));
} else {
TRef = MkDBRefTerm(record_at(MkLast, dbr, t2, Unsigned(0) PASS_REGS));
}
if (LOCAL_Error_TYPE != YAP_NO_ERROR) {
if (recover_from_record_error(3)) {
t1 = Deref(ARG1);
t2 = Deref(ARG2);
goto restart_record;
} else {
return FALSE;
}
}
return Yap_unify(ARG3, TRef);
}
/* '$record_stat_source'(+Functor,+Term) */
static Int p_rcdstatp(USES_REGS1) {
Term t1 = Deref(ARG1), t2 = Deref(ARG2), t3 = Deref(ARG3);
int mk_first;
Term TRef;
if (IsVarTerm(t3) || !IsIntTerm(t3))
return (FALSE);
if (IsVarTerm(t3) || !IsIntTerm(t3))
return (FALSE);
mk_first = ((IntOfTerm(t3) % 4) == 2);
LOCAL_Error_Size = 0;
restart_record:
if (mk_first)
TRef =
MkDBRefTerm(record(MkFirst | MkCode, t1, t2, MkIntTerm(0) PASS_REGS));
else
TRef = MkDBRefTerm(record(MkLast | MkCode, t1, t2, MkIntTerm(0) PASS_REGS));
if (LOCAL_Error_TYPE != YAP_NO_ERROR) {
if (recover_from_record_error(4)) {
t1 = Deref(ARG1);
t2 = Deref(ARG2);
t3 = Deref(ARG3);
goto restart_record;
} else {
return FALSE;
}
}
return Yap_unify(ARG4, TRef);
}
/* '$recordap'(+Functor,+Term,-Ref,+CRef) */
static Int p_drcdap(USES_REGS1) {
Term TRef, t1 = Deref(ARG1), t2 = Deref(ARG2), t4 = Deref(ARG4);
if (!IsVarTerm(Deref(ARG3)))
return (FALSE);
if (IsVarTerm(t4) || !IsIntegerTerm(t4))
return (FALSE);
LOCAL_Error_Size = 0;
restart_record:
TRef = MkDBRefTerm(record(MkFirst | MkCode | WithRef, t1, t2, t4 PASS_REGS));
if (LOCAL_Error_TYPE != YAP_NO_ERROR) {
if (recover_from_record_error(4)) {
t1 = Deref(ARG1);
t2 = Deref(ARG2);
t4 = Deref(ARG4);
goto restart_record;
} else {
return FALSE;
}
}
return Yap_unify(ARG3, TRef);
}
/* '$recordzp'(+Functor,+Term,-Ref,+CRef) */
static Int p_drcdzp(USES_REGS1) {
Term TRef, t1 = Deref(ARG1), t2 = Deref(ARG2), t4 = Deref(ARG4);
if (!IsVarTerm(Deref(ARG3)))
return (FALSE);
if (IsVarTerm(t4) || !IsIntegerTerm(t4))
return (FALSE);
restart_record:
LOCAL_Error_Size = 0;
TRef = MkDBRefTerm(record(MkLast | MkCode | WithRef, t1, t2, t4 PASS_REGS));
if (LOCAL_Error_TYPE != YAP_NO_ERROR) {
if (recover_from_record_error(4)) {
t1 = Deref(ARG1);
t2 = Deref(ARG2);
t4 = Deref(ARG4);
goto restart_record;
} else {
return FALSE;
}
}
return Yap_unify(ARG3, TRef);
}
static Int p_still_variant(USES_REGS1) {
CELL *old_h = B->cp_h;
tr_fr_ptr old_tr = B->cp_tr;
Term t1 = Deref(ARG1), t2 = Deref(ARG2);
DBTerm *dbt;
DBRef dbr;
if (IsVarTerm(t1) || !IsDBRefTerm(t1)) {
return (FALSE);
/* limited sanity checking */
if (dbr->id != FunctorDBRef) {
return FALSE;
}
} else {
dbr = DBRefOfTerm(t1);
}
/* ok, we assume there was a choicepoint before we copied the term */
/* skip binding for argument variable */
old_tr++;
if (dbr->Flags & LogUpdMask) {
LogUpdClause *cl = (LogUpdClause *)dbr;
if (old_tr == TR - 1) {
if (TrailTerm(old_tr) != CLREF_TO_TRENTRY(cl))
return FALSE;
} else if (old_tr != TR)
return FALSE;
if (Yap_op_from_opcode(cl->ClCode->opc) == _unify_idb_term) {
return TRUE;
} else {
dbt = cl->lusl.ClSource;
}
} else {
if (old_tr == TR - 1) {
if (TrailTerm(old_tr) != REF_TO_TRENTRY(dbr))
return FALSE;
} else if (old_tr != TR)
return FALSE;
if (dbr->Flags & (DBNoVars | DBAtomic))
return TRUE;
if (dbr->Flags & DBVar)
return IsVarTerm(t2);
dbt = &(dbr->DBT);
}
/*
we checked the trail, so we are sure only variables in the new term
were bound
*/
{
link_entry *lp = (link_entry *)(dbt->Contents + dbt->NOfCells);
link_entry link;
if (!dbt->NOfCells) {
return IsVarTerm(t2);
}
while ((link = *lp++)) {
Term t2 = Deref(old_h[link - 1]);
if (IsUnboundVar(dbt->Contents + (link - 1))) {
if (IsVarTerm(t2)) {
Yap_unify(t2, MkAtomTerm(AtomFoundVar));
} else {
return FALSE;
}
}
}
}
return TRUE;
}
#ifdef COROUTINING
static int copy_attachments(CELL *ts USES_REGS) {
/* we will change delayed vars, and that also means the trail */
tr_fr_ptr tr0 = TR;
while (TRUE) {
/* store away in case there is an overflow */
if (GLOBAL_attas[IntegerOfTerm(ts[2])].term_to_op(ts[1], ts[0] PASS_REGS) ==
FALSE) {
/* oops, we did not have enough space to copy the elements */
/* reset queue of woken up goals */
TR = tr0;
return FALSE;
}
if (ts[3] == TermNil)
return TRUE;
ts = RepAppl(ts[3]) + 1;
}
}
#endif
static Term GetDBLUKey(PredEntry *ap) {
PELOCK(63, ap);
if (ap->PredFlags & NumberDBPredFlag) {
CACHE_REGS
Int id = ap->src.IndxId;
UNLOCK(ap->PELock);
return MkIntegerTerm(id);
} else if (ap->PredFlags & AtomDBPredFlag ||
(ap->ModuleOfPred != IDB_MODULE && ap->ArityOfPE == 0)) {
Atom at = (Atom)ap->FunctorOfPred;
UNLOCK(ap->PELock);
return MkAtomTerm(at);
} else {
Functor f = ap->FunctorOfPred;
UNLOCK(ap->PELock);
return Yap_MkNewApplTerm(f, ArityOfFunctor(f));
}
}
static int UnifyDBKey(DBRef DBSP, PropFlags flags, Term t) {
DBProp p = DBSP->Parent;
Term t1, tf;
READ_LOCK(p->DBRWLock);
/* get the key */
if (p->ArityOfDB == 0) {
t1 = MkAtomTerm((Atom)(p->FunctorOfDB));
} else {
t1 = Yap_MkNewApplTerm(p->FunctorOfDB, p->ArityOfDB);
}
if ((p->KindOfPE & CodeDBBit) && (flags & CodeDBBit)) {
Term t[2];
if (p->ModuleOfDB)
t[0] = p->ModuleOfDB;
else
t[0] = TermProlog;
t[1] = t1;
tf = Yap_MkApplTerm(FunctorModule, 2, t);
} else if (!(flags & CodeDBBit)) {
tf = t1;
} else {
return FALSE;
}
READ_UNLOCK(p->DBRWLock);
return Yap_unify(tf, t);
}
static int UnifyDBNumber(DBRef DBSP, Term t) {
CACHE_REGS
DBProp p = DBSP->Parent;
DBRef ref;
Int i = 1;
READ_LOCK(p->DBRWLock);
ref = p->First;
while (ref != NIL) {
if (ref == DBSP)
break;
if (!DEAD_REF(ref))
i++;
ref = ref->Next;
}
if (ref == NIL)
return FALSE;
READ_UNLOCK(p->DBRWLock);
return Yap_unify(MkIntegerTerm(i), t);
}
Int Yap_unify_immediate_ref(DBRef ref USES_REGS) {
// old immediate semantics style
LOCK(ref->lock);
if (ref == NULL || DEAD_REF(ref) || !UnifyDBKey(ref, 0, ARG1) ||
!UnifyDBNumber(ref, ARG2)) {
UNLOCK(ref->lock);
return FALSE;
} else {
UNLOCK(ref->lock);
return TRUE;
}
}
static Term GetDBTerm(DBTerm *DBSP, int src USES_REGS) {
Term t = DBSP->Entry;
if (IsVarTerm(t)
#if COROUTINING
&& !DBSP->ag.attachments
#endif
) {
return MkVarTerm();
} else if (IsAtomOrIntTerm(t)) {
return t;
} else {
CELL *HOld = HR;
CELL *HeapPtr;
CELL *pt;
CELL NOf;
if (!(NOf = DBSP->NOfCells)) {
return t;
}
pt = CellPtr(DBSP->Contents);
CalculateStackGap(PASS_REGS1);
if (HR + NOf > ASP - EventFlag / sizeof(CELL)) {
if (LOCAL_PrologMode & InErrorMode) {
if (HR + NOf > ASP)
fprintf(stderr,
"\n\n [ FATAL ERROR: No Stack for Error Handling ]\n");
Yap_exit(1);
} else {
LOCAL_Error_TYPE = RESOURCE_ERROR_STACK;
LOCAL_Error_Size = NOf * sizeof(CELL);
return (Term)0;
}
}
HeapPtr = cpcells(HOld, pt, NOf);
pt += HeapPtr - HOld;
HR = HeapPtr;
{
link_entry *lp = (link_entry *)pt;
linkblk(lp, HOld - 1, (CELL)HOld - (CELL)(DBSP->Contents));
}
#ifdef COROUTINING
if (DBSP->ag.attachments != 0L && !src) {
if (!copy_attachments((CELL *)AdjustIDBPtr(
DBSP->ag.attachments, (CELL)HOld - (CELL)(DBSP->Contents))
PASS_REGS)) {
HR = HOld;
LOCAL_Error_TYPE = RESOURCE_ERROR_ATTRIBUTED_VARIABLES;
LOCAL_Error_Size = 0;
return (Term)0;
}
}
#endif
return AdjustIDBPtr(t, Unsigned(HOld) - (CELL)(DBSP->Contents));
}
}
static Term GetDBTermFromDBEntry(DBRef DBSP USES_REGS) {
if (DBSP->Flags & (DBNoVars | DBAtomic))
return DBSP->DBT.Entry;
return GetDBTerm(&(DBSP->DBT), FALSE PASS_REGS);
}
static void init_int_keys(void) {
INT_KEYS = (Prop *)Yap_AllocCodeSpace(sizeof(Prop) * INT_KEYS_SIZE);
if (INT_KEYS != NULL) {
UInt i = 0;
Prop *p = INT_KEYS;
for (i = 0; i < INT_KEYS_SIZE; i++) {
p[0] = NIL;
p++;
}
Yap_LUClauseSpace += sizeof(Prop) * INT_KEYS_SIZE;
}
}
static void init_int_lu_keys(void) {
INT_LU_KEYS = (Prop *)Yap_AllocCodeSpace(sizeof(Prop) * INT_KEYS_SIZE);
if (INT_LU_KEYS != NULL) {
UInt i = 0;
Prop *p = INT_LU_KEYS;
for (i = 0; i < INT_KEYS_SIZE; i++) {
p[0] = NULL;
p++;
}
Yap_LUClauseSpace += sizeof(Prop) * INT_KEYS_SIZE;
}
}
static int resize_int_keys(UInt new_size) {
CACHE_REGS
Prop *new;
UInt i;
UInt old_size = INT_KEYS_SIZE;
YAPEnterCriticalSection();
if (INT_KEYS == NULL) {
INT_KEYS_SIZE = new_size;
YAPLeaveCriticalSection();
return TRUE;
}
new = (Prop *)Yap_AllocCodeSpace(sizeof(Prop) * new_size);
if (new == NULL) {
YAPLeaveCriticalSection();
LOCAL_Error_TYPE = RESOURCE_ERROR_HEAP;
LOCAL_Error_Term = TermNil;
LOCAL_ErrorMessage = "could not allocate space";
return FALSE;
}
Yap_LUClauseSpace += sizeof(Prop) * new_size;
for (i = 0; i < new_size; i++) {
new[i] = NIL;
}
for (i = 0; i < INT_KEYS_SIZE; i++) {
if (INT_KEYS[i] != NIL) {
Prop p0 = INT_KEYS[i];
while (p0 != NIL) {
DBProp p = RepDBProp(p0);
CELL key = (CELL)(p->FunctorOfDB);
UInt hash_key = (CELL)key % new_size;
p0 = p->NextOfPE;
p->NextOfPE = new[hash_key];
new[hash_key] = AbsDBProp(p);
}
}
}
Yap_LUClauseSpace -= sizeof(Prop) * old_size;
Yap_FreeCodeSpace((char *)INT_KEYS);
INT_KEYS = new;
INT_KEYS_SIZE = new_size;
INT_KEYS_TIMESTAMP++;
if (INT_KEYS_TIMESTAMP == MAX_ABS_INT)
INT_KEYS_TIMESTAMP = 0;
YAPLeaveCriticalSection();
return TRUE;
}
static PredEntry *find_lu_int_key(Int key) {
UInt hash_key = (CELL)key % INT_KEYS_SIZE;
Prop p0;
if (INT_LU_KEYS != NULL) {
p0 = INT_LU_KEYS[hash_key];
while (p0) {
PredEntry *pe = RepPredProp(p0);
if (pe->src.IndxId == key) {
return pe;
}
p0 = pe->NextOfPE;
}
}
if (UPDATE_MODE == UPDATE_MODE_LOGICAL && find_int_key(key) == NULL) {
return new_lu_int_key(key);
}
return NULL;
}
PredEntry *Yap_FindLUIntKey(Int key) { return find_lu_int_key(key); }
static DBProp find_int_key(Int key) {
UInt hash_key = (CELL)key % INT_KEYS_SIZE;
Prop p0;
if (INT_KEYS == NULL) {
return NULL;
}
p0 = INT_KEYS[hash_key];
while (p0) {
DBProp p = RepDBProp(p0);
if (p->FunctorOfDB == (Functor)key)
return p;
p0 = p->NextOfPE;
}
return NULL;
}
static PredEntry *new_lu_int_key(Int key) {
UInt hash_key = (CELL)key % INT_KEYS_SIZE;
PredEntry *p;
Prop p0;
Atom ae;
if (INT_LU_KEYS == NULL) {
init_int_lu_keys();
if (INT_LU_KEYS == NULL) {
CACHE_REGS
LOCAL_Error_TYPE = RESOURCE_ERROR_HEAP;
LOCAL_Error_Term = TermNil;
LOCAL_ErrorMessage = "could not allocate space";
return NULL;
}
}
ae = AtomDInteger;
WRITE_LOCK(ae->ARWLock);
p0 = Yap_NewPredPropByAtom(ae, IDB_MODULE);
p = RepPredProp(p0);
p->NextOfPE = INT_LU_KEYS[hash_key];
p->src.IndxId = key;
p->PredFlags |= LogUpdatePredFlag | NumberDBPredFlag;
p->ArityOfPE = 3;
p->OpcodeOfPred = Yap_opcode(_op_fail);
p->cs.p_code.TrueCodeOfPred = p->CodeOfPred = FAILCODE;
INT_LU_KEYS[hash_key] = p0;
return p;
}
static PredEntry *new_lu_entry(Term t) {
Prop p0;
PredEntry *pe;
if (IsApplTerm(t)) {
Functor f = FunctorOfTerm(t);
FUNC_WRITE_LOCK(f);
p0 = Yap_NewPredPropByFunctor(f, IDB_MODULE);
} else if (IsAtomTerm(t)) {
Atom at = AtomOfTerm(t);
WRITE_LOCK(RepAtom(at)->ARWLock);
p0 = Yap_NewPredPropByAtom(at, IDB_MODULE);
} else {
FUNC_WRITE_LOCK(FunctorList);
p0 = Yap_NewPredPropByFunctor(FunctorList, IDB_MODULE);
}
pe = RepPredProp(p0);
pe->PredFlags |= LogUpdatePredFlag;
if (IsAtomTerm(t)) {
pe->PredFlags |= AtomDBPredFlag;
}
pe->ArityOfPE = 3;
pe->OpcodeOfPred = Yap_opcode(_op_fail);
if (CurrentModule == PROLOG_MODULE)
pe->PredFlags |= StandardPredFlag;
pe->cs.p_code.TrueCodeOfPred = pe->CodeOfPred = FAILCODE;
return pe;
}
static DBProp find_entry(Term t) {
Atom at;
UInt arity;
if (IsVarTerm(t)) {
return RepDBProp(NIL);
} else if (IsAtomTerm(t)) {
at = AtomOfTerm(t);
arity = 0;
} else if (IsIntegerTerm(t)) {
return find_int_key(IntegerOfTerm(t));
} else if (IsApplTerm(t)) {
Functor f = FunctorOfTerm(t);
at = NameOfFunctor(f);
arity = ArityOfFunctor(f);
} else {
at = AtomDot;
arity = 2;
}
return RepDBProp(FindDBProp(RepAtom(at), 0, arity, 0));
}
static PredEntry *find_lu_entry(Term t) {
Prop p;
if (IsVarTerm(t)) {
Yap_Error(INSTANTIATION_ERROR, t, "while accessing database key");
return NULL;
}
if (IsIntegerTerm(t)) {
return find_lu_int_key(IntegerOfTerm(t));
} else if (IsApplTerm(t)) {
Functor f = FunctorOfTerm(t);
if (IsExtensionFunctor(f)) {
Yap_Error(TYPE_ERROR_KEY, t, "while accessing database key");
return NULL;
}
p = Yap_GetPredPropByFuncInThisModule(FunctorOfTerm(t), IDB_MODULE);
} else if (IsAtomTerm(t)) {
p = Yap_GetPredPropByAtomInThisModule(AtomOfTerm(t), IDB_MODULE);
} else {
p = Yap_GetPredPropByFuncInThisModule(FunctorList, IDB_MODULE);
}
if (p == NIL) {
if (UPDATE_MODE == UPDATE_MODE_LOGICAL && !find_entry(t)) {
return new_lu_entry(t);
} else {
return NULL;
}
}
return RepPredProp(p);
}
static DBProp FetchIntDBPropFromKey(Int key, int flag, int new,
char *error_mssg) {
Functor fun = (Functor)key;
UInt hash_key = (CELL)key % INT_KEYS_SIZE;
Prop p0;
if (INT_KEYS == NULL) {
init_int_keys();
if (INT_KEYS == NULL) {
CACHE_REGS
LOCAL_Error_TYPE = RESOURCE_ERROR_HEAP;
LOCAL_Error_Term = TermNil;
LOCAL_ErrorMessage = "could not allocate space";
return NULL;
}
}
p0 = INT_KEYS[hash_key];
while (p0 != NIL) {
DBProp p = RepDBProp(p0);
if (p->FunctorOfDB == fun)
return p;
p0 = p->NextOfPE;
}
/* p is NULL, meaning we did not find the functor */
if (new) {
DBProp p;
/* create a new DBProp */
p = (DBProp)Yap_AllocAtomSpace(sizeof(*p));
p->KindOfPE = DBProperty | flag;
p->F0 = p->L0 = NULL;
p->ArityOfDB = 0;
p->First = p->Last = NULL;
p->ModuleOfDB = 0;
p->FunctorOfDB = fun;
p->NextOfPE = INT_KEYS[hash_key];
INIT_RWLOCK(p->DBRWLock);
INT_KEYS[hash_key] = AbsDBProp(p);
return p;
} else {
return RepDBProp(NULL);
}
}
static DBProp FetchDBPropFromKey(Term twork, int flag, int new,
char *error_mssg) {
Atom At;
Int arity;
Term dbmod;
if (flag & MkCode) {
if (IsVarTerm(twork)) {
Yap_Error(INSTANTIATION_ERROR, twork, error_mssg);
return RepDBProp(NULL);
}
if (!IsApplTerm(twork)) {
Yap_Error(SYSTEM_ERROR_INTERNAL, twork, "missing module");
return RepDBProp(NULL);
} else {
Functor f = FunctorOfTerm(twork);
if (f != FunctorModule) {
Yap_Error(SYSTEM_ERROR_INTERNAL, twork, "missing module");
return RepDBProp(NULL);
}
dbmod = ArgOfTerm(1, twork);
if (IsVarTerm(dbmod)) {
Yap_Error(INSTANTIATION_ERROR, twork, "var in module");
return RepDBProp(NIL);
}
if (!IsAtomTerm(dbmod)) {
Yap_Error(TYPE_ERROR_ATOM, twork, "not atom in module");
return RepDBProp(NIL);
}
twork = ArgOfTerm(2, twork);
}
} else {
dbmod = 0;
}
if (IsVarTerm(twork)) {
Yap_Error(INSTANTIATION_ERROR, twork, error_mssg);
return RepDBProp(NIL);
} else if (IsAtomTerm(twork)) {
arity = 0, At = AtomOfTerm(twork);
} else if (IsIntegerTerm(twork)) {
return FetchIntDBPropFromKey(IntegerOfTerm(twork), flag, new, error_mssg);
} else if (IsApplTerm(twork)) {
Register Functor f = FunctorOfTerm(twork);
if (IsExtensionFunctor(f)) {
Yap_Error(TYPE_ERROR_KEY, twork, error_mssg);
return RepDBProp(NIL);
}
At = NameOfFunctor(f);
arity = ArityOfFunctor(f);
} else if (IsPairTerm(twork)) {
At = AtomDot;
arity = 2;
} else {
Yap_Error(TYPE_ERROR_KEY, twork, error_mssg);
return RepDBProp(NIL);
}
if (new) {
DBProp p;
AtomEntry *ae = RepAtom(At);
WRITE_LOCK(ae->ARWLock);
if (EndOfPAEntr(
p = RepDBProp(FindDBPropHavingLock(ae, flag, arity, dbmod)))) {
/* create a new DBProp */
int OLD_UPDATE_MODE = UPDATE_MODE;
if (flag & MkCode) {
PredEntry *pp;
pp = RepPredProp(Yap_GetPredPropHavingLock(At, arity, dbmod));
if (!EndOfPAEntr(pp)) {
PELOCK(64, pp);
if (pp->PredFlags & LogUpdatePredFlag)
UPDATE_MODE = UPDATE_MODE_LOGICAL;
UNLOCK(pp->PELock);
}
}
p = (DBProp)Yap_AllocAtomSpace(sizeof(*p));
p->KindOfPE = DBProperty | flag;
p->F0 = p->L0 = NULL;
UPDATE_MODE = OLD_UPDATE_MODE;
p->ArityOfDB = arity;
p->First = p->Last = NIL;
p->ModuleOfDB = dbmod;
/* This is NOT standard but is QUITE convenient */
INIT_RWLOCK(p->DBRWLock);
if (arity == 0)
p->FunctorOfDB = (Functor)At;
else
p->FunctorOfDB = Yap_UnlockedMkFunctor(ae, arity);
AddPropToAtom(ae, (PropEntry *)p);
}
WRITE_UNLOCK(ae->ARWLock);
return p;
} else
return RepDBProp(FindDBProp(RepAtom(At), flag, arity, dbmod));
}
static Int lu_nth_recorded(PredEntry *pe, Int Count USES_REGS) {
LogUpdClause *cl;
XREGS[2] = MkVarTerm();
cl = Yap_NthClause(pe, Count);
if (cl == NULL)
return FALSE;
#if MULTIPLE_STACKS
TRAIL_CLREF(cl); /* So that fail will erase it */
INC_CLREF_COUNT(cl);
#else
if (!(cl->ClFlags & InUseMask)) {
cl->ClFlags |= InUseMask;
TRAIL_CLREF(cl); /* So that fail will erase it */
}
#endif
UNLOCK(pe->PELock);
return Yap_unify(MkDBRefTerm((DBRef)cl), ARG4);
}
/* Finds a term recorded under the key ARG1 */
static Int nth_recorded(DBProp AtProp, Int Count USES_REGS) {
Register DBRef ref;
READ_LOCK(AtProp->DBRWLock);
ref = AtProp->First;
Count--;
while (ref != NULL && DEAD_REF(ref))
ref = NextDBRef(ref);
if (ref == NULL) {
READ_UNLOCK(AtProp->DBRWLock);
return FALSE;
}
while (Count) {
Count--;
ref = NextDBRef(ref);
while (ref != NULL && DEAD_REF(ref))
ref = NextDBRef(ref);
if (ref == NULL) {
READ_UNLOCK(AtProp->DBRWLock);
return FALSE;
}
}
#if MULTIPLE_STACKS
LOCK(ref->lock);
READ_UNLOCK(AtProp->DBRWLock);
TRAIL_REF(ref); /* So that fail will erase it */
INC_DBREF_COUNT(ref);
UNLOCK(ref->lock);
#else
if (!(ref->Flags & InUseMask)) {
ref->Flags |= InUseMask;
TRAIL_REF(ref); /* So that fail will erase it */
}
READ_UNLOCK(AtProp->DBRWLock);
#endif
return Yap_unify(MkDBRefTerm(ref), ARG4);
}
Int Yap_db_nth_recorded(PredEntry *pe, Int Count USES_REGS) {
DBProp AtProp;
if (pe == NULL) {
return lu_nth_recorded(pe, Count PASS_REGS);
}
if (EndOfPAEntr(AtProp = FetchDBPropFromKey(Deref(ARG1), 0, FALSE,
"nth_instance/3"))) {
UNLOCK(pe->PELock);
return FALSE;
}
return nth_recorded(AtProp, Count PASS_REGS);
}
static Int p_db_key(USES_REGS1) {
Register Term twork = Deref(ARG1); /* fetch the key */
DBProp AtProp;
if (EndOfPAEntr(AtProp = FetchDBPropFromKey(twork, 0, TRUE, "db_key/3"))) {
/* should never happen */
return FALSE;
}
return Yap_unify(ARG2, MkIntegerTerm((Int)AtProp));
}
/* Finds a term recorded under the key ARG1 */
static Int i_recorded(DBProp AtProp, Term t3 USES_REGS) {
Term TermDB, TRef;
Register DBRef ref;
Term twork;
READ_LOCK(AtProp->DBRWLock);
ref = AtProp->First;
while (ref != NULL && DEAD_REF(ref))
ref = NextDBRef(ref);
READ_UNLOCK(AtProp->DBRWLock);
if (ref == NULL) {
cut_fail();
}
twork = Deref(ARG2); /* now working with ARG2 */
if (IsVarTerm(twork)) {
EXTRA_CBACK_ARG(3, 2) = MkIntegerTerm(0);
EXTRA_CBACK_ARG(3, 3) = MkIntegerTerm(0);
B->cp_h = HR;
while ((TermDB = GetDBTermFromDBEntry(ref PASS_REGS)) == (CELL)0) {
/* make sure the garbage collector sees what we want it to see! */
EXTRA_CBACK_ARG(3, 1) = (CELL)ref;
/* oops, we are in trouble, not enough stack space */
if (LOCAL_Error_TYPE == RESOURCE_ERROR_ATTRIBUTED_VARIABLES) {
LOCAL_Error_TYPE = YAP_NO_ERROR;
if (!Yap_growglobal(NULL)) {
Yap_Error(RESOURCE_ERROR_ATTRIBUTED_VARIABLES, TermNil,
LOCAL_ErrorMessage);
return FALSE;
}
} else {
LOCAL_Error_TYPE = YAP_NO_ERROR;
if (!Yap_gcl(LOCAL_Error_Size, 3, ENV, CP)) {
Yap_Error(RESOURCE_ERROR_STACK, TermNil, LOCAL_ErrorMessage);
return FALSE;
}
}
LOCAL_Error_Size = 0;
twork = Deref(ARG2);
t3 = Deref(ARG3);
}
if (!Yap_unify(twork, TermDB)) {
cut_fail();
}
} else if (IsAtomOrIntTerm(twork)) {
EXTRA_CBACK_ARG(3, 2) = MkIntegerTerm(0);
EXTRA_CBACK_ARG(3, 3) = MkIntegerTerm((Int)twork);
B->cp_h = HR;
READ_LOCK(AtProp->DBRWLock);
do {
if (((twork == ref->DBT.Entry) || IsVarTerm(ref->DBT.Entry)) &&
!DEAD_REF(ref))
break;
ref = NextDBRef(ref);
if (ref == NIL) {
READ_UNLOCK(AtProp->DBRWLock);
cut_fail();
}
} while (TRUE);
READ_UNLOCK(AtProp->DBRWLock);
} else {
CELL key;
CELL mask = EvalMasks(twork, &key);
B->cp_h = HR;
READ_LOCK(AtProp->DBRWLock);
do {
while ((mask & ref->Key) != (key & ref->Mask) && !DEAD_REF(ref)) {
ref = NextDBRef(ref);
if (ref == NULL) {
READ_UNLOCK(AtProp->DBRWLock);
cut_fail();
}
}
if ((TermDB = GetDBTermFromDBEntry(ref PASS_REGS)) != (CELL)0) {
if (Yap_unify(TermDB, ARG2)) {
/* success */
EXTRA_CBACK_ARG(3, 2) = MkIntegerTerm(((Int)mask));
EXTRA_CBACK_ARG(3, 3) = MkIntegerTerm(((Int)key));
B->cp_h = HR;
break;
} else {
while ((ref = NextDBRef(ref)) != NULL && DEAD_REF(ref))
;
if (ref == NULL) {
READ_UNLOCK(AtProp->DBRWLock);
cut_fail();
}
}
} else {
/* make sure the garbage collector sees what we want it to see! */
EXTRA_CBACK_ARG(3, 1) = (CELL)ref;
READ_UNLOCK(AtProp->DBRWLock);
EXTRA_CBACK_ARG(3, 2) = MkIntegerTerm(((Int)mask));
EXTRA_CBACK_ARG(3, 3) = MkIntegerTerm(((Int)key));
/* oops, we are in trouble, not enough stack space */
if (LOCAL_Error_TYPE == RESOURCE_ERROR_ATTRIBUTED_VARIABLES) {
LOCAL_Error_TYPE = YAP_NO_ERROR;
if (!Yap_growglobal(NULL)) {
Yap_Error(RESOURCE_ERROR_ATTRIBUTED_VARIABLES, TermNil,
LOCAL_ErrorMessage);
return FALSE;
}
} else {
LOCAL_Error_TYPE = YAP_NO_ERROR;
if (!Yap_gcl(LOCAL_Error_Size, 3, ENV, CP)) {
Yap_Error(RESOURCE_ERROR_STACK, TermNil, LOCAL_ErrorMessage);
return FALSE;
}
}
READ_LOCK(AtProp->DBRWLock);
}
} while (TRUE);
READ_UNLOCK(AtProp->DBRWLock);
}
EXTRA_CBACK_ARG(3, 1) = (CELL)ref;
/* This should be after any non-tagged terms, because the routines in grow.c
go from upper to lower addresses */
TRef = MkDBRefTerm(ref);
#if MULTIPLE_STACKS
LOCK(ref->lock);
TRAIL_REF(ref); /* So that fail will erase it */
INC_DBREF_COUNT(ref);
UNLOCK(ref->lock);
#else
if (!(ref->Flags & InUseMask)) {
ref->Flags |= InUseMask;
TRAIL_REF(ref); /* So that fail will erase it */
}
#endif
return (Yap_unify(ARG3, TRef));
}
static Int c_recorded(int flags USES_REGS) {
Term TermDB, TRef;
Register DBRef ref, ref0;
CELL *PreviousHeap = HR;
CELL mask, key;
Term t1;
t1 = EXTRA_CBACK_ARG(3, 1);
ref0 = (DBRef)t1;
READ_LOCK(ref0->Parent->DBRWLock);
ref = NextDBRef(ref0);
if (ref == NIL) {
if (ref0->Flags & ErasedMask) {
ref = ref0;
while ((ref = ref->n) != NULL) {
if (!(ref->Flags & ErasedMask))
break;
}
/* we have used the DB entry, so we can remove it now, although
first we have to make sure noone is pointing to it */
if (ref == NULL) {
READ_UNLOCK(ref0->Parent->DBRWLock);
cut_fail();
}
} else {
READ_UNLOCK(ref0->Parent->DBRWLock);
cut_fail();
}
}
{
Term ttmp = EXTRA_CBACK_ARG(3, 2);
if (IsLongIntTerm(ttmp))
mask = (CELL)LongIntOfTerm(ttmp);
else
mask = (CELL)IntOfTerm(ttmp);
}
{
Term ttmp = EXTRA_CBACK_ARG(3, 3);
if (IsLongIntTerm(ttmp))
key = (CELL)LongIntOfTerm(ttmp);
else
key = (CELL)IntOfTerm(ttmp);
}
while (ref != NIL && DEAD_REF(ref))
ref = NextDBRef(ref);
if (ref == NIL) {
READ_UNLOCK(ref0->Parent->DBRWLock);
cut_fail();
}
if (mask == 0 && key == 0) { /* ARG2 is a variable */
while ((TermDB = GetDBTermFromDBEntry(ref PASS_REGS)) == (CELL)0) {
/* make sure the garbage collector sees what we want it to see! */
EXTRA_CBACK_ARG(3, 1) = (CELL)ref;
/* oops, we are in trouble, not enough stack space */
if (LOCAL_Error_TYPE == RESOURCE_ERROR_ATTRIBUTED_VARIABLES) {
LOCAL_Error_TYPE = YAP_NO_ERROR;
if (!Yap_growglobal(NULL)) {
Yap_Error(RESOURCE_ERROR_ATTRIBUTED_VARIABLES, TermNil,
LOCAL_ErrorMessage);
return FALSE;
}
} else {
LOCAL_Error_TYPE = YAP_NO_ERROR;
if (!Yap_gcl(LOCAL_Error_Size, 3, ENV, CP)) {
Yap_Error(RESOURCE_ERROR_STACK, TermNil, LOCAL_ErrorMessage);
return FALSE;
}
}
LOCAL_Error_Size = 0;
PreviousHeap = HR;
}
Yap_unify(ARG2, TermDB);
} else if (mask == 0) { /* ARG2 is a constant */
do {
if (((key == Unsigned(ref->DBT.Entry)) || (ref->Flags & DBVar)) &&
!DEAD_REF(ref))
break;
ref = NextDBRef(ref);
} while (ref != NIL);
if (ref == NIL) {
READ_UNLOCK(ref0->Parent->DBRWLock);
cut_fail();
}
} else
do { /* ARG2 is a structure */
HR = PreviousHeap;
while ((mask & ref->Key) != (key & ref->Mask)) {
while ((ref = NextDBRef(ref)) != NIL && DEAD_REF(ref))
;
if (ref == NIL) {
READ_UNLOCK(ref0->Parent->DBRWLock);
cut_fail();
}
}
while ((TermDB = GetDBTermFromDBEntry(ref PASS_REGS)) == (CELL)0) {
/* make sure the garbage collector sees what we want it to see! */
EXTRA_CBACK_ARG(3, 1) = (CELL)ref;
/* oops, we are in trouble, not enough stack space */
if (LOCAL_Error_TYPE == RESOURCE_ERROR_ATTRIBUTED_VARIABLES) {
LOCAL_Error_TYPE = YAP_NO_ERROR;
if (!Yap_growglobal(NULL)) {
Yap_Error(RESOURCE_ERROR_ATTRIBUTED_VARIABLES, TermNil,
LOCAL_ErrorMessage);
return FALSE;
}
} else {
LOCAL_Error_TYPE = YAP_NO_ERROR;
if (!Yap_gcl(LOCAL_Error_Size, 3, ENV, CP)) {
Yap_Error(RESOURCE_ERROR_STACK, TermNil, LOCAL_ErrorMessage);
return FALSE;
}
}
LOCAL_Error_Size = 0;
PreviousHeap = HR;
}
if (Yap_unify(ARG2, TermDB))
break;
while ((ref = NextDBRef(ref)) != NIL && DEAD_REF(ref))
;
if (ref == NIL) {
READ_UNLOCK(ref0->Parent->DBRWLock);
cut_fail();
}
} while (1);
READ_UNLOCK(ref0->Parent->DBRWLock);
TRef = MkDBRefTerm(ref);
EXTRA_CBACK_ARG(3, 1) = (CELL)ref;
#if MULTIPLE_STACKS
LOCK(ref->lock);
TRAIL_REF(ref); /* So that fail will erase it */
INC_DBREF_COUNT(ref);
UNLOCK(ref->lock);
#else
if (!(ref->Flags & InUseMask)) {
ref->Flags |= InUseMask;
TRAIL_REF(ref); /* So that fail will erase it */
}
#endif
return (Yap_unify(ARG3, TRef));
}
/*
* The arguments for this 4 functions are the flags for terms which should be
* skipped
*/
static Int lu_recorded(PredEntry *pe USES_REGS) {
op_numbers opc = Yap_op_from_opcode(P->opc);
#if defined(YAPOR) || defined(THREADS)
PELOCK(66, pe);
PP = pe;
#endif
if (opc == _procceed) {
P = pe->CodeOfPred;
} else {
if (P->opc != Yap_opcode(_execute_cpred)) {
CP = P;
ENV = YENV;
YENV = ASP;
YENV[E_CB] = (CELL)B;
}
P = pe->CodeOfPred;
#if defined(YAPOR) || defined(THREADS)
/* avoid holding a lock if we don't have anything in the database */
if (P == FAILCODE) {
UNLOCK(pe->PELock);
PP = NULL;
}
#endif
}
if (pe->PredFlags & ProfiledPredFlag) {
LOCK(pe->StatisticsForPred->lock);
pe->StatisticsForPred->NOfEntries++;
UNLOCK(pe->StatisticsForPred->lock);
}
return TRUE;
}
/* recorded(+Functor,+Term,-Ref) */
static Int in_rded_with_key(USES_REGS1) {
DBProp AtProp = (DBProp)IntegerOfTerm(Deref(ARG1));
return (i_recorded(AtProp, Deref(ARG3) PASS_REGS));
}
/* recorded(+Functor,+Term,-Ref) */
static Int p_recorded(USES_REGS1) {
DBProp AtProp;
Register Term twork = Deref(ARG1); /* initially working with
* ARG1 */
Term t3 = Deref(ARG3);
PredEntry *pe;
if (!IsVarTerm(t3)) {
DBRef ref = DBRefOfTerm(t3);
if (!IsDBRefTerm(t3)) {
return FALSE;
} else {
ref = DBRefOfTerm(t3);
}
ref = DBRefOfTerm(t3);
if (ref == NULL)
return FALSE;
if (DEAD_REF(ref)) {
return FALSE;
}
if (ref->Flags & LogUpdMask) {
LogUpdClause *cl = (LogUpdClause *)ref;
PredEntry *ap = cl->ClPred;
op_numbers opc = Yap_op_from_opcode(P->opc);
if (!Yap_unify(GetDBLUKey(ap), ARG1))
return FALSE;
if (opc == _procceed) {
P = cl->ClCode;
} else {
CP = P;
#if defined(YAPOR) || defined(THREADS)
PP = cl->ClPred;
#endif
P = cl->ClCode;
ENV = YENV;
YENV = ASP;
YENV[E_CB] = (CELL)B;
}
return TRUE;
} else {
Term TermDB;
while ((TermDB = GetDBTermFromDBEntry(ref PASS_REGS)) == (CELL)0) {
/* oops, we are in trouble, not enough stack space */
if (LOCAL_Error_TYPE == RESOURCE_ERROR_ATTRIBUTED_VARIABLES) {
LOCAL_Error_TYPE = YAP_NO_ERROR;
if (!Yap_growglobal(NULL)) {
Yap_Error(RESOURCE_ERROR_ATTRIBUTED_VARIABLES, TermNil,
LOCAL_ErrorMessage);
return FALSE;
}
} else {
LOCAL_Error_TYPE = YAP_NO_ERROR;
if (!Yap_gcl(LOCAL_Error_Size, 3, ENV, gc_P(P, CP))) {
Yap_Error(RESOURCE_ERROR_STACK, TermNil, LOCAL_ErrorMessage);
return FALSE;
}
}
}
if (!Yap_unify(ARG2, TermDB) || !UnifyDBKey(ref, 0, ARG1)) {
return FALSE;
} else {
return TRUE;
}
}
}
if ((pe = find_lu_entry(twork)) != NULL) {
return lu_recorded(pe PASS_REGS);
}
if (EndOfPAEntr(AtProp = FetchDBPropFromKey(twork, 0, FALSE, "recorded/3"))) {
return FALSE;
}
ARG1 = MkIntegerTerm((Int)AtProp);
P = PredRecordedWithKey->CodeOfPred;
return (i_recorded(AtProp, t3 PASS_REGS));
}
static Int co_rded(USES_REGS1) { return (c_recorded(0 PASS_REGS)); }
/* '$recordedp'(+Functor,+Term,-Ref) */
static Int in_rdedp(USES_REGS1) {
DBProp AtProp;
register choiceptr b0 = B;
Register Term twork = Deref(ARG1); /* initially working with
* ARG1 */
Term t3 = Deref(ARG3);
if (!IsVarTerm(t3)) {
if (!IsDBRefTerm(t3)) {
cut_fail();
} else {
DBRef ref = DBRefOfTerm(t3);
LOCK(ref->lock);
if (ref == NULL || DEAD_REF(ref) ||
!Yap_unify(ARG2, GetDBTermFromDBEntry(ref PASS_REGS)) ||
!UnifyDBKey(ref, CodeDBBit, ARG1)) {
UNLOCK(ref->lock);
cut_fail();
} else {
UNLOCK(ref->lock);
cut_succeed();
}
}
}
if (EndOfPAEntr(AtProp =
FetchDBPropFromKey(twork, MkCode, FALSE, "recorded/3"))) {
if (b0 == B)
cut_fail();
else
return FALSE;
}
return (i_recorded(AtProp, t3 PASS_REGS));
}
static Int co_rdedp(USES_REGS1) { return (c_recorded(MkCode PASS_REGS)); }
/* '$some_recordedp'(Functor) */
static Int p_somercdedp(USES_REGS1) {
Register DBRef ref;
DBProp AtProp;
Register Term twork = Deref(ARG1); /* initially working with
* ARG1 */
if (EndOfPAEntr(AtProp = FetchDBPropFromKey(twork, MkCode, FALSE,
"some_recorded/3"))) {
return FALSE;
}
READ_LOCK(AtProp->DBRWLock);
ref = FrstDBRef(AtProp);
while (ref != NIL && (ref->Flags & (DBNoCode | ErasedMask)))
ref = NextDBRef(ref);
READ_UNLOCK(AtProp->DBRWLock);
if (ref == NIL)
return (FALSE);
else
return (TRUE);
}
/* Finds the first instance recorded under key ARG1 */
static Int p_first_instance(USES_REGS1) {
Term TRef;
Register DBRef ref;
DBProp AtProp;
Register Term twork = Deref(ARG1); /* initially working with
* ARG1 */
Term TermDB;
ARG3 = Deref(ARG3);
if (!IsVarTerm(ARG3)) {
cut_fail();
}
if (EndOfPAEntr(
AtProp = FetchDBPropFromKey(twork, 0, FALSE, "first_instance/3"))) {
return FALSE;
}
READ_LOCK(AtProp->DBRWLock);
ref = AtProp->First;
while (ref != NIL && (ref->Flags & (DBCode | ErasedMask)))
ref = NextDBRef(ref);
READ_UNLOCK(AtProp->DBRWLock);
if (ref == NIL) {
cut_fail();
}
TRef = MkDBRefTerm(ref);
/* we have a pointer to the term available */
LOCK(ref->lock);
#if MULTIPLE_STACKS
TRAIL_REF(ref); /* So that fail will erase it */
INC_DBREF_COUNT(ref);
#else
if (!(ref->Flags & InUseMask)) {
ref->Flags |= InUseMask;
TRAIL_REF(ref); /* So that fail will erase it */
}
#endif
UNLOCK(ref->lock);
while ((TermDB = GetDBTermFromDBEntry(ref PASS_REGS)) == (CELL)0) {
/* oops, we are in trouble, not enough stack space */
if (LOCAL_Error_TYPE == RESOURCE_ERROR_ATTRIBUTED_VARIABLES) {
LOCAL_Error_TYPE = YAP_NO_ERROR;
if (!Yap_growglobal(NULL)) {
Yap_Error(RESOURCE_ERROR_ATTRIBUTED_VARIABLES, TermNil,
LOCAL_ErrorMessage);
return FALSE;
}
} else {
LOCAL_Error_TYPE = YAP_NO_ERROR;
if (!Yap_gcl(LOCAL_Error_Size, 3, ENV, gc_P(P, CP))) {
Yap_Error(RESOURCE_ERROR_STACK, TermNil, LOCAL_ErrorMessage);
return FALSE;
}
}
}
if (IsVarTerm(TermDB)) {
Yap_unify(TermDB, ARG2);
} else {
return Yap_unify(ARG2, TermDB);
}
return Yap_unify(ARG3, TRef);
}
static UInt index_sz(LogUpdIndex *x) {
UInt sz = x->ClSize;
yamop *start = x->ClCode;
op_numbers op = Yap_op_from_opcode(start->opc);
/* add try-retry-trust children */
while (op == _jump_if_nonvar) {
start = NEXTOP(start, xll);
op = Yap_op_from_opcode(start->opc);
}
if (op == _enter_lu_pred) {
PredEntry *ap = x->ClPred;
OPCODE endop, op1;
UInt count = 0, dead = 0;
if (ap->PredFlags & CountPredFlag)
endop = Yap_opcode(_count_trust_logical);
else if (ap->PredFlags & ProfiledPredFlag)
endop = Yap_opcode(_profiled_trust_logical);
else
endop = Yap_opcode(_trust_logical);
start = start->y_u.Illss.l1;
if (start->y_u.Illss.s)
do {
sz += (UInt)NEXTOP((yamop *)NULL, OtaLl);
op1 = start->opc;
count++;
if (start->y_u.OtaLl.d->ClFlags & ErasedMask)
dead++;
start = start->y_u.OtaLl.n;
} while (op1 != endop);
}
x = x->ChildIndex;
while (x != NULL) {
sz += index_sz(x);
x = x->SiblingIndex;
}
return sz;
}
static Int lu_statistics(PredEntry *pe USES_REGS) {
UInt sz = sizeof(PredEntry), cls = 0, isz = 0;
/* count number of clauses and size */
LogUpdClause *x;
if (pe->cs.p_code.FirstClause == NULL) {
cls = 0;
sz = 0;
} else {
x = ClauseCodeToLogUpdClause(pe->cs.p_code.FirstClause);
while (x != NULL) {
cls++;
sz += x->ClSize;
x = x->ClNext;
}
}
isz = 0;
if (pe->PredFlags & IndexedPredFlag) {
/* expand clause blocks */
yamop *ep = ExpandClausesFirst;
while (ep) {
if (ep->y_u.sssllp.p == pe)
isz += (UInt)NEXTOP((yamop *)NULL, sssllp) +
ep->y_u.sssllp.s1 * sizeof(yamop *);
ep = ep->y_u.sssllp.snext;
}
isz += index_sz(ClauseCodeToLogUpdIndex(pe->cs.p_code.TrueCodeOfPred));
}
return Yap_unify(ARG2, MkIntegerTerm(cls)) &&
Yap_unify(ARG3, MkIntegerTerm(sz)) &&
Yap_unify(ARG4, MkIntegerTerm(isz));
}
/** @pred key_statistics(+ _K_,- _Entries_,- _Size_,- _IndexSize_)
Returns several statistics for a key _K_. Currently, it says how
many entries we have for that key, _Entries_, what is the
total size spent on entries, _Size_, and what is the amount of
space spent in indices.
*/
static Int p_key_statistics(USES_REGS1) {
Register DBProp p;
Register DBRef x;
UInt sz = 0, cls = 0;
Term twork = Deref(ARG1);
PredEntry *pe;
if ((pe = find_lu_entry(twork)) != NULL) {
return lu_statistics(pe PASS_REGS);
}
if (EndOfPAEntr(p = FetchDBPropFromKey(twork, 0, TRUE, "key_statistics/4"))) {
/* This is not a key property */
return FALSE;
}
/* count number of clauses and size */
x = p->First;
while (x != NULL) {
cls++;
sz += sizeof(DBStruct) + sizeof(CELL) * x->DBT.NOfCells;
if (x->Code) {
DynamicClause *cl = ClauseCodeToDynamicClause(x->Code);
sz += cl->ClSize;
}
x = NextDBRef(x);
}
return Yap_unify(ARG2, MkIntegerTerm(cls)) &&
Yap_unify(ARG3, MkIntegerTerm(sz)) && Yap_unify(ARG4, MkIntTerm(0));
}
static Int p_lu_statistics(USES_REGS1) {
Term t = Deref(ARG1);
Term mod = Deref(ARG5);
PredEntry *pe;
if (IsVarTerm(t)) {
return (FALSE);
} else if (IsAtomTerm(t)) {
Atom at = AtomOfTerm(t);
pe = RepPredProp(Yap_GetPredPropByAtom(at, mod));
} else if (IsIntegerTerm(t) && mod == IDB_MODULE) {
pe = find_lu_int_key(IntegerOfTerm(t));
} else if (IsApplTerm(t)) {
Functor fun = FunctorOfTerm(t);
pe = RepPredProp(Yap_GetPredPropByFunc(fun, mod));
} else
return FALSE;
if (pe == NIL)
return FALSE;
if (!(pe->PredFlags & LogUpdatePredFlag)) {
/* should use '$recordedp' in this case */
return FALSE;
}
return lu_statistics(pe PASS_REGS);
}
static Int p_total_erased(USES_REGS1) {
UInt sz = 0, cls = 0;
UInt isz = 0, icls = 0;
LogUpdClause *cl = DBErasedList;
LogUpdIndex *icl = DBErasedIList;
/* only for log upds */
while (cl) {
cls++;
sz += cl->ClSize;
cl = cl->ClNext;
}
while (icl) {
icls++;
isz += icl->ClSize;
icl = icl->SiblingIndex;
}
return Yap_unify(ARG1, MkIntegerTerm(cls)) &&
Yap_unify(ARG2, MkIntegerTerm(sz)) &&
Yap_unify(ARG3, MkIntegerTerm(icls)) &&
Yap_unify(ARG4, MkIntegerTerm(isz));
}
static Int lu_erased_statistics(PredEntry *pe USES_REGS) {
UInt sz = 0, cls = 0;
UInt isz = 0, icls = 0;
LogUpdClause *cl = DBErasedList;
LogUpdIndex *icl = DBErasedIList;
while (cl) {
if (cl->ClPred == pe) {
cls++;
sz += cl->ClSize;
}
cl = cl->ClNext;
}
while (icl) {
if (pe == icl->ClPred) {
icls++;
isz += icl->ClSize;
}
icl = icl->SiblingIndex;
}
return Yap_unify(ARG2, MkIntegerTerm(cls)) &&
Yap_unify(ARG3, MkIntegerTerm(sz)) &&
Yap_unify(ARG4, MkIntegerTerm(icls)) &&
Yap_unify(ARG5, MkIntegerTerm(isz));
}
static Int p_key_erased_statistics(USES_REGS1) {
Term twork = Deref(ARG1);
PredEntry *pe;
/* only for log upds */
if ((pe = find_lu_entry(twork)) == NULL)
return FALSE;
return lu_erased_statistics(pe PASS_REGS);
}
static Int p_heap_space_info(USES_REGS1) {
return Yap_unify(ARG1, MkIntegerTerm(HeapUsed)) &&
Yap_unify(ARG2, MkIntegerTerm(HeapMax - HeapUsed)) &&
Yap_unify(ARG3, MkIntegerTerm(Yap_expand_clauses_sz));
}
/*
* This is called when we are erasing a data base clause, because we may have
* pending references
*/
static void ErasePendingRefs(DBTerm *entryref USES_REGS) {
DBRef *cp;
DBRef ref;
cp = entryref->DBRefs;
if (entryref->DBRefs == NULL)
return;
while ((ref = *--cp) != NULL) {
if ((ref->Flags & DBClMask) && (--(ref->NOfRefsTo) == 0) &&
(ref->Flags & ErasedMask))
ErDBE(ref PASS_REGS);
}
}
inline static void RemoveDBEntry(DBRef entryref USES_REGS) {
ErasePendingRefs(&(entryref->DBT)PASS_REGS);
/* We may be backtracking back to a deleted entry. If we just remove
the space then the info on the entry may be corrupt. */
if ((B->cp_ap == RETRY_C_RECORDED_K_CODE ||
B->cp_ap == RETRY_C_RECORDEDP_CODE) &&
EXTRA_CBACK_ARG(3, 1) == (CELL)entryref) {
/* make it clear the entry has been released */
#if MULTIPLE_STACKS
DEC_DBREF_COUNT(entryref);
#else
entryref->Flags &= ~InUseMask;
#endif
DBErasedMarker->Next = NULL;
DBErasedMarker->Parent = entryref->Parent;
DBErasedMarker->n = entryref->n;
EXTRA_CBACK_ARG(3, 1) = (CELL)DBErasedMarker;
}
if (entryref->p != NULL)
entryref->p->n = entryref->n;
else
entryref->Parent->F0 = entryref->n;
if (entryref->n != NULL)
entryref->n->p = entryref->p;
else
entryref->Parent->L0 = entryref->p;
/* Yap_LUClauseSpace -= entryref->Size; */
FreeDBSpace((char *)entryref);
}
static yamop *find_next_clause(DBRef ref0 USES_REGS) {
Register DBRef ref;
yamop *newp;
/* fetch ref0 from the instruction we just started executing */
#ifdef DEBUG
if (!(ref0->Flags & ErasedMask)) {
Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil,
"find_next_clause (dead clause %x)", ref0);
return NULL;
}
#endif
/* search for an newer entry that is to the left and points to code */
ref = ref0;
while ((ref = ref->n) != NULL) {
if (!(ref->Flags & ErasedMask))
break;
}
/* no extra alternatives to try, let us leave gracefully */
if (ref == NULL) {
return NULL;
} else {
/* OK, we found a clause we can jump to, do a bit of hanky pancking with
the choice-point, so that it believes we are actually working from that
clause */
newp = ref->Code;
/* and next let's tell the world this clause is being used, just
like if we were executing a standard retry_and_mark */
#if MULTIPLE_STACKS
{
DynamicClause *cl = ClauseCodeToDynamicClause(newp);
LOCK(cl->ClLock);
TRAIL_CLREF(cl);
INC_CLREF_COUNT(cl);
UNLOCK(cl->ClLock);
}
#else
if (!(DynamicFlags(newp) & InUseMask)) {
DynamicFlags(newp) |= InUseMask;
TRAIL_CLREF(ClauseCodeToDynamicClause(newp));
}
#endif
return newp;
}
}
/* This procedure is called when a clause is officialy deleted. Its job
is to find out where the code can go next, if it can go anywhere */
static Int p_jump_to_next_dynamic_clause(USES_REGS1) {
DBRef ref =
(DBRef)(((yamop *)((CODEADDR)P - (CELL)NEXTOP((yamop *)NULL, Osbpp)))
->y_u.Osbpp.bmap);
yamop *newp = find_next_clause(ref PASS_REGS);
if (newp == NULL) {
cut_fail();
}
/* the next alternative to try must be obtained from this clause */
B->cp_ap = newp;
/* and next, enter the clause */
P = NEXTOP(newp, Otapl);
/* and return like if nothing had happened. */
return TRUE;
}
static void complete_lu_erase(LogUpdClause *clau) {
DBRef *cp;
if (clau->ClFlags & FactMask)
cp = NULL;
else
cp = clau->lusl.ClSource->DBRefs;
if (CL_IN_USE(clau)) {
return;
}
#ifndef THREADS
if (clau->ClNext)
clau->ClNext->ClPrev = clau->ClPrev;
if (clau->ClPrev) {
clau->ClPrev->ClNext = clau->ClNext;
} else {
DBErasedList = clau->ClNext;
}
#endif
if (cp != NULL) {
DBRef ref;
while ((ref = *--cp) != NIL) {
if (ref->Flags & LogUpdMask) {
LogUpdClause *cl = (LogUpdClause *)ref;
cl->ClRefCount--;
if (cl->ClFlags & ErasedMask && !(cl->ClFlags & InUseMask) &&
!(cl->ClRefCount)) {
EraseLogUpdCl(cl);
}
} else {
LOCK(ref->lock);
ref->NOfRefsTo--;
if (ref->Flags & ErasedMask && !(ref->Flags & InUseMask) &&
ref->NOfRefsTo) {
CACHE_REGS
UNLOCK(ref->lock);
ErDBE(ref PASS_REGS);
} else {
UNLOCK(ref->lock);
}
}
}
}
Yap_InformOfRemoval(clau);
Yap_LUClauseSpace -= clau->ClSize;
Yap_FreeCodeSpace((char *)clau);
}
static void EraseLogUpdCl(LogUpdClause *clau) {
PredEntry *ap;
ap = clau->ClPred;
/* no need to erase what has been erased */
if (!(clau->ClFlags & ErasedMask)) {
/* get ourselves out of the list */
if (clau->ClNext != NULL) {
clau->ClNext->ClPrev = clau->ClPrev;
}
if (clau->ClPrev != NULL) {
clau->ClPrev->ClNext = clau->ClNext;
}
if (ap) {
if (clau->ClCode == ap->cs.p_code.FirstClause) {
if (clau->ClNext == NULL) {
ap->cs.p_code.FirstClause = NULL;
} else {
ap->cs.p_code.FirstClause = clau->ClNext->ClCode;
}
}
if (clau->ClCode == ap->cs.p_code.LastClause) {
if (clau->ClPrev == NULL) {
ap->cs.p_code.LastClause = NULL;
} else {
ap->cs.p_code.LastClause = clau->ClPrev->ClCode;
}
}
ap->cs.p_code.NOfClauses--;
}
clau->ClFlags |= ErasedMask;
#ifndef THREADS
{
LogUpdClause *er_head = DBErasedList;
if (er_head == NULL) {
clau->ClPrev = clau->ClNext = NULL;
} else {
clau->ClNext = er_head;
er_head->ClPrev = clau;
clau->ClPrev = NULL;
}
DBErasedList = clau;
}
#endif
/* we are holding a reference to the clause */
clau->ClRefCount++;
if (ap) {
/* mark it as erased */
if (ap->LastCallOfPred != LUCALL_RETRACT) {
if (ap->cs.p_code.NOfClauses > 1) {
if (ap->TimeStampOfPred >= TIMESTAMP_RESET)
Yap_UpdateTimestamps(ap);
++ap->TimeStampOfPred;
/* fprintf(stderr,"-
* %x--%d--%ul\n",ap,ap->TimeStampOfPred,ap->ArityOfPE);*/
ap->LastCallOfPred = LUCALL_RETRACT;
} else {
/* OK, there's noone left */
#ifndef THREADS
if (ap->cs.p_code.NOfClauses == 0) {
/* Other threads may hold refs to clauses */
ap->TimeStampOfPred = 0L;
}
#endif
/* fprintf(stderr,"-
* %x--%d--%ul\n",ap,ap->TimeStampOfPred,ap->ArityOfPE);*/
ap->LastCallOfPred = LUCALL_ASSERT;
}
}
clau->ClTimeEnd = ap->TimeStampOfPred;
Yap_RemoveClauseFromIndex(ap, clau->ClCode);
/* release the extra reference */
}
clau->ClRefCount--;
}
complete_lu_erase(clau);
}
static void MyEraseClause(DynamicClause *clau USES_REGS) {
DBRef ref;
if (CL_IN_USE(clau))
return;
/*
I don't need to lock the clause at this point because
I am the last one using it anyway.
*/
ref = (DBRef)NEXTOP(clau->ClCode, Otapl)->y_u.Osbpp.bmap;
/* don't do nothing if the reference is still in use */
if (DBREF_IN_USE(ref))
return;
if (P == clau->ClCode) {
yamop *np = RTRYCODE;
/* make it the next alternative */
np->y_u.Otapl.d =
find_next_clause((DBRef)(NEXTOP(P, Otapl)->y_u.Osbpp.bmap)PASS_REGS);
if (np->y_u.Otapl.d == NULL)
P = (yamop *)FAILCODE;
else {
/* with same arity as before */
np->y_u.Otapl.s = P->y_u.Otapl.s;
np->y_u.Otapl.p = P->y_u.Otapl.p;
/* go ahead and try this code */
P = np;
}
} else {
Yap_InformOfRemoval(clau);
Yap_LUClauseSpace -= clau->ClSize;
Yap_FreeCodeSpace((char *)clau);
#ifdef DEBUG
if (ref->NOfRefsTo)
fprintf(stderr, "Error: references to dynamic clause\n");
#endif
RemoveDBEntry(ref PASS_REGS);
}
}
/*
This predicate is supposed to be called with a
lock on the current predicate
*/
void Yap_ErLogUpdCl(LogUpdClause *clau) { EraseLogUpdCl(clau); }
/*
This predicate is supposed to be called with a
lock on the current predicate
*/
void Yap_ErCl(DynamicClause *clau) {
CACHE_REGS
MyEraseClause(clau PASS_REGS);
}
static void PrepareToEraseLogUpdClause(LogUpdClause *clau, DBRef dbr) {
yamop *code_p = clau->ClCode;
PredEntry *p = clau->ClPred;
yamop *cl = code_p;
if (clau->ClFlags & ErasedMask) {
return;
}
clau->ClFlags |= ErasedMask;
if (p->cs.p_code.FirstClause != cl) {
/* we are not the first clause... */
yamop *prev_code_p = (yamop *)(dbr->Prev->Code);
prev_code_p->y_u.Otapl.d = code_p->y_u.Otapl.d;
/* are we the last? */
if (p->cs.p_code.LastClause == cl)
p->cs.p_code.LastClause = prev_code_p;
} else {
/* we are the first clause, what about the last ? */
if (p->cs.p_code.LastClause == p->cs.p_code.FirstClause) {
p->cs.p_code.LastClause = p->cs.p_code.FirstClause = NULL;
} else {
p->cs.p_code.FirstClause = code_p->y_u.Otapl.d;
p->cs.p_code.FirstClause->opc = Yap_opcode(_try_me);
}
}
dbr->Code = NULL; /* unlink the two now */
if (p->PredFlags & IndexedPredFlag) {
p->cs.p_code.NOfClauses--;
Yap_RemoveIndexation(p);
} else {
EraseLogUpdCl(clau);
}
if (p->cs.p_code.FirstClause == p->cs.p_code.LastClause) {
if (p->cs.p_code.FirstClause != NULL) {
code_p = p->cs.p_code.FirstClause;
code_p->y_u.Otapl.d = p->cs.p_code.FirstClause;
p->cs.p_code.TrueCodeOfPred = NEXTOP(code_p, Otapl);
if (p->PredFlags & (SpiedPredFlag | CountPredFlag | ProfiledPredFlag)) {
p->OpcodeOfPred = Yap_opcode(_spy_pred);
p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
#if defined(YAPOR) || defined(THREADS)
} else if (p->ModuleOfPred != IDB_MODULE &&
!(p->PredFlags & ThreadLocalPredFlag)) {
p->OpcodeOfPred = LOCKPRED_OPCODE;
p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
#endif
} else {
p->CodeOfPred = p->cs.p_code.TrueCodeOfPred;
p->OpcodeOfPred = p->cs.p_code.TrueCodeOfPred->opc;
}
#if defined(YAPOR) || defined(THREADS)
} else if (p->ModuleOfPred != IDB_MODULE &&
!(p->PredFlags & ThreadLocalPredFlag)) {
p->OpcodeOfPred = LOCKPRED_OPCODE;
p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
#endif
} else {
p->OpcodeOfPred = FAIL_OPCODE;
p->cs.p_code.TrueCodeOfPred = p->CodeOfPred =
(yamop *)(&(p->OpcodeOfPred));
}
} else {
if (p->PredFlags & (SpiedPredFlag | CountPredFlag | ProfiledPredFlag)) {
p->OpcodeOfPred = Yap_opcode(_spy_pred);
p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
#if defined(YAPOR) || defined(THREADS)
} else if (p->ModuleOfPred != IDB_MODULE &&
!(p->PredFlags & ThreadLocalPredFlag)) {
p->OpcodeOfPred = LOCKPRED_OPCODE;
p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
#endif
} else {
p->OpcodeOfPred = INDEX_OPCODE;
p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
}
}
}
static void PrepareToEraseClause(DynamicClause *clau, DBRef dbr) {}
static void ErDBE(DBRef entryref USES_REGS) {
if ((entryref->Flags & DBCode) && entryref->Code) {
if (entryref->Flags & LogUpdMask) {
LogUpdClause *clau = ClauseCodeToLogUpdClause(entryref->Code);
if (CL_IN_USE(clau) || entryref->NOfRefsTo != 0) {
PrepareToEraseLogUpdClause(clau, entryref);
} else {
if (!(clau->ClFlags & ErasedMask))
PrepareToEraseLogUpdClause(clau, entryref);
/* the clause must have left the chain */
EraseLogUpdCl(clau);
}
} else {
DynamicClause *clau = ClauseCodeToDynamicClause(entryref->Code);
if (CL_IN_USE(clau) || entryref->NOfRefsTo != 0) {
PrepareToEraseClause(clau, entryref);
} else {
if (!(clau->ClFlags & ErasedMask))
PrepareToEraseClause(clau, entryref);
/* the clause must have left the chain */
MyEraseClause(clau PASS_REGS);
}
}
} else if (!(DBREF_IN_USE(entryref))) {
if (entryref->NOfRefsTo == 0)
RemoveDBEntry(entryref PASS_REGS);
else if (!(entryref->Flags & ErasedMask)) {
/* oops, I cannot remove it, but I at least have to tell
the world what's going on */
entryref->Flags |= ErasedMask;
entryref->Next = entryref->Prev = NIL;
}
}
}
void Yap_ErDBE(DBRef entryref) {
CACHE_REGS
ErDBE(entryref PASS_REGS);
}
static void EraseEntry(DBRef entryref) {
DBProp p;
if (entryref->Flags & ErasedMask)
return;
if (entryref->Flags & LogUpdMask && !(entryref->Flags & DBClMask)) {
LogUpdClause *luclause = (LogUpdClause *)entryref;
PELOCK(67, luclause->ClPred);
EraseLogUpdCl(luclause);
UNLOCK(luclause->ClPred->PELock);
return;
}
entryref->Flags |= ErasedMask;
/* update FirstNEr */
p = entryref->Parent;
/* exit the db chain */
if (entryref->Next != NIL) {
entryref->Next->Prev = entryref->Prev;
} else {
p->Last = entryref->Prev;
}
if (entryref->Prev != NIL)
entryref->Prev->Next = entryref->Next;
else
p->First = entryref->Next;
/* make sure we know the entry has been removed from the list */
entryref->Next = NIL;
if (!DBREF_IN_USE(entryref)) {
CACHE_REGS
ErDBE(entryref PASS_REGS);
} else if ((entryref->Flags & DBCode) && entryref->Code) {
PrepareToEraseClause(ClauseCodeToDynamicClause(entryref->Code), entryref);
}
}
/* erase(+Ref) */
static Int p_erase(USES_REGS1) {
Term t1 = Deref(ARG1);
if (IsVarTerm(t1)) {
Yap_Error(INSTANTIATION_ERROR, t1, "erase");
return FALSE;
}
if (!IsDBRefTerm(t1)) {
Yap_Error(TYPE_ERROR_DBREF, t1, "erase");
return FALSE;
}
EraseEntry(DBRefOfTerm(t1));
return TRUE;
}
/* increase_reference_counter(+Ref) */
static Int p_increase_reference_counter(USES_REGS1) {
Term t1 = Deref(ARG1);
LogUpdClause *cl;
if (IsVarTerm(t1)) {
Yap_Error(INSTANTIATION_ERROR, t1, "increase_reference_counter/1");
return FALSE;
}
if (!IsDBRefTerm(t1)) {
Yap_Error(TYPE_ERROR_DBREF, t1, "increase_reference_counter");
return FALSE;
}
cl = (LogUpdClause *)DBRefOfTerm(t1);
PELOCK(67, cl->ClPred);
cl->ClRefCount++;
UNLOCK(cl->ClPred->PELock);
return TRUE;
}
/* increase_reference_counter(+Ref) */
static Int p_decrease_reference_counter(USES_REGS1) {
Term t1 = Deref(ARG1);
LogUpdClause *cl;
if (IsVarTerm(t1)) {
Yap_Error(INSTANTIATION_ERROR, t1, "increase_reference_counter/1");
return FALSE;
}
if (!IsDBRefTerm(t1)) {
Yap_Error(TYPE_ERROR_DBREF, t1, "increase_reference_counter");
return FALSE;
}
cl = (LogUpdClause *)DBRefOfTerm(t1);
PELOCK(67, cl->ClPred);
if (cl->ClRefCount) {
cl->ClRefCount--;
UNLOCK(cl->ClPred->PELock);
return TRUE;
}
UNLOCK(cl->ClPred->PELock);
return FALSE;
}
/* erase(+Ref) */
/** @pred erase(+ _R_)
The term referred to by _R_ is erased from the internal database. If
reference _R_ does not exist in the database, `erase` just fails.
*/
static Int p_current_reference_counter(USES_REGS1) {
Term t1 = Deref(ARG1);
LogUpdClause *cl;
if (IsVarTerm(t1)) {
Yap_Error(INSTANTIATION_ERROR, t1, "increase_reference_counter/1");
return FALSE;
}
if (!IsDBRefTerm(t1)) {
Yap_Error(TYPE_ERROR_DBREF, t1, "increase_reference_counter");
return FALSE;
}
cl = (LogUpdClause *)DBRefOfTerm(t1);
return Yap_unify(ARG2, MkIntegerTerm(cl->ClRefCount));
}
static Int p_erase_clause(USES_REGS1) {
Term t1 = Deref(ARG1);
DBRef entryref;
if (IsVarTerm(t1)) {
Yap_Error(INSTANTIATION_ERROR, t1, "erase");
return FALSE;
}
if (!IsDBRefTerm(t1)) {
if (IsApplTerm(t1)) {
if (FunctorOfTerm(t1) == FunctorStaticClause) {
Yap_EraseStaticClause(Yap_ClauseFromTerm(t1),
(PredEntry *)IntegerOfTerm(ArgOfTerm(2, t1)),
Deref(ARG2));
return TRUE;
}
if (FunctorOfTerm(t1) == FunctorMegaClause) {
Yap_EraseMegaClause(Yap_MegaClauseFromTerm(t1),
Yap_MegaClausePredicateFromTerm(t1));
return TRUE;
}
if (FunctorOfTerm(t1) == FunctorExoClause) {
Yap_Error(TYPE_ERROR_DBREF, t1, "erase exo clause");
return FALSE;
}
}
Yap_Error(TYPE_ERROR_DBREF, t1, "erase");
return FALSE;
} else {
entryref = DBRefOfTerm(t1);
}
EraseEntry(entryref);
return TRUE;
}
/* eraseall(+Key) */
/** @pred eraseall(+ _K_)
All terms belonging to the key `K` are erased from the internal
database. The predicate always succeeds.
*/
static Int p_eraseall(USES_REGS1) {
Register Term twork = Deref(ARG1);
Register DBRef entryref;
DBProp p;
PredEntry *pe;
if ((pe = find_lu_entry(twork)) != NULL) {
LogUpdClause *cl;
if (!pe->cs.p_code.NOfClauses)
return TRUE;
if (pe->PredFlags & IndexedPredFlag)
Yap_RemoveIndexation(pe);
cl = ClauseCodeToLogUpdClause(pe->cs.p_code.FirstClause);
do {
LogUpdClause *ncl = cl->ClNext;
Yap_ErLogUpdCl(cl);
cl = ncl;
} while (cl != NULL);
return TRUE;
}
if (EndOfPAEntr(p = FetchDBPropFromKey(twork, 0, FALSE, "eraseall/3"))) {
return TRUE;
}
WRITE_LOCK(p->DBRWLock);
entryref = FrstDBRef(p);
do {
DBRef next_entryref;
while (entryref != NIL && (entryref->Flags & (DBCode | ErasedMask)))
entryref = NextDBRef(entryref);
if (entryref == NIL)
break;
next_entryref = NextDBRef(entryref);
/* exit the db chain */
if (entryref->Next != NIL) {
entryref->Next->Prev = entryref->Prev;
} else {
p->Last = entryref->Prev;
}
if (entryref->Prev != NIL)
entryref->Prev->Next = entryref->Next;
else
p->First = entryref->Next;
/* make sure we know the entry has been removed from the list */
entryref->Next = entryref->Prev = NIL;
if (!DBREF_IN_USE(entryref))
ErDBE(entryref PASS_REGS);
else {
entryref->Flags |= ErasedMask;
}
entryref = next_entryref;
} while (entryref != NIL);
WRITE_UNLOCK(p->DBRWLock);
return (TRUE);
}
/* erased(+Ref) */
/** @pred erased(+ _R_)
Succeeds if the object whose database reference is _R_ has been
erased.
*/
static Int p_erased(USES_REGS1) {
Term t = Deref(ARG1);
if (IsVarTerm(t)) {
Yap_Error(INSTANTIATION_ERROR, t, "erased");
return (FALSE);
}
if (!IsDBRefTerm(t)) {
Yap_Error(TYPE_ERROR_DBREF, t, "erased");
return (FALSE);
}
return (DBRefOfTerm(t)->Flags & ErasedMask);
}
static Int static_instance(StaticClause *cl, PredEntry *ap USES_REGS) {
if (cl->ClFlags & ErasedMask) {
return FALSE;
}
if (cl->ClFlags & FactMask) {
if (ap->ArityOfPE == 0) {
return Yap_unify(ARG2, MkAtomTerm((Atom)ap->FunctorOfPred));
} else {
Functor f = ap->FunctorOfPred;
UInt arity = ArityOfFunctor(ap->FunctorOfPred), i;
Term t2 = Deref(ARG2);
CELL *ptr;
if (IsVarTerm(t2)) {
Yap_unify(ARG2, (t2 = Yap_MkNewApplTerm(f, arity)));
} else if (!IsApplTerm(t2) || FunctorOfTerm(t2) != f) {
return FALSE;
}
ptr = RepAppl(t2) + 1;
for (i = 0; i < arity; i++) {
XREGS[i + 1] = ptr[i];
}
CP = P;
YENV = ASP;
YENV[E_CB] = (CELL)B;
P = cl->ClCode;
return TRUE;
}
} else {
Term TermDB;
while ((TermDB = GetDBTerm(cl->usc.ClSource, TRUE PASS_REGS)) == 0L) {
/* oops, we are in trouble, not enough stack space */
if (LOCAL_Error_TYPE == RESOURCE_ERROR_ATTRIBUTED_VARIABLES) {
LOCAL_Error_TYPE = YAP_NO_ERROR;
if (!Yap_growglobal(NULL)) {
Yap_Error(RESOURCE_ERROR_ATTRIBUTED_VARIABLES, TermNil,
LOCAL_ErrorMessage);
return FALSE;
}
} else {
LOCAL_Error_TYPE = YAP_NO_ERROR;
if (!Yap_gcl(LOCAL_Error_Size, 2, ENV, gc_P(P, CP))) {
Yap_Error(RESOURCE_ERROR_STACK, TermNil, LOCAL_ErrorMessage);
return FALSE;
}
}
}
return Yap_unify(ARG2, TermDB);
}
}
static Int exo_instance(Int i, PredEntry *ap USES_REGS) {
if (ap->ArityOfPE == 0) {
return Yap_unify(ARG2, MkAtomTerm((Atom)ap->FunctorOfPred));
} else {
MegaClause *mcl = ClauseCodeToMegaClause(ap->cs.p_code.FirstClause);
Functor f = ap->FunctorOfPred;
UInt arity = ArityOfFunctor(ap->FunctorOfPred);
Term t2 = Deref(ARG2);
CELL *ptr = (CELL *)((ADDR)mcl->ClCode + 2 * sizeof(struct index_t *) +
i * (mcl->ClItemSize));
if (IsVarTerm(t2)) {
// fresh slate
t2 = Yap_MkApplTerm(f, arity, ptr);
Yap_unify(ARG2, t2);
} else if (!IsApplTerm(t2) || FunctorOfTerm(t2) != f) {
return FALSE;
}
for (i = 0; i < arity; i++) {
XREGS[i + 1] = ptr[i];
}
S = ptr;
CP = P;
YENV = ASP;
YENV[E_CB] = (CELL)B;
P = mcl->ClCode;
return TRUE;
}
}
static Int mega_instance(yamop *code, PredEntry *ap USES_REGS) {
if (ap->ArityOfPE == 0) {
return Yap_unify(ARG2, MkAtomTerm((Atom)ap->FunctorOfPred));
} else {
Functor f = ap->FunctorOfPred;
UInt arity = ArityOfFunctor(ap->FunctorOfPred), i;
Term t2 = Deref(ARG2);
CELL *ptr;
if (IsVarTerm(t2)) {
t2 = Yap_MkNewApplTerm(f, arity);
Yap_unify(ARG2, t2);
} else if (!IsApplTerm(t2) || FunctorOfTerm(t2) != f) {
return FALSE;
}
ptr = RepAppl(t2) + 1;
for (i = 0; i < arity; i++) {
XREGS[i + 1] = ptr[i];
}
CP = P;
YENV = ASP;
YENV[E_CB] = (CELL)B;
P = code;
return TRUE;
}
}
/* instance(+Ref,?Term) */
/** @pred instance(+ _R_,- _T_)
If _R_ refers to a clause or a recorded term, _T_ is unified
with its most general instance. If _R_ refers to an unit clause
_C_, then _T_ is unified with ` _C_ :- true`. When
_R_ is not a reference to an existing clause or to a recorded term,
this goal fails.
*/
static Int p_instance(USES_REGS1) {
Term t1 = Deref(ARG1);
DBRef dbr;
if (IsVarTerm(t1) || !IsDBRefTerm(t1)) {
if (IsApplTerm(t1)) {
if (FunctorOfTerm(t1) == FunctorStaticClause) {
return static_instance(Yap_ClauseFromTerm(t1),
(PredEntry *)IntegerOfTerm(ArgOfTerm(2, t1))
PASS_REGS);
}
if (FunctorOfTerm(t1) == FunctorMegaClause) {
return mega_instance(Yap_MegaClauseFromTerm(t1),
Yap_MegaClausePredicateFromTerm(t1) PASS_REGS);
}
if (FunctorOfTerm(t1) == FunctorExoClause) {
return exo_instance(Yap_ExoClauseFromTerm(t1),
Yap_ExoClausePredicateFromTerm(t1) PASS_REGS);
}
}
return FALSE;
} else {
dbr = DBRefOfTerm(t1);
}
if (dbr->Flags & LogUpdMask) {
op_numbers opc;
LogUpdClause *cl = (LogUpdClause *)dbr;
PredEntry *ap = cl->ClPred;
PELOCK(68, ap);
if (cl->ClFlags & ErasedMask) {
UNLOCK(ap->PELock);
return FALSE;
}
if (cl->ClFlags & FactMask) {
if (ap->ArityOfPE == 0) {
UNLOCK(ap->PELock);
return Yap_unify(ARG2, MkAtomTerm((Atom)ap->FunctorOfPred));
} else {
Functor f = ap->FunctorOfPred;
UInt arity = ArityOfFunctor(ap->FunctorOfPred), i;
Term t2 = Deref(ARG2);
CELL *ptr;
if (IsVarTerm(t2)) {
Yap_unify(ARG2, (t2 = Yap_MkNewApplTerm(f, arity)));
} else if (!IsApplTerm(t2) || FunctorOfTerm(t2) != f) {
UNLOCK(ap->PELock);
return FALSE;
}
ptr = RepAppl(t2) + 1;
for (i = 0; i < arity; i++) {
XREGS[i + 1] = ptr[i];
}
CP = P;
YENV = ASP;
YENV[E_CB] = (CELL)B;
P = cl->ClCode;
#if defined(YAPOR) || defined(THREADS)
if (ap->PredFlags & ThreadLocalPredFlag) {
UNLOCK(ap->PELock);
} else {
PP = ap;
}
#endif
return TRUE;
}
}
opc = Yap_op_from_opcode(cl->ClCode->opc);
if (opc == _unify_idb_term) {
UNLOCK(ap->PELock);
return Yap_unify(ARG2, cl->lusl.ClSource->Entry);
} else {
Term TermDB;
int in_cl = (opc != _copy_idb_term);
while ((TermDB = GetDBTerm(cl->lusl.ClSource, in_cl PASS_REGS)) == 0L) {
/* oops, we are in trouble, not enough stack space */
if (LOCAL_Error_TYPE == RESOURCE_ERROR_ATTRIBUTED_VARIABLES) {
LOCAL_Error_TYPE = YAP_NO_ERROR;
if (!Yap_growglobal(NULL)) {
Yap_Error(RESOURCE_ERROR_ATTRIBUTED_VARIABLES, TermNil,
LOCAL_ErrorMessage);
UNLOCK(ap->PELock);
return FALSE;
}
} else {
LOCAL_Error_TYPE = YAP_NO_ERROR;
if (!Yap_gcl(LOCAL_Error_Size, 2, ENV, gc_P(P, CP))) {
Yap_Error(RESOURCE_ERROR_STACK, TermNil, LOCAL_ErrorMessage);
UNLOCK(ap->PELock);
return FALSE;
}
}
}
UNLOCK(ap->PELock);
return Yap_unify(ARG2, TermDB);
}
} else {
Term TermDB;
while ((TermDB = GetDBTermFromDBEntry(dbr PASS_REGS)) == 0L) {
/* oops, we are in trouble, not enough stack space */
if (LOCAL_Error_TYPE == RESOURCE_ERROR_ATTRIBUTED_VARIABLES) {
LOCAL_Error_TYPE = YAP_NO_ERROR;
if (!Yap_growglobal(NULL)) {
Yap_Error(RESOURCE_ERROR_ATTRIBUTED_VARIABLES, TermNil,
LOCAL_ErrorMessage);
return FALSE;
}
} else {
LOCAL_Error_TYPE = YAP_NO_ERROR;
if (!Yap_gcl(LOCAL_Error_Size, 2, ENV, gc_P(P, CP))) {
Yap_Error(RESOURCE_ERROR_STACK, TermNil, LOCAL_ErrorMessage);
return FALSE;
}
}
t1 = Deref(ARG1);
}
return Yap_unify(ARG2, TermDB);
}
}
Term Yap_LUInstance(LogUpdClause *cl, UInt arity) {
CACHE_REGS
Term TermDB;
op_numbers opc = Yap_op_from_opcode(cl->ClCode->opc);
if (opc == _unify_idb_term) {
TermDB = cl->lusl.ClSource->Entry;
} else {
CACHE_REGS
int in_src;
in_src = (opc != _copy_idb_term);
while ((TermDB = GetDBTerm(cl->lusl.ClSource, in_src PASS_REGS)) == 0L) {
/* oops, we are in trouble, not enough stack space */
if (LOCAL_Error_TYPE == RESOURCE_ERROR_ATTRIBUTED_VARIABLES) {
LOCAL_Error_TYPE = YAP_NO_ERROR;
if (!Yap_growglobal(NULL)) {
Yap_Error(RESOURCE_ERROR_ATTRIBUTED_VARIABLES, TermNil,
LOCAL_ErrorMessage);
return 0L;
}
} else {
LOCAL_Error_TYPE = YAP_NO_ERROR;
if (!Yap_gcl(LOCAL_Error_Size, arity, ENV, gc_P(P, CP))) {
Yap_Error(RESOURCE_ERROR_STACK, TermNil, LOCAL_ErrorMessage);
return 0L;
}
}
}
}
#if MULTIPLE_STACKS
cl->ClRefCount++;
TRAIL_CLREF(cl); /* So that fail will erase it */
#else
if (!(cl->ClFlags & InUseMask)) {
cl->ClFlags |= InUseMask;
TRAIL_CLREF(cl);
}
#endif
return TermDB;
}
/* instance(+Ref,?Term) */
static Int p_instance_module(USES_REGS1) {
Term t1 = Deref(ARG1);
DBRef dbr;
if (IsVarTerm(t1)) {
return FALSE;
}
if (IsDBRefTerm(t1)) {
dbr = DBRefOfTerm(t1);
} else {
return FALSE;
}
if (dbr->Flags & LogUpdMask) {
LogUpdClause *cl = (LogUpdClause *)dbr;
if (cl->ClFlags & ErasedMask) {
return FALSE;
}
if (cl->ClPred->ModuleOfPred)
return Yap_unify(ARG2, cl->ClPred->ModuleOfPred);
else
return Yap_unify(ARG2, TermProlog);
} else {
return Yap_unify(ARG2, dbr->Parent->ModuleOfDB);
}
}
inline static int NotActiveDB(DBRef my_dbref) {
while (my_dbref && (my_dbref->Flags & (DBCode | ErasedMask)))
my_dbref = my_dbref->Next;
return (my_dbref == NIL);
}
inline static DBEntry *NextDBProp(PropEntry *pp) {
while (!EndOfPAEntr(pp) && (((pp->KindOfPE & ~0x1) != DBProperty) ||
NotActiveDB(((DBProp)pp)->First)))
pp = RepProp(pp->NextOfPE);
return ((DBEntry *)pp);
}
static Int init_current_key(USES_REGS1) { /* current_key(+Atom,?key) */
Int i = 0;
DBEntry *pp;
Atom a;
Term t1 = ARG1;
t1 = Deref(ARG1);
if (!IsVarTerm(t1)) {
if (IsAtomTerm(t1))
a = AtomOfTerm(t1);
else {
cut_fail();
}
} else {
/* ask for the first hash line */
while (TRUE) {
READ_LOCK(HashChain[i].AERWLock);
a = HashChain[i].Entry;
if (a != NIL) {
break;
}
READ_UNLOCK(HashChain[i].AERWLock);
i++;
}
READ_UNLOCK(HashChain[i].AERWLock);
}
READ_LOCK(RepAtom(a)->ARWLock);
pp = NextDBProp(RepProp(RepAtom(a)->PropsOfAE));
READ_UNLOCK(RepAtom(a)->ARWLock);
EXTRA_CBACK_ARG(2, 3) = MkAtomTerm(a);
EXTRA_CBACK_ARG(2, 2) = MkIntTerm(i);
EXTRA_CBACK_ARG(2, 1) = MkIntegerTerm((Int)pp);
return cont_current_key(PASS_REGS1);
}
static Int cont_current_key(USES_REGS1) {
unsigned int arity;
Functor functor;
Term term, AtT;
Atom a;
Int i = IntegerOfTerm(EXTRA_CBACK_ARG(2, 2));
Term first = Deref(ARG1);
DBEntry *pp = (DBEntry *)IntegerOfTerm(EXTRA_CBACK_ARG(2, 1));
if (IsIntTerm(term = EXTRA_CBACK_ARG(2, 3)))
return cont_current_key_integer(PASS_REGS1);
a = AtomOfTerm(term);
if (EndOfPAEntr(pp) && IsAtomTerm(first)) {
cut_fail();
}
while (EndOfPAEntr(pp)) {
UInt j;
if ((a = RepAtom(a)->NextOfAE) == NIL) {
i++;
while (i < AtomHashTableSize) {
/* protect current hash table line, notice that the current
LOCK/UNLOCK algorithm assumes new entries are added to
the *front* of the list, otherwise I should have locked
earlier.
*/
READ_LOCK(HashChain[i].AERWLock);
a = HashChain[i].Entry;
if (a != NIL) {
break;
}
/* move to next entry */
READ_UNLOCK(HashChain[i].AERWLock);
i++;
}
if (i == AtomHashTableSize) {
/* we have left the atom hash table */
/* we don't have a lock over the hash table any longer */
if (IsAtomTerm(first)) {
cut_fail();
}
j = 0;
if (INT_KEYS == NULL) {
cut_fail();
}
for (j = 0; j < INT_KEYS_SIZE; j++) {
if (INT_KEYS[j] != NIL) {
DBProp pptr = RepDBProp(INT_KEYS[j]);
EXTRA_CBACK_ARG(2, 1) = MkIntegerTerm((Int)(pptr->NextOfPE));
EXTRA_CBACK_ARG(2, 2) = MkIntegerTerm(j + 1);
EXTRA_CBACK_ARG(2, 3) = MkIntTerm(INT_KEYS_TIMESTAMP);
term = MkIntegerTerm((Int)(pptr->FunctorOfDB));
return Yap_unify(term, ARG1) && Yap_unify(term, ARG2);
}
}
if (j == INT_KEYS_SIZE) {
cut_fail();
}
return cont_current_key_integer(PASS_REGS1);
} else {
/* release our lock over the hash table */
READ_UNLOCK(HashChain[i].AERWLock);
EXTRA_CBACK_ARG(2, 2) = MkIntTerm(i);
}
}
READ_LOCK(RepAtom(a)->ARWLock);
if (!EndOfPAEntr(pp = NextDBProp(RepProp(RepAtom(a)->PropsOfAE))))
EXTRA_CBACK_ARG(2, 3) = (CELL)MkAtomTerm(a);
READ_UNLOCK(RepAtom(a)->ARWLock);
}
READ_LOCK(RepAtom(a)->ARWLock);
EXTRA_CBACK_ARG(2, 1) = MkIntegerTerm((Int)NextDBProp(RepProp(pp->NextOfPE)));
READ_UNLOCK(RepAtom(a)->ARWLock);
arity = (unsigned int)(pp->ArityOfDB);
if (arity == 0) {
term = AtT = MkAtomTerm(a);
} else {
unsigned int j;
CELL *p = HR;
for (j = 0; j < arity; j++) {
p[j] = MkVarTerm();
}
functor = Yap_MkFunctor(a, arity);
term = Yap_MkApplTerm(functor, arity, p);
AtT = MkAtomTerm(a);
}
return (Yap_unify_constant(ARG1, AtT) && Yap_unify(ARG2, term));
}
static Int cont_current_key_integer(USES_REGS1) {
Term term;
UInt i = IntOfTerm(EXTRA_CBACK_ARG(2, 2));
Prop pp = (Prop)IntegerOfTerm(EXTRA_CBACK_ARG(2, 1));
UInt tstamp = (UInt)IntOfTerm(EXTRA_CBACK_ARG(2, 3));
DBProp pptr;
if (tstamp != INT_KEYS_TIMESTAMP) {
cut_fail();
}
while (pp == NIL) {
for (; i < INT_KEYS_SIZE; i++) {
if (INT_KEYS[i] != NIL) {
EXTRA_CBACK_ARG(2, 2) = MkIntTerm(i + 1);
pp = INT_KEYS[i];
break;
}
}
if (i == INT_KEYS_SIZE) {
cut_fail();
}
}
pptr = RepDBProp(pp);
EXTRA_CBACK_ARG(2, 1) = MkIntegerTerm((Int)(pptr->NextOfPE));
term = MkIntegerTerm((Int)(pptr->FunctorOfDB));
return Yap_unify(term, ARG1) && Yap_unify(term, ARG2);
}
Term Yap_FetchTermFromDB(DBTerm *ref) {
CACHE_REGS
return GetDBTerm(ref, FALSE PASS_REGS);
}
Term Yap_FetchClauseTermFromDB(DBTerm *ref) {
CACHE_REGS
return GetDBTerm(ref, TRUE PASS_REGS);
}
Term Yap_PopTermFromDB(DBTerm *ref) {
CACHE_REGS
Term t = GetDBTerm(ref, FALSE PASS_REGS);
if (t != 0L)
ReleaseTermFromDB(ref PASS_REGS);
return t;
}
static DBTerm *StoreTermInDB(Term t, int nargs USES_REGS) {
DBTerm *x;
int needs_vars;
struct db_globs dbg;
LOCAL_s_dbg = &dbg;
LOCAL_Error_Size = 0;
while ((x = (DBTerm *)CreateDBStruct(t, (DBProp)NULL, InQueue, &needs_vars, 0,
&dbg)) == NULL) {
if (LOCAL_Error_TYPE == YAP_NO_ERROR) {
break;
} else if (nargs == -1) {
return NULL;
} else {
XREGS[nargs + 1] = t;
if (recover_from_record_error(nargs + 1)) {
t = Deref(XREGS[nargs + 1]);
} else {
return NULL;
}
}
}
return x;
}
DBTerm *Yap_StoreTermInDB(Term t, int nargs) {
CACHE_REGS
return StoreTermInDB(t, nargs PASS_REGS);
}
DBTerm *Yap_StoreTermInDBPlusExtraSpace(Term t, UInt extra_size, UInt *sz) {
CACHE_REGS
int needs_vars;
struct db_globs dbg;
DBTerm *o;
LOCAL_s_dbg = &dbg;
o = (DBTerm *)CreateDBStruct(t, (DBProp)NULL, InQueue, &needs_vars,
extra_size, &dbg);
*sz = dbg.sz;
return o;
}
void Yap_init_tqueue(db_queue *dbq) {
dbq->id = FunctorDBRef;
dbq->Flags = DBClMask;
dbq->FirstInQueue = dbq->LastInQueue = NULL;
INIT_RWLOCK(dbq->QRWLock);
}
void Yap_destroy_tqueue(db_queue *dbq USES_REGS) {
QueueEntry *cur_instance = dbq->FirstInQueue;
while (cur_instance) {
/* release space for cur_instance */
keepdbrefs(cur_instance->DBT PASS_REGS);
ErasePendingRefs(cur_instance->DBT PASS_REGS);
FreeDBSpace((char *)cur_instance->DBT);
FreeDBSpace((char *)cur_instance);
}
dbq->FirstInQueue = dbq->LastInQueue = NULL;
}
bool Yap_enqueue_tqueue(db_queue *father_key, Term t USES_REGS) {
QueueEntry *x;
while ((x = (QueueEntry *)AllocDBSpace(sizeof(QueueEntry))) == NULL) {
if (!Yap_growheap(FALSE, sizeof(QueueEntry), NULL)) {
Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "in findall");
return false;
}
}
/* Yap_LUClauseSpace += sizeof(QueueEntry); */
x->DBT = StoreTermInDB(Deref(t), 2 PASS_REGS);
if (x->DBT == NULL) {
return false;
}
x->next = NULL;
if (father_key->LastInQueue != NULL)
father_key->LastInQueue->next = x;
father_key->LastInQueue = x;
if (father_key->FirstInQueue == NULL) {
father_key->FirstInQueue = x;
}
return true;
}
bool Yap_dequeue_tqueue(db_queue *father_key, Term t, bool first,
bool release USES_REGS) {
Term TDB;
CELL *oldH = HR;
tr_fr_ptr oldTR = TR;
QueueEntry *cur_instance = father_key->FirstInQueue, *prev = NULL;
while (cur_instance) {
HR = oldH;
HB = LCL0;
while ((TDB = GetDBTerm(cur_instance->DBT, false PASS_REGS)) == 0L) {
if (LOCAL_Error_TYPE == RESOURCE_ERROR_ATTRIBUTED_VARIABLES) {
LOCAL_Error_TYPE = YAP_NO_ERROR;
if (!Yap_growglobal(NULL)) {
Yap_Error(RESOURCE_ERROR_ATTRIBUTED_VARIABLES, TermNil,
LOCAL_ErrorMessage);
return false;
}
} else {
LOCAL_Error_TYPE = YAP_NO_ERROR;
if (!Yap_gcl(LOCAL_Error_Size, 2, ENV, gc_P(P, CP))) {
Yap_Error(RESOURCE_ERROR_STACK, TermNil, LOCAL_ErrorMessage);
return false;
}
}
oldTR = TR;
oldH = HR;
}
if (Yap_unify(t, TDB)) {
if (release) {
if (cur_instance == father_key->FirstInQueue) {
father_key->FirstInQueue = cur_instance->next;
}
if (cur_instance == father_key->LastInQueue) {
father_key->LastInQueue = prev;
}
if (prev) {
prev->next = cur_instance->next;
}
/* release space for cur_instance */
keepdbrefs(cur_instance->DBT PASS_REGS);
ErasePendingRefs(cur_instance->DBT PASS_REGS);
FreeDBSpace((char *)cur_instance->DBT);
FreeDBSpace((char *)cur_instance);
} else {
// undo if you'rejust peeking
while (oldTR < TR) {
CELL d1 = TrailTerm(TR - 1);
TR--;
/* normal variable */
RESET_VARIABLE(d1);
}
}
return true;
} else {
// just getting the first
if (first)
return false;
// but keep on going, if we want to check everything.
prev = cur_instance;
cur_instance = cur_instance->next;
}
}
return false;
}
static Int p_init_queue(USES_REGS1) {
db_queue *dbq;
Term t;
while ((dbq = (db_queue *)AllocDBSpace(sizeof(db_queue))) == NULL) {
if (!Yap_growheap(FALSE, sizeof(db_queue), NULL)) {
Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "in findall");
return FALSE;
}
}
/* Yap_LUClauseSpace += sizeof(db_queue); */
Yap_init_tqueue(dbq);
t = MkIntegerTerm((Int)dbq);
return Yap_unify(ARG1, t);
}
static Int p_enqueue(USES_REGS1) {
Term Father = Deref(ARG1);
db_queue *father_key;
bool rc;
if (IsVarTerm(Father)) {
Yap_Error(INSTANTIATION_ERROR, Father, "enqueue");
return FALSE;
} else if (!IsIntegerTerm(Father)) {
Yap_Error(TYPE_ERROR_INTEGER, Father, "enqueue");
return FALSE;
} else
father_key = (db_queue *)IntegerOfTerm(Father);
WRITE_LOCK(father_key->QRWLock);
rc = Yap_enqueue_tqueue(father_key, Deref(ARG2) PASS_REGS);
WRITE_UNLOCK(father_key->QRWLock);
return rc;
}
static Int p_enqueue_unlocked(USES_REGS1) {
Term Father = Deref(ARG1);
db_queue *father_key;
if (IsVarTerm(Father)) {
Yap_Error(INSTANTIATION_ERROR, Father, "enqueue");
return FALSE;
} else if (!IsIntegerTerm(Father)) {
Yap_Error(TYPE_ERROR_INTEGER, Father, "enqueue");
return FALSE;
} else
father_key = (db_queue *)IntegerOfTerm(Father);
return Yap_enqueue_tqueue(father_key, Deref(ARG2) PASS_REGS);
}
/* when reading an entry in the data base we are making it accessible from
the outside. If the entry was removed, and this was the last pointer, the
target entry would be immediately removed, leading to dangling pointers.
We avoid this problem by making every entry accessible.
Note that this could not happen with recorded, because the original db
entry itself is still accessible from a trail entry, so we could not remove
the target entry,
*/
static void keepdbrefs(DBTerm *entryref USES_REGS) {
DBRef *cp;
DBRef ref;
cp = entryref->DBRefs;
if (cp == NULL) {
return;
}
while ((ref = *--cp) != NIL) {
if (!(ref->Flags & LogUpdMask)) {
LOCK(ref->lock);
if (!(ref->Flags & InUseMask)) {
ref->Flags |= InUseMask;
TRAIL_REF(ref); /* So that fail will erase it */
}
UNLOCK(ref->lock);
}
}
}
static Int p_dequeue(USES_REGS1) {
db_queue *father_key;
QueueEntry *cur_instance;
Term Father = Deref(ARG1);
Int rc;
if (IsVarTerm(Father)) {
Yap_Error(INSTANTIATION_ERROR, Father, "dequeue");
return FALSE;
} else if (!IsIntegerTerm(Father)) {
Yap_Error(TYPE_ERROR_INTEGER, Father, "dequeue");
return FALSE;
} else {
father_key = (db_queue *)IntegerOfTerm(Father);
WRITE_LOCK(father_key->QRWLock);
if ((cur_instance = father_key->FirstInQueue) == NULL) {
/* an empty queue automatically goes away */
WRITE_UNLOCK(father_key->QRWLock);
FreeDBSpace((char *)father_key);
return false;
}
rc = Yap_dequeue_tqueue(father_key, ARG2, true, true PASS_REGS);
WRITE_UNLOCK(father_key->QRWLock);
return rc;
}
}
static Int p_dequeue_unlocked(USES_REGS1) {
db_queue *father_key;
QueueEntry *cur_instance;
Term Father = Deref(ARG1);
if (IsVarTerm(Father)) {
Yap_Error(INSTANTIATION_ERROR, Father, "dequeue");
return FALSE;
} else if (!IsIntegerTerm(Father)) {
Yap_Error(TYPE_ERROR_INTEGER, Father, "dequeue");
return FALSE;
} else {
father_key = (db_queue *)IntegerOfTerm(Father);
if ((cur_instance = father_key->FirstInQueue) == NULL) {
/* an empty queue automatically goes away */
FreeDBSpace((char *)father_key);
return FALSE;
}
return Yap_dequeue_tqueue(father_key, ARG2, true, true PASS_REGS);
}
}
static Int p_peek_queue(USES_REGS1) {
db_queue *father_key;
QueueEntry *cur_instance;
Term Father = Deref(ARG1);
if (IsVarTerm(Father)) {
Yap_Error(INSTANTIATION_ERROR, Father, "dequeue");
return FALSE;
} else if (!IsIntegerTerm(Father)) {
Yap_Error(TYPE_ERROR_INTEGER, Father, "dequeue");
return FALSE;
} else {
father_key = (db_queue *)IntegerOfTerm(Father);
if ((cur_instance = father_key->FirstInQueue) == NULL) {
/* an empty queue automatically goes away */
FreeDBSpace((char *)father_key);
return FALSE;
}
if (!Yap_dequeue_tqueue(father_key, ARG2, true, false PASS_REGS))
return FALSE;
if (cur_instance == father_key->LastInQueue)
father_key->FirstInQueue = father_key->LastInQueue = NULL;
else
father_key->FirstInQueue = cur_instance->next;
return TRUE;
}
}
static Int p_clean_queues(USES_REGS1) { return TRUE; }
/* set the logical updates flag */
static Int p_slu(USES_REGS1) {
Term t = Deref(ARG1);
if (IsVarTerm(t)) {
Yap_Error(INSTANTIATION_ERROR, t, "switch_logical_updates/1");
return FALSE;
}
if (!IsIntTerm(t)) {
Yap_Error(TYPE_ERROR_INTEGER, t, "switch_logical_updates/1");
return FALSE;
}
UPDATE_MODE = IntOfTerm(t);
return TRUE;
}
/* get a hold over the index table for logical update predicates */
static Int p_hold_index(USES_REGS1) {
Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "hold_index in debugger");
return FALSE;
}
static Int p_fetch_reference_from_index(USES_REGS1) {
Term t1 = Deref(ARG1), t2 = Deref(ARG2);
DBRef table, el;
Int pos;
if (IsVarTerm(t1) || !IsDBRefTerm(t1))
return FALSE;
table = DBRefOfTerm(t1);
if (IsVarTerm(t2) || !IsIntTerm(t2))
return FALSE;
pos = IntOfTerm(t2);
el = (DBRef)(table->DBT.Contents[pos]);
LOCK(el->lock);
#if MULTIPLE_STACKS
TRAIL_REF(el); /* So that fail will erase it */
INC_DBREF_COUNT(el);
#else
if (!(el->Flags & InUseMask)) {
el->Flags |= InUseMask;
TRAIL_REF(el);
}
#endif
UNLOCK(el->lock);
return Yap_unify(ARG3, MkDBRefTerm(el));
}
static Int p_resize_int_keys(USES_REGS1) {
Term t1 = Deref(ARG1);
if (IsVarTerm(t1)) {
return Yap_unify(ARG1, MkIntegerTerm((Int)INT_KEYS_SIZE));
}
if (!IsIntegerTerm(t1)) {
Yap_Error(TYPE_ERROR_INTEGER, t1, "yap_flag(resize_db_int_keys,T)");
return FALSE;
}
return resize_int_keys(IntegerOfTerm(t1));
}
static void ReleaseTermFromDB(DBTerm *ref USES_REGS) {
if (!ref)
return;
keepdbrefs(ref PASS_REGS);
ErasePendingRefs(ref PASS_REGS);
FreeDBSpace((char *)ref);
}
void Yap_ReleaseTermFromDB(DBTerm *ref) {
CACHE_REGS
ReleaseTermFromDB(ref PASS_REGS);
}
static Int p_install_thread_local(USES_REGS1) { /* '$is_dynamic'(+P) */
PredEntry *pe;
Term t = Deref(ARG1);
Term mod = Deref(ARG2);
if (IsVarTerm(t)) {
return (FALSE);
}
if (mod == IDB_MODULE) {
pe = find_lu_entry(t);
if (!pe->cs.p_code.NOfClauses) {
if (IsIntegerTerm(t))
pe->PredFlags |= LogUpdatePredFlag | NumberDBPredFlag;
else if (IsAtomTerm(t))
pe->PredFlags |= LogUpdatePredFlag | AtomDBPredFlag;
else
pe->PredFlags |= LogUpdatePredFlag;
}
} else if (IsAtomTerm(t)) {
Atom at = AtomOfTerm(t);
pe = RepPredProp(PredPropByAtom(at, mod));
} else if (IsApplTerm(t)) {
Functor fun = FunctorOfTerm(t);
pe = RepPredProp(PredPropByFunc(fun, mod));
} else {
return FALSE;
}
PELOCK(69, pe);
if (pe->PredFlags & (ThreadLocalPredFlag | LogUpdatePredFlag)) {
// second declaration, just ignore
UNLOCK(pe->PELock);
return TRUE;
}
if (pe->PredFlags &
(UserCPredFlag | HiddenPredFlag | CArgsPredFlag | SyncPredFlag |
TestPredFlag | AsmPredFlag | StandardPredFlag | CPredFlag |
SafePredFlag | IndexedPredFlag | BinaryPredFlag) ||
pe->cs.p_code.NOfClauses) {
UNLOCK(pe->PELock);
return FALSE;
}
#if THREADS
pe->PredFlags |= ThreadLocalPredFlag | LogUpdatePredFlag;
pe->OpcodeOfPred = Yap_opcode(_thread_local);
pe->CodeOfPred = (yamop *)&pe->OpcodeOfPred;
#else
pe->PredFlags |= LogUpdatePredFlag;
#endif
UNLOCK(pe->PELock);
return TRUE;
}
void Yap_InitDBPreds(void) {
Yap_InitCPred("$set_pred_flags", 2, p_rcdz, SyncPredFlag);
/** @pred recorded(+ _K_, _T_, _R_)
Searches in the internal database under the key _K_, a term that
unifies with _T_ and whose reference matches _R_. This
built-in may be used in one of two ways:
+ _K_ may be given, in this case the built-in will return all
elements of the internal data-base that match the key.
+ _R_ may be given, if so returning the key and element that
match the reference.
*/
Yap_InitCPred("recorded", 3, p_recorded, SyncPredFlag);
Yap_InitCPred("recorda", 3, p_rcda, SyncPredFlag);
/** @pred recorda(+ _K_, _T_,- _R_)
Makes term _T_ the first record under key _K_ and unifies _R_
with its reference.
*/
Yap_InitCPred("recordz", 3, p_rcdz, SyncPredFlag);
Yap_InitCPred("$still_variant", 2, p_still_variant, SyncPredFlag);
Yap_InitCPred("recorda_at", 3, p_rcda_at, SyncPredFlag);
Yap_InitCPred("recordz_at", 3, p_rcdz_at, SyncPredFlag);
Yap_InitCPred("$recordap", 3, p_rcdap, SyncPredFlag);
Yap_InitCPred("$recordzp", 3, p_rcdzp, SyncPredFlag);
Yap_InitCPred("$recordap", 4, p_drcdap, SyncPredFlag);
Yap_InitCPred("$recordzp", 4, p_drcdzp, SyncPredFlag);
Yap_InitCPred("erase", 1, p_erase, SafePredFlag | SyncPredFlag);
Yap_InitCPred("$erase_clause", 2, p_erase_clause,
SafePredFlag | SyncPredFlag);
Yap_InitCPred("increase_reference_count", 1, p_increase_reference_counter,
SafePredFlag | SyncPredFlag);
Yap_InitCPred("decrease_reference_count", 1, p_decrease_reference_counter,
SafePredFlag | SyncPredFlag);
Yap_InitCPred("current_reference_count", 2, p_current_reference_counter,
SafePredFlag | SyncPredFlag);
Yap_InitCPred("erased", 1, p_erased,
TestPredFlag | SafePredFlag | SyncPredFlag);
Yap_InitCPred("instance", 2, p_instance, SyncPredFlag);
Yap_InitCPred("$instance_module", 2, p_instance_module, SyncPredFlag);
Yap_InitCPred("eraseall", 1, p_eraseall, SafePredFlag | SyncPredFlag);
Yap_InitCPred("$record_stat_source", 4, p_rcdstatp,
SafePredFlag | SyncPredFlag);
Yap_InitCPred("$some_recordedp", 1, p_somercdedp,
SafePredFlag | SyncPredFlag);
Yap_InitCPred("$first_instance", 3, p_first_instance,
SafePredFlag | SyncPredFlag);
Yap_InitCPred("$init_db_queue", 1, p_init_queue, SafePredFlag | SyncPredFlag);
Yap_InitCPred("$db_key", 2, p_db_key, 0L);
Yap_InitCPred("$db_enqueue", 2, p_enqueue, SyncPredFlag);
Yap_InitCPred("$db_enqueue_unlocked", 2, p_enqueue_unlocked, SyncPredFlag);
Yap_InitCPred("$db_dequeue", 2, p_dequeue, SyncPredFlag);
Yap_InitCPred("$db_dequeue_unlocked", 2, p_dequeue_unlocked, SyncPredFlag);
Yap_InitCPred("$db_peek_queue", 2, p_peek_queue, SyncPredFlag);
Yap_InitCPred("$db_clean_queues", 1, p_clean_queues, SyncPredFlag);
Yap_InitCPred("$switch_log_upd", 1, p_slu, SafePredFlag | SyncPredFlag);
Yap_InitCPred("$hold_index", 3, p_hold_index, SafePredFlag | SyncPredFlag);
Yap_InitCPred("$fetch_reference_from_index", 3, p_fetch_reference_from_index,
SafePredFlag | SyncPredFlag);
Yap_InitCPred("$resize_int_keys", 1, p_resize_int_keys,
SafePredFlag | SyncPredFlag);
Yap_InitCPred("key_statistics", 4, p_key_statistics, SyncPredFlag);
Yap_InitCPred("$lu_statistics", 5, p_lu_statistics, SyncPredFlag);
Yap_InitCPred("total_erased", 4, p_total_erased, SyncPredFlag);
Yap_InitCPred("key_erased_statistics", 5, p_key_erased_statistics,
SyncPredFlag);
Yap_InitCPred("heap_space_info", 3, p_heap_space_info, SyncPredFlag);
Yap_InitCPred("$jump_to_next_dynamic_clause", 0,
p_jump_to_next_dynamic_clause, SyncPredFlag);
Yap_InitCPred("$install_thread_local", 2, p_install_thread_local,
SafePredFlag);
}
void Yap_InitBackDB(void) {
Yap_InitCPredBack("$recorded_with_key", 3, 3, in_rded_with_key, co_rded,
SyncPredFlag);
RETRY_C_RECORDED_K_CODE =
NEXTOP(PredRecordedWithKey->cs.p_code.FirstClause, OtapFs);
Yap_InitCPredBack("$recordedp", 3, 3, in_rdedp, co_rdedp, SyncPredFlag);
RETRY_C_RECORDEDP_CODE =
NEXTOP(RepPredProp(PredPropByFunc(Yap_MkFunctor(AtomRecordedP, 3), 0))
->cs.p_code.FirstClause,
OtapFs);
Yap_InitCPredBack("$current_immediate_key", 2, 4, init_current_key,
cont_current_key, SyncPredFlag);
}
/**
@}
*/
Reference in New Issue View Git Blame Copy Permalink