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.
675befae75
yap-6.3/C/adtdefs.c
Vítor Santos Costa c25d35356a Try to clarify operators 
prolog has priority and cannot be redefined by default.
user is global but may be redefined
others should just plug-in.
2016-02-26 17:18:37 +00:00

1390 lines
35 KiB
C
Executable File
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: adtdefs.c *
* Last rev: *
* mods: *
* comments: abstract machine definitions *
* *
*************************************************************************/
#ifdef SCCS
static char SccsId[] = "%W% %G%";
#endif
#define ADTDEFS_C
#ifdef __SUNPRO_CC
#define inline
#endif
#include "Yap.h"
#include "Yatom.h"
#include "yapio.h"
#include "clause.h"
#include <stdio.h>
#include <wchar.h>
#if HAVE_STRING_Hq
#include <string.h>
#endif
uint64_t HashFunction(const unsigned char *CHP) {
/* djb2 */
uint64_t hash = 5381;
uint64_t c;
while ((c = (uint64_t)(*CHP++)) != '\0') {
/* hash = ((hash << 5) + hash) + c; hash * 33 + c */
hash = hash * (uint64_t)33 + c;
}
return hash;
/*
UInt OUT=0, i = 1;
while(*CHP != '\0') { OUT += (UInt)(*CHP++); }
return OUT;
*/
}
uint64_t WideHashFunction(wchar_t *CHP) {
UInt hash = 5381;
UInt c;
while ((c = *CHP++) != '\0') {
hash = hash * 33 ^ c;
}
return hash;
}
/* this routine must be run at least having a read lock on ae */
static Prop
GetFunctorProp(AtomEntry *ae,
unsigned int arity) { /* look property list of atom a for kind */
FunctorEntry *pp;
pp = RepFunctorProp(ae->PropsOfAE);
while (!EndOfPAEntr(pp) &&
(!IsFunctorProperty(pp->KindOfPE) || pp->ArityOfFE != arity))
pp = RepFunctorProp(pp->NextOfPE);
return (AbsFunctorProp(pp));
}
/* vsc: We must guarantee that IsVarTerm(functor) returns true! */
static inline Functor InlinedUnlockedMkFunctor(AtomEntry *ae,
unsigned int arity) {
FunctorEntry *p;
Prop p0;
p0 = GetFunctorProp(ae, arity);
if (p0 != NIL) {
return ((Functor)RepProp(p0));
}
p = (FunctorEntry *)Yap_AllocAtomSpace(sizeof(*p));
if (!p)
return NULL;
p->KindOfPE = FunctorProperty;
p->NameOfFE = AbsAtom(ae);
p->ArityOfFE = arity;
p->PropsOfFE = NIL;
INIT_RWLOCK(p->FRWLock);
/* respect the first property, in case this is a wide atom */
AddPropToAtom(ae, (PropEntry *)p);
return ((Functor)p);
}
Functor Yap_UnlockedMkFunctor(AtomEntry *ae, unsigned int arity) {
return (InlinedUnlockedMkFunctor(ae, arity));
}
/* vsc: We must guarantee that IsVarTerm(functor) returns true! */
Functor Yap_MkFunctor(Atom ap, unsigned int arity) {
AtomEntry *ae = RepAtom(ap);
Functor f;
WRITE_LOCK(ae->ARWLock);
f = InlinedUnlockedMkFunctor(ae, arity);
WRITE_UNLOCK(ae->ARWLock);
return (f);
}
/* vsc: We must guarantee that IsVarTerm(functor) returns true! */
void Yap_MkFunctorWithAddress(Atom ap, unsigned int arity, FunctorEntry *p) {
AtomEntry *ae = RepAtom(ap);
WRITE_LOCK(ae->ARWLock);
p->KindOfPE = FunctorProperty;
p->NameOfFE = ap;
p->ArityOfFE = arity;
AddPropToAtom(ae, (PropEntry *)p);
WRITE_UNLOCK(ae->ARWLock);
}
inline static Atom SearchInInvisible(const unsigned char *atom) {
AtomEntry *chain;
READ_LOCK(INVISIBLECHAIN.AERWLock);
chain = RepAtom(INVISIBLECHAIN.Entry);
while (!EndOfPAEntr(chain) && strcmp((char *)chain->StrOfAE, (char *)atom)) {
chain = RepAtom(chain->NextOfAE);
}
READ_UNLOCK(INVISIBLECHAIN.AERWLock);
if (EndOfPAEntr(chain))
return (NIL);
else
return (AbsAtom(chain));
}
static inline Atom SearchAtom(const unsigned char *p, Atom a) {
AtomEntry *ae;
/* search atom in chain */
while (a != NIL) {
ae = RepAtom(a);
if (strcmp((char *)ae->StrOfAE, (const char *)p) == 0) {
return (a);
}
a = ae->NextOfAE;
}
return (NIL);
}
static inline Atom SearchWideAtom(const wchar_t *p, Atom a) {
AtomEntry *ae;
/* search atom in chain */
while (a != NIL) {
ae = RepAtom(a);
if (wcscmp((wchar_t *)ae->StrOfAE, p) == 0) {
return a;
}
a = ae->NextOfAE;
}
return (NIL);
}
static Atom
LookupAtom(const unsigned char *atom) { /* lookup atom in atom table */
uint64_t hash;
const unsigned char *p;
Atom a, na;
AtomEntry *ae;
size_t sz = AtomHashTableSize;
/* compute hash */
p = atom;
hash = HashFunction(p);
hash = hash % sz ;
/* we'll start by holding a read lock in order to avoid contention */
READ_LOCK(HashChain[hash].AERWLock);
a = HashChain[hash].Entry;
/* search atom in chain */
na = SearchAtom(atom, a);
if (na != NIL) {
READ_UNLOCK(HashChain[hash].AERWLock);
return (na);
}
READ_UNLOCK(HashChain[hash].AERWLock);
/* we need a write lock */
WRITE_LOCK(HashChain[hash].AERWLock);
/* concurrent version of Yap, need to take care */
#if defined(YAPOR) || defined(THREADS)
if (a != HashChain[hash].Entry) {
a = HashChain[hash].Entry;
na = SearchAtom(atom, a);
if (na != NIL) {
WRITE_UNLOCK(HashChain[hash].AERWLock);
return (na);
}
}
#endif
/* add new atom to start of chain */
ae = (AtomEntry *)Yap_AllocAtomSpace((sizeof *ae) +
strlen((const char *)atom) + 1);
if (ae == NULL) {
WRITE_UNLOCK(HashChain[hash].AERWLock);
return NIL;
}
NOfAtoms++;
na = AbsAtom(ae);
ae->PropsOfAE = NIL;
if (ae->UStrOfAE != atom)
strcpy((char *)ae->StrOfAE, (const char *)atom);
ae->NextOfAE = a;
HashChain[hash].Entry = na;
INIT_RWLOCK(ae->ARWLock);
WRITE_UNLOCK(HashChain[hash].AERWLock);
if (NOfAtoms > 2 * AtomHashTableSize) {
Yap_signal(YAP_CDOVF_SIGNAL);
}
return na;
}
static Atom
LookupWideAtom(const wchar_t *atom) { /* lookup atom in atom table */
CELL hash;
wchar_t *p;
Atom a, na;
AtomEntry *ae;
UInt sz;
WideAtomEntry *wae;
/* compute hash */
p = (wchar_t *)atom;
hash = WideHashFunction(p) % WideAtomHashTableSize;
/* we'll start by holding a read lock in order to avoid contention */
READ_LOCK(WideHashChain[hash].AERWLock);
a = WideHashChain[hash].Entry;
/* search atom in chain */
na = SearchWideAtom(atom, a);
if (na != NIL) {
READ_UNLOCK(WideHashChain[hash].AERWLock);
return (na);
}
READ_UNLOCK(WideHashChain[hash].AERWLock);
/* we need a write lock */
WRITE_LOCK(WideHashChain[hash].AERWLock);
/* concurrent version of Yap, need to take care */
#if defined(YAPOR) || defined(THREADS)
if (a != WideHashChain[hash].Entry) {
a = WideHashChain[hash].Entry;
na = SearchWideAtom(atom, a);
if (na != NIL) {
WRITE_UNLOCK(WideHashChain[hash].AERWLock);
return na;
}
}
#endif
/* add new atom to start of chain */
sz = wcslen(atom);
ae = (AtomEntry *)Yap_AllocAtomSpace((size_t)(((AtomEntry *)NULL) + 1) +
sizeof(wchar_t) * (sz + 1));
if (ae == NULL) {
WRITE_UNLOCK(WideHashChain[hash].AERWLock);
return NIL;
}
wae = (WideAtomEntry *)Yap_AllocAtomSpace(sizeof(WideAtomEntry));
if (wae == NULL) {
WRITE_UNLOCK(WideHashChain[hash].AERWLock);
return NIL;
}
na = AbsAtom(ae);
ae->PropsOfAE = AbsWideAtomProp(wae);
wae->NextOfPE = NIL;
wae->KindOfPE = WideAtomProperty;
wae->SizeOfAtom = sz;
if (ae->WStrOfAE != atom)
wcscpy(ae->WStrOfAE, atom);
NOfAtoms++;
ae->NextOfAE = a;
WideHashChain[hash].Entry = na;
INIT_RWLOCK(ae->ARWLock);
WRITE_UNLOCK(WideHashChain[hash].AERWLock);
if (NOfWideAtoms > 2 * WideAtomHashTableSize) {
Yap_signal(YAP_CDOVF_SIGNAL);
}
return na;
}
Atom Yap_LookupMaybeWideAtom(
const wchar_t *atom) { /* lookup atom in atom table */
wchar_t *p = (wchar_t *)atom, c;
size_t len = 0;
unsigned char *ptr, *ptr0;
Atom at;
while ((c = *p++)) {
if (c > 255)
return LookupWideAtom(atom);
len++;
}
/* not really a wide atom */
p = (wchar_t *)atom;
ptr0 = ptr = Yap_AllocCodeSpace(len + 1);
if (!ptr)
return NIL;
while ((*ptr++ = *p++))
;
at = LookupAtom(ptr0);
Yap_FreeCodeSpace(ptr0);
return at;
}
Atom Yap_LookupMaybeWideAtomWithLength(
const wchar_t *atom, size_t len0) { /* lookup atom in atom table */
Atom at;
int wide = FALSE;
size_t i = 0;
while (i < len0) {
// primary support for atoms with null chars
wchar_t c = atom[i];
if (c >= 255) {
wide = true;
break;
}
if (c == '\0') {
wide = true;
break;
}
i++;
}
if (wide) {
wchar_t *ptr0;
ptr0 = (wchar_t *)Yap_AllocCodeSpace(sizeof(wchar_t) * (len0 + 2));
if (!ptr0)
return NIL;
memcpy(ptr0, atom, (len0+1) * sizeof(wchar_t));
ptr0[len0] = '\0';
at = LookupWideAtom(ptr0);
Yap_FreeCodeSpace((char *)ptr0);
return at;
} else {
unsigned char *ptr0;
ptr0 = Yap_AllocCodeSpace((len0 + 2));
if (!ptr0)
return NIL;
for (i = 0; i < len0; i++)
ptr0[i] = atom[i];
ptr0[len0] = '\0';
at = LookupAtom(ptr0);
Yap_FreeCodeSpace(ptr0);
return at;
}
}
Atom Yap_LookupAtomWithLength(const char *atom,
size_t len0) { /* lookup atom in atom table */
Atom at;
unsigned char *ptr;
/* not really a wide atom */
ptr = Yap_AllocCodeSpace(len0 + 1);
if (!ptr)
return NIL;
memcpy(ptr, atom, len0);
ptr[len0] = '\0';
at = LookupAtom(ptr);
Yap_FreeCodeSpace(ptr);
return at;
}
Atom Yap_LookupAtom(const char *atom) { /* lookup atom in atom table */
return LookupAtom((const unsigned char *)atom);
}
Atom Yap_ULookupAtom(
const unsigned char *atom) { /* lookup atom in atom table */
return LookupAtom(atom);
}
Atom Yap_LookupWideAtom(const wchar_t *atom) { /* lookup atom in atom table */
return LookupWideAtom(atom);
}
Atom Yap_FullLookupAtom(const char *atom) { /* lookup atom in atom table */
Atom t;
if ((t = SearchInInvisible((const unsigned char *)atom)) != NIL) {
return (t);
}
return (LookupAtom((const unsigned char *)atom));
}
void Yap_LookupAtomWithAddress(const char *atom,
AtomEntry *ae) { /* lookup atom in atom table */
register CELL hash;
register const unsigned char *p;
Atom a;
/* compute hash */
p = (const unsigned char *)atom;
hash = HashFunction(p) % AtomHashTableSize;
/* ask for a WRITE lock because it is highly unlikely we shall find anything
*/
WRITE_LOCK(HashChain[hash].AERWLock);
a = HashChain[hash].Entry;
/* search atom in chain */
if (SearchAtom(p, a) != NIL) {
Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil,
"repeated initialization for atom %s", ae);
WRITE_UNLOCK(HashChain[hash].AERWLock);
return;
}
/* add new atom to start of chain */
NOfAtoms++;
ae->NextOfAE = a;
HashChain[hash].Entry = AbsAtom(ae);
ae->PropsOfAE = NIL;
strcpy((char *)ae->StrOfAE, (char *)atom);
INIT_RWLOCK(ae->ARWLock);
WRITE_UNLOCK(HashChain[hash].AERWLock);
}
void Yap_ReleaseAtom(Atom atom) { /* Releases an atom from the hash chain */
register Int hash;
register const unsigned char *p;
AtomEntry *inChain;
AtomEntry *ap = RepAtom(atom);
char unsigned *name = ap->UStrOfAE;
/* compute hash */
p = name;
hash = HashFunction(p) % AtomHashTableSize;
WRITE_LOCK(HashChain[hash].AERWLock);
if (HashChain[hash].Entry == atom) {
NOfAtoms--;
HashChain[hash].Entry = ap->NextOfAE;
WRITE_UNLOCK(HashChain[hash].AERWLock);
return;
}
/* else */
inChain = RepAtom(HashChain[hash].Entry);
while (inChain->NextOfAE != atom)
inChain = RepAtom(inChain->NextOfAE);
WRITE_LOCK(inChain->ARWLock);
inChain->NextOfAE = ap->NextOfAE;
WRITE_UNLOCK(inChain->ARWLock);
WRITE_UNLOCK(HashChain[hash].AERWLock);
}
static Prop
GetAPropHavingLock(AtomEntry *ae,
PropFlags kind) { /* look property list of atom a for kind */
PropEntry *pp;
pp = RepProp(ae->PropsOfAE);
while (!EndOfPAEntr(pp) && pp->KindOfPE != kind)
pp = RepProp(pp->NextOfPE);
return (AbsProp(pp));
}
Prop Yap_GetAPropHavingLock(
AtomEntry *ae, PropFlags kind) { /* look property list of atom a for kind */
return GetAPropHavingLock(ae, kind);
}
static Prop
GetAProp(Atom a, PropFlags kind) { /* look property list of atom a for kind */
AtomEntry *ae = RepAtom(a);
Prop out;
READ_LOCK(ae->ARWLock);
out = GetAPropHavingLock(ae, kind);
READ_UNLOCK(ae->ARWLock);
return (out);
}
Prop Yap_GetAProp(Atom a,
PropFlags kind) { /* look property list of atom a for kind */
return GetAProp(a, kind);
}
OpEntry *Yap_GetOpPropForAModuleHavingALock(
Atom a, Term mod) { /* look property list of atom a for kind */
AtomEntry *ae = RepAtom(a);
PropEntry *pp;
pp = RepProp(ae->PropsOfAE);
while (!EndOfPAEntr(pp) &&
(pp->KindOfPE != OpProperty || ((OpEntry *)pp)->OpModule != mod))
pp = RepProp(pp->NextOfPE);
if (EndOfPAEntr(pp)) {
return NULL;
}
return (OpEntry *)pp;
}
int Yap_HasOp(Atom a) { /* look property list of atom a for kind */
AtomEntry *ae = RepAtom(a);
PropEntry *pp;
READ_LOCK(ae->ARWLock);
pp = RepProp(ae->PropsOfAE);
while (!EndOfPAEntr(pp) && (pp->KindOfPE != OpProperty))
pp = RepProp(pp->NextOfPE);
READ_UNLOCK(ae->ARWLock);
if (EndOfPAEntr(pp)) {
return FALSE;
} else {
return TRUE;
}
}
OpEntry *
Yap_OpPropForModule(Atom a,
Term mod) { /* look property list of atom a for kind */
AtomEntry *ae = RepAtom(a);
PropEntry *pp;
OpEntry *info = NULL;
if (mod == TermProlog)
mod = PROLOG_MODULE;
WRITE_LOCK(ae->ARWLock);
pp = RepProp(ae->PropsOfAE);
while (!EndOfPAEntr(pp)) {
if (pp->KindOfPE == OpProperty) {
info = (OpEntry *)pp;
if (info->OpModule == mod) {
WRITE_LOCK(info->OpRWLock);
WRITE_UNLOCK(ae->ARWLock);
return info;
}
}
pp = pp->NextOfPE;
}
info = (OpEntry *)Yap_AllocAtomSpace(sizeof(OpEntry));
info->KindOfPE = Ord(OpProperty);
info->OpModule = mod;
info->OpName = a;
LOCK(OpListLock);
info->OpNext = OpList;
OpList = info;
UNLOCK(OpListLock);
AddPropToAtom(ae, (PropEntry *)info);
INIT_RWLOCK(info->OpRWLock);
WRITE_LOCK(info->OpRWLock);
WRITE_UNLOCK(ae->ARWLock);
info->Prefix = info->Infix = info->Posfix = 0;
return info;
}
static OpEntry *
fetchOpWithModule( PropEntry *pp, Term tmod, op_type type )
{
while (!EndOfPAEntr(pp)) {
OpEntry *info = NULL;
if (pp->KindOfPE != OpProperty) {
pp = RepProp(pp->NextOfPE);
continue;
}
info = (OpEntry *)pp;
if (info->OpModule != tmod) {
pp = RepProp(pp->NextOfPE);
continue;
}
if (type == INFIX_OP) {
if (!info->Infix) {
return NULL;
}
} else if (type == POSFIX_OP) {
if (!info->Posfix) {
return NULL;
}
} else {
if (!info->Prefix) {
return NULL;
}
}
return info;
}
return NULL;
}
OpEntry *
Yap_GetOpProp(Atom a,
op_type type,
Term tmod
USES_REGS) { /* look property list of atom a for kind */
AtomEntry *ae = RepAtom(a);
PropEntry *pp;
OpEntry *info;
READ_LOCK(ae->ARWLock);
pp = RepProp(ae->PropsOfAE);
if (( (info = fetchOpWithModule( pp, tmod, type )) != NULL) ||
( (info = fetchOpWithModule( pp, USER_MODULE, type )) != NULL) ||
( (info = fetchOpWithModule( pp, PROLOG_MODULE, type )) != NULL)
) {
LOCK(info->OpRWLock);
return info;
READ_UNLOCK(ae->ARWLock);
}
READ_UNLOCK(ae->ARWLock);
return NULL;
}
inline static Prop GetPredPropByAtomHavingLock(AtomEntry *ae, Term cur_mod)
/* get predicate entry for ap/arity; create it if neccessary. */
{
Prop p0;
p0 = ae->PropsOfAE;
while (p0) {
PredEntry *pe = RepPredProp(p0);
if (pe->KindOfPE == PEProp &&
(pe->ModuleOfPred == cur_mod || !pe->ModuleOfPred)) {
return (p0);
#if THREADS
/* Thread Local Predicates */
if (pe->PredFlags & ThreadLocalPredFlag) {
return AbsPredProp(Yap_GetThreadPred(pe INIT_REGS));
}
#endif
}
p0 = pe->NextOfPE;
}
return (NIL);
}
Prop Yap_GetPredPropByAtom(Atom at, Term cur_mod)
/* get predicate entry for ap/arity; create it if neccessary. */
{
Prop p0;
AtomEntry *ae = RepAtom(at);
READ_LOCK(ae->ARWLock);
p0 = GetPredPropByAtomHavingLock(ae, cur_mod);
READ_UNLOCK(ae->ARWLock);
return (p0);
}
inline static Prop GetPredPropByAtomHavingLockInThisModule(AtomEntry *ae,
Term cur_mod)
/* get predicate entry for ap/arity; create it if neccessary. */
{
Prop p0;
p0 = ae->PropsOfAE;
while (p0) {
PredEntry *pe = RepPredProp(p0);
if (pe->KindOfPE == PEProp && pe->ModuleOfPred == cur_mod) {
#if THREADS
/* Thread Local Predicates */
if (pe->PredFlags & ThreadLocalPredFlag) {
return AbsPredProp(Yap_GetThreadPred(pe INIT_REGS));
}
#endif
return (p0);
}
p0 = pe->NextOfPE;
}
return (NIL);
}
Prop Yap_GetPredPropByAtomInThisModule(Atom at, Term cur_mod)
/* get predicate entry for ap/arity; create it if neccessary. */
{
Prop p0;
AtomEntry *ae = RepAtom(at);
READ_LOCK(ae->ARWLock);
p0 = GetPredPropByAtomHavingLockInThisModule(ae, cur_mod);
READ_UNLOCK(ae->ARWLock);
return (p0);
}
Prop Yap_GetPredPropByFunc(Functor f, Term cur_mod)
/* get predicate entry for ap/arity; */
{
Prop p0;
FUNC_READ_LOCK(f);
p0 = GetPredPropByFuncHavingLock(f, cur_mod);
FUNC_READ_UNLOCK(f);
return (p0);
}
Prop Yap_GetPredPropByFuncInThisModule(Functor f, Term cur_mod)
/* get predicate entry for ap/arity; */
{
Prop p0;
FUNC_READ_LOCK(f);
p0 = GetPredPropByFuncHavingLock(f, cur_mod);
FUNC_READ_UNLOCK(f);
return (p0);
}
Prop Yap_GetPredPropHavingLock(Atom ap, unsigned int arity, Term mod)
/* get predicate entry for ap/arity; */
{
Prop p0;
AtomEntry *ae = RepAtom(ap);
Functor f;
if (arity == 0) {
GetPredPropByAtomHavingLock(ae, mod);
}
f = InlinedUnlockedMkFunctor(ae, arity);
FUNC_READ_LOCK(f);
p0 = GetPredPropByFuncHavingLock(f, mod);
FUNC_READ_UNLOCK(f);
return (p0);
}
/* get expression entry for at/arity; */
Prop Yap_GetExpProp(Atom at, unsigned int arity) {
Prop p0;
AtomEntry *ae = RepAtom(at);
ExpEntry *p;
READ_LOCK(ae->ARWLock);
p = RepExpProp(p0 = ae->PropsOfAE);
while (p0 && (p->KindOfPE != ExpProperty || p->ArityOfEE != arity))
p = RepExpProp(p0 = p->NextOfPE);
READ_UNLOCK(ae->ARWLock);
return (p0);
}
/* get expression entry for at/arity, at is already locked; */
Prop Yap_GetExpPropHavingLock(AtomEntry *ae, unsigned int arity) {
Prop p0;
ExpEntry *p;
p = RepExpProp(p0 = ae->PropsOfAE);
while (p0 && (p->KindOfPE != ExpProperty || p->ArityOfEE != arity))
p = RepExpProp(p0 = p->NextOfPE);
return (p0);
}
static int ExpandPredHash(void) {
UInt new_size = PredHashTableSize + PredHashIncrement;
PredEntry **oldp = PredHash;
PredEntry **np =
(PredEntry **)Yap_AllocAtomSpace(sizeof(PredEntry **) * new_size);
UInt i;
if (!np) {
return FALSE;
}
for (i = 0; i < new_size; i++) {
np[i] = NULL;
}
for (i = 0; i < PredHashTableSize; i++) {
PredEntry *p = PredHash[i];
while (p) {
PredEntry *nextp = p->NextPredOfHash;
UInt hsh = PRED_HASH(p->FunctorOfPred, p->ModuleOfPred, new_size);
p->NextPredOfHash = np[hsh];
np[hsh] = p;
p = nextp;
}
}
PredHashTableSize = new_size;
PredHash = np;
Yap_FreeAtomSpace((ADDR)oldp);
return TRUE;
}
/* fe is supposed to be locked */
Prop Yap_NewPredPropByFunctor(FunctorEntry *fe, Term cur_mod) {
PredEntry *p = (PredEntry *)Yap_AllocAtomSpace(sizeof(*p));
if (p == NULL) {
WRITE_UNLOCK(fe->FRWLock);
return NULL;
}
if (cur_mod == TermProlog || cur_mod == 0L) {
p->ModuleOfPred = 0L;
} else
p->ModuleOfPred = cur_mod;
// TRUE_FUNC_WRITE_LOCK(fe);
INIT_LOCK(p->PELock);
p->KindOfPE = PEProp;
p->ArityOfPE = fe->ArityOfFE;
p->cs.p_code.FirstClause = p->cs.p_code.LastClause = NULL;
p->cs.p_code.NOfClauses = 0;
p->PredFlags = 0L;
p->src.OwnerFile = Yap_source_file_name();
p->OpcodeOfPred = UNDEF_OPCODE;
p->CodeOfPred = p->cs.p_code.TrueCodeOfPred = (yamop *)(&(p->OpcodeOfPred));
p->cs.p_code.ExpandCode = EXPAND_OP_CODE;
p->TimeStampOfPred = 0L;
p->LastCallOfPred = LUCALL_ASSERT;
if (cur_mod == TermProlog)
p->ModuleOfPred = 0L;
else
p->ModuleOfPred = cur_mod;
Yap_NewModulePred(cur_mod, p);
#ifdef TABLING
p->TableOfPred = NULL;
#endif /* TABLING */
#ifdef BEAM
p->beamTable = NULL;
#endif /* BEAM */
/* careful that they don't cross MkFunctor */
if (!trueGlobalPrologFlag(DEBUG_INFO_FLAG)) {
p->PredFlags |= NoTracePredFlag;
}
p->FunctorOfPred = fe;
if (fe->PropsOfFE) {
UInt hsh = PRED_HASH(fe, cur_mod, PredHashTableSize);
WRITE_LOCK(PredHashRWLock);
if (10 * (PredsInHashTable + 1) > 6 * PredHashTableSize) {
if (!ExpandPredHash()) {
Yap_FreeCodeSpace((ADDR)p);
WRITE_UNLOCK(PredHashRWLock);
FUNC_WRITE_UNLOCK(fe);
return NULL;
}
/* retry hashing */
hsh = PRED_HASH(fe, cur_mod, PredHashTableSize);
}
PredsInHashTable++;
if (p->ModuleOfPred == 0L) {
PredEntry *pe = RepPredProp(fe->PropsOfFE);
hsh = PRED_HASH(fe, pe->ModuleOfPred, PredHashTableSize);
/* should be the first one */
pe->NextPredOfHash = PredHash[hsh];
PredHash[hsh] = pe;
fe->PropsOfFE = AbsPredProp(p);
p->NextOfPE = AbsPredProp(pe);
} else {
p->NextPredOfHash = PredHash[hsh];
PredHash[hsh] = p;
p->NextOfPE = fe->PropsOfFE->NextOfPE;
fe->PropsOfFE->NextOfPE = AbsPredProp(p);
}
WRITE_UNLOCK(PredHashRWLock);
} else {
fe->PropsOfFE = AbsPredProp(p);
p->NextOfPE = NIL;
}
FUNC_WRITE_UNLOCK(fe);
{
Yap_inform_profiler_of_clause(&(p->OpcodeOfPred), &(p->OpcodeOfPred) + 1, p,
GPROF_NEW_PRED_FUNC);
if (!(p->PredFlags & (CPredFlag | AsmPredFlag))) {
Yap_inform_profiler_of_clause(&(p->cs.p_code.ExpandCode),
&(p->cs.p_code.ExpandCode) + 1, p,
GPROF_NEW_PRED_FUNC);
}
}
return AbsPredProp(p);
}
#if THREADS
Prop Yap_NewThreadPred(PredEntry *ap USES_REGS) {
PredEntry *p = (PredEntry *)Yap_AllocAtomSpace(sizeof(*p));
if (p == NULL) {
return NIL;
}
INIT_LOCK(p->PELock);
p->KindOfPE = PEProp;
p->ArityOfPE = ap->ArityOfPE;
p->cs.p_code.FirstClause = p->cs.p_code.LastClause = NULL;
p->cs.p_code.NOfClauses = 0;
p->PredFlags = ap->PredFlags & ~(IndexedPredFlag | SpiedPredFlag);
#if SIZEOF_INT_P == 4
p->ExtraPredFlags = 0L;
#endif
p->src.OwnerFile = ap->src.OwnerFile;
p->OpcodeOfPred = FAIL_OPCODE;
p->CodeOfPred = p->cs.p_code.TrueCodeOfPred = (yamop *)(&(p->OpcodeOfPred));
p->cs.p_code.ExpandCode = EXPAND_OP_CODE;
p->ModuleOfPred = ap->ModuleOfPred;
p->NextPredOfModule = NULL;
p->TimeStampOfPred = 0L;
p->LastCallOfPred = LUCALL_ASSERT;
#ifdef TABLING
p->TableOfPred = NULL;
#endif /* TABLING */
#ifdef BEAM
p->beamTable = NULL;
#endif
/* careful that they don't cross MkFunctor */
p->NextOfPE = AbsPredProp(LOCAL_ThreadHandle.local_preds);
LOCAL_ThreadHandle.local_preds = p;
p->FunctorOfPred = ap->FunctorOfPred;
Yap_inform_profiler_of_clause(&(p->OpcodeOfPred), &(p->OpcodeOfPred) + 1, p,
GPROF_NEW_PRED_THREAD);
if (falseGlobalPrologFlag(DEBUG_INFO_FLAG)) {
p->PredFlags |= (NoSpyPredFlag | NoTracePredFlag);
}
if (!(p->PredFlags & (CPredFlag | AsmPredFlag))) {
Yap_inform_profiler_of_clause(&(p->cs.p_code.ExpandCode),
&(p->cs.p_code.ExpandCode) + 1, p,
GPROF_NEW_PRED_THREAD);
}
return AbsPredProp(p);
}
#endif
Prop Yap_NewPredPropByAtom(AtomEntry *ae, Term cur_mod) {
Prop p0;
PredEntry *p = (PredEntry *)Yap_AllocAtomSpace(sizeof(*p));
CACHE_REGS
/* Printf("entering %s:%s/0\n", RepAtom(AtomOfTerm(cur_mod))->StrOfAE,
* ae->StrOfAE); */
if (p == NULL) {
WRITE_UNLOCK(ae->ARWLock);
return NIL;
}
INIT_LOCK(p->PELock);
p->KindOfPE = PEProp;
p->ArityOfPE = 0;
p->cs.p_code.FirstClause = p->cs.p_code.LastClause = NULL;
p->cs.p_code.NOfClauses = 0;
p->PredFlags = 0L;
p->src.OwnerFile = Yap_source_file_name();
p->OpcodeOfPred = UNDEF_OPCODE;
p->cs.p_code.ExpandCode = EXPAND_OP_CODE;
p->CodeOfPred = p->cs.p_code.TrueCodeOfPred = (yamop *)(&(p->OpcodeOfPred));
if (cur_mod == TermProlog)
p->ModuleOfPred = 0;
else
p->ModuleOfPred = cur_mod;
Yap_NewModulePred(cur_mod, p);
p->TimeStampOfPred = 0L;
p->LastCallOfPred = LUCALL_ASSERT;
#ifdef TABLING
p->TableOfPred = NULL;
#endif /* TABLING */
#ifdef BEAM
p->beamTable = NULL;
#endif
/* careful that they don't cross MkFunctor */
AddPropToAtom(ae, (PropEntry *)p);
p0 = AbsPredProp(p);
p->FunctorOfPred = (Functor)AbsAtom(ae);
if (!trueGlobalPrologFlag(DEBUG_INFO_FLAG)) {
p->PredFlags |= (NoTracePredFlag | NoSpyPredFlag);
}
if (Yap_isSystemModule(CurrentModule))
p->PredFlags |= StandardPredFlag;
WRITE_UNLOCK(ae->ARWLock);
{
Yap_inform_profiler_of_clause(&(p->OpcodeOfPred), &(p->OpcodeOfPred) + 1, p,
GPROF_NEW_PRED_ATOM);
if (!(p->PredFlags & (CPredFlag | AsmPredFlag))) {
Yap_inform_profiler_of_clause(&(p->cs.p_code.ExpandCode),
&(p->cs.p_code.ExpandCode) + 1, p,
GPROF_NEW_PRED_ATOM);
}
}
return p0;
}
Prop Yap_PredPropByFunctorNonThreadLocal(Functor f, Term cur_mod)
/* get predicate entry for ap/arity; create it if neccessary. */
{
PredEntry *p;
FUNC_WRITE_LOCK(f);
if (!(p = RepPredProp(f->PropsOfFE)))
return Yap_NewPredPropByFunctor(f, cur_mod);
if ((p->ModuleOfPred == cur_mod || !(p->ModuleOfPred))) {
/* don't match multi-files */
if (!(p->PredFlags & MultiFileFlag) || p->ModuleOfPred || !cur_mod ||
cur_mod == TermProlog) {
FUNC_WRITE_UNLOCK(f);
return AbsPredProp(p);
}
}
if (p->NextOfPE) {
UInt hash = PRED_HASH(f, cur_mod, PredHashTableSize);
READ_LOCK(PredHashRWLock);
p = PredHash[hash];
while (p) {
if (p->FunctorOfPred == f && p->ModuleOfPred == cur_mod) {
READ_UNLOCK(PredHashRWLock);
FUNC_WRITE_UNLOCK(f);
return AbsPredProp(p);
}
p = p->NextPredOfHash;
}
READ_UNLOCK(PredHashRWLock);
}
return Yap_NewPredPropByFunctor(f, cur_mod);
}
Prop Yap_PredPropByAtomNonThreadLocal(Atom at, Term cur_mod)
/* get predicate entry for ap/arity; create it if neccessary. */
{
Prop p0;
AtomEntry *ae = RepAtom(at);
WRITE_LOCK(ae->ARWLock);
p0 = ae->PropsOfAE;
while (p0) {
PredEntry *pe = RepPredProp(p0);
if (pe->KindOfPE == PEProp &&
(pe->ModuleOfPred == cur_mod || !pe->ModuleOfPred)) {
/* don't match multi-files */
if (!(pe->PredFlags & MultiFileFlag) || pe->ModuleOfPred || !cur_mod ||
cur_mod == TermProlog) {
WRITE_UNLOCK(ae->ARWLock);
return (p0);
}
}
p0 = pe->NextOfPE;
}
return Yap_NewPredPropByAtom(ae, cur_mod);
}
Term Yap_GetValue(Atom a) {
Prop p0 = GetAProp(a, ValProperty);
Term out;
if (p0 == NIL)
return (TermNil);
READ_LOCK(RepValProp(p0)->VRWLock);
out = RepValProp(p0)->ValueOfVE;
if (IsApplTerm(out)) {
Functor f = FunctorOfTerm(out);
if (f == FunctorDouble) {
CACHE_REGS
out = MkFloatTerm(FloatOfTerm(out));
} else if (f == FunctorLongInt) {
CACHE_REGS
out = MkLongIntTerm(LongIntOfTerm(out));
} else if (f == FunctorString) {
CACHE_REGS
out = MkStringTerm(StringOfTerm(out));
}
#ifdef USE_GMP
else {
out = Yap_MkBigIntTerm(Yap_BigIntOfTerm(out));
}
#endif
}
READ_UNLOCK(RepValProp(p0)->VRWLock);
return (out);
}
void Yap_PutValue(Atom a, Term v) {
AtomEntry *ae = RepAtom(a);
Prop p0;
ValEntry *p;
Term t0;
WRITE_LOCK(ae->ARWLock);
p0 = GetAPropHavingLock(ae, ValProperty);
if (p0 != NIL) {
p = RepValProp(p0);
WRITE_LOCK(p->VRWLock);
WRITE_UNLOCK(ae->ARWLock);
} else {
p = (ValEntry *)Yap_AllocAtomSpace(sizeof(ValEntry));
if (p == NULL) {
WRITE_UNLOCK(ae->ARWLock);
return;
}
p->KindOfPE = ValProperty;
p->ValueOfVE = TermNil;
AddPropToAtom(RepAtom(a), (PropEntry *)p);
/* take care that the lock for the property will be inited even
if someone else searches for the property */
INIT_RWLOCK(p->VRWLock);
WRITE_LOCK(p->VRWLock);
WRITE_UNLOCK(ae->ARWLock);
}
t0 = p->ValueOfVE;
if (IsFloatTerm(v)) {
/* store a float in code space, so that we can access the property */
union {
Float f;
CELL ar[sizeof(Float) / sizeof(CELL)];
} un;
CELL *pt, *iptr;
unsigned int i;
un.f = FloatOfTerm(v);
if (IsFloatTerm(t0)) {
pt = RepAppl(t0);
} else {
if (IsApplTerm(t0)) {
Yap_FreeCodeSpace((char *)(RepAppl(t0)));
}
pt = (CELL *)Yap_AllocAtomSpace(sizeof(CELL) *
(1 + 2 * sizeof(Float) / sizeof(CELL)));
if (pt == NULL) {
WRITE_UNLOCK(ae->ARWLock);
return;
}
p->ValueOfVE = AbsAppl(pt);
pt[0] = (CELL)FunctorDouble;
}
iptr = pt + 1;
for (i = 0; i < sizeof(Float) / sizeof(CELL); i++) {
*iptr++ = (CELL)un.ar[i];
}
} else if (IsLongIntTerm(v)) {
CELL *pt;
Int val = LongIntOfTerm(v);
if (IsLongIntTerm(t0)) {
pt = RepAppl(t0);
} else {
if (IsApplTerm(t0)) {
Yap_FreeCodeSpace((char *)(RepAppl(t0)));
}
pt = (CELL *)Yap_AllocAtomSpace(2 * sizeof(CELL));
if (pt == NULL) {
WRITE_UNLOCK(ae->ARWLock);
return;
}
p->ValueOfVE = AbsAppl(pt);
pt[0] = (CELL)FunctorLongInt;
}
pt[1] = (CELL)val;
#ifdef USE_GMP
} else if (IsBigIntTerm(v)) {
CELL *ap = RepAppl(v);
Int sz = sizeof(MP_INT) + sizeof(CELL) +
(((MP_INT *)(ap + 1))->_mp_alloc * sizeof(mp_limb_t));
CELL *pt = (CELL *)Yap_AllocAtomSpace(sz);
if (pt == NULL) {
WRITE_UNLOCK(ae->ARWLock);
return;
}
if (IsApplTerm(t0)) {
Yap_FreeCodeSpace((char *)RepAppl(t0));
}
memcpy((void *)pt, (void *)ap, sz);
p->ValueOfVE = AbsAppl(pt);
#endif
} else if (IsStringTerm(v)) {
CELL *ap = RepAppl(v);
Int sz = sizeof(CELL) * (3 + ap[1]);
CELL *pt = (CELL *)Yap_AllocAtomSpace(sz);
if (pt == NULL) {
WRITE_UNLOCK(ae->ARWLock);
return;
}
if (IsApplTerm(t0)) {
Yap_FreeCodeSpace((char *)RepAppl(t0));
}
memcpy((void *)pt, (void *)ap, sz);
p->ValueOfVE = AbsAppl(pt);
} else {
if (IsApplTerm(t0)) {
/* recover space */
Yap_FreeCodeSpace((char *)(RepAppl(p->ValueOfVE)));
}
p->ValueOfVE = v;
}
WRITE_UNLOCK(p->VRWLock);
}
bool Yap_PutAtomTranslation(Atom a, arity_t arity, Int i) {
AtomEntry *ae = RepAtom(a);
Prop p0;
TranslationEntry *p;
WRITE_LOCK(ae->ARWLock);
p0 = GetAPropHavingLock(ae, TranslationProperty);
if (p0 == NIL) {
p = (TranslationEntry *)Yap_AllocAtomSpace(sizeof(TranslationEntry));
if (p == NULL) {
WRITE_UNLOCK(ae->ARWLock);
return false;
}
p->KindOfPE = TranslationProperty;
p->Translation = i;
p->arity = arity;
AddPropToAtom(RepAtom(a), (PropEntry *)p);
}
/* take care that the lock for the property will be inited even
if someone else searches for the property */
WRITE_UNLOCK(ae->ARWLock);
return true;
}
bool Yap_PutFunctorTranslation(Atom a, arity_t arity, Int i) {
AtomEntry *ae = RepAtom(a);
Prop p0;
TranslationEntry *p;
WRITE_LOCK(ae->ARWLock);
p0 = GetAPropHavingLock(ae, TranslationProperty);
if (p0 == NIL) {
p = (TranslationEntry *)Yap_AllocAtomSpace(sizeof(TranslationEntry));
if (p == NULL) {
WRITE_UNLOCK(ae->ARWLock);
return false;
}
p->KindOfPE = TranslationProperty;
p->Translation = i;
p->arity = arity;
AddPropToAtom(RepAtom(a), (PropEntry *)p);
}
/* take care that the lock for the property will be inited even
if someone else searches for the property */
WRITE_UNLOCK(ae->ARWLock);
return true;
}
bool Yap_PutAtomMutex(Atom a, void *i) {
AtomEntry *ae = RepAtom(a);
Prop p0;
MutexEntry *p;
WRITE_LOCK(ae->ARWLock);
p0 = GetAPropHavingLock(ae, MutexProperty);
if (p0 == NIL) {
p = (MutexEntry *)Yap_AllocAtomSpace(sizeof(MutexEntry));
if (p == NULL) {
WRITE_UNLOCK(ae->ARWLock);
return false;
}
p->KindOfPE = MutexProperty;
p->Mutex = i;
AddPropToAtom(RepAtom(a), (PropEntry *)p);
}
/* take care that the lock for the property will be inited even
if someone else searches for the property */
WRITE_UNLOCK(ae->ARWLock);
return true;
}
Term Yap_ArrayToList(register Term *tp, size_t nof) {
CACHE_REGS
register Term *pt = tp + nof;
register Term t;
t = MkAtomTerm(AtomNil);
while (pt > tp) {
Term tm = *--pt;
#if YAPOR_SBA
if (tm == 0)
t = MkPairTerm((CELL)pt, t);
else
#endif
t = MkPairTerm(tm, t);
}
return (t);
}
int Yap_GetName(char *s, UInt max, Term t) {
register Term Head;
register Int i;
if (IsVarTerm(t) || !IsPairTerm(t))
return FALSE;
while (IsPairTerm(t)) {
Head = HeadOfTerm(t);
if (!IsNumTerm(Head))
return (FALSE);
i = IntOfTerm(Head);
if (i < 0 || i > MAX_ISO_LATIN1)
return FALSE;
*s++ = i;
t = TailOfTerm(t);
if (--max == 0) {
Yap_Error(SYSTEM_ERROR_FATAL, t, "not enough space for GetName");
}
}
*s = '\0';
return TRUE;
}
#ifdef SFUNC
Term MkSFTerm(Functor f, int n, Term *a, empty_value) {
Term t, p = AbsAppl(H);
int i;
*H++ = f;
RESET_VARIABLE(H);
++H;
for (i = 1; i <= n; ++i) {
t = Derefa(a++);
if (t != empty_value) {
*H++ = i;
*H++ = t;
}
}
*H++ = 0;
return (p);
}
CELL *ArgsOfSFTerm(Term t) {
CELL *p = RepAppl(t) + 1;
while (*p != (CELL)p)
p = CellPtr(*p) + 1;
return (p + 1);
}
#endif
static HoldEntry *InitAtomHold(void) {
HoldEntry *x = (HoldEntry *)Yap_AllocAtomSpace(sizeof(struct hold_entry));
if (x == NULL) {
return NULL;
}
x->KindOfPE = HoldProperty;
x->NextOfPE = NIL;
x->RefsOfPE = 1;
return x;
}
int Yap_AtomIncreaseHold(Atom at) {
AtomEntry *ae = RepAtom(at);
HoldEntry *pp;
Prop *opp = &(ae->PropsOfAE);
WRITE_LOCK(ae->ARWLock);
pp = RepHoldProp(ae->PropsOfAE);
while (!EndOfPAEntr(pp) && pp->KindOfPE != HoldProperty) {
opp = &(pp->NextOfPE);
pp = RepHoldProp(pp->NextOfPE);
}
if (!pp) {
HoldEntry *new = InitAtomHold();
if (!new) {
WRITE_UNLOCK(ae->ARWLock);
return FALSE;
}
*opp = AbsHoldProp(new);
} else {
pp->RefsOfPE++;
}
WRITE_UNLOCK(ae->ARWLock);
return TRUE;
}
int Yap_AtomDecreaseHold(Atom at) {
AtomEntry *ae = RepAtom(at);
HoldEntry *pp;
Prop *opp = &(ae->PropsOfAE);
WRITE_LOCK(ae->ARWLock);
pp = RepHoldProp(ae->PropsOfAE);
while (!EndOfPAEntr(pp) && pp->KindOfPE != HoldProperty) {
opp = &(pp->NextOfPE);
pp = RepHoldProp(pp->NextOfPE);
}
if (!pp) {
WRITE_UNLOCK(ae->ARWLock);
return FALSE;
}
pp->RefsOfPE--;
if (!pp->RefsOfPE) {
*opp = pp->NextOfPE;
Yap_FreeCodeSpace((ADDR)pp);
}
WRITE_UNLOCK(ae->ARWLock);
return TRUE;
}
Reference in New Issue View Git Blame Copy Permalink