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.
yap-6.3/C/exo.c

713 lines
17 KiB
C
Raw Normal View History

2013-01-07 09:47:14 +00:00
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: exo.c *
* comments: Exo compilation *
* *
* Last rev: $Date: 2008-07-22 23:34:44 $,$Author: vsc $ * *
* $Log: not supported by cvs2svn $ *
* *
* *
*************************************************************************/
#include "Yap.h"
#include "clause.h"
#include "yapio.h"
#include "eval.h"
#include "tracer.h"
#ifdef YAPOR
#include "or.macros.h"
#endif /* YAPOR */
#ifdef TABLING
#include "tab.macros.h"
#endif /* TABLING */
#if HAVE_STRING_H
#include <string.h>
#endif
2013-01-09 16:38:39 +00:00
//static int exo_write=FALSE;
//void do_write(void) { exo_write=TRUE;}
2013-01-07 09:47:14 +00:00
#define MAX_ARITY 256
2013-11-16 16:58:07 +00:00
#define FNV32_PRIME ((UInt)16777619)
#define FNV64_PRIME ((UInt)1099511628211)
2013-11-16 16:58:07 +00:00
#define FNV32_OFFSET ((UInt)2166136261)
#define FNV64_OFFSET ((UInt)14695981039346656037)
2013-06-22 06:25:37 +01:00
/*MurmurHash3 from: https://code.google.com/p/smhasher/wiki/MurmurHash3*/
BITS32 rotl32 ( BITS32, int8_t);
inline BITS32 rotl32 ( BITS32 x, int8_t r )
{
return (x << r) | (x >> (32 - r));
}
#define ROTL32(x,y) rotl32(x,y)
//-----------------------------------------------------------------------------
// Finalization mix - force all bits of a hash block to avalanche
BITS32 fmix32 ( BITS32 );
inline BITS32 fmix32 ( BITS32 h )
{
h ^= h >> 16;
h *= 0x85ebca6b;
h ^= h >> 13;
h *= 0xc2b2ae35;
h ^= h >> 16;
return h;
}
//-----------------------------------------------------------------------------
2013-08-10 01:46:04 +01:00
INLINE_ONLY inline BITS32
2013-06-22 06:25:37 +01:00
HASH_MURMUR3_32 (UInt arity, CELL *cl, UInt bnds[], UInt sz);
2013-08-10 01:46:04 +01:00
INLINE_ONLY inline BITS32
2013-06-22 06:25:37 +01:00
HASH_MURMUR3_32 (UInt arity, CELL *cl, UInt bnds[], UInt sz)
{
UInt hash;
UInt j=0;
int len = 0;
const BITS32 c1 = 0xcc9e2d51;
const BITS32 c2 = 0x1b873593;
hash = FNV32_OFFSET; /*did not find what seed to use yet*/
while (j < arity) {
if (bnds[j]) {
unsigned char *i=(unsigned char*)(cl+j);
unsigned char *m=(unsigned char*)(cl+(j+1));
while (i < m) {
BITS32 k1 = i[0];
k1 *= c1;
k1 = ROTL32(k1,15);
k1 *= c2;
2013-11-21 11:38:16 +00:00
2013-06-22 06:25:37 +01:00
hash ^= k1;
2013-11-21 11:38:16 +00:00
hash = ROTL32(hash,13);
2013-06-22 06:25:37 +01:00
hash = hash*5+0xe6546b64;
i++;
len++;
}
}
j++;
}
//----------
// tail not used becouse len is block multiple
//----------
// finalization
hash ^= len;
hash = fmix32(hash);
return hash;
2013-11-21 11:38:16 +00:00
}
2013-06-22 06:25:37 +01:00
/*DJB2*/
2013-11-21 11:38:16 +00:00
#define DJB2_OFFSET 5381
2013-06-22 06:25:37 +01:00
2013-08-10 01:46:04 +01:00
INLINE_ONLY inline BITS32
2013-06-22 06:25:37 +01:00
HASH_DJB2(UInt arity, CELL *cl, UInt bnds[], UInt sz);
2013-08-10 01:46:04 +01:00
INLINE_ONLY inline BITS32
2013-06-22 06:25:37 +01:00
HASH_DJB2(UInt arity, CELL *cl, UInt bnds[], UInt sz)
{
BITS32 hash;
UInt j=0;
hash = DJB2_OFFSET;
while (j < arity) {
if (bnds[j]) {
unsigned char *i=(unsigned char*)(cl+j);
unsigned char *m=(unsigned char*)(cl+(j+1));
while (i < m) {
BITS32 h5 = hash << 5;
hash += h5 + i[0]; /* hash * 33 + i[0] */
i++;
}
}
j++;
}
return hash;
}
2013-08-10 01:46:04 +01:00
INLINE_ONLY inline BITS32
2013-06-22 06:25:37 +01:00
HASH_RS(UInt arity, CELL *cl, UInt bnds[], UInt sz);
/* RS Hash Function */
2013-08-10 01:46:04 +01:00
INLINE_ONLY inline BITS32
2013-06-22 06:25:37 +01:00
HASH_RS(UInt arity, CELL *cl, UInt bnds[], UInt sz)
{
UInt hash=0;
UInt j=0;
UInt b = 378551;
UInt a = 63689;
while (j < arity) {
if (bnds[j]) {
unsigned char *i=(unsigned char*)(cl+j);
unsigned char *m=(unsigned char*)(cl+(j+1));
while (i < m) {
hash = hash * a + i[0];
a = a * b;
i++;
}
}
j++;
}
return hash;
}
2013-08-10 01:46:04 +01:00
INLINE_ONLY inline BITS32
2013-06-22 06:25:37 +01:00
HASH_FVN_1A(UInt arity, CELL *cl, UInt bnds[], UInt sz);
2013-01-09 09:21:07 +00:00
2013-01-09 16:38:39 +00:00
/* Simple hash function:
2013-06-22 06:25:37 +01:00
FVN-1A
2013-01-09 16:38:39 +00:00
first component is the base key.
hash0 spreads extensions coming from different elements.
spread over j quadrants.
*/
2013-08-10 01:46:04 +01:00
INLINE_ONLY inline BITS32
2013-08-05 21:07:51 +01:00
HASH_FVN_1A(UInt arity, CELL *cl, UInt bnds[], UInt sz)
2013-01-07 09:47:14 +00:00
{
UInt hash;
UInt j=0;
hash = FNV32_OFFSET;
2013-08-05 21:07:51 +01:00
while (j < arity) {
if (bnds[j]) {
unsigned char *i=(unsigned char*)(cl+j);
unsigned char *m=(unsigned char*)(cl+(j+1));
while (i < m) {
hash = hash ^ i[0];
hash = hash * FNV32_PRIME;
i++;
}
}
j++;
}
return hash;
2013-01-13 11:49:12 +00:00
}
2013-11-21 11:38:16 +00:00
//#define TEST_HASH_DJB 1
2013-06-22 06:25:37 +01:00
#if defined TEST_HASH_MURMUR
# define HASH(...) HASH_MURMUR3_32(__VA_ARGS__)
#elif defined TEST_HASH_DJB
# define HASH(...) HASH_DJB2(__VA_ARGS__)
#elif defined TEST_HASH_RS
# define HASH(...) HASH_RS(__VA_ARGS__)
#else
/* Default: TEST_HASH_FVN */
# define HASH(...) HASH_FVN_1A(__VA_ARGS__)
2013-08-05 21:07:51 +01:00
# define HASH1(...) HASH_MURMUR3_32(__VA_ARGS__)
2013-06-22 06:25:37 +01:00
#endif
static BITS32
2013-08-05 21:07:51 +01:00
NEXT(UInt arity, CELL *cl, UInt bnds[], UInt sz, BITS32 hash)
2013-01-13 11:49:12 +00:00
{
2013-08-05 21:07:51 +01:00
int i = 0;
BITS32 hash1;
while (bnds[i]==0) i++;
hash1 = HASH1(arity, cl, bnds, sz);
return (hash + hash1 +cl[i]);
2013-01-07 09:47:14 +00:00
}
/* search for matching elements */
2013-11-21 11:38:16 +00:00
static int
MATCH(CELL *clp, CELL *kvp, UInt arity, UInt bnds[])
2013-01-07 09:47:14 +00:00
{
UInt j = 0;
while (j< arity) {
if ( bnds[j] && clp[j] != kvp[j])
2013-01-07 09:47:14 +00:00
return FALSE;
j++;
}
2013-01-07 09:47:14 +00:00
return TRUE;
}
static void
ADD_TO_TRY_CHAIN(CELL *kvp, CELL *cl, struct index_t *it)
{
2013-06-23 02:09:20 +01:00
BITS32 old = EXO_ADDRESS_TO_OFFSET(it, kvp);
BITS32 new = EXO_ADDRESS_TO_OFFSET(it, cl);
BITS32 *links = it->links;
BITS32 tmp = links[old]; /* points to the end of the chain */
2013-01-07 09:47:14 +00:00
if (!tmp) {
links[old] = links[new] = new;
} else {
links[new] = links[tmp];
links[tmp] = new;
links[old] = new;
}
}
/* This is the critical routine, it builds the hash table *
* each HT field stores a key pointer which is actually
* a pointer to the point in the clause where one can find the element.
*
* The cls table indexes all elements that can be reached using that key.
2013-11-21 11:38:16 +00:00
*
2013-01-07 09:47:14 +00:00
* Insert:
* j = first
* not match cij -> insert, open new chain
2013-11-21 11:38:16 +00:00
* match ci..j ck..j -> find j = minarg(cij \= c2j),
2013-01-07 09:47:14 +00:00
* else j = +inf -> c2+ci
* Lookup:
* j= first
* not match cij -> fail
* match ci..j ck..j -> find j = minarg(cij \= c2j)
* else
*/
2013-03-20 02:26:22 +00:00
static int
INSERT(CELL *cl, struct index_t *it, UInt arity, UInt base, UInt bnds[])
2013-01-07 09:47:14 +00:00
{
CELL *kvp;
BITS32 hash;
2013-03-20 02:26:22 +00:00
int coll_count = 0;
2013-01-07 09:47:14 +00:00
hash = HASH(arity, cl, bnds, it->hsize);
2013-01-07 09:47:14 +00:00
next:
kvp = EXO_OFFSET_TO_ADDRESS(it, it->key [hash % it->hsize]);
2013-01-07 09:47:14 +00:00
if (kvp == NULL) {
/* simple case, new entry */
2013-01-09 16:38:39 +00:00
it->nentries++;
it->key[hash % it->hsize ] = EXO_ADDRESS_TO_OFFSET(it, cl);
2013-08-05 21:07:51 +01:00
if (coll_count > it -> max_col_count)
it->max_col_count = coll_count;
2013-03-20 02:26:22 +00:00
return TRUE;
} else if (MATCH(kvp, cl, arity, bnds)) {
2013-01-09 16:38:39 +00:00
it->ntrys++;
2013-01-08 00:40:51 +00:00
ADD_TO_TRY_CHAIN(kvp, cl, it);
2013-03-20 02:26:22 +00:00
return TRUE;
2013-01-07 09:47:14 +00:00
} else {
2013-03-20 02:26:22 +00:00
coll_count++;
2013-01-09 16:38:39 +00:00
it->ncollisions++;
// printf("#");
2013-08-05 21:07:51 +01:00
hash = NEXT(arity, cl, bnds, it->hsize, hash);
2013-01-09 16:38:39 +00:00
//if (exo_write) printf("N=%ld\n", hash);
2013-01-07 09:47:14 +00:00
goto next;
}
}
static yamop *
2013-01-10 23:22:11 +00:00
LOOKUP(struct index_t *it, UInt arity, UInt j, UInt bnds[])
2013-01-07 09:47:14 +00:00
{
2013-01-10 23:22:11 +00:00
CACHE_REGS
2013-01-07 09:47:14 +00:00
CELL *kvp;
BITS32 hash;
2013-01-07 09:47:14 +00:00
/* j is the firs bound element */
/* check if we match */
hash = HASH(arity, XREGS+1, bnds, it->hsize);
2013-01-07 09:47:14 +00:00
next:
/* loop to insert element */
kvp = EXO_OFFSET_TO_ADDRESS(it, it->key[hash % it->hsize]);
2013-01-07 09:47:14 +00:00
if (kvp == NULL) {
/* simple case, no element */
return FAILCODE;
} else if (MATCH(kvp, XREGS+1, arity, bnds)) {
S = kvp;
2013-06-23 02:09:20 +01:00
if (!it->is_key && it->links[EXO_ADDRESS_TO_OFFSET(it, S)])
2013-01-08 00:40:51 +00:00
return it->code;
else
return NEXTOP(NEXTOP(it->code,lp),lp);
2013-01-07 09:47:14 +00:00
} else {
/* collision */
2013-08-05 21:07:51 +01:00
hash = NEXT(arity, XREGS+1, bnds, it->hsize, hash);
2013-01-07 09:47:14 +00:00
goto next;
}
}
2013-03-20 02:26:22 +00:00
static int
2013-01-10 23:22:11 +00:00
fill_hash(UInt bmap, struct index_t *it, UInt bnds[])
2013-01-07 09:47:14 +00:00
{
UInt i;
UInt arity = it->arity;
CELL *cl = it->cls;
for (i=0; i < it->nels; i++) {
2013-03-20 02:26:22 +00:00
if (!INSERT(cl, it, arity, 0, bnds))
return FALSE;
2013-01-07 09:47:14 +00:00
cl += arity;
}
2013-01-09 16:38:39 +00:00
for (i=0; i < it->hsize; i++) {
2013-01-07 09:47:14 +00:00
if (it->key[i]) {
2013-06-23 02:09:20 +01:00
BITS32 offset = it->key[i];
2013-06-22 06:25:37 +01:00
BITS32 last = it->links[offset];
2013-01-08 00:40:51 +00:00
if (last) {
2013-06-23 02:09:20 +01:00
/* the chain used to point straight to the last, and the last back to the original first */
2013-01-08 00:40:51 +00:00
it->links[offset] = it->links[last];
it->links[last] = 0;
}
2013-01-07 09:47:14 +00:00
}
}
2013-03-20 02:26:22 +00:00
return TRUE;
2013-01-07 09:47:14 +00:00
}
static struct index_t *
2013-04-17 02:04:53 +01:00
add_index(struct index_t **ip, UInt bmap, PredEntry *ap, UInt count)
2013-01-07 09:47:14 +00:00
{
2013-01-23 09:58:02 +00:00
CACHE_REGS
2013-01-07 09:47:14 +00:00
UInt ncls = ap->cs.p_code.NOfClauses, j;
2013-01-08 12:35:18 +00:00
CELL *base = NULL;
2013-01-07 09:47:14 +00:00
struct index_t *i;
2013-05-01 17:34:55 +01:00
size_t sz, dsz;
2013-01-07 09:47:14 +00:00
yamop *ptr;
2013-04-17 02:04:53 +01:00
UInt *bnds = LOCAL_ibnds;
2013-06-23 02:09:20 +01:00
2013-01-07 09:47:14 +00:00
sz = (CELL)NEXTOP(NEXTOP((yamop*)NULL,lp),lp)+ap->ArityOfPE*(CELL)NEXTOP((yamop *)NULL,x) +(CELL)NEXTOP(NEXTOP((yamop *)NULL,p),l);
if (!(i = (struct index_t *)Yap_AllocCodeSpace(sizeof(struct index_t)+sz))) {
CACHE_REGS
save_machine_regs();
LOCAL_Error_Size = 3*ncls*sizeof(CELL);
LOCAL_ErrorMessage = "not enough space to index";
Yap_Error(OUT_OF_HEAP_ERROR, TermNil, LOCAL_ErrorMessage);
return NULL;
}
2013-03-20 02:26:22 +00:00
i->is_key = FALSE;
2013-01-09 16:38:39 +00:00
i->next = *ip;
i->prev = NULL;
i->nels = ncls;
i->arity = ap->ArityOfPE;
i->ap = ap;
i->bmap = bmap;
i->is_key = FALSE;
i->hsize = 2*ncls;
2013-06-23 02:09:20 +01:00
dsz = sizeof(BITS32)*(ncls+1+i->hsize);
2013-01-09 09:21:07 +00:00
if (count) {
2013-05-01 17:34:55 +01:00
if (!(base = (CELL *)Yap_AllocCodeSpace(dsz))) {
2013-01-09 09:21:07 +00:00
CACHE_REGS
save_machine_regs();
2013-05-01 17:34:55 +01:00
LOCAL_Error_Size = dsz;
2013-01-09 16:38:39 +00:00
LOCAL_ErrorMessage = "not enough space to generate indices";
Yap_FreeCodeSpace((void *)i);
2013-01-09 09:21:07 +00:00
Yap_Error(OUT_OF_HEAP_ERROR, TermNil, LOCAL_ErrorMessage);
return NULL;
}
2014-01-19 21:15:05 +00:00
memset(base, 0, dsz);
2013-01-09 09:21:07 +00:00
}
2013-05-01 17:34:55 +01:00
i->size = sz+dsz+sizeof(struct index_t);
i->key = (BITS32 *)base;
2013-06-22 06:25:37 +01:00
i->links = (BITS32 *)base+i->hsize;
2013-01-09 16:38:39 +00:00
i->ncollisions = i->nentries = i->ntrys = 0;
2013-11-21 11:38:16 +00:00
i->cls = (CELL *)((ADDR)ap->cs.p_code.FirstClause+2*sizeof(struct index_t *));
2013-06-23 02:09:20 +01:00
i->bcls= i->cls-i->arity;
2013-08-05 21:07:51 +01:00
i->udi_free_args = 0;
i->is_udi = FALSE;
i->udi_arg = 0;
2013-01-08 00:40:51 +00:00
*ip = i;
2013-03-20 02:26:22 +00:00
while (count) {
if (!fill_hash(bmap, i, bnds)) {
size_t sz;
i->hsize += ncls;
if (i->is_key) {
sz = i->hsize*sizeof(BITS32);
} else {
2013-06-23 02:09:20 +01:00
sz = (ncls+1+i->hsize)*sizeof(BITS32);
2013-03-20 02:26:22 +00:00
}
2013-05-01 17:34:55 +01:00
if (base != (CELL *)Yap_ReallocCodeSpace((char *)base, sz))
2013-03-20 02:26:22 +00:00
return FALSE;
2014-01-19 21:15:05 +00:00
memset(base, 0, sz);
2013-06-22 06:25:37 +01:00
i->key = (BITS32 *)base;
i->links = (BITS32 *)(base+i->hsize);
2013-03-20 02:26:22 +00:00
i->ncollisions = i->nentries = i->ntrys = 0;
continue;
}
2013-04-17 02:04:53 +01:00
#if DEBUG
2013-08-05 21:07:51 +01:00
fprintf(stderr, "entries=%ld collisions=%ld (max=%ld) trys=%ld\n", i->nentries, i->ncollisions, i->max_col_count, i->ntrys);
2013-04-17 02:04:53 +01:00
#endif
2013-03-20 02:26:22 +00:00
if (!i->ntrys && !i->is_key) {
2013-01-09 09:21:07 +00:00
i->is_key = TRUE;
2013-05-01 17:34:55 +01:00
if (base != (CELL *)Yap_ReallocCodeSpace((char *)base, i->hsize*sizeof(BITS32)))
2013-03-20 02:26:22 +00:00
return FALSE;
}
/* our hash table is just too large */
if (( i->nentries+i->ncollisions )*10 < i->hsize) {
size_t sz;
i->hsize = ( i->nentries+i->ncollisions )*10;
if (i->is_key) {
sz = i->hsize*sizeof(BITS32);
} else {
2013-06-23 02:09:20 +01:00
sz = (ncls+1+i->hsize)*sizeof(BITS32);
2013-03-20 02:26:22 +00:00
}
2013-05-01 17:34:55 +01:00
if (base != (CELL *)Yap_ReallocCodeSpace((char *)base, sz))
2013-01-09 09:21:07 +00:00
return FALSE;
2014-01-19 21:15:05 +00:00
memset(base, 0, sz);
2013-06-22 06:25:37 +01:00
i->key = (BITS32 *)base;
i->links = (BITS32 *)base+i->hsize;
2013-03-20 02:26:22 +00:00
i->ncollisions = i->nentries = i->ntrys = 0;
} else {
break;
2013-01-09 09:21:07 +00:00
}
2013-01-08 12:35:18 +00:00
}
2013-01-07 09:47:14 +00:00
ptr = (yamop *)(i+1);
i->code = ptr;
2013-01-08 12:35:18 +00:00
if (count)
ptr->opc = Yap_opcode(_try_exo);
else
ptr->opc = Yap_opcode(_try_all_exo);
2013-01-07 09:47:14 +00:00
ptr->u.lp.l = (yamop *)i;
ptr->u.lp.p = ap;
ptr = NEXTOP(ptr, lp);
2013-01-08 12:35:18 +00:00
if (count)
ptr->opc = Yap_opcode(_retry_exo);
else
ptr->opc = Yap_opcode(_retry_all_exo);
2013-01-07 09:47:14 +00:00
ptr->u.lp.p = ap;
ptr->u.lp.l = (yamop *)i;
ptr = NEXTOP(ptr, lp);
for (j = 0; j < i->arity; j++) {
ptr->opc = Yap_opcode(_get_atom_exo);
#if PRECOMPUTE_REGADDRESS
ptr->u.x.x = (CELL) (XREGS + (j+1));
#else
ptr->u.x.x = j+1;
#endif
ptr = NEXTOP(ptr, x);
}
ptr->opc = Yap_opcode(_procceed);
ptr->u.p.p = ap;
ptr = NEXTOP(ptr, p);
ptr->opc = Yap_opcode(_Ystop);
ptr->u.l.l = i->code;
2013-04-17 02:04:53 +01:00
Yap_inform_profiler_of_clause((char *)(i->code), (char *)NEXTOP(ptr,l), ap, GPROF_INDEX);
if (ap->PredFlags & UDIPredFlag) {
Yap_new_udi_clause( ap, NULL, (Term)ip);
} else {
i->is_udi = FALSE;
}
2013-01-07 09:47:14 +00:00
return i;
}
yamop *
2013-11-21 11:38:16 +00:00
Yap_ExoLookup(PredEntry *ap USES_REGS)
2013-01-07 09:47:14 +00:00
{
UInt arity = ap->ArityOfPE;
2013-01-09 09:21:07 +00:00
UInt bmap = 0L, bit = 1, count = 0, j, j0 = 0;
2013-01-08 00:40:51 +00:00
struct index_t **ip = (struct index_t **)(ap->cs.p_code.FirstClause);
struct index_t *i = *ip;
2013-11-21 11:38:16 +00:00
2013-01-07 09:47:14 +00:00
for (j=0; j< arity; j++, bit<<=1) {
Term t = Deref(XREGS[j+1]);
if (!IsVarTerm(t)) {
bmap += bit;
2013-01-09 09:21:07 +00:00
LOCAL_ibnds[j] = TRUE;
2013-11-21 11:38:16 +00:00
if (!count) j0= j;
2013-01-07 09:47:14 +00:00
count++;
2013-01-08 00:40:51 +00:00
} else {
2013-01-09 09:21:07 +00:00
LOCAL_ibnds[j] = FALSE;
2013-01-07 09:47:14 +00:00
}
XREGS[j+1] = t;
}
while (i) {
// if (i->is_key && (i->bmap & bmap) == i->bmap) {
// break;
// }
if (i->bmap == bmap) {
break;
2013-01-07 09:47:14 +00:00
}
2013-01-08 00:40:51 +00:00
ip = &i->next;
i = i->next;
2013-01-07 09:47:14 +00:00
}
if (!i) {
2013-04-17 02:04:53 +01:00
i = add_index(ip, bmap, ap, count);
2013-01-07 09:47:14 +00:00
}
2013-04-17 02:04:53 +01:00
if (count) {
yamop *code = LOOKUP(i, arity, j0, LOCAL_ibnds);
2013-04-29 22:19:43 +01:00
if (code == FAILCODE)
return code;
2013-11-21 11:38:16 +00:00
if (i->is_udi)
2013-04-17 03:49:37 +01:00
return ((CEnterExoIndex)i->udi_first)(i PASS_REGS);
2013-11-21 11:38:16 +00:00
else
2013-08-05 21:07:51 +01:00
return code;
2013-11-21 11:38:16 +00:00
} else if(i->is_udi) {
2013-04-29 17:58:05 +01:00
return ((CEnterExoIndex)i->udi_first)(i PASS_REGS);
} else {
2013-01-08 12:35:18 +00:00
return i->code;
2013-04-29 17:58:05 +01:00
}
2013-01-07 09:47:14 +00:00
}
CELL
2013-11-21 11:38:16 +00:00
Yap_NextExo(choiceptr cptr, struct index_t *it)
2013-01-07 09:47:14 +00:00
{
2013-01-10 23:22:11 +00:00
CACHE_REGS
2013-06-22 06:25:37 +01:00
BITS32 offset = ADDRESS_TO_LINK(it,(BITS32 *)((CELL *)(B+1))[it->arity]);
BITS32 next = it->links[offset];
((CELL *)(B+1))[it->arity] = (CELL)LINK_TO_ADDRESS(it, next);
2013-01-07 09:47:14 +00:00
S = it->cls+it->arity*offset;
return next;
}
2014-01-19 21:15:05 +00:00
static MegaClause *
2013-11-21 11:38:16 +00:00
exodb_get_space( Term t, Term mod, Term tn )
{
UInt arity;
2013-01-07 09:47:14 +00:00
Prop pe;
PredEntry *ap;
MegaClause *mcl;
UInt ncls;
UInt required;
struct index_t **li;
if (IsVarTerm(mod) || !IsAtomTerm(mod)) {
2013-11-21 11:38:16 +00:00
return NULL;
2013-01-07 09:47:14 +00:00
}
if (IsAtomTerm(t)) {
Atom a = AtomOfTerm(t);
arity = 0;
pe = PredPropByAtom(a, mod);
} else if (IsApplTerm(t)) {
register Functor f = FunctorOfTerm(t);
arity = ArityOfFunctor(f);
pe = PredPropByFunc(f, mod);
} else {
2013-11-21 11:38:16 +00:00
return NULL;
2013-01-07 09:47:14 +00:00
}
2013-11-21 11:38:16 +00:00
if (EndOfPAEntr(pe))
return NULL;
2013-01-07 09:47:14 +00:00
ap = RepPredProp(pe);
if (ap->PredFlags & (DynamicPredFlag|LogUpdatePredFlag
#ifdef TABLING
2013-11-21 11:38:16 +00:00
|TabledPredFlag
2013-01-07 09:47:14 +00:00
#endif /* TABLING */
2013-11-21 11:38:16 +00:00
)) {
2013-01-07 09:47:14 +00:00
Yap_Error(PERMISSION_ERROR_MODIFY_STATIC_PROCEDURE,t,"dbload_get_space/4");
2013-11-21 11:38:16 +00:00
return NULL;
2013-01-07 09:47:14 +00:00
}
if (IsVarTerm(tn) || !IsIntegerTerm(tn)) {
2013-11-21 11:38:16 +00:00
return NULL;
2013-01-07 09:47:14 +00:00
}
ncls = IntegerOfTerm(tn);
if (ncls <= 1) {
2013-11-21 11:38:16 +00:00
return NULL;
2013-01-07 09:47:14 +00:00
}
2013-01-09 09:21:07 +00:00
required = ncls*arity*sizeof(CELL)+sizeof(MegaClause)+2*sizeof(struct index_t *);
2013-01-07 09:47:14 +00:00
while (!(mcl = (MegaClause *)Yap_AllocCodeSpace(required))) {
if (!Yap_growheap(FALSE, required, NULL)) {
/* just fail, the system will keep on going */
2013-11-21 11:38:16 +00:00
return NULL;
2013-01-07 09:47:14 +00:00
}
}
Yap_ClauseSpace += required;
/* cool, it's our turn to do the conversion */
2013-01-11 16:45:14 +00:00
mcl->ClFlags = MegaMask|ExoMask;
2013-01-11 18:36:34 +00:00
mcl->ClSize = required;
2013-01-07 09:47:14 +00:00
mcl->ClPred = ap;
mcl->ClItemSize = arity*sizeof(CELL);
mcl->ClNext = NULL;
li = (struct index_t **)(mcl->ClCode);
li[0] = li[1] = NULL;
ap->cs.p_code.FirstClause =
ap->cs.p_code.LastClause =
mcl->ClCode;
2013-09-28 18:20:04 +01:00
ap->PredFlags |= MegaClausePredFlag;
2013-01-07 09:47:14 +00:00
ap->cs.p_code.NOfClauses = ncls;
if (ap->PredFlags & (SpiedPredFlag|CountPredFlag|ProfiledPredFlag)) {
ap->OpcodeOfPred = Yap_opcode(_spy_pred);
} else {
ap->OpcodeOfPred = Yap_opcode(_enter_exo);
}
2013-11-21 11:38:16 +00:00
ap->CodeOfPred = ap->cs.p_code.TrueCodeOfPred = (yamop *)(&(ap->OpcodeOfPred));
return mcl;
}
static Int
p_exodb_get_space( USES_REGS1 )
{ /* '$number_of_clauses'(Predicate,M,N) */
void *mcl;
if ((mcl = exodb_get_space(Deref(ARG1), Deref(ARG2), Deref(ARG3))) == NULL)
return FALSE;
2013-01-07 09:47:14 +00:00
return Yap_unify(ARG4, MkIntegerTerm((Int)mcl));
}
#define DerefAndCheck(t, V) \
t = Deref(V); if(IsVarTerm(t) || !(IsAtomOrIntTerm(t))) Yap_Error(TYPE_ERROR_ATOM, t0, "load_db");
2013-11-21 11:38:16 +00:00
static Int
2013-01-07 09:47:14 +00:00
store_exo(yamop *pc, UInt arity, Term t0)
{
Term t;
CELL *tp = RepAppl(t0)+1,
*cpc = (CELL *)pc;
UInt i;
for (i = 0; i< arity; i++) {
DerefAndCheck(t, tp[0]);
*cpc = t;
tp++;
cpc++;
}
return TRUE;
}
2014-01-19 21:15:05 +00:00
static void
2013-11-21 11:38:16 +00:00
exoassert( void *handle, Int n, Term term )
{ /* '$number_of_clauses'(Predicate,M,N) */
PredEntry *pe;
MegaClause *mcl;
mcl = (MegaClause *) handle;
pe = mcl->ClPred;
store_exo((yamop *)((ADDR)mcl->ClCode+2*sizeof(struct index_t *)+n*(mcl->ClItemSize)),pe->ArityOfPE, term);
}
static Int
2013-01-07 09:47:14 +00:00
p_exoassert( USES_REGS1 )
{ /* '$number_of_clauses'(Predicate,M,N) */
Term thandle = Deref(ARG2);
Term tn = Deref(ARG3);
MegaClause *mcl;
Int n;
if (IsVarTerm(thandle) || !IsIntegerTerm(thandle)) {
return FALSE;
}
mcl = (MegaClause *)IntegerOfTerm(thandle);
if (IsVarTerm(tn) || !IsIntegerTerm(tn)) {
return FALSE;
}
n = IntegerOfTerm(tn);
2013-11-21 11:38:16 +00:00
exoassert(mcl,n,Deref(ARG1));
return TRUE;
2013-01-07 09:47:14 +00:00
}
2013-11-21 11:38:16 +00:00
void
2013-01-07 09:47:14 +00:00
Yap_InitExoPreds(void)
{
CACHE_REGS
Term cm = CurrentModule;
CurrentModule = DBLOAD_MODULE;
Yap_InitCPred("exo_db_get_space", 4, p_exodb_get_space, 0L);
Yap_InitCPred("exoassert", 3, p_exoassert, 0L);
CurrentModule = cm;
}