YAP 7.1.0
exo.c
1
2/*************************************************************************
3* *
4* YAP Prolog *
5* *
6* Yap Prolog was developed at NCCUP - Universidade do Porto *
7* *
8* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
9* *
10**************************************************************************
11* *
12* File: exo.c *
13* comments: Exo compilation *
14* *
15* Last rev: $Date: 2008-07-22 23:34:44 $,$Author: vsc $ * *
16* $Log: not supported by cvs2svn $ *
17* *
18* *
19*************************************************************************/
20
21#include "Yap.h"
22#include "clause.h"
23#include "yapio.h"
24#include "YapEval.h"
25#include "tracer.h"
26#ifdef YAPOR
27#include "or.macros.h"
28#endif /* YAPOR */
29#ifdef TABLING
30#include "tab.macros.h"
31#endif /* TABLING */
32#if HAVE_STRING_H
33#include <string.h>
34#endif
35#if HAVE_STRING_H
36#include <string.h>
37#endif
38#if HAVE_STDBOOL_H
39#include <stdbool.h>
40#endif
41
42bool YAP_NewExo( PredEntry *ap, size_t data, struct udi_info *udi);
43bool YAP_AssertTuples( PredEntry *pe, const Term *ts, size_t offset, size_t m);
44
45//static int exo_write=FALSE;
46
47//void do_write(void) { exo_write=TRUE;}
48
49#define MAX_ARITY 256
50
51#if SIZEOF_INT_P==4
52#define FNV32_PRIME (16777619UL)
53#define FNV32_OFFSET (0x811c9dc5UL)
54#define FNV_PRIME FNV32_PRIME
55#define FNV_OFFSET FNV32_OFFSET
56#elif SIZEOF_INT_P==8
57#define FNV64_PRIME (1099511628211)
58#if SIZEOF_LONG_INT==4
59#define FNV64_OFFSET (14695981039346656037ULL)
60#else
61#define FNV64_OFFSET (14695981039346656037UL)
62#endif
63#define FNV_PRIME FNV64_PRIME
64#define FNV_OFFSET FNV64_OFFSET
65#endif
66
67/*MurmurHash3 from: https://code.google.com/p/smhasher/wiki/MurmurHash3*/
68BITS32 rotl32 ( BITS32, int8_t);
69
70inline BITS32 rotl32 ( BITS32 x, int8_t r )
71{
72 return (x << r) | (x >> (32 - r));
73}
74#define ROTL32(x,y) rotl32(x,y)
75//-----------------------------------------------------------------------------
76// Finalization mix - force all bits of a hash block to avalanche
77
78BITS32 fmix32 ( BITS32 );
79inline BITS32 fmix32 ( BITS32 h )
80{
81 h ^= h >> 16;
82 h *= 0x85ebca6b;
83 h ^= h >> 13;
84 h *= 0xc2b2ae35;
85 h ^= h >> 16;
86
87 return h;
88}
89//-----------------------------------------------------------------------------
90INLINE_ONLY BITS32
91HASH_MURMUR3_32 (UInt arity, CELL *cl, UInt bnds[], UInt sz);
92
93INLINE_ONLY BITS32
94HASH_MURMUR3_32 (UInt arity, CELL *cl, UInt bnds[], UInt sz)
95{
96 UInt hash;
97 UInt j=0;
98 int len = 0;
99 const BITS32 c1 = 0xcc9e2d51;
100 const BITS32 c2 = 0x1b873593;
101
102 hash = FNV_OFFSET; /*did not find what seed to use yet*/
103
104 while (j < arity) {
105 if (bnds[j]) {
106 unsigned char *i=(unsigned char*)(cl+j);
107 unsigned char *m=(unsigned char*)(cl+(j+1));
108
109 while (i < m) {
110 BITS32 k1 = i[0];
111
112 k1 *= c1;
113 k1 = ROTL32(k1,15);
114 k1 *= c2;
115
116 hash ^= k1;
117 hash = ROTL32(hash,13);
118 hash = hash*5+0xe6546b64;
119 i++;
120 len++;
121 }
122 }
123 j++;
124 }
125
126 //----------
127 // tail not used becouse len is block multiple
128
129 //----------
130 // finalization
131
132 hash ^= len;
133
134 hash = fmix32(hash);
135
136 return hash;
137}
138
139/*DJB2*/
140#define DJB2_OFFSET 5381
141
142INLINE_ONLY BITS32
143HASH_DJB2(UInt arity, CELL *cl, UInt bnds[], UInt sz);
144
145INLINE_ONLY BITS32
146HASH_DJB2(UInt arity, CELL *cl, UInt bnds[], UInt sz)
147{
148 BITS32 hash;
149 UInt j=0;
150
151 hash = DJB2_OFFSET;
152 while (j < arity) {
153 if (bnds[j]) {
154 unsigned char *i=(unsigned char*)(cl+j);
155 unsigned char *m=(unsigned char*)(cl+(j+1));
156
157 while (i < m) {
158 BITS32 h5 = hash << 5;
159 hash += h5 + i[0]; /* hash * 33 + i[0] */
160 i++;
161 }
162 }
163 j++;
164 }
165 return hash;
166}
167
168INLINE_ONLY BITS32
169HASH_RS(UInt arity, CELL *cl, UInt bnds[], UInt sz);
170
171/* RS Hash Function */
172INLINE_ONLY BITS32
173HASH_RS(UInt arity, CELL *cl, UInt bnds[], UInt sz)
174{
175 UInt hash=0;
176 UInt j=0;
177
178 UInt b = 378551;
179 UInt a = 63689;
180
181 while (j < arity) {
182 if (bnds[j]) {
183 unsigned char *i=(unsigned char*)(cl+j);
184 unsigned char *m=(unsigned char*)(cl+(j+1));
185
186 while (i < m) {
187 hash = hash * a + i[0];
188 a = a * b;
189 i++;
190 }
191 }
192 j++;
193 }
194 return hash;
195}
196
197INLINE_ONLY BITS32
198HASH_FVN_1A(UInt arity, CELL *cl, UInt bnds[], UInt sz);
199
200/* Simple hash function:
201 FVN-1A
202 first component is the base key.
203 hash0 spreads extensions coming from different elements.
204 spread over j quadrants.
205 */
206INLINE_ONLY BITS32
207HASH_FVN_1A(UInt arity, CELL *cl, UInt bnds[], UInt sz)
208{
209 UInt hash;
210 UInt j=0;
211
212 hash = FNV_OFFSET;
213 while (j < arity) {
214 if (bnds[j]) {
215 unsigned char *i=(unsigned char*)(cl+j);
216 unsigned char *m=(unsigned char*)(cl+(j+1));
217
218 while (i < m) {
219 hash = hash ^ i[0];
220 hash = hash * FNV_PRIME;
221 i++;
222 }
223 }
224 j++;
225 }
226 return hash;
227}
228
229//#define TEST_HASH_DJB 1
230
231#if defined TEST_HASH_MURMUR
232# define HASH(...) HASH_MURMUR3_32(__VA_ARGS__)
233#elif defined TEST_HASH_DJB
234# define HASH(...) HASH_DJB2(__VA_ARGS__)
235#elif defined TEST_HASH_RS
236# define HASH(...) HASH_RS(__VA_ARGS__)
237#else
238/* Default: TEST_HASH_FVN */
239# define HASH(...) HASH_FVN_1A(__VA_ARGS__)
240# define HASH1(...) HASH_MURMUR3_32(__VA_ARGS__)
241#endif
242
243static BITS32
244NEXT(UInt arity, CELL *cl, UInt bnds[], UInt sz, BITS32 hash)
245{
246 int i = 0;
247 BITS32 hash1;
248
249 while (bnds[i]==0) i++;
250 hash1 = HASH1(arity, cl, bnds, sz);
251 return (hash + hash1 +cl[i]);
252}
253
254/* search for matching elements */
255static int
256MATCH(CELL *clp, CELL *kvp, UInt arity, UInt bnds[])
257{
258 UInt j = 0;
259 while (j< arity) {
260 if ( bnds[j] && clp[j] != kvp[j])
261 return FALSE;
262 j++;
263 }
264 return TRUE;
265}
266
267static void
268ADD_TO_TRY_CHAIN(CELL *kvp, CELL *cl, struct index_t *it)
269{
270 BITS32 old = EXO_ADDRESS_TO_OFFSET(it, kvp);
271 BITS32 new = EXO_ADDRESS_TO_OFFSET(it, cl);
272 BITS32 *links = it->links;
273 BITS32 tmp = links[old]; /* points to the end of the chain */
274
275 if (!tmp) {
276 links[old] = links[new] = new;
277 } else {
278 links[new] = links[tmp];
279 links[tmp] = new;
280 links[old] = new;
281 }
282}
283
284/* This is the critical routine, it builds the hash table *
285 * each HT field stores a key pointer which is actually
286 * a pointer to the point in the clause where one can find the element.
287 *
288 * The cls table indexes all elements that can be reached using that key.
289 *
290 * Insert:
291 * j = first
292 * not match cij -> insert, open new chain
293 * match ci..j ck..j -> find j = minarg(cij \= c2j),
294 * else j = +inf -> c2+ci
295 * Lookup:
296 * j= first
297 * not match cij -> fail
298 * match ci..j ck..j -> find j = minarg(cij \= c2j)
299 * else
300 */
301static int
302INSERT(CELL *cl, struct index_t *it, UInt arity, UInt base, UInt bnds[])
303{
304 CELL *kvp;
305 BITS32 hash;
306 int coll_count = 0;
307
308
309 hash = HASH(arity, cl, bnds, it->hsize);
310 next:
311 kvp = EXO_OFFSET_TO_ADDRESS(it, it->key [hash % it->hsize]);
312 if (kvp == NULL) {
313 /* simple case, new entry */
314 it->nentries++;
315 it->key[hash % it->hsize ] = EXO_ADDRESS_TO_OFFSET(it, cl);
316 if (coll_count > it -> max_col_count)
317 it->max_col_count = coll_count;
318 return TRUE;
319 } else if (MATCH(kvp, cl, arity, bnds)) {
320 it->ntrys++;
321 ADD_TO_TRY_CHAIN(kvp, cl, it);
322 return TRUE;
323 } else {
324 coll_count++;
325 it->ncollisions++;
326 // printf("#");
327 hash = NEXT(arity, cl, bnds, it->hsize, hash);
328 //if (exo_write) printf("N=%ld\n", hash);
329 goto next;
330 }
331}
332
333static yamop *
334LOOKUP(struct index_t *it, UInt arity, UInt j, UInt bnds[])
335{
336 CACHE_REGS
337 CELL *kvp;
338 BITS32 hash;
339
340 /* j is the firs bound element */
341 /* check if we match */
342 hash = HASH(arity, XREGS+1, bnds, it->hsize);
343 next:
344 /* loop to insert element */
345 kvp = EXO_OFFSET_TO_ADDRESS(it, it->key[hash % it->hsize]);
346 if (kvp == NULL) {
347 /* simple case, no element */
348 return FAILCODE;
349 } else if (MATCH(kvp, XREGS+1, arity, bnds)) {
350 S = kvp;
351 if (!it->is_key && it->links[EXO_ADDRESS_TO_OFFSET(it, S)])
352 return it->code;
353 else
354 return NEXTOP(NEXTOP(it->code,lp),lp);
355 } else {
356 /* collision */
357 hash = NEXT(arity, XREGS+1, bnds, it->hsize, hash);
358 goto next;
359 }
360}
361
362static int
363fill_hash(UInt bmap, struct index_t *it, UInt bnds[])
364{
365 UInt i;
366 UInt arity = it->arity;
367 CELL *cl = it->cls;
368
369 for (i=0; i < it->nels; i++) {
370 if (!INSERT(cl, it, arity, 0, bnds))
371 return FALSE;
372 cl += arity;
373 }
374 for (i=0; i < it->hsize; i++) {
375 if (it->key[i]) {
376 BITS32 offset = it->key[i];
377 BITS32 last = it->links[offset];
378 if (last) {
379 /* the chain used to point straight to the last, and the last back to the original first */
380 it->links[offset] = it->links[last];
381 it->links[last] = 0;
382 }
383 }
384 }
385 return TRUE;
386}
387
388static struct index_t *
389add_index(struct index_t **ip, UInt bmap, PredEntry *ap, UInt count)
390{
391 CACHE_REGS
392 UInt ncls = ap->cs.p_code.NOfClauses, j;
393 CELL *base = NULL;
394 struct index_t *i;
395 size_t sz, dsz;
396 yamop *ptr;
397 UInt *bnds = LOCAL_ibnds;
398
399 sz = (CELL)NEXTOP(NEXTOP((yamop*)NULL,lp),lp)+ap->ArityOfPE*(CELL)NEXTOP((yamop *)NULL,x) +(CELL)NEXTOP(NEXTOP((yamop *)NULL,p),l);
400 if (!(i = (struct index_t *)Yap_AllocCodeSpace(sizeof(struct index_t)+sz))) {
401 CACHE_REGS
402 save_machine_regs();
403 LOCAL_Error_Size = 3*ncls*sizeof(CELL);
404 LOCAL_ErrorMessage = "not enough space to index";
405 Yap_Error(RESOURCE_ERROR_HEAP, TermNil, LOCAL_ErrorMessage);
406 return NULL;
407 }
408 i->is_key = FALSE;
409 i->next = *ip;
410 i->prev = NULL;
411 i->nels = ncls;
412 i->arity = ap->ArityOfPE;
413 i->ap = ap;
414 i->bmap = bmap;
415 i->is_key = FALSE;
416 i->hsize = 2*ncls;
417 dsz = sizeof(BITS32)*(ncls+1+i->hsize);
418 if (count) {
419 if (!(base = (CELL *)Yap_AllocCodeSpace(dsz))) {
420 CACHE_REGS
421 save_machine_regs();
422 LOCAL_Error_Size = dsz;
423 LOCAL_ErrorMessage = "not enough space to generate indices";
424 Yap_FreeCodeSpace((void *)i);
425 Yap_Error(RESOURCE_ERROR_HEAP, TermNil, LOCAL_ErrorMessage);
426 return NULL;
427 }
428 memset(base, 0, dsz);
429 }
430 i->size = sz+dsz+sizeof(struct index_t);
431 i->key = (BITS32 *)base;
432 i->links = (BITS32 *)base+i->hsize;
433 i->ncollisions = i->nentries = i->ntrys = 0;
434 i->cls = (CELL *)((ADDR)ap->cs.p_code.FirstClause+2*sizeof(struct index_t *));
435 i->bcls= i->cls-i->arity;
436 i->udi_free_args = 0;
437 i->is_udi = FALSE;
438 i->udi_arg = 0;
439 *ip = i;
440 while (count) {
441 if (!fill_hash(bmap, i, bnds)) {
442 size_t sz;
443 i->hsize += ncls;
444 if (i->is_key) {
445 sz = i->hsize*sizeof(BITS32);
446 } else {
447 sz = (ncls+1+i->hsize)*sizeof(BITS32);
448 }
449 if (base != (CELL *)Yap_ReallocCodeSpace((char *)base, sz))
450 return FALSE;
451 memset(base, 0, sz);
452 i->key = (BITS32 *)base;
453 i->links = (BITS32 *)(base+i->hsize);
454 i->ncollisions = i->nentries = i->ntrys = 0;
455 continue;
456 }
457#if DEBUG
458 fprintf(stderr, "entries=" UInt_FORMAT " collisions=" UInt_FORMAT" (max=" UInt_FORMAT ") trys=" UInt_FORMAT "\n", i->nentries, i->ncollisions, i->max_col_count, i->ntrys);
459#endif
460 if (!i->ntrys && !i->is_key) {
461 i->is_key = TRUE;
462 if (base != (CELL *)Yap_ReallocCodeSpace((char *)base, i->hsize*sizeof(BITS32)))
463 return FALSE;
464 }
465 /* our hash table is just too large */
466 if (( i->nentries+i->ncollisions )*10 < i->hsize) {
467 size_t sz;
468 i->hsize = ( i->nentries+i->ncollisions )*10;
469 if (i->is_key) {
470 sz = i->hsize*sizeof(BITS32);
471 } else {
472 sz = (ncls+1+i->hsize)*sizeof(BITS32);
473 }
474 if (base != (CELL *)Yap_ReallocCodeSpace((char *)base, sz))
475 return FALSE;
476 memset(base, 0, sz);
477 i->key = (BITS32 *)base;
478 i->links = (BITS32 *)base+i->hsize;
479 i->ncollisions = i->nentries = i->ntrys = 0;
480 } else {
481 break;
482 }
483 }
484 ptr = (yamop *)(i+1);
485 i->code = ptr;
486 if (count)
487 ptr->opc = Yap_opcode(_try_exo);
488 else
489 ptr->opc = Yap_opcode(_try_all_exo);
490 ptr->y_u.lp.l = (yamop *)i;
491 ptr->y_u.lp.p = ap;
492 ptr = NEXTOP(ptr, lp);
493 if (count)
494 ptr->opc = Yap_opcode(_retry_exo);
495 else
496 ptr->opc = Yap_opcode(_retry_all_exo);
497 ptr->y_u.lp.p = ap;
498 ptr->y_u.lp.l = (yamop *)i;
499 ptr = NEXTOP(ptr, lp);
500 for (j = 0; j < i->arity; j++) {
501 ptr->opc = Yap_opcode(_get_atom_exo);
502#if PRECOMPUTE_REGADDRESS
503 ptr->y_u.x.x = (CELL) (XREGS + (j+1));
504#else
505 ptr->y_u.x.x = j+1;
506#endif
507 ptr = NEXTOP(ptr, x);
508 }
509 ptr->opc = Yap_opcode(_procceed);
510 ptr->y_u.p.p = ap;
511 ptr = NEXTOP(ptr, p);
512 ptr->opc = Yap_opcode(_Ystop);
513 ptr->y_u.l.l = i->code;
514 Yap_inform_profiler_of_clause((char *)(i->code), (char *)NEXTOP(ptr,l), ap, GPROF_INDEX);
515 if (ap->PredFlags & UDIPredFlag) {
516 Yap_new_udi_clause( ap, NULL, (Term)ip);
517 } else {
518 i->is_udi = FALSE;
519 }
520 return i;
521}
522
523yamop *
524Yap_ExoLookup(PredEntry *ap USES_REGS)
525{
526 UInt arity = ap->ArityOfPE;
527 UInt bmap = 0L, bit = 1, count = 0, j, j0 = 0;
528 struct index_t **ip = (struct index_t **)(ap->cs.p_code.FirstClause);
529 struct index_t *i = *ip;
530
531 for (j=0; j< arity; j++, bit<<=1) {
532 Term t = Deref(XREGS[j+1]);
533 if (!IsVarTerm(t)) {
534 bmap += bit;
535 LOCAL_ibnds[j] = TRUE;
536 if (!count) j0= j;
537 count++;
538 } else {
539 LOCAL_ibnds[j] = FALSE;
540 }
541 XREGS[j+1] = t;
542 }
543
544 while (i) {
545 // if (i->is_key && (i->bmap & bmap) == i->bmap) {
546 // break;
547 // }
548 if (i->bmap == bmap) {
549 break;
550 }
551 ip = &i->next;
552 i = i->next;
553 }
554 if (!i) {
555 i = add_index(ip, bmap, ap, count);
556 }
557 if (count) {
558 yamop *code = LOOKUP(i, arity, j0, LOCAL_ibnds);
559 if (code == FAILCODE)
560 return code;
561 if (i->is_udi)
562 return ((CEnterExoIndex)i->udi_first)(i PASS_REGS);
563 else
564 return code;
565 } else if(i->is_udi) {
566 return ((CEnterExoIndex)i->udi_first)(i PASS_REGS);
567 } else {
568 return i->code;
569 }
570}
571
572CELL
573Yap_NextExo(choiceptr cptr, struct index_t *it)
574{
575 CACHE_REGS
576 BITS32 offset = ADDRESS_TO_LINK(it,(BITS32 *)((CELL *)(B+1))[it->arity]);
577 BITS32 next = it->links[offset];
578 ((CELL *)(B+1))[it->arity] = (CELL)LINK_TO_ADDRESS(it, next);
579 S = it->cls+it->arity*offset;
580 return next;
581}
582
583static MegaClause *
584exodb_get_space( Term t, Term mod, Term tn )
585{
586 UInt arity;
587 Prop pe;
588 PredEntry *ap;
589 MegaClause *mcl;
590 UInt ncls;
591 UInt required;
592 struct index_t **li;
593
594
595 if (IsVarTerm(mod) || !IsAtomTerm(mod)) {
596 return NULL;
597 }
598 if (IsAtomTerm(t)) {
599 Atom a = AtomOfTerm(t);
600 arity = 0;
601 pe = PredPropByAtom(a, mod);
602 } else if (IsApplTerm(t)) {
603 register Functor f = FunctorOfTerm(t);
604 arity = ArityOfFunctor(f);
605 pe = PredPropByFunc(f, mod);
606 } else {
607 return NULL;
608 }
609 if (EndOfPAEntr(pe))
610 return NULL;
611 ap = RepPredProp(pe);
612 if (ap->PredFlags & (DynamicPredFlag|LogUpdatePredFlag
613#ifdef TABLING
614 |TabledPredFlag
615#endif /* TABLING */
616 )) {
617 Yap_Error(PERMISSION_ERROR_MODIFY_STATIC_PROCEDURE,t,"dbload_get_space/4");
618 return NULL;
619 }
620 if (IsVarTerm(tn) || !IsIntegerTerm(tn)) {
621 return NULL;
622 }
623 ncls = IntegerOfTerm(tn);
624 if (ncls <= 1) {
625 return NULL;
626 }
627
628 required = ncls*arity*sizeof(CELL)+sizeof(MegaClause)+2*sizeof(struct index_t *);
629 while (!(mcl = (MegaClause *)Yap_AllocCodeSpace(required))) {
630 if (!Yap_growheap(FALSE, required, NULL)) {
631 /* just fail, the system will keep on going */
632 return NULL;
633 }
634 }
635 Yap_ClauseSpace += required;
636 /* cool, it's our turn to do the conversion */
637 mcl->ClFlags = MegaMask|ExoMask;
638 mcl->ClSize = required;
639 mcl->ClPred = ap;
640 mcl->ClItemSize = arity*sizeof(CELL);
641 mcl->ClNext = NULL;
642 li = (struct index_t **)(mcl->ClCode);
643 li[0] = li[1] = NULL;
644 ap->cs.p_code.FirstClause =
645 ap->cs.p_code.LastClause =
646 mcl->ClCode;
647 ap->PredFlags |= MegaClausePredFlag;
648 ap->cs.p_code.NOfClauses = ncls;
649 if (ap->PredFlags & (SpiedPredFlag|CountPredFlag|ProfiledPredFlag)) {
650 ap->OpcodeOfPred = Yap_opcode(_spy_pred);
651 } else {
652 ap->OpcodeOfPred = Yap_opcode(_enter_exo);
653 }
654 ap->CodeOfPred = ap->cs.p_code.TrueCodeOfPred = (yamop *)(&(ap->OpcodeOfPred));
655 return mcl;
656}
657
658bool
659YAP_NewExo( PredEntry *ap, size_t data, struct udi_info *udi)
660{
661 MegaClause *mcl;
662 size_t required;
663 struct index_t **li;
664
665 if (data <= ap->ArityOfPE*sizeof(CELL)) {
666 return false;
667 }
668 // data = ncls*arity*sizeof(CELL);
669 required = data+sizeof(MegaClause)+2*sizeof(struct index_t *);
670 while (!(mcl = (MegaClause *)Yap_AllocCodeSpace(required))) {
671 if (!Yap_growheap(FALSE, required, NULL)) {
672 /* just fail, the system will keep on going */
673 return false;
674 }
675 }
676 Yap_ClauseSpace += required;
677 /* cool, it's our turn to do the conversion */
678 mcl->ClFlags = MegaMask|ExoMask;
679 mcl->ClSize = required;
680 mcl->ClPred = ap;
681 mcl->ClItemSize = ap->ArityOfPE*sizeof(CELL);
682 mcl->ClNext = NULL;
683 li = (struct index_t **)(mcl->ClCode);
684 li[0] = li[1] = NULL;
685 ap->cs.p_code.FirstClause =
686 ap->cs.p_code.LastClause =
687 mcl->ClCode;
688 ap->PredFlags |= MegaClausePredFlag;
689 ap->cs.p_code.NOfClauses = 0;
690 if (ap->PredFlags & (SpiedPredFlag|CountPredFlag|ProfiledPredFlag)) {
691 ap->OpcodeOfPred = Yap_opcode(_spy_pred);
692 } else {
693 ap->OpcodeOfPred = Yap_opcode(_enter_exo);
694 }
695 ap->CodeOfPred = ap->cs.p_code.TrueCodeOfPred = (yamop *)(&(ap->OpcodeOfPred));
696 return true;
697}
698
699static Int
700p_exodb_get_space( USES_REGS1 )
701{ /* '$number_of_clauses'(Predicate,M,N) */
702 void *mcl;
703
704 if ((mcl = exodb_get_space(Deref(ARG1), Deref(ARG2), Deref(ARG3))) == NULL)
705 return FALSE;
706
707 return Yap_unify(ARG4, MkIntegerTerm((Int)mcl));
708}
709
710#define DerefAndCheck(t, V) \
711 t = Deref(V); if(IsVarTerm(t) || !(IsAtomOrIntTerm(t))) Yap_Error(TYPE_ERROR_ATOMIC, t0, "load_db");
712
713static Int
714store_exo(yamop *pc, UInt arity, Term t0)
715{
716 Term t;
717 CELL *tp = RepAppl(t0)+1,
718 *cpc = (CELL *)pc;
719 UInt i;
720 for (i = 0; i< arity; i++) {
721 DerefAndCheck(t, tp[0]);
722 *cpc = t;
723 // Yap_DebugPlWrite(t); fprintf(stderr,"\n");
724 tp++;
725 cpc++;
726 }
727 //fprintf(stderr,"\n");
728 return TRUE;
729}
730
731bool
732YAP_AssertTuples( PredEntry *pe, const Term *ts, size_t offset, size_t m)
733{
734 MegaClause *mcl = ClauseCodeToMegaClause(pe->cs.p_code.FirstClause);
735 size_t i;
736 ADDR base = (ADDR)mcl->ClCode+2*sizeof(struct index_t *);
737 for (i=0; i<m; i++) {
738 yamop *ptr = (yamop *)(base+offset*(mcl->ClItemSize));
739 store_exo( ptr, pe->ArityOfPE, ts[i]);
740 }
741 return true;
742}
743
744static void
745exoassert( void *handle, Int n, Term term )
746{ /* '$number_of_clauses'(Predicate,M,N) */
747 PredEntry *pe;
748 MegaClause *mcl;
749
750
751 mcl = (MegaClause *) handle;
752 pe = mcl->ClPred;
753 store_exo((yamop *)((ADDR)mcl->ClCode+2*sizeof(struct index_t *)+n*(mcl->ClItemSize)),pe->ArityOfPE, term);
754}
755
756static Int
757p_exoassert( USES_REGS1 )
758{ /* '$number_of_clauses'(Predicate,M,N) */
759 Term thandle = Deref(ARG2);
760 Term tn = Deref(ARG3);
761 MegaClause *mcl;
762 Int n;
763
764
765 if (IsVarTerm(thandle) || !IsIntegerTerm(thandle)) {
766 return FALSE;
767 }
768 mcl = (MegaClause *)IntegerOfTerm(thandle);
769 if (IsVarTerm(tn) || !IsIntegerTerm(tn)) {
770 return FALSE;
771 }
772 n = IntegerOfTerm(tn);
773 exoassert(mcl,n,Deref(ARG1));
774 return TRUE;
775}
776
777void
778Yap_InitExoPreds(void)
779{
780 CACHE_REGS
781 Term cm = CurrentModule;
782
783 CurrentModule = DBLOAD_MODULE;
784 Yap_InitCPred("exo_db_get_space", 4, p_exodb_get_space, 0L);
785 Yap_InitCPred("exoassert", 3, p_exoassert, 0L);
786 CurrentModule = cm;
787}
Main definitions.
A matrix.
Definition: matrix.c:68
Definition: Yatom.h:544
Definition: amidefs.h:264