YAP 7.1.0
adtdefs.c
1/*************************************************************************
2* *
3* YAP Prolog *
4* *
5* Yap Prolog was developed at NCCUP - Universidade do Porto *
6* *
7* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
8* *
9**************************************************************************
10* *
11* File: adtdefs.c *
12* Last rev: *
13* mods: *
14* comments: abstract machine definitions *
15* *
16*************************************************************************/
17#ifdef SCCS
18static char SccsId[] = "%W% %G%";
19#endif
20
21#define ADTDEFS_C
22
23#ifdef __SUNPRO_CC
24#define inline
25#endif
26
27#include "Yap.h"
28#include "Yatom.h"
29#include "clause.h"
30#include "alloc.h"
31#include "yapio.h"
32#include <stdio.h>
33#include <wchar.h>
34#if HAVE_STRING_Hq
35#include <string.h>
36#endif
37
38uint64_t HashFunction(const unsigned char *CHP) {
39 /* djb2 */
40 uint64_t hash = 5381;
41 uint64_t c;
42
43 while ((c = *CHP++) != '\0') {
44 /* hash = ((hash << 5) + hash) + c; hash * 33 + c */
45 hash = hash * (uint64_t)33 + c;
46 }
47 return hash;
48 /*
49 UInt OUT=0, i = 1;
50 while(*CHP != '\0') { OUT += (UInt)(*CHP++); }
51 return OUT;
52 */
53}
54
55/* this routine must be run at least having a read lock on ae */
56static Prop
57GetFunctorProp(AtomEntry *ae,
58 arity_t arity) { /* look property list of atom a for kind */
59
60 PropEntry *p = ae->PropsOfAE;
61 while (p != NIL) {
62 if (p->KindOfPE == FunctorProperty &&
63 RepFunctorProp(p)->ArityOfFE == arity) {
64 return p;
65 }
66 p = p->NextOfPE;
67 }
68 return NIL;
69}
70
71/* vsc: We must guarantee that IsVarTerm(functor) returns true! */
72static inline Functor InlinedUnlockedMkFunctor(AtomEntry *ae, arity_t arity) {
73 FunctorEntry *p;
74 Prop p0;
75
76 p0 = GetFunctorProp(ae, arity);
77 if (p0 != NIL) {
78 return ((Functor)RepProp(p0));
79 }
80 p = (FunctorEntry *)Yap_AllocAtomSpace(sizeof(*p));
81 if (!p)
82 return NULL;
83 p->KindOfPE = FunctorProperty;
84 p->NameOfFE = AbsAtom(ae);
85 p->ArityOfFE = arity;
86 p->PropsOfFE = NIL;
87 INIT_RWLOCK(p->FRWLock);
88 /* respect the first property, in case this is a wide atom */
89 AddPropToAtom(ae, (PropEntry *)p);
90 return ((Functor)p);
91}
92
93Functor Yap_UnlockedMkFunctor(AtomEntry *ae, arity_t arity) {
94 return (InlinedUnlockedMkFunctor(ae, arity));
95}
96
97/* vsc: We must guarantee that IsVarTerm(functor) returns true! */
98Functor Yap_MkFunctor(Atom ap, arity_t arity) {
99 AtomEntry *ae = RepAtom(ap);
100 Functor f;
101
102 WRITE_LOCK(ae->ARWLock);
103 f = InlinedUnlockedMkFunctor(ae, arity);
104 WRITE_UNLOCK(ae->ARWLock);
105 return f;
106}
107
108/* vsc: We must guarantee that IsVarTerm(functor) returns true! */
109void Yap_MkFunctorWithAddress(Atom ap, unsigned int arity, FunctorEntry *p) {
110 AtomEntry *ae = RepAtom(ap);
111
112 WRITE_LOCK(ae->ARWLock);
113 p->KindOfPE = FunctorProperty;
114 p->NameOfFE = ap;
115 p->ArityOfFE = arity;
116 AddPropToAtom(ae, (PropEntry *)p);
117 WRITE_UNLOCK(ae->ARWLock);
118}
119
120inline static Atom SearchInInvisible(const unsigned char *atom) {
121 AtomEntry *chain;
122
123 READ_LOCK(INVISIBLECHAIN.AERWLock);
124 chain = RepAtom(INVISIBLECHAIN.Entry);
125 while (!EndOfPAEntr(chain) && strcmp((char *)chain->StrOfAE, (char *)atom)) {
126 chain = RepAtom(chain->NextOfAE);
127 }
128 READ_UNLOCK(INVISIBLECHAIN.AERWLock);
129 if (EndOfPAEntr(chain))
130 return (NIL);
131 else
132 return (AbsAtom(chain));
133}
134
135static inline Atom SearchAtom(const unsigned char *p, Atom a) {
136 AtomEntry *ae;
137 const char *ps = (const char *)p;
138
139 /* search atom in chain */
140 while (a != NIL) {
141 ae = RepAtom(a);
142 if (strcmp(ae->StrOfAE, ps) == 0) {
143 return (a);
144 }
145 a = ae->NextOfAE;
146 }
147 return (NIL);
148}
149
150
151static Atom
152LookupAtom(const unsigned char *atom) { /* lookup atom in atom table */
153 uint64_t hash;
154 const unsigned char *p;
155 Atom a, na = NIL;
156 AtomEntry *ae;
157 size_t sz = AtomHashTableSize;
158 /* compute hash */
159 p = atom;
160
161 if (atom==NULL) return NULL;
162 hash = HashFunction(p);
163 hash = hash % sz;
164 /* we'll start by holding a read lock in order to avoid contention */
165 READ_LOCK(HashChain[hash].AERWLock);
166 a = HashChain[hash].Entry;
167 /* search atom in chain */
168 na = SearchAtom(atom, a);
169 if (na != NIL) {
170 READ_UNLOCK(HashChain[hash].AERWLock);
171 return (na);
172 }
173 READ_UNLOCK(HashChain[hash].AERWLock);
174 /* we need a write lock */
175 WRITE_LOCK(HashChain[hash].AERWLock);
176/* concurrent version of Yap, need to take care */
177#if defined(YAPOR) || defined(THREADS)
178 if (a != HashChain[hash].Entry) {
179 a = HashChain[hash].Entry;
180 na = SearchAtom(atom, a);
181 if (na != NIL) {
182 WRITE_UNLOCK(HashChain[hash].AERWLock);
183 return na;
184 }
185 }
186#endif
187 /* add new atom to start of chain */
188 sz = strlen((const char *)atom);
189 size_t asz = (sizeof *ae) + ( sz+1);
190 ae = malloc(asz);
191 if (ae == NULL) {
192 WRITE_UNLOCK(HashChain[hash].AERWLock);
193 return NIL;
194 }
195 // enable fast hashing by making sure that
196 // the last cell is fully initialized.
197 CELL *aec = (CELL*)ae;
198 aec[asz/(YAP_ALIGN+1)-1] = 0;
199 NOfAtoms++;
200 na = AbsAtom(ae);
201 ae->PropsOfAE = NIL;
202 strcpy(ae->StrOfAE, (const char *)atom);
203
204 ae->NextOfAE = a;
205 HashChain[hash].Entry = na;
206 INIT_RWLOCK(ae->ARWLock);
207 WRITE_UNLOCK(HashChain[hash].AERWLock);
208 if (NOfAtoms > 2 * AtomHashTableSize) {
209 Yap_signal(YAP_CDOVF_SIGNAL);
210 }
211
212 return na;
213}
214
215Atom Yap_LookupAtomWithLength(const char *atom,
216 size_t len0) { /*
217lookup atom in atom table */
218 Atom at;
219 unsigned char *ptr;
220
221 /* not really a wide atom */
222 if (atom==NULL) return NULL;
223 ptr = Yap_AllocCodeSpace(len0 + 1);
224 if (!ptr)
225 return NIL;
226 memcpy(ptr, atom, len0);
227 ptr[len0] = '\0';
228 at = LookupAtom(ptr);
229 return at;
230 }
231
232 Atom Yap_LookupAtom(const char *atom) { /* lookup atom in atom table */
233 return LookupAtom((const unsigned char *)atom);
234 }
235
236 Atom Yap_ULookupAtom(
237 const unsigned char *atom) { /* lookup atom in atom table */
238 return LookupAtom(atom);
239 }
240
241
242 Atom Yap_FullLookupAtom(const char *atom) { /* lookup atom in atom table */
243 Atom t;
244
245 if ((t = SearchInInvisible((const unsigned char *)atom)) != NIL) {
246 return (t);
247 }
248 return LookupAtom((const unsigned char *)atom);
249 }
250
251 void Yap_LookupAtomWithAddress(const char *atom,
252 AtomEntry *ae) { /* lookup atom in atom table */
253 register CELL hash;
254 register const unsigned char *p;
255 Atom a;
256
257 if (atom == NULL) return;
258 /* compute hash */
259 p = (const unsigned char *)atom;
260 hash = HashFunction(p) % AtomHashTableSize;
261 /* ask for a WRITE lock because it is highly unlikely we shall find anything
262 */
263 WRITE_LOCK(HashChain[hash].AERWLock);
264 a = HashChain[hash].Entry;
265 /* search atom in chain */
266 if (SearchAtom(p, a) != NIL) {
267 Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil,
268 "repeated initialization for atom %s", ae);
269 WRITE_UNLOCK(HashChain[hash].AERWLock);
270 return;
271 }
272 /* add new atom to start of chain */
273 NOfAtoms++;
274 ae->NextOfAE = a;
275 HashChain[hash].Entry = AbsAtom(ae);
276 ae->PropsOfAE = NIL;
277 strcpy((char *)ae->StrOfAE, (char *)atom);
278 INIT_RWLOCK(ae->ARWLock);
279 WRITE_UNLOCK(HashChain[hash].AERWLock);
280 }
281
282 void Yap_ReleaseAtom(Atom atom) { /* Releases an atom from the hash chain */
283 register Int hash;
284 register const unsigned char *p;
285 AtomEntry *inChain;
286 AtomEntry *ap = RepAtom(atom);
287 char unsigned *name = ap->UStrOfAE;
288
289 /* compute hash */
290 p = name;
291 hash = HashFunction(p) % AtomHashTableSize;
292 WRITE_LOCK(HashChain[hash].AERWLock);
293 if (HashChain[hash].Entry == atom) {
294 NOfAtoms--;
295 HashChain[hash].Entry = ap->NextOfAE;
296 WRITE_UNLOCK(HashChain[hash].AERWLock);
297 return;
298 }
299 /* else */
300 inChain = RepAtom(HashChain[hash].Entry);
301 while (inChain && inChain->NextOfAE != atom)
302 inChain = RepAtom(inChain->NextOfAE);
303 if (!inChain)
304 return;
305 WRITE_LOCK(inChain->ARWLock);
306 inChain->NextOfAE = ap->NextOfAE;
307 WRITE_UNLOCK(inChain->ARWLock);
308 WRITE_UNLOCK(HashChain[hash].AERWLock);
309 ap->NextOfAE = NULL;
310 }
311
312 static Prop
313 GetAPropHavingLock(AtomEntry *ae,
314 PropFlags kind) { /* look property list of atom a for kind */
315 PropEntry *pp;
316
317 pp = RepProp(ae->PropsOfAE);
318 while (!EndOfPAEntr(pp) && pp->KindOfPE != kind)
319 pp = RepProp(pp->NextOfPE);
320 return (AbsProp(pp));
321 }
322
323 Prop Yap_GetAPropHavingLock(
324 AtomEntry *ae, PropFlags kind) { /* look property list of atom a for kind */
325 return GetAPropHavingLock(ae, kind);
326 }
327
328 static Prop
329 GetAProp(Atom a, PropFlags kind) { /* look property list of atom a for kind */
330 AtomEntry *ae = RepAtom(a);
331 Prop out;
332
333 READ_LOCK(ae->ARWLock);
334 out = GetAPropHavingLock(ae, kind);
335 READ_UNLOCK(ae->ARWLock);
336 return (out);
337 }
338
339 Prop Yap_GetAProp(Atom a,
340 PropFlags kind) { /* look property list of atom a for kind */
341 return GetAProp(a, kind);
342 }
343
344 OpEntry *Yap_GetOpPropForAModuleHavingALock(
345 Atom a, Term mod) { /* look property list of atom a for kind */
346 AtomEntry *ae = RepAtom(a);
347 PropEntry *pp;
348
349 pp = RepProp(ae->PropsOfAE);
350 while (!EndOfPAEntr(pp) &&
351 (pp->KindOfPE != OpProperty || ((OpEntry *)pp)->OpModule != mod))
352 pp = RepProp(pp->NextOfPE);
353 if (EndOfPAEntr(pp)) {
354 return NULL;
355 }
356 return (OpEntry *)pp;
357 }
358
359 int Yap_HasOp(Atom a) { /* look property list of atom a for kind */
360 AtomEntry *ae = RepAtom(a);
361 PropEntry *pp;
362
363 READ_LOCK(ae->ARWLock);
364 pp = RepProp(ae->PropsOfAE);
365 while (!EndOfPAEntr(pp) && (pp->KindOfPE != OpProperty))
366 pp = RepProp(pp->NextOfPE);
367 READ_UNLOCK(ae->ARWLock);
368 if (EndOfPAEntr(pp)) {
369 return FALSE;
370 } else {
371 return TRUE;
372 }
373 }
374
375 OpEntry *
376 Yap_OpPropForModule(Atom a,
377 Term mod) { /* look property list of atom a for kind */
378 AtomEntry *ae = RepAtom(a);
379 PropEntry *pp;
380 OpEntry *info = NULL;
381
382 if (mod == TermProlog)
383 mod = PROLOG_MODULE;
384 WRITE_LOCK(ae->ARWLock);
385 pp = RepProp(ae->PropsOfAE);
386 while (!EndOfPAEntr(pp)) {
387 if (pp->KindOfPE == OpProperty) {
388 info = (OpEntry *)pp;
389 if (info->OpModule == mod) {
390 WRITE_LOCK(info->OpRWLock);
391 WRITE_UNLOCK(ae->ARWLock);
392 return info;
393 }
394 }
395 pp = pp->NextOfPE;
396 }
397 info = (OpEntry *)Yap_AllocAtomSpace(sizeof(OpEntry));
398 info->KindOfPE = Ord(OpProperty);
399 info->NextOfPE = NULL;
400 info->OpModule = mod;
401 info->OpName = a;
402 LOCK(OpListLock);
403 info->OpNext = OpList;
404 OpList = info;
405 UNLOCK(OpListLock);
406 AddPropToAtom(ae, (PropEntry *)info);
407 INIT_RWLOCK(info->OpRWLock);
408 WRITE_LOCK(info->OpRWLock);
409 WRITE_UNLOCK(ae->ARWLock);
410 info->Prefix = info->Infix = info->Posfix = 0;
411 return info;
412 }
413
414 OpEntry *
415 Yap_GetOpProp(Atom a, op_type type,
416 Term cmod USES_REGS) { /* look property list of atom a for kind */
417 AtomEntry *ae = RepAtom(a);
418 PropEntry *pp;
419 OpEntry *oinfo = NULL;
420
421 READ_LOCK(ae->ARWLock);
422 pp = RepProp(ae->PropsOfAE);
423 while (!EndOfPAEntr(pp)) {
424 OpEntry *info = NULL;
425 if (pp->KindOfPE != OpProperty) {
426 pp = RepProp(pp->NextOfPE);
427 continue;
428 }
429 info = (OpEntry *)pp;
430 if (info->OpModule != cmod && info->OpModule != PROLOG_MODULE) {
431 pp = RepProp(pp->NextOfPE);
432 continue;
433 }
434 if (type == INFIX_OP) {
435 if (!info->Infix) {
436 pp = RepProp(pp->NextOfPE);
437 continue;
438 }
439 } else if (type == POSFIX_OP) {
440 if (!info->Posfix) {
441 pp = RepProp(pp->NextOfPE);
442 continue;
443 }
444 } else {
445 if (!info->Prefix) {
446 pp = RepProp(pp->NextOfPE);
447 continue;
448 }
449 }
450 /* if it is not the latest module */
451 if (info->OpModule == PROLOG_MODULE) {
452 /* cannot commit now */
453 oinfo = info;
454 pp = RepProp(pp->NextOfPE);
455 } else {
456 READ_LOCK(info->OpRWLock);
457 READ_UNLOCK(ae->ARWLock);
458 return info;
459 }
460 }
461 if (oinfo) {
462 READ_LOCK(oinfo->OpRWLock);
463 READ_UNLOCK(ae->ARWLock);
464 return oinfo;
465 }
466 READ_UNLOCK(ae->ARWLock);
467 return NULL;
468 }
469
470 inline static Prop GetPredPropByAtomHavingLock(AtomEntry *ae, Term cur_mod)
471 /* get predicate entry for ap/arity; create it if neccessary. */
472 {
473 Prop p0;
474
475 p0 = ae->PropsOfAE;
476 while (p0) {
477 PredEntry *pe = RepPredProp(p0);
478 if (pe->KindOfPE == PEProp &&
479 (pe->ModuleOfPred == cur_mod || !pe->ModuleOfPred)) {
480 return (p0);
481#if THREADS
482 /* Thread Local Predicates */
483 if (pe->PredFlags & ThreadLocalPredFlag) {
484 return AbsPredProp(Yap_GetThreadPred(pe INIT_REGS));
485 }
486#endif
487 }
488 p0 = pe->NextOfPE;
489 }
490 return (NIL);
491 }
492
493 Prop Yap_GetPredPropByAtom(Atom at, Term cur_mod)
494 /* get predicate entry for ap/arity; create it if neccessary. */
495 {
496 Prop p0;
497 AtomEntry *ae = RepAtom(at);
498
499 READ_LOCK(ae->ARWLock);
500 p0 = GetPredPropByAtomHavingLock(ae, cur_mod);
501 READ_UNLOCK(ae->ARWLock);
502 return (p0);
503 }
504
505 inline static Prop GetPredPropByAtomHavingLockInThisModule(AtomEntry *ae, Term cur_mod)
506 /* get predicate entry for ap/arity; create it if neccessary. */
507 {
508 Prop p0;
509
510 p0 = ae->PropsOfAE;
511 while (p0) {
512 PredEntry *pe = RepPredProp(p0);
513 if (pe->KindOfPE == PEProp && pe->ModuleOfPred == cur_mod) {
514#if THREADS
515 /* Thread Local Predicates */
516 if (pe->PredFlags & ThreadLocalPredFlag) {
517 return AbsPredProp(Yap_GetThreadPred(pe INIT_REGS));
518 }
519#endif
520 return (p0);
521 }
522 p0 = pe->NextOfPE;
523 }
524 return (NIL);
525 }
526
527 Prop Yap_GetPredPropByAtomInThisModule(Atom at, Term cur_mod)
528 /* get predicate entry for ap/arity; create it if neccessary. */
529 {
530 Prop p0;
531 AtomEntry *ae = RepAtom(at);
532
533 READ_LOCK(ae->ARWLock);
534 p0 = GetPredPropByAtomHavingLockInThisModule(ae, cur_mod);
535 READ_UNLOCK(ae->ARWLock);
536 return (p0);
537 }
538
539
540 Prop Yap_GetPredPropByFunc(Functor f, Term cur_mod)
541 /* get predicate entry for ap/arity; */
542 {
543 Prop p0;
544 FUNC_READ_LOCK(f);
545
546 p0 = GetPredPropByFuncHavingLock(f, cur_mod);
547
548 FUNC_READ_UNLOCK(f);
549 return (p0);
550 }
551
552 Prop Yap_GetPredPropByFuncInThisModule(Functor f, Term cur_mod)
553 /* get predicate entry for ap/arity; */
554 {
555 Prop p0;
556
557 FUNC_READ_LOCK(f);
558 p0 = GetPredPropByFuncHavingLock(f, cur_mod);
559 FUNC_READ_UNLOCK(f);
560 return (p0);
561 }
562
563 Prop Yap_GetPredPropHavingLock(Atom ap, unsigned int arity, Term mod)
564 /* get predicate entry for ap/arity; */
565 {
566 Prop p0;
567 AtomEntry *ae = RepAtom(ap);
568 Functor f;
569
570 if (arity == 0) {
571 GetPredPropByAtomHavingLock(ae, mod);
572 }
573 f = InlinedUnlockedMkFunctor(ae, arity);
574 FUNC_READ_LOCK(f);
575 p0 = GetPredPropByFuncHavingLock(f, mod);
576 FUNC_READ_UNLOCK(f);
577 return (p0);
578 }
579
580 /* get expression entry for at/arity; */
581 Prop Yap_GetExpProp(Atom at, unsigned int arity) {
582 Prop p0;
583 AtomEntry *ae = RepAtom(at);
584 ExpEntry *p;
585
586 READ_LOCK(ae->ARWLock);
587 p = RepExpProp(p0 = ae->PropsOfAE);
588 while (p0 && (p->KindOfPE != ExpProperty || p->ArityOfEE != arity))
589 p = RepExpProp(p0 = p->NextOfPE);
590 READ_UNLOCK(ae->ARWLock);
591 return (p0);
592 }
593
594 /* get expression entry for at/arity, at is already locked; */
595 Prop Yap_GetExpPropHavingLock(AtomEntry *ae, unsigned int arity) {
596 Prop p0;
597 ExpEntry *p;
598
599 p = RepExpProp(p0 = ae->PropsOfAE);
600 while (p0 && (p->KindOfPE != ExpProperty || p->ArityOfEE != arity))
601 p = RepExpProp(p0 = p->NextOfPE);
602
603 return (p0);
604 }
605
606 static int ExpandPredHash(void) {
607 UInt new_size = PredHashTableSize + PredHashIncrement;
608 PredEntry **oldp = PredHash;
609 PredEntry **np =
610 (PredEntry **)Yap_AllocAtomSpace(sizeof(PredEntry **) * new_size);
611 UInt i;
612
613 if (!np) {
614 return FALSE;
615 }
616 for (i = 0; i < new_size; i++) {
617 np[i] = NULL;
618 }
619 for (i = 0; i < PredHashTableSize; i++) {
620 PredEntry *p = PredHash[i];
621
622 while (p) {
623 PredEntry *nextp = p->NextPredOfHash;
624 UInt hsh = PRED_HASH(p->FunctorOfPred, p->ModuleOfPred, new_size);
625 p->NextPredOfHash = np[hsh];
626 np[hsh] = p;
627 p = nextp;
628 }
629 }
630 PredHashTableSize = new_size;
631 PredHash = np;
632 Yap_FreeAtomSpace((ADDR)oldp);
633 return TRUE;
634 }
635
636 /* fe is supposed to be locked */
637 Prop Yap_NewPredPropByFunctor(FunctorEntry *fe, Term cur_mod) {
638 PredEntry *p = (PredEntry *)Yap_AllocAtomSpace(sizeof(*p));
639
640 if (p == NULL) {
641 WRITE_UNLOCK(fe->FRWLock);
642 return NULL;
643 }
644 if (cur_mod == TermProlog || cur_mod == 0L) {
645 p->ModuleOfPred = 0L;
646 } else
647 p->ModuleOfPred = cur_mod;
648 // TRUE_FUNC_WRITE_LOCK(fe);
649 INIT_LOCK(p->PELock);
650 p->KindOfPE = PEProp;
651 p->ArityOfPE = fe->ArityOfFE;
652 p->cs.p_code.FirstClause = p->cs.p_code.LastClause = NULL;
653 p->cs.p_code.NOfClauses = 0;
654 p->PredFlags = UndefPredFlag;
655 p->src.OwnerFile = Yap_source_file_name();
656 p->OpcodeOfPred = UNDEF_OPCODE;
657 p->CodeOfPred = p->cs.p_code.TrueCodeOfPred = (yamop *)(&(p->OpcodeOfPred));
658 p->cs.p_code.ExpandCode = EXPAND_OP_CODE;
659 p->TimeStampOfPred = 0L;
660 p->LastCallOfPred = LUCALL_ASSERT;
661 p->MetaEntryOfPred = NULL;
662 if (cur_mod == TermProlog)
663 p->ModuleOfPred = 0L;
664 else
665 p->ModuleOfPred = cur_mod;
666 p->StatisticsForPred = NULL;
667 Yap_NewModulePred(cur_mod, p);
668
669#ifdef TABLING
670 p->TableOfPred = NULL;
671#endif /* TABLING */
672#ifdef BEAM
673 p->beamTable = NULL;
674#endif /* BEAM */
675 /* careful that they don't cross MkFunctor */
676 if (!trueGlobalPrologFlag(DEBUG_INFO_FLAG)) {
677 p->PredFlags |= NoTracePredFlag;
678 }
679 p->FunctorOfPred = fe;
680 if (fe->PropsOfFE) {
681 UInt hsh = PRED_HASH(fe, cur_mod, PredHashTableSize);
682
683 WRITE_LOCK(PredHashRWLock);
684 if (10 * (PredsInHashTable + 1) > 6 * PredHashTableSize) {
685 if (!ExpandPredHash()) {
686 Yap_FreeCodeSpace((ADDR)p);
687 WRITE_UNLOCK(PredHashRWLock);
688 FUNC_WRITE_UNLOCK(fe);
689 return NULL;
690 }
691 /* retry hashing */
692 hsh = PRED_HASH(fe, cur_mod, PredHashTableSize);
693 }
694 PredsInHashTable++;
695 if (p->ModuleOfPred == 0L) {
696 PredEntry *pe = RepPredProp(fe->PropsOfFE);
697
698 hsh = PRED_HASH(fe, pe->ModuleOfPred, PredHashTableSize);
699 /* should be the first one */
700 pe->NextPredOfHash = PredHash[hsh];
701 PredHash[hsh] = pe;
702 fe->PropsOfFE = AbsPredProp(p);
703 p->NextOfPE = AbsPredProp(pe);
704 } else {
705 p->NextPredOfHash = PredHash[hsh];
706 PredHash[hsh] = p;
707 p->NextOfPE = fe->PropsOfFE->NextOfPE;
708 fe->PropsOfFE->NextOfPE = AbsPredProp(p);
709 }
710 WRITE_UNLOCK(PredHashRWLock);
711 } else {
712 fe->PropsOfFE = AbsPredProp(p);
713 p->NextOfPE = NIL;
714 }
715 FUNC_WRITE_UNLOCK(fe);
716 {
717 Yap_inform_profiler_of_clause(&(p->OpcodeOfPred), &(p->OpcodeOfPred) + 1, p,
718 GPROF_NEW_PRED_FUNC);
719 if (!(p->PredFlags & (CPredFlag | AsmPredFlag))) {
720 Yap_inform_profiler_of_clause(&(p->cs.p_code.ExpandCode),
721 &(p->cs.p_code.ExpandCode) + 1, p,
722 GPROF_NEW_PRED_FUNC);
723 }
724 }
725 return AbsPredProp(p);
726 }
727
728#if THREADS
729 Prop Yap_NewThreadPred(PredEntry *ap USES_REGS) {
730 PredEntry *p = (PredEntry *)Yap_AllocAtomSpace(sizeof(*p));
731
732 if (p == NULL) {
733 return NIL;
734 }
735 INIT_LOCK(p->PELock);
736 p->StatisticsForPred = NULL : p->KindOfPE = PEProp;
737 p->ArityOfPE = ap->ArityOfPE;
738 p->cs.p_code.FirstClause = p->cs.p_code.LastClause = NULL;
739 p->cs.p_code.NOfClauses = 0;
740 p->PredFlags = ap->PredFlags & ~(IndexedPredFlag | SpiedPredFlag);
741#if SIZEOF_INT_P == 4
742 p->ExtraPredFlags = 0L;
743#endif
744 p->MetaEntryOfPred = NULL;
745 p->src.OwnerFile = ap->src.OwnerFile;
746 p->OpcodeOfPred = FAIL_OPCODE;
747 p->CodeOfPred = p->cs.p_code.TrueCodeOfPred = (yamop *)(&(p->OpcodeOfPred));
748 p->cs.p_code.ExpandCode = EXPAND_OP_CODE;
749 p->ModuleOfPred = ap->ModuleOfPred;
750 p->NextPredOfModule = NULL;
751 p->TimeStampOfPred = 0L;
752 p->LastCallOfPred = LUCALL_ASSERT;
753#ifdef TABLING
754 p->TableOfPred = NULL;
755#endif /* TABLING */
756#ifdef BEAM
757 p->beamTable = NULL;
758#endif
759 /* careful that they don't cross MkFunctor */
760 p->NextOfPE = AbsPredProp(LOCAL_ThreadHandle.local_preds);
761 LOCAL_ThreadHandle.local_preds = p;
762 p->FunctorOfPred = ap->FunctorOfPred;
763 Yap_inform_profiler_of_clause(&(p->OpcodeOfPred), &(p->OpcodeOfPred) + 1, p,
764 GPROF_NEW_PRED_THREAD);
765 if (falseGlobalPrologFlag(DEBUG_INFO_FLAG)) {
766 p->PredFlags |= (NoSpyPredFlag | NoTracePredFlag);
767 }
768 if (!(p->PredFlags & (CPredFlag | AsmPredFlag))) {
769 Yap_inform_profiler_of_clause(&(p->cs.p_code.ExpandCode),
770 &(p->cs.p_code.ExpandCode) + 1, p,
771 GPROF_NEW_PRED_THREAD);
772 }
773 return AbsPredProp(p);
774 }
775#endif
776
777 Prop Yap_NewPredPropByAtom(AtomEntry *ae, Term cur_mod) {
778 Prop p0;
779 PredEntry *p = (PredEntry *)Yap_AllocAtomSpace(sizeof(*p));
780 CACHE_REGS
781 /* Printf("entering %s:%s/0\n", RepAtom(AtomOfTerm(cur_mod))->StrOfAE,
782 * ae->StrOfAE); */
783
784 if (p == NULL) {
785 WRITE_UNLOCK(ae->ARWLock);
786 return NIL;
787 }
788 INIT_LOCK(p->PELock);
789 p->KindOfPE = PEProp;
790 p->ArityOfPE = 0;
791 p->StatisticsForPred = NULL;
792 p->cs.p_code.FirstClause = p->cs.p_code.LastClause = NULL;
793 p->cs.p_code.NOfClauses = 0;
794 p->PredFlags = UndefPredFlag;
795 p->src.OwnerFile = Yap_source_file_name();
796 p->OpcodeOfPred = UNDEF_OPCODE;
797 p->cs.p_code.ExpandCode = EXPAND_OP_CODE;
798 p->CodeOfPred = p->cs.p_code.TrueCodeOfPred = (yamop *)(&(p->OpcodeOfPred));
799 p->MetaEntryOfPred = NULL;
800 if (cur_mod == TermProlog)
801 p->ModuleOfPred = 0;
802 else
803 p->ModuleOfPred = cur_mod;
804 Yap_NewModulePred(cur_mod, p);
805 p->TimeStampOfPred = 0L;
806 p->LastCallOfPred = LUCALL_ASSERT;
807#ifdef TABLING
808 p->TableOfPred = NULL;
809#endif /* TABLING */
810#ifdef BEAM
811 p->beamTable = NULL;
812#endif
813 /* careful that they don't cross MkFunctor */
814 AddPropToAtom(ae, (PropEntry *)p);
815 p0 = AbsPredProp(p);
816 p->FunctorOfPred = (Functor)AbsAtom(ae);
817 if (!trueGlobalPrologFlag(DEBUG_INFO_FLAG)) {
818 p->PredFlags |= (NoTracePredFlag | NoSpyPredFlag);
819 }
820 if (Yap_isSystemModule(CurrentModule))
821 p->PredFlags |= StandardPredFlag;
822 WRITE_UNLOCK(ae->ARWLock);
823 {
824 Yap_inform_profiler_of_clause(&(p->OpcodeOfPred), &(p->OpcodeOfPred) + 1, p,
825 GPROF_NEW_PRED_ATOM);
826 if (!(p->PredFlags & (CPredFlag | AsmPredFlag))) {
827 Yap_inform_profiler_of_clause(&(p->cs.p_code.ExpandCode),
828 &(p->cs.p_code.ExpandCode) + 1, p,
829 GPROF_NEW_PRED_ATOM);
830 }
831 }
832 return p0;
833 }
834
835 Prop Yap_PredPropByFunctorNonThreadLocal(Functor f, Term cur_mod)
836 /* get predicate entry for ap/arity; create it if neccessary. */
837 {
838 PredEntry *p;
839
840 FUNC_WRITE_LOCK(f);
841 if (!(p = RepPredProp(f->PropsOfFE)))
842 return Yap_NewPredPropByFunctor(f, cur_mod);
843
844 if ((p->ModuleOfPred == cur_mod || !(p->ModuleOfPred))) {
845 /* don't match multi-files */
846 if ( true || p->ModuleOfPred || !cur_mod ||
847 cur_mod == TermProlog) {
848 FUNC_WRITE_UNLOCK(f);
849 return AbsPredProp(p);
850 }
851 }
852 if (p->NextOfPE) {
853 UInt hash = PRED_HASH(f, cur_mod, PredHashTableSize);
854 READ_LOCK(PredHashRWLock);
855 p = PredHash[hash];
856
857 while (p) {
858 if (p->FunctorOfPred == f && p->ModuleOfPred == cur_mod) {
859 READ_UNLOCK(PredHashRWLock);
860 FUNC_WRITE_UNLOCK(f);
861 return AbsPredProp(p);
862 }
863 p = p->NextPredOfHash;
864 }
865 READ_UNLOCK(PredHashRWLock);
866 }
867 return Yap_NewPredPropByFunctor(f, cur_mod);
868 }
869
870 Prop Yap_PredPropByAtomNonThreadLocal(Atom at, Term cur_mod)
871 /* get predicate entry for ap/arity; create it if neccessary. */
872 {
873 Prop p0;
874 AtomEntry *ae = RepAtom(at);
875
876 WRITE_LOCK(ae->ARWLock);
877 p0 = ae->PropsOfAE;
878 while (p0) {
879 PredEntry *pe = RepPredProp(p0);
880 if (pe->KindOfPE == PEProp &&
881 (pe->ModuleOfPred == cur_mod || !pe->ModuleOfPred)) {
882 /* don't match multi-files */
883 if ( true || pe->ModuleOfPred || !cur_mod ||
884 cur_mod == TermProlog) {
885 WRITE_UNLOCK(ae->ARWLock);
886 return (p0);
887 }
888 }
889 p0 = pe->NextOfPE;
890 }
891 return Yap_NewPredPropByAtom(ae, cur_mod);
892 }
893
894 Term Yap_GetValue(Atom a) {
895 Prop p0 = GetAProp(a, ValProperty);
896 Term out;
897
898 if (p0 == NIL)
899 return (TermNil);
900 READ_LOCK(RepValProp(p0)->VRWLock);
901 out = RepValProp(p0)->ValueOfVE;
902 if (IsApplTerm(out)) {
903 Functor f = FunctorOfTerm(out);
904 if (f == FunctorDouble) {
905 CACHE_REGS
906 out = MkFloatTerm(FloatOfTerm(out));
907 } else if (f == FunctorLongInt) {
908 CACHE_REGS
909 out = MkLongIntTerm(LongIntOfTerm(out));
910 } else if (f == FunctorString) {
911 CACHE_REGS
912 out = MkStringTerm(StringOfTerm(out));
913 }
914#ifdef USE_GMP
915 else {
916 out = Yap_MkBigIntTerm(Yap_BigIntOfTerm(out));
917 }
918#endif
919 }
920 READ_UNLOCK(RepValProp(p0)->VRWLock);
921 return (out);
922 }
923
924 void Yap_PutValue(Atom a, Term v) {
925 AtomEntry *ae = RepAtom(a);
926 Prop p0;
927 ValEntry *p;
928 Term t0;
929
930 WRITE_LOCK(ae->ARWLock);
931 p0 = GetAPropHavingLock(ae, ValProperty);
932 if (p0 != NIL) {
933 p = RepValProp(p0);
934 WRITE_LOCK(p->VRWLock);
935 WRITE_UNLOCK(ae->ARWLock);
936 } else {
937 p = (ValEntry *)Yap_AllocAtomSpace(sizeof(ValEntry));
938 if (p == NULL) {
939 WRITE_UNLOCK(ae->ARWLock);
940 return;
941 }
942 p->KindOfPE = ValProperty;
943 p->ValueOfVE = TermNil;
944 AddPropToAtom(RepAtom(a), (PropEntry *)p);
945 /* take care that the lock for the property will be inited even
946 if someone else searches for the property */
947 INIT_RWLOCK(p->VRWLock);
948 WRITE_LOCK(p->VRWLock);
949 WRITE_UNLOCK(ae->ARWLock);
950 }
951 t0 = p->ValueOfVE;
952 if (IsFloatTerm(v)) {
953 /* store a float in code space, so that we can access the property */
954 union {
955 Float f;
956 CELL ar[sizeof(Float) / sizeof(CELL)];
957 } un;
958 CELL *pt, *iptr;
959 unsigned int i;
960
961 un.f = FloatOfTerm(v);
962 if (IsFloatTerm(t0)) {
963 pt = RepAppl(t0);
964 } else {
965 if (IsApplTerm(t0)) {
966 Yap_FreeCodeSpace((char *)(RepAppl(t0)));
967 }
968 pt = (CELL *)Yap_AllocAtomSpace(sizeof(CELL) *
969 (1 + 2 * sizeof(Float) / sizeof(CELL)));
970 if (pt == NULL) {
971 WRITE_UNLOCK(ae->ARWLock);
972 return;
973 }
974 p->ValueOfVE = AbsAppl(pt);
975 pt[0] = (CELL)FunctorDouble;
976 }
977
978 iptr = pt + 1;
979 for (i = 0; i < sizeof(Float) / sizeof(CELL); i++) {
980 *iptr++ = (CELL)un.ar[i];
981 }
982 } else if (IsLongIntTerm(v)) {
983 CELL *pt;
984 Int val = LongIntOfTerm(v);
985
986 if (IsLongIntTerm(t0)) {
987 pt = RepAppl(t0);
988 } else {
989 if (IsApplTerm(t0)) {
990 Yap_FreeCodeSpace((char *)(RepAppl(t0)));
991 }
992 pt = (CELL *)Yap_AllocAtomSpace(2 * sizeof(CELL));
993 if (pt == NULL) {
994 WRITE_UNLOCK(ae->ARWLock);
995 return;
996 }
997 p->ValueOfVE = AbsAppl(pt);
998 pt[0] = (CELL)FunctorLongInt;
999 }
1000 pt[1] = (CELL)val;
1001#ifdef USE_GMP
1002 } else if (IsBigIntTerm(v)) {
1003 CELL *ap = RepAppl(v);
1004 Int sz = sizeof(MP_INT) + sizeof(CELL) +
1005 (((MP_INT *)(ap + 1))->_mp_alloc * sizeof(mp_limb_t));
1006 CELL *pt = (CELL *)Yap_AllocAtomSpace(sz);
1007
1008 if (pt == NULL) {
1009 WRITE_UNLOCK(ae->ARWLock);
1010 return;
1011 }
1012 if (IsApplTerm(t0)) {
1013 Yap_FreeCodeSpace((char *)RepAppl(t0));
1014 }
1015 memcpy((void *)pt, (void *)ap, sz);
1016 p->ValueOfVE = AbsAppl(pt);
1017#endif
1018 } else if (IsStringTerm(v)) {
1019 CELL *ap = RepAppl(v);
1020 Int sz = sizeof(CELL) * (3 + ap[1]);
1021 CELL *pt = (CELL *)Yap_AllocAtomSpace(sz);
1022
1023 if (pt == NULL) {
1024 WRITE_UNLOCK(ae->ARWLock);
1025 return;
1026 }
1027 if (IsApplTerm(t0)) {
1028 Yap_FreeCodeSpace((char *)RepAppl(t0));
1029 }
1030 memcpy((void *)pt, (void *)ap, sz);
1031 p->ValueOfVE = AbsAppl(pt);
1032 } else {
1033 if (IsApplTerm(t0)) {
1034 /* recover space */
1035 Yap_FreeCodeSpace((char *)(RepAppl(p->ValueOfVE)));
1036 }
1037 p->ValueOfVE = v;
1038 }
1039 WRITE_UNLOCK(p->VRWLock);
1040 }
1041
1042 bool Yap_PutAtomTranslation(Atom a, arity_t arity, Int i) {
1043 AtomEntry *ae = RepAtom(a);
1044 Prop p0;
1045 TranslationEntry *p;
1046
1047 WRITE_LOCK(ae->ARWLock);
1048 p0 = GetAPropHavingLock(ae, TranslationProperty);
1049 if (p0 == NIL) {
1050 p = (TranslationEntry *)Yap_AllocAtomSpace(sizeof(TranslationEntry));
1051 if (p == NULL) {
1052 WRITE_UNLOCK(ae->ARWLock);
1053 return false;
1054 }
1055 p->KindOfPE = TranslationProperty;
1056 p->Translation = i;
1057 p->arity = arity;
1058 AddPropToAtom(RepAtom(a), (PropEntry *)p);
1059 }
1060 /* take care that the lock for the property will be inited even
1061 if someone else searches for the property */
1062 WRITE_UNLOCK(ae->ARWLock);
1063 return true;
1064 }
1065
1066 bool Yap_PutFunctorTranslation(Atom a, arity_t arity, Int i) {
1067 AtomEntry *ae = RepAtom(a);
1068 Prop p0;
1069 TranslationEntry *p;
1070
1071 WRITE_LOCK(ae->ARWLock);
1072 p0 = GetAPropHavingLock(ae, TranslationProperty);
1073 if (p0 == NIL) {
1074 p = (TranslationEntry *)Yap_AllocAtomSpace(sizeof(TranslationEntry));
1075 if (p == NULL) {
1076 WRITE_UNLOCK(ae->ARWLock);
1077 return false;
1078 }
1079 p->KindOfPE = TranslationProperty;
1080 p->Translation = i;
1081 p->arity = arity;
1082 AddPropToAtom(RepAtom(a), (PropEntry *)p);
1083 }
1084 /* take care that the lock for the property will be inited even
1085 if someone else searches for the property */
1086 WRITE_UNLOCK(ae->ARWLock);
1087 return true;
1088 }
1089
1090 bool Yap_PutAtomMutex(Atom a, void *i) {
1091 AtomEntry *ae = RepAtom(a);
1092 Prop p0;
1093 MutexEntry *p;
1094
1095 WRITE_LOCK(ae->ARWLock);
1096 p0 = GetAPropHavingLock(ae, MutexProperty);
1097 if (p0 == NIL) {
1098 p = (MutexEntry *)Yap_AllocAtomSpace(sizeof(MutexEntry));
1099 if (p == NULL) {
1100 WRITE_UNLOCK(ae->ARWLock);
1101 return false;
1102 }
1103 p->KindOfPE = MutexProperty;
1104 p->Mutex = i;
1105 AddPropToAtom(RepAtom(a), (PropEntry *)p);
1106 }
1107 /* take care that the lock for the property will be inited even
1108 if someone else searches for the property */
1109 WRITE_UNLOCK(ae->ARWLock);
1110 return true;
1111 }
1112
1113 Term Yap_ArrayToList(register Term *tp, size_t nof) {
1114 CACHE_REGS
1115 register Term *pt = tp + nof;
1116 register Term t;
1117
1118 t = MkAtomTerm(AtomNil);
1119 while (pt > tp) {
1120 Term tm = *--pt;
1121#if YAPOR_SBA
1122 if (tm == 0)
1123 t = MkPairTerm((CELL)pt, t);
1124 else
1125#endif
1126 t = MkPairTerm(tm, t);
1127 }
1128 return (t);
1129 }
1130
1131 int Yap_GetName(char *s, UInt max, Term t) {
1132 register Term Head;
1133 register Int i;
1134
1135 if (IsVarTerm(t) || !IsPairTerm(t))
1136 return FALSE;
1137 while (IsPairTerm(t)) {
1138 Head = HeadOfTerm(t);
1139 if (!IsNumTerm(Head))
1140 return (FALSE);
1141 i = IntOfTerm(Head);
1142 if (i < 0 || i > MAX_ISO_LATIN1)
1143 return FALSE;
1144 *s++ = i;
1145 t = TailOfTerm(t);
1146 if (--max == 0) {
1147 Yap_Error(SYSTEM_ERROR_FATAL, t, "not enough space for GetName");
1148 }
1149 }
1150 *s = '\0';
1151 return TRUE;
1152 }
1153
1154#ifdef SFUNC
1155
1156 Term MkSFTerm(Functor f, int n, Term *a, empty_value) {
1157 Term t, p = AbsAppl(H);
1158 int i;
1159
1160 *H++ = f;
1161 RESET_VARIABLE(H);
1162 ++H;
1163 for (i = 1; i <= n; ++i) {
1164 t = Derefa(a++);
1165 if (t != empty_value) {
1166 *H++ = i;
1167 *H++ = t;
1168 }
1169 }
1170 *H++ = 0;
1171 return (p);
1172 }
1173
1174 CELL *ArgsOfSFTerm(Term t) {
1175 CELL *p = RepAppl(t) + 1;
1176
1177 while (*p != (CELL)p)
1178 p = CellPtr(*p) + 1;
1179 return (p + 1);
1180 }
1181
1182#endif
1183
1184 static HoldEntry *InitAtomHold(void) {
1185 HoldEntry *x = (HoldEntry *)Yap_AllocAtomSpace(sizeof(struct hold_entry));
1186 if (x == NULL) {
1187 return NULL;
1188 }
1189 x->KindOfPE = HoldProperty;
1190 x->NextOfPE = NIL;
1191 x->RefsOfPE = 1;
1192 return x;
1193 }
1194
1195 int Yap_AtomIncreaseHold(Atom at) {
1196 AtomEntry *ae = RepAtom(at);
1197 HoldEntry *pp;
1198 Prop *opp = &(ae->PropsOfAE);
1199
1200 WRITE_LOCK(ae->ARWLock);
1201 pp = RepHoldProp(ae->PropsOfAE);
1202 while (!EndOfPAEntr(pp) && pp->KindOfPE != HoldProperty) {
1203 opp = &(pp->NextOfPE);
1204 pp = RepHoldProp(pp->NextOfPE);
1205 }
1206 if (!pp) {
1207 HoldEntry *new = InitAtomHold();
1208 if (!new) {
1209 WRITE_UNLOCK(ae->ARWLock);
1210 return FALSE;
1211 }
1212 *opp = AbsHoldProp(new);
1213 } else {
1214 pp->RefsOfPE++;
1215 }
1216 WRITE_UNLOCK(ae->ARWLock);
1217 return TRUE;
1218 }
1219
1220 int Yap_AtomDecreaseHold(Atom at) {
1221 AtomEntry *ae = RepAtom(at);
1222 HoldEntry *pp;
1223 Prop *opp = &(ae->PropsOfAE);
1224
1225 WRITE_LOCK(ae->ARWLock);
1226 pp = RepHoldProp(ae->PropsOfAE);
1227 while (!EndOfPAEntr(pp) && pp->KindOfPE != HoldProperty) {
1228 opp = &(pp->NextOfPE);
1229 pp = RepHoldProp(pp->NextOfPE);
1230 }
1231 if (!pp) {
1232 WRITE_UNLOCK(ae->ARWLock);
1233 return FALSE;
1234 }
1235 pp->RefsOfPE--;
1236 if (!pp->RefsOfPE) {
1237 *opp = pp->NextOfPE;
1238 Yap_FreeCodeSpace((ADDR)pp);
1239 }
1240 WRITE_UNLOCK(ae->ARWLock);
1241 return TRUE;
1242 }
1243
1244 const char *IndicatorOfPred(PredEntry *pe) {
1245 const char *mods;
1246 Atom at;
1247 arity_t arity;
1248 if (pe->ModuleOfPred == IDB_MODULE) {
1249 mods = "idb";
1250 if (pe->PredFlags & NumberDBPredFlag) {
1251 char * buf = malloc(MAX_PATH+1);
1252 snprintf(buf, MAX_PATH, "idb:" UInt_FORMAT,
1253 (Int)(pe->FunctorOfPred));
1254 return buf;
1255 } else if (pe->PredFlags & AtomDBPredFlag) {
1256 at = (Atom)pe->FunctorOfPred;
1257 arity = 0;
1258 } else {
1259 at = NameOfFunctor(pe->FunctorOfPred);
1260 arity = ArityOfFunctor(pe->FunctorOfPred);
1261 }
1262 } else {
1263 if (pe->ModuleOfPred == 0)
1264 mods = "prolog";
1265 else
1266 mods = RepAtom(AtomOfTerm(pe->ModuleOfPred))->StrOfAE;
1267 arity = pe->ArityOfPE;
1268 if (arity == 0) {
1269 at = (Atom)pe->FunctorOfPred;
1270 } else {
1271 at = NameOfFunctor(pe->FunctorOfPred);
1272 }
1273 }
1274 char * buf = malloc(MAX_PATH+1);
1275 snprintf(buf, MAX_PATH, "%s:%s/" UInt_FORMAT, mods,
1276 RepAtom(at)->StrOfAE, arity);
1277 return buf;
1278 }
Yap.h
Main definitions.
MP_INT
Definition: TermExt.h:345
hold_entry
Definition: Yatom.h:917
mutex_entry
Definition: Yatom.h:1020
operator_entry
Definition: Yatom.h:295
pred_entry
Definition: Yatom.h:544
translation_entry
Definition: Yatom.h:954
yami
Definition: amidefs.h:264