YAP 7.1.0
cdmgr.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: cdmgr.c *
12 * comments: Code manager *
13 * *
14 * Last rev: $Date: 2008-07-22 23:34:44 $,$Author: vsc $ *
15 *************************************************************************/
16
17
18#include "Yap.h"
19
20#include "YapHeap.h"
21#include "Yapproto.h"
22#ifdef SCCS
23static char SccsId[] = "@(#)cdmgr.c 1.1 05/02/98";
24#endif
25
26#include "YapEval.h"
27#include "clause.h"
28#include "tracer.h"
29#include "yapio.h"
30#ifdef YAPOR
31#include "or.macros.h"
32#endif /* YAPOR */
33#ifdef TABLING
34#include "tab.macros.h"
35#endif /* TABLING */
36#if HAVE_STRING_H
37#include <string.h>
38#endif
39#include <assert.h>
40#include <heapgc.h>
41#include <iopreds.h>
42
43static void retract_all(PredEntry *, int);
44static void add_first_static(PredEntry *, yamop *, int);
45static void add_first_dynamic(PredEntry *, yamop *, int);
46static void asserta_stat_clause(PredEntry *, yamop *, int);
47static void asserta_dynam_clause(PredEntry *, yamop *);
48static void assertz_stat_clause(PredEntry *, yamop *, int);
49static void assertz_dynam_clause(PredEntry *, yamop *);
50static void expand_consult(void);
51static int not_was_reconsulted(PredEntry *, Term, int);
52static int RemoveIndexation(PredEntry *);
53static Int number_of_clauses(USES_REGS1);
54static Int p_compile(USES_REGS1);
55static Int p_purge_clauses(USES_REGS1);
56static Int p_startconsult(USES_REGS1);
57static Int p_showconslultlev(USES_REGS1);
58static Int p_endconsult(USES_REGS1);
59static Int p_undefined(USES_REGS1);
60static Int new_multifile(USES_REGS1);
61static Int p_is_multifile(USES_REGS1);
62static Int p_optimizer_on(USES_REGS1);
63static Int p_optimizer_off(USES_REGS1);
64static Int p_is_dynamic(USES_REGS1);
65static Int p_kill_dynamic(USES_REGS1);
66static Int p_is_profiled(USES_REGS1);
67static Int p_profile_info(USES_REGS1);
68static Int p_profile_reset(USES_REGS1);
69static Int p_is_call_counted(USES_REGS1);
70static Int p_call_count_info(USES_REGS1);
71static Int p_call_count_set(USES_REGS1);
72static Int p_call_count_reset(USES_REGS1);
73static void kill_first_log_iblock(LogUpdIndex *, LogUpdIndex *, PredEntry *);
74
75#define PredArity(p) (p->ArityOfPE)
76#define TRYCODE(G, F, N) ((N) < 5 ? (op_numbers)((int)F + (N)*3) : G)
77
78static void InitConsultStack(void) {
79 CACHE_REGS
80 LOCAL_ConsultLow = NULL;
81 expand_consult();
82}
83
84void Yap_ResetConsultStack(void) {
85 CACHE_REGS
86 Yap_FreeCodeSpace((char *)LOCAL_ConsultLow);
87 LOCAL_ConsultBase = LOCAL_ConsultSp = LOCAL_ConsultLow = NULL;
88 LOCAL_ConsultCapacity = InitialConsultCapacity;
89}
90
91
92/******************************************************************
93
94 ADDING AND REMOVE INFO TO A PROCEDURE
95
96******************************************************************/
97
98/*
99 * we have three kinds of predicates: dynamic DynamicPredFlag
100 * static CompiledPredFlag fast FastPredFlag all the
101 * database predicates are supported for dynamic predicates only abolish and
102 * assertz are supported for static predicates no database predicates are
103 * supportted for fast predicates
104 */
105
106PredEntry *Yap_get_pred(Term t, Term tmod, const char *pname) {
107 Term t0 = t;
108
109restart:
110 t = Yap_YapStripModule(t,&tmod);
111 if (IsVarTerm(t)) {
112 Yap_ThrowError(INSTANTIATION_ERROR, t0, pname);
113 return NULL;
114 } else if (IsVarTerm(tmod)) {
115 Yap_ThrowError(INSTANTIATION_ERROR, t0, pname);
116 return NULL;
117 } else if (!IsAtomTerm(tmod)) {
118 Yap_ThrowError(TYPE_ERROR_ATOM, t0, pname);
119 return NULL;
120 } else if (IsAtomTerm(t)) {
121 PredEntry *ap = RepPredProp(Yap_GetPredPropByAtom(AtomOfTerm(t), tmod));
122 return ap;
123 } else if (IsIntegerTerm(t) && tmod == IDB_MODULE) {
124 return Yap_FindLUIntKey(IntegerOfTerm(t));
125 } else if (IsPairTerm(t)) {
126 t = Yap_MkApplTerm(FunctorCsult, 1, &t);
127 goto restart;
128 } else if (IsApplTerm(t)) {
129 Functor fun = FunctorOfTerm(t);
130 if (IsExtensionFunctor(fun)) {
131 Yap_ThrowError(TYPE_ERROR_CALLABLE, Yap_PredicateIndicator(t, tmod), pname);
132 return NULL;
133 }
134 PredEntry *ap = RepPredProp(Yap_GetPredPropByFunc(fun, tmod));
135 return ap;
136 } else {
137 Yap_ThrowError(TYPE_ERROR_CALLABLE, t0, pname);
138 }
139 return NULL;
140}
141
145PredEntry *Yap_new_pred(Term t, Term tmod, bool mkLU, const char *pname) {
146 PredEntry *rc;
147 Term t0 = t;
148
149 restart:
150 t = Yap_YapStripModule(t,&tmod);
151 if (IsVarTerm(t)) {
152 Yap_ThrowError(INSTANTIATION_ERROR, t0, pname);
153 return NULL;
154 } else if (IsVarTerm(tmod)) {
155 Yap_ThrowError(INSTANTIATION_ERROR, tmod, pname);
156 return NULL;
157 } else if (!IsAtomTerm(tmod)) {
158 Yap_ThrowError(TYPE_ERROR_CALLABLE, tmod, pname);
159 return NULL;
160 } else if (IsAtomTerm(t)) {
161 if (mkLU) {
162 rc = RepPredProp(Yap_GetPredPropByAtom(AtomOfTerm(t), tmod));
163 if (rc)
164 return rc;
165 return Yap_MkLogPred( RepPredProp(PredPropByAtom(AtomOfTerm(t), tmod)) );
166 }
167 rc = RepPredProp(PredPropByAtom(AtomOfTerm(t), tmod));
168 } else if (IsIntegerTerm(t)) {
169 if (tmod == IDB_MODULE) {
170 rc = Yap_FindLUIntKey(IntegerOfTerm(t));
171 }
172 Yap_ThrowError(TYPE_ERROR_CALLABLE, t0, pname);
173
174 } else if (IsApplTerm(t)) {
175 Functor fun = FunctorOfTerm(t);
176 if (IsExtensionFunctor(fun)) {
177 Yap_ThrowError(TYPE_ERROR_CALLABLE, Yap_PredicateIndicator(t, tmod), pname);
178 return NULL;
179 }
180 if (fun == FunctorModule) {
181 Term tmod = ArgOfTerm(1, t);
182 if (IsVarTerm(tmod)) {
183 Yap_ThrowError(INSTANTIATION_ERROR, t0, pname);
184 return NULL;
185 }
186 if (!IsAtomTerm(tmod)) {
187 Yap_ThrowError(TYPE_ERROR_ATOM, t0, pname);
188 return NULL;
189 }
190 t = ArgOfTerm(2, t);
191 goto restart;
192 }
193 if (mkLU) {
194 rc = RepPredProp(Yap_GetPredPropByFunc(fun, tmod));
195 if (rc)
196 return rc;
197 return Yap_MkLogPred( RepPredProp(PredPropByFunc(fun, tmod)) );
198 }
199 return ( RepPredProp(PredPropByFunc(fun, tmod)) );
200 } else
201 return NULL;
202 // new stuff
203 if (mkLU)
204 return Yap_MkLogPred(rc);
205 else
206 return rc;
207}
208
209/******************************************************************
210
211 Mega Clauses
212
213******************************************************************/
214
215#define OrArgAdjust(P)
216#define TabEntryAdjust(P)
217#define DoubleInCodeAdjust(D)
218#define IntegerInCodeAdjust(D)
219#define IntegerAdjust(D) (D)
220#define PtoPredAdjust(X) (X)
221#define PtoOpAdjust(X) (X)
222#define PtoLUClauseAdjust(P) (P)
223#define PtoLUIndexAdjust(P) (P)
224#define XAdjust(X) (X)
225#define YAdjust(X) (X)
226#define AtomTermAdjust(X) (X)
227#define CellPtoHeapAdjust(X) (X)
228#define FuncAdjust(X) (X)
229#define CodeAddrAdjust(X) (X)
230#define CodeComposedTermAdjust(X) (X)
231#define ConstantAdjust(X) (X)
232#define ArityAdjust(X) (X)
233#define OpcodeAdjust(X) (X)
234#define ModuleAdjust(X) (X)
235#define ExternalFunctionAdjust(X) (X)
236#define AdjustSwitchTable(X, Y, Z)
237#define DBGroundTermAdjust(X) (X)
238#define rehash(A, B, C)
239
240static Term BlobTermInCodeAdjust(Term t) {
241 CACHE_REGS
242#if TAGS_FAST_OPS
243 return t - LOCAL_ClDiff;
244#else
245 return t + LOCAL_ClDiff;
246#endif
247}
248
249static Term ConstantTermAdjust(Term t) {
250 if (IsAtomTerm(t))
251 return AtomTermAdjust(t);
252 return t;
253}
254
255#include "rclause.h"
256
257#ifdef DEBUG
258static UInt total_megaclause, total_released, nof_megaclauses;
259#endif
260
261void Yap_BuildMegaClause(PredEntry *ap) {
262 CACHE_REGS
263 StaticClause *cl;
264 UInt sz;
265 MegaClause *mcl;
266 yamop *ptr;
267 size_t required;
268 UInt has_blobs = 0;
269
270 if (ap->PredFlags & LivePredFlags ||
271 ap->cs.p_code.FirstClause == NULL || ap->cs.p_code.NOfClauses < 16) {
272 return;
273 }
274 cl = ClauseCodeToStaticClause(ap->cs.p_code.FirstClause);
275 sz = cl->ClSize;
276 while (TRUE) {
277 if (!(cl->ClFlags & FactMask))
278 return; /* no mega clause, sorry */
279 if (cl->ClSize != sz)
280 return; /* no mega clause, sorry */
281 if (cl->ClCode == ap->cs.p_code.LastClause)
282 break;
283 has_blobs |= (cl->ClFlags & HasBlobsMask);
284 cl = cl->ClNext;
285 }
286 /* ok, we got the chance for a mega clause */
287 if (has_blobs) {
288 sz -= sizeof(StaticClause);
289 } else {
290 sz -= (UInt)NEXTOP((yamop *)NULL, p) + sizeof(StaticClause);
291 }
292 required = sz * ap->cs.p_code.NOfClauses + sizeof(MegaClause) +
293 (UInt)NEXTOP((yamop *)NULL, l);
294 while (!(mcl = (MegaClause *)Yap_AllocCodeSpace(required))) {
295 if (!Yap_growheap(FALSE, required, NULL)) {
296 /* just fail, the system will keep on going */
297 return;
298 }
299 }
300#ifdef DEBUG
301 total_megaclause += required;
302 cl = ClauseCodeToStaticClause(ap->cs.p_code.FirstClause);
303 total_released += ap->cs.p_code.NOfClauses * cl->ClSize;
304 nof_megaclauses++;
305#endif
306 Yap_ClauseSpace += required;
307 /* cool, it's our turn to do the conversion */
308 mcl->ClFlags = MegaMask | has_blobs;
309 mcl->ClSize = required;
310 mcl->ClPred = ap;
311 mcl->ClItemSize = sz;
312 mcl->ClNext = NULL;
313 cl = ClauseCodeToStaticClause(ap->cs.p_code.FirstClause);
314 mcl->ClLine = cl->usc.ClLine;
315 ptr = mcl->ClCode;
316 while (TRUE) {
317 memcpy((void *)ptr, (void *)cl->ClCode, sz);
318 if (has_blobs) {
319 LOCAL_ClDiff = (char *)(ptr) - (char *)cl->ClCode;
320 restore_opcodes(ptr, NULL PASS_REGS);
321 }
322 ptr = (yamop *)((char *)ptr + sz);
323 if (cl->ClCode == ap->cs.p_code.LastClause)
324 break;
325 cl = cl->ClNext;
326 }
327 ptr->opc = Yap_opcode(_Ystop);
328 cl = ClauseCodeToStaticClause(ap->cs.p_code.FirstClause);
329 /* recover the space spent on the original clauses */
330 while (TRUE) {
331 StaticClause *ncl, *curcl = cl;
332
333 ncl = cl->ClNext;
334 Yap_InformOfRemoval(cl);
335 Yap_ClauseSpace -= cl->ClSize;
336 Yap_FreeCodeSpace((ADDR)cl);
337 if (curcl->ClCode == ap->cs.p_code.LastClause)
338 break;
339 cl = ncl;
340 }
341 ap->cs.p_code.FirstClause = ap->cs.p_code.LastClause = mcl->ClCode;
342 ap->PredFlags |= MegaClausePredFlag;
343 Yap_inform_profiler_of_clause(mcl, (char *)mcl + required, ap, GPROF_MEGA);
344}
345
346static void split_megaclause(PredEntry *ap) {
347 StaticClause *start = NULL, *prev = NULL;
348 MegaClause *mcl;
349 yamop *ptr;
350 UInt ncls = ap->cs.p_code.NOfClauses, i;
351
352 mcl = ClauseCodeToMegaClause(ap->cs.p_code.FirstClause);
353 if (mcl->ClFlags & ExoMask) {
354 Yap_ThrowError(PERMISSION_ERROR_MODIFY_STATIC_PROCEDURE, TermNil,
355 "while deleting clause from exo predicate %s/%d\n",
356 RepAtom(NameOfFunctor(ap->FunctorOfPred))->StrOfAE,
357 ap->ArityOfPE);
358 return;
359 }
360 RemoveIndexation(ap);
361 for (i = 0, ptr = mcl->ClCode; i < ncls; i++) {
362 StaticClause *new = (StaticClause *)Yap_AllocCodeSpace(
363 sizeof(StaticClause) + mcl->ClItemSize +
364 (UInt)NEXTOP((yamop *)NULL, p));
365 if (new == NULL) {
366 if (!Yap_growheap(FALSE,
367 (sizeof(StaticClause) + mcl->ClItemSize) * (ncls - i),
368 NULL)) {
369 while (start) {
370 StaticClause *cl = start;
371 start = cl->ClNext;
372 Yap_InformOfRemoval(cl);
373 Yap_ClauseSpace -= cl->ClSize;
374 Yap_FreeCodeSpace((char *)cl);
375 }
376 if (ap->ArityOfPE) {
377 Yap_ThrowError(RESOURCE_ERROR_HEAP, TermNil,
378 "while breaking up mega clause for %s/%d\n",
379 RepAtom(NameOfFunctor(ap->FunctorOfPred))->StrOfAE,
380 ap->ArityOfPE);
381 } else {
382 Yap_ThrowError(RESOURCE_ERROR_HEAP, TermNil,
383 "while breaking up mega clause for %s\n",
384 RepAtom((Atom)ap->FunctorOfPred)->StrOfAE);
385 }
386 return;
387 }
388 break;
389 }
390 Yap_ClauseSpace +=
391 sizeof(StaticClause) + mcl->ClItemSize + (UInt)NEXTOP((yamop *)NULL, p);
392 new->ClFlags = StaticMask | FactMask;
393 new->ClSize = mcl->ClItemSize;
394 new->usc.ClLine = Yap_source_line_no();
395 new->ClNext = NULL;
396 memcpy((void *)new->ClCode, (void *)ptr, mcl->ClItemSize);
397 if (prev) {
398 prev->ClNext = new;
399 } else {
400 start = new;
401 }
402 ptr = (yamop *)((char *)ptr + mcl->ClItemSize);
403 prev = new;
404 }
405 ap->PredFlags &= ~MegaClausePredFlag;
406 ap->cs.p_code.FirstClause = start->ClCode;
407 ap->cs.p_code.LastClause = prev->ClCode;
408}
409
410/******************************************************************
411
412 Indexation Info
413
414******************************************************************/
415#define ByteAdr(X) ((Int) & (X))
416
417/* Index a prolog pred, given its predicate entry */
418/* ap is already locked. */
419static void IPred(PredEntry *ap, UInt NSlots, yamop *next_pc) {
420 yamop *BaseAddr;
421
422#ifdef DEBUG
423 CACHE_REGS
424 if (GLOBAL_Option['i' - 'a' + 1]) {
425 Term tmod = ap->ModuleOfPred;
426 if (!tmod)
427 tmod = TermProlog;
428 Yap_DebugPutc(stderr, '\t');
429 Yap_DebugPlWrite(tmod);
430 Yap_DebugPutc(stderr, ':');
431 if (ap->ModuleOfPred == IDB_MODULE) {
432 Term t = Deref(ARG1);
433 if (IsAtomTerm(t)) {
434 Yap_DebugPlWrite(t);
435 } else if (IsIntegerTerm(t)) {
436 Yap_DebugPlWrite(t);
437 } else {
438 Functor f = FunctorOfTerm(t);
439 Atom At = NameOfFunctor(f);
440 Yap_DebugPlWrite(MkAtomTerm(At));
441 Yap_DebugPutc(stderr, '/');
442 Yap_DebugPlWrite(MkIntTerm(ArityOfFunctor(f)));
443 }
444 } else {
445 if (ap->ArityOfPE == 0) {
446 Atom At = (Atom)ap->FunctorOfPred;
447 Yap_DebugPlWrite(MkAtomTerm(At));
448 } else {
449 Functor f = ap->FunctorOfPred;
450 Atom At = NameOfFunctor(f);
451 Yap_DebugPlWrite(MkAtomTerm(At));
452 Yap_DebugPutc(stderr, '/');
453 Yap_DebugPlWrite(MkIntTerm(ArityOfFunctor(f)));
454 }
455 }
456 Yap_DebugPutc(stderr, '\n');
457 }
458#endif
459 /* Do not try to index a dynamic predicate or one whithout args */
460 if (is_dynamic(ap)) {
461 Yap_ThrowError(SYSTEM_ERROR_INTERNAL, TermNil,
462 "trying to index a dynamic predicate");
463 return;
464 }
465 if ((BaseAddr = Yap_PredIsIndexable(ap, NSlots, next_pc)) != NULL) {
466 ap->cs.p_code.TrueCodeOfPred = BaseAddr;
467 }
468 if (ap->PredFlags & (SpiedPredFlag | CountPredFlag | ProfiledPredFlag)) {
469 if (ap->PredFlags & ProfiledPredFlag) {
470 Yap_initProfiler(ap);
471 }
472 ap->OpcodeOfPred = Yap_opcode(_spy_pred);
473 ap->CodeOfPred = (yamop *)(&(ap->OpcodeOfPred));
474#if defined(YAPOR) || defined(THREADS)
475 } else if (ap->PredFlags & LogUpdatePredFlag &&
476 !(ap->PredFlags & ThreadLocalPredFlag) &&
477 ap->ModuleOfPred != IDB_MODULE) {
478 ap->OpcodeOfPred = LOCKPRED_OPCODE;
479 ap->CodeOfPred = (yamop *)(&(ap->OpcodeOfPred));
480#endif
481 } else {
482 ap->CodeOfPred = ap->cs.p_code.TrueCodeOfPred;
483 ap->OpcodeOfPred = ap->CodeOfPred->opc;
484 }
485#ifdef DEBUG
486 if (GLOBAL_Option['i' - 'a' + 1])
487 Yap_DebugPutc(stderr, '\n');
488#endif
489}
490
491void Yap_IPred(PredEntry *p, UInt NSlots, yamop *next_pc) {
492 IPred(p, NSlots, next_pc);
493}
494
495#define GONEXT(TYPE) code_p = ((yamop *)(&(code_p->y_u.TYPE.next)))
496
497static void RemoveMainIndex(PredEntry *ap) {
498 yamop *First = ap->cs.p_code.FirstClause;
499 int spied =
500 ap->PredFlags & (SpiedPredFlag | CountPredFlag | ProfiledPredFlag);
501
502 ap->PredFlags &= ~IndexedPredFlag;
503 if (First == NULL) {
504 ap->cs.p_code.TrueCodeOfPred = FAILCODE;
505 } else {
506 ap->cs.p_code.TrueCodeOfPred = First;
507 }
508 if (First != NULL && spied) {
509 ap->OpcodeOfPred = Yap_opcode(_spy_pred);
510 ap->CodeOfPred = (yamop *)(&(ap->OpcodeOfPred));
511 } else if (ap->cs.p_code.NOfClauses > 1
512#ifdef TABLING
513 || ap->PredFlags & TabledPredFlag
514#endif /* TABLING */
515 ) {
516 ap->OpcodeOfPred = INDEX_OPCODE;
517 ap->CodeOfPred = ap->cs.p_code.TrueCodeOfPred =
518 (yamop *)(&(ap->OpcodeOfPred));
519 } else {
520 ap->OpcodeOfPred = ap->cs.p_code.TrueCodeOfPred->opc;
521 ap->CodeOfPred = ap->cs.p_code.TrueCodeOfPred;
522 }
523#if defined(YAPOR) || defined(THREADS)
524 if (ap->PredFlags & LogUpdatePredFlag &&
525 !(ap->PredFlags & ThreadLocalPredFlag) &&
526 ap->ModuleOfPred != IDB_MODULE) {
527 ap->OpcodeOfPred = LOCKPRED_OPCODE;
528 ap->CodeOfPred = (yamop *)(&(ap->OpcodeOfPred));
529 }
530#endif
531}
532
533static void decrease_ref_counter(yamop *ptr, yamop *b, yamop *e, yamop *sc) {
534 if (ptr != FAILCODE && ptr != sc && (ptr < b || ptr > e)) {
535 LogUpdClause *cl = ClauseCodeToLogUpdClause(ptr);
536 cl->ClRefCount--;
537 if (cl->ClFlags & ErasedMask && !(cl->ClRefCount) &&
538 !(cl->ClFlags & InUseMask)) {
539 /* last ref to the clause */
540 Yap_ErLogUpdCl(cl);
541 }
542 }
543}
544
545static yamop *release_wcls(yamop *cop, OPCODE ecs) {
546 if (cop->opc == ecs) {
547 cop->y_u.sssllp.s3--;
548 if (!cop->y_u.sssllp.s3) {
549 UInt sz = (UInt)NEXTOP((yamop *)NULL, sssllp) +
550 cop->y_u.sssllp.s1 * sizeof(yamop *);
551 LOCK(ExpandClausesListLock);
552#ifdef DEBUG
553 Yap_expand_clauses_sz -= sz;
554 Yap_ExpandClauses--;
555#endif
556 if (cop->y_u.sssllp.p->PredFlags & LogUpdatePredFlag) {
557 Yap_LUIndexSpace_EXT -= sz;
558 } else {
559 Yap_IndexSpace_EXT -= sz;
560 }
561 if (ExpandClausesFirst == cop)
562 ExpandClausesFirst = cop->y_u.sssllp.snext;
563 if (ExpandClausesLast == cop) {
564 ExpandClausesLast = cop->y_u.sssllp.sprev;
565 }
566 if (cop->y_u.sssllp.sprev) {
567 cop->y_u.sssllp.sprev->y_u.sssllp.snext = cop->y_u.sssllp.snext;
568 }
569 if (cop->y_u.sssllp.snext) {
570 cop->y_u.sssllp.snext->y_u.sssllp.sprev = cop->y_u.sssllp.sprev;
571 }
572 UNLOCK(ExpandClausesListLock);
573 Yap_InformOfRemoval(cop);
574 Yap_FreeCodeSpace((char *)cop);
575 }
576 }
577 return FAILCODE;
578}
579
580static void cleanup_dangling_indices(yamop *ipc, yamop *beg, yamop *end,
581 yamop *suspend_code) {
582 OPCODE ecs = Yap_opcode(_expand_clauses);
583
584 while (ipc) {
585 op_numbers op = Yap_op_from_opcode(ipc->opc);
586 /* fprintf(stderr,"op: %d %p->%p\n", op, ipc, end);*/
587 switch (op) {
588 case _Ystop:
589 /* end of clause, for now */
590 return;
591 case _index_dbref:
592 case _index_blob:
593 case _index_long:
594 ipc = NEXTOP(ipc, e);
595 break;
596 case _lock_lu:
597 case _unlock_lu:
598 /* locking should be done already */
599 ipc = NEXTOP(ipc, e);
600 case _retry_profiled:
601 case _count_retry:
602 ipc = NEXTOP(ipc, p);
603 break;
604 case _try_clause2:
605 case _try_clause3:
606 case _try_clause4:
607 ipc = NEXTOP(ipc, l);
608 break;
609 case _retry2:
610 case _retry3:
611 case _retry4:
612 decrease_ref_counter(ipc->y_u.l.l, beg, end, suspend_code);
613 ipc = NEXTOP(ipc, l);
614 break;
615 case _retry:
616 case _trust:
617 decrease_ref_counter(ipc->y_u.Otapl.d, beg, end, suspend_code);
618 ipc = NEXTOP(ipc, Otapl);
619 break;
620 case _try_clause:
621 case _try_me:
622 case _retry_me:
623 case _profiled_trust_me:
624 case _trust_me:
625 case _count_trust_me:
626 ipc = NEXTOP(ipc, Otapl);
627 break;
628 case _try_logical:
629 case _retry_logical:
630 case _count_retry_logical:
631 case _profiled_retry_logical: {
632 yamop *oipc = ipc;
633 decrease_ref_counter(ipc->y_u.OtaLl.d->ClCode, beg, end, suspend_code);
634 ipc = ipc->y_u.OtaLl.n;
635 Yap_LUIndexSpace_CP -= (UInt)NEXTOP((yamop *)NULL, OtaLl);
636 Yap_FreeCodeSpace((ADDR)oipc);
637#ifdef DEBUG
638 Yap_DirtyCps--;
639 Yap_FreedCps++;
640#endif
641 } break;
642 case _trust_logical:
643 case _count_trust_logical:
644 case _profiled_trust_logical:
645#ifdef DEBUG
646 Yap_DirtyCps--;
647 Yap_FreedCps++;
648#endif
649 decrease_ref_counter(ipc->y_u.OtILl.d->ClCode, beg, end, suspend_code);
650 Yap_LUIndexSpace_CP -= (UInt)NEXTOP((yamop *)NULL, OtILl);
651 Yap_FreeCodeSpace((ADDR)ipc);
652 return;
653 case _enter_lu_pred: {
654 yamop *oipc = ipc;
655 if (ipc->y_u.Illss.I->ClFlags & InUseMask || ipc->y_u.Illss.I->ClRefCount)
656 return;
657#ifdef DEBUG
658 Yap_DirtyCps += ipc->y_u.Illss.s;
659 Yap_LiveCps -= ipc->y_u.Illss.s;
660#endif
661 ipc = ipc->y_u.Illss.l1;
662 /* in case we visit again */
663 oipc->y_u.Illss.l1 = FAILCODE;
664 oipc->y_u.Illss.s = 0;
665 oipc->y_u.Illss.e = 0;
666 } break;
667 case _try_in:
668 case _jump:
669 case _jump_if_var:
670 ipc->y_u.l.l = release_wcls(ipc->y_u.l.l, ecs);
671 ipc = NEXTOP(ipc, l);
672 break;
673 /* instructions type xl */
674 case _jump_if_nonvar:
675 ipc->y_u.xll.l1 = release_wcls(ipc->y_u.xll.l1, ecs);
676 ipc = NEXTOP(ipc, xll);
677 break;
678 /* instructions type p */
679 case _user_switch:
680 ipc = NEXTOP(ipc, lp);
681 break;
682 /* instructions type e */
683 case _switch_on_type:
684 ipc->y_u.llll.l1 = release_wcls(ipc->y_u.llll.l1, ecs);
685 ipc->y_u.llll.l2 = release_wcls(ipc->y_u.llll.l2, ecs);
686 ipc->y_u.llll.l3 = release_wcls(ipc->y_u.llll.l3, ecs);
687 ipc->y_u.llll.l4 = release_wcls(ipc->y_u.llll.l4, ecs);
688 ipc = NEXTOP(ipc, llll);
689 break;
690 case _switch_list_nl:
691 ipc->y_u.ollll.l1 = release_wcls(ipc->y_u.ollll.l1, ecs);
692 ipc->y_u.ollll.l2 = release_wcls(ipc->y_u.ollll.l2, ecs);
693 ipc->y_u.ollll.l3 = release_wcls(ipc->y_u.ollll.l3, ecs);
694 ipc->y_u.ollll.l4 = release_wcls(ipc->y_u.ollll.l4, ecs);
695 ipc = NEXTOP(ipc, ollll);
696 break;
697 case _switch_on_arg_type:
698 ipc->y_u.xllll.l1 = release_wcls(ipc->y_u.xllll.l1, ecs);
699 ipc->y_u.xllll.l2 = release_wcls(ipc->y_u.xllll.l2, ecs);
700 ipc->y_u.xllll.l3 = release_wcls(ipc->y_u.xllll.l3, ecs);
701 ipc->y_u.xllll.l4 = release_wcls(ipc->y_u.xllll.l4, ecs);
702 ipc = NEXTOP(ipc, xllll);
703 break;
704 case _switch_on_sub_arg_type:
705 ipc->y_u.sllll.l1 = release_wcls(ipc->y_u.sllll.l1, ecs);
706 ipc->y_u.sllll.l2 = release_wcls(ipc->y_u.sllll.l2, ecs);
707 ipc->y_u.sllll.l3 = release_wcls(ipc->y_u.sllll.l3, ecs);
708 ipc->y_u.sllll.l4 = release_wcls(ipc->y_u.sllll.l4, ecs);
709 ipc = NEXTOP(ipc, sllll);
710 break;
711 case _if_not_then:
712 ipc = NEXTOP(ipc, clll);
713 break;
714 case _switch_on_func:
715 case _if_func:
716 case _go_on_func:
717 case _switch_on_cons:
718 case _if_cons:
719 case _go_on_cons:
720 /* make sure we don't leave dangling references to memory that is going to
721 * be removed */
722 ipc->y_u.sssl.l = NULL;
723 ipc = NEXTOP(ipc, sssl);
724 break;
725 case _op_fail:
726 return;
727 default:
728 Yap_ThrowError(SYSTEM_ERROR_INTERNAL, TermNil,
729 "Bug in Indexing Code: opcode %d", op);
730 return;
731 }
732#if defined(YAPOR) || defined(THREADS)
733 ipc = (yamop *)((CELL)ipc & ~1);
734#endif
735 }
736}
737
738static void decrease_log_indices(LogUpdIndex *c, yamop *suspend_code) {
739 /* decrease all reference counters */
740 yamop *beg = c->ClCode, *end, *ipc;
741
742 if (c->ClFlags & SwitchTableMask) {
743 CELL *end = (CELL *)((char *)c + c->ClSize);
744 CELL *beg = (CELL *)(c->ClCode);
745 OPCODE ecs = Yap_opcode(_expand_clauses);
746
747 while (beg < end) {
748 yamop **x = (yamop **)(beg + 1);
749 beg += 2;
750 *x = release_wcls(*x, ecs);
751 }
752 return;
753 }
754 end = (yamop *)((CODEADDR)c + c->ClSize);
755 ipc = beg;
756 cleanup_dangling_indices(ipc, beg, end, suspend_code);
757}
758
759static void kill_static_child_indxs(StaticIndex *indx, int in_use) {
760 StaticIndex *cl = indx->ChildIndex;
761 while (cl != NULL) {
762 StaticIndex *next = cl->SiblingIndex;
763 kill_static_child_indxs(cl, in_use);
764 cl = next;
765 }
766 if (in_use) {
767 LOCK(DeadStaticIndicesLock);
768 indx->SiblingIndex = DeadStaticIndices;
769 indx->ChildIndex = NULL;
770 DeadStaticIndices = indx;
771 UNLOCK(DeadStaticIndicesLock);
772 } else {
773 Yap_InformOfRemoval(indx);
774 if (indx->ClFlags & SwitchTableMask)
775 Yap_IndexSpace_SW -= indx->ClSize;
776 else
777 Yap_IndexSpace_Tree -= indx->ClSize;
778 Yap_FreeCodeSpace((char *)indx);
779 }
780}
781
782static void kill_children(LogUpdIndex *c, PredEntry *ap) {
783 LogUpdIndex *ncl;
784
785 c->ClRefCount++;
786 ncl = c->ChildIndex;
787 /* kill children */
788 while (ncl) {
789 kill_first_log_iblock(ncl, c, ap);
790 ncl = c->ChildIndex;
791 }
792 c->ClRefCount--;
793}
794
795/* assumes c is already locked */
796static void kill_off_lu_block(LogUpdIndex *c, LogUpdIndex *parent,
797 PredEntry *ap) {
798 /* first, make sure that I killed off all my children, some children may
799 remain in case I have tables as children */
800 if (parent != NULL) {
801 /* sat bye bye */
802 /* decrease refs */
803 parent->ClRefCount--;
804 if (parent->ClFlags & ErasedMask && !(parent->ClFlags & InUseMask) &&
805 parent->ClRefCount == 0) {
806 /* cool, I can erase the father too. */
807 if (parent->ClFlags & SwitchRootMask) {
808 kill_off_lu_block(parent, NULL, ap);
809 } else {
810 kill_off_lu_block(parent, parent->ParentIndex, ap);
811 }
812 }
813 }
814 decrease_log_indices(c, (yamop *)&(ap->cs.p_code.ExpandCode));
815 /* remove from list */
816 if (c->SiblingIndex)
817 c->SiblingIndex->PrevSiblingIndex = c->PrevSiblingIndex;
818 if (c->PrevSiblingIndex) {
819 c->PrevSiblingIndex->SiblingIndex = c->SiblingIndex;
820 } else {
821 DBErasedIList = c->SiblingIndex;
822 }
823 Yap_InformOfRemoval(c);
824 if (c->ClFlags & SwitchTableMask)
825 Yap_LUIndexSpace_SW -= c->ClSize;
826 else {
827 Yap_LUIndexSpace_Tree -= c->ClSize;
828 }
829 Yap_FreeCodeSpace((char *)c);
830}
831
832static void kill_first_log_iblock(LogUpdIndex *c, LogUpdIndex *parent,
833 PredEntry *ap) {
834 /* parent is always locked, now I lock myself */
835 if (parent != NULL) {
836 /* remove myself from parent */
837 if (c == parent->ChildIndex) {
838 parent->ChildIndex = c->SiblingIndex;
839 if (parent->ChildIndex) {
840 parent->ChildIndex->PrevSiblingIndex = NULL;
841 }
842 } else {
843 c->PrevSiblingIndex->SiblingIndex = c->SiblingIndex;
844 if (c->SiblingIndex) {
845 c->SiblingIndex->PrevSiblingIndex = c->PrevSiblingIndex;
846 }
847 }
848 } else {
849 /* I am top node */
850 if (ap->cs.p_code.TrueCodeOfPred == c->ClCode) {
851 RemoveMainIndex(ap);
852 }
853 }
854 decrease_log_indices(c, (yamop *)&(ap->cs.p_code.ExpandCode));
855 /* make sure that a child cannot remove us */
856 kill_children(c, ap);
857 /* check if we are still the main index */
858 /* always add to erased list */
859 c->SiblingIndex = DBErasedIList;
860 c->PrevSiblingIndex = NULL;
861 if (DBErasedIList)
862 DBErasedIList->PrevSiblingIndex = c;
863 DBErasedIList = c;
864 if (!((c->ClFlags & InUseMask) || c->ClRefCount)) {
865 kill_off_lu_block(c, parent, ap);
866 } else {
867 if (c->ClFlags & ErasedMask)
868 return;
869 c->ClFlags |= ErasedMask;
870 /* try to move up, so that we don't hold a switch table */
871 if (parent != NULL && parent->ClFlags & SwitchTableMask) {
872
873 c->ParentIndex = parent->ParentIndex;
874 parent->ParentIndex->ClRefCount++;
875 parent->ClRefCount--;
876 }
877 }
878}
879
880static void kill_top_static_iblock(StaticIndex *c, PredEntry *ap) {
881 kill_static_child_indxs(c, Yap_static_in_use(ap, TRUE));
882 RemoveMainIndex(ap);
883}
884
885void Yap_kill_iblock(ClauseUnion *blk, ClauseUnion *parent_blk, PredEntry *ap) {
886 if (ap->PredFlags & LogUpdatePredFlag) {
887 LogUpdIndex *c = (LogUpdIndex *)blk;
888 if (parent_blk != NULL) {
889 LogUpdIndex *cl = (LogUpdIndex *)parent_blk;
890#if MULTIPLE_STACKS
891 /* protect against attempts at erasing */
892 cl->ClRefCount++;
893#endif
894 kill_first_log_iblock(c, cl, ap);
895#if MULTIPLE_STACKS
896 cl->ClRefCount--;
897#endif
898 } else {
899 kill_first_log_iblock(c, NULL, ap);
900 }
901 } else {
902 StaticIndex *c = (StaticIndex *)blk;
903 if (parent_blk != NULL) {
904 StaticIndex *cl = parent_blk->si.ChildIndex;
905 if (cl == c) {
906 parent_blk->si.ChildIndex = c->SiblingIndex;
907 } else {
908 while (cl->SiblingIndex != c) {
909 cl = cl->SiblingIndex;
910 }
911 cl->SiblingIndex = c->SiblingIndex;
912 }
913 }
914 kill_static_child_indxs(c, Yap_static_in_use(ap, TRUE));
915 }
916}
917
918/*
919 This predicate is supposed to be called with a
920 lock on the current predicate
921*/
922void Yap_ErLogUpdIndex(LogUpdIndex *clau) {
923 if (clau->ClFlags & ErasedMask) {
924 if (!clau->ClRefCount) {
925 decrease_log_indices(clau,
926 (yamop *)&(clau->ClPred->cs.p_code.ExpandCode));
927 if (clau->ClFlags & SwitchRootMask) {
928 kill_off_lu_block(clau, NULL, clau->ClPred);
929 } else {
930 kill_off_lu_block(clau, clau->ParentIndex, clau->ClPred);
931 }
932 }
933 /* otherwise, nothing I can do, I have been erased already */
934 return;
935 }
936 if (clau->ClFlags & SwitchRootMask) {
937 kill_first_log_iblock(clau, NULL, clau->ClPred);
938 } else {
939#if MULTIPLE_STACKS
940 /* protect against attempts at erasing */
941 clau->ClRefCount++;
942#endif
943 kill_first_log_iblock(clau, clau->ParentIndex, clau->ClPred);
944#if MULTIPLE_STACKS
945 /* protect against attempts at erasing */
946 clau->ClRefCount--;
947#endif
948 }
949}
950
951/* Routine used when wanting to remove the indexation */
952/* ap is known to already have been locked for WRITING */
953static int RemoveIndexation(PredEntry *ap) {
954 if (ap->OpcodeOfPred == INDEX_OPCODE) {
955 ap->PredFlags &= ~ IndexedPredFlag;
956 return TRUE;
957 }
958 if (ap->PredFlags & LogUpdatePredFlag &&
959 ap->PredFlags & IndexedPredFlag
960 ) {
961 kill_first_log_iblock(ClauseCodeToLogUpdIndex(ap->cs.p_code.TrueCodeOfPred),
962 NULL, ap);
963 } else {
964 StaticIndex *cl;
965
966 cl = ClauseCodeToStaticIndex(ap->cs.p_code.TrueCodeOfPred);
967
968 kill_top_static_iblock(cl, ap);
969 }
970 ap->PredFlags &= ~ IndexedPredFlag;
971 return TRUE;
972}
973
974int Yap_RemoveIndexation(PredEntry *ap) { return RemoveIndexation(ap); }
975/******************************************************************
976
977 Adding clauses
978
979******************************************************************/
980
981#define ASSERTZ 0
982#define CONSULT 1
983#define ASSERTA 2
984#define ASSERTZ_STATIC 3
985#define ASSERTA_STATIC 4
986#define RECONSULT 5
987
988/* p is already locked */
989static void retract_all(PredEntry *p, int in_use) {
990 yamop *q;
991
992 q = p->cs.p_code.FirstClause;
993 if (q != NULL) {
994 if (p->PredFlags & LogUpdatePredFlag) {
995 LogUpdClause *cl = ClauseCodeToLogUpdClause(q);
996 do {
997 LogUpdClause *ncl = cl->ClNext;
998 Yap_ErLogUpdCl(cl);
999 cl = ncl;
1000 } while (cl != NULL);
1001 } else if (p->PredFlags & MegaClausePredFlag) {
1002 MegaClause *cl = ClauseCodeToMegaClause(q);
1003
1004 if (in_use || cl->ClFlags & HasBlobsMask) {
1005 LOCK(DeadMegaClausesLock);
1006 cl->ClNext = DeadMegaClauses;
1007 DeadMegaClauses = cl;
1008 UNLOCK(DeadMegaClausesLock);
1009 } else {
1010 Yap_InformOfRemoval(cl);
1011 Yap_ClauseSpace -= cl->ClSize;
1012 Yap_FreeCodeSpace((char *)cl);
1013 }
1014 /* make sure this is not a MegaClause */
1015 p->PredFlags &= ~MegaClausePredFlag;
1016 p->cs.p_code.NOfClauses = 0;
1017 } else {
1018 StaticClause *cl = ClauseCodeToStaticClause(q);
1019
1020 while (cl) {
1021 StaticClause *ncl = cl->ClNext;
1022
1023 if (in_use || cl->ClFlags & HasBlobsMask) {
1024 LOCK(DeadStaticClausesLock);
1025 cl->ClNext = DeadStaticClauses;
1026 DeadStaticClauses = cl;
1027 UNLOCK(DeadStaticClausesLock);
1028 } else {
1029 Yap_InformOfRemoval(cl);
1030 Yap_ClauseSpace -= cl->ClSize;
1031 Yap_FreeCodeSpace((char *)cl);
1032 }
1033 p->cs.p_code.NOfClauses--;
1034 if (!ncl)
1035 break;
1036 cl = ncl;
1037 }
1038 }
1039 }
1040 p->cs.p_code.FirstClause = NULL;
1041 p->cs.p_code.LastClause = NULL;
1042 if (is_live(p)) {
1043 p->cs.p_code.TrueCodeOfPred = p->CodeOfPred =
1044 (yamop *)(&p->OpcodeOfPred);
1045 p->OpcodeOfPred = FAIL_OPCODE;
1046 } else {
1047 p->OpcodeOfPred = UNDEF_OPCODE;
1048 p->PredFlags |= UndefPredFlag;
1049 }
1050 p->cs.p_code.TrueCodeOfPred = p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
1051 if (trueGlobalPrologFlag(PROFILING_FLAG)) {
1052 p->PredFlags |= ProfiledPredFlag;
1053 if (!Yap_initProfiler(p)) {
1054 return;
1055 }
1056 } else
1057 p->PredFlags &= ~ProfiledPredFlag;
1058 if (CALL_COUNTING) {
1059 p->PredFlags |= CountPredFlag;
1060 } else
1061 p->PredFlags &= ~CountPredFlag;
1062 Yap_PutValue(AtomAbol, MkAtomTerm(AtomTrue));
1063}
1064
1065bool Yap_unknown(Term t) {
1066
1067 if (t == TermFastFail) {
1068 UndefHook->OpcodeOfPred = FAIL_OPCODE;
1069 return true;
1070 } else if (t == TermError) {
1071 UndefHook->OpcodeOfPred = UndefHook->CodeOfPred->opc;
1072 return true;
1073 } else if (t == TermFail) {
1074 UndefHook->OpcodeOfPred = UndefHook->CodeOfPred->opc;
1075 return true;
1076 } else if (t == TermWarning) {
1077 UndefHook->OpcodeOfPred = UndefHook->CodeOfPred->opc;
1078 return true;
1079 }
1080
1081 return false;
1082}
1083
1084static int source_pred(PredEntry *p, yamop *q) {
1085 if (p->PredFlags & (DynamicPredFlag | LogUpdatePredFlag))
1086 return FALSE;
1087 if (p->PredFlags & MultiFileFlag)
1088 return TRUE;
1089 if (trueGlobalPrologFlag(SOURCE_FLAG)) {
1090 return TRUE;
1091 }
1092 return FALSE;
1093}
1094
1095/* p is already locked */
1096static void add_first_static(PredEntry *p, yamop *cp, int spy_flag) {
1097 CACHE_REGS
1098 yamop *pt = cp;
1099
1100#ifdef TABLING
1101 if (is_tabled(p)) {
1102 p->OpcodeOfPred = INDEX_OPCODE;
1103 p->cs.p_code.TrueCodeOfPred = p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
1104 }
1105#endif /* TABLING */
1106 p->cs.p_code.TrueCodeOfPred = pt;
1107 p->cs.p_code.FirstClause = p->cs.p_code.LastClause = cp;
1108 p->OpcodeOfPred = pt->opc;
1109#if defined(YAPOR) || defined(THREADS)
1110 if (p->PredFlags & LogUpdatePredFlag &&
1111 !(p->PredFlags & ThreadLocalPredFlag) && p->ModuleOfPred != IDB_MODULE) {
1112 p->OpcodeOfPred = LOCKPRED_OPCODE;
1113 p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
1114 } else
1115#endif
1116 p->CodeOfPred = pt;
1117 p->cs.p_code.NOfClauses = 1;
1118 if (trueGlobalPrologFlag(PROFILING_FLAG)) {
1119 p->PredFlags |= ProfiledPredFlag;
1120 if (!Yap_initProfiler(p)) {
1121 return;
1122 }
1123 spy_flag = TRUE;
1124 } else {
1125 p->PredFlags &= ~ProfiledPredFlag;
1126 }
1127 if (CALL_COUNTING) {
1128 p->PredFlags |= CountPredFlag;
1129 spy_flag = TRUE;
1130 } else {
1131 p->PredFlags &= ~CountPredFlag;
1132 }
1133 if (spy_flag) {
1134 p->OpcodeOfPred = Yap_opcode(_spy_pred);
1135 p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
1136 }
1137 if (source_pred(p, cp)) {
1138 p->PredFlags |= SourcePredFlag;
1139 }
1140 if (!(p->PredFlags & MultiFileFlag) && p->src.OwnerFile == AtomNil)
1141 p->src.OwnerFile = Yap_ConsultingFile(PASS_REGS1);
1142}
1143
1144/* p is already locked */
1145static void add_first_dynamic(PredEntry *p, yamop *cp, int spy_flag) {
1146 yamop *ncp = ((DynamicClause *)NULL)->ClCode;
1147 DynamicClause *cl;
1148
1149 if (trueGlobalPrologFlag(PROFILING_FLAG)) {
1150 p->PredFlags |= ProfiledPredFlag;
1151 if (!Yap_initProfiler(p)) {
1152 return;
1153 }
1154 spy_flag = true;
1155 } else {
1156 p->PredFlags &= ~ProfiledPredFlag;
1157 }
1158 if (CALL_COUNTING) {
1159 p->PredFlags |= CountPredFlag;
1160 spy_flag = true;
1161 } else {
1162 p->PredFlags &= ~CountPredFlag;
1163 }
1164#ifdef YAPOR
1165 p->PredFlags |= SequentialPredFlag;
1166#endif /* YAPOR */
1167 /* allocate starter block, containing info needed to start execution,
1168 * that is a try_mark to start the code and a fail to finish things up */
1169 cl = (DynamicClause *)Yap_AllocCodeSpace(
1170 (Int)NEXTOP(NEXTOP(NEXTOP(ncp, Otapl), e), l));
1171 if (cl == NIL) {
1172 Yap_ThrowError(RESOURCE_ERROR_HEAP, TermNil, "Heap crashed against Stacks");
1173 return;
1174 }
1175 Yap_ClauseSpace += (Int)NEXTOP(NEXTOP(NEXTOP(ncp, Otapl), e), l);
1176 /* skip the first entry, this contains the back link and will always be
1177 empty for this entry */
1178 ncp = (yamop *)(((CELL *)ncp) + 1);
1179 /* next we have the flags. For this block mainly say whether we are
1180 * being spied */
1181 cl->ClFlags = DynamicMask;
1182 ncp = cl->ClCode;
1183 INIT_LOCK(cl->ClLock);
1184 INIT_CLREF_COUNT(cl);
1185 /* next, set the first instruction to execute in the dyamic
1186 * predicate */
1187 if (spy_flag)
1188 p->OpcodeOfPred = ncp->opc = Yap_opcode(_spy_or_trymark);
1189 else
1190 p->OpcodeOfPred = ncp->opc = Yap_opcode(_try_and_mark);
1191 ncp->y_u.Otapl.s = p->ArityOfPE;
1192 ncp->y_u.Otapl.p = p;
1193 ncp->y_u.Otapl.d = cp;
1194 /* This is the point we enter the code */
1195 p->cs.p_code.TrueCodeOfPred = p->CodeOfPred = ncp;
1196 p->cs.p_code.NOfClauses = 1;
1197#if defined(YAPOR) || defined(THREADS)
1198 if (p->PredFlags & LogUpdatePredFlag &&
1199 !(p->PredFlags & ThreadLocalPredFlag) && p->ModuleOfPred != IDB_MODULE) {
1200 p->OpcodeOfPred = LOCKPRED_OPCODE;
1201 p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
1202 }
1203#endif
1204 /* set the first clause to have a retry and mark which will
1205 * backtrack to the previous block */
1206 if (p->PredFlags & ProfiledPredFlag)
1207 cp->opc = Yap_opcode(_profiled_retry_and_mark);
1208 else if (p->PredFlags & CountPredFlag)
1209 cp->opc = Yap_opcode(_count_retry_and_mark);
1210 else
1211 cp->opc = Yap_opcode(_retry_and_mark);
1212 cp->y_u.Otapl.s = p->ArityOfPE;
1213 cp->y_u.Otapl.p = p;
1214 cp->y_u.Otapl.d = ncp;
1215 /* also, keep a backpointer for the days you delete the clause */
1216 ClauseCodeToDynamicClause(cp)->ClPrevious = ncp;
1217 /* Don't forget to say who is the only clause for the predicate so
1218 far */
1219 p->cs.p_code.LastClause = p->cs.p_code.FirstClause = cp;
1220 /* we're only missing what to do when we actually exit the procedure
1221 */
1222 ncp = NEXTOP(ncp, Otapl);
1223 /* and the last instruction to execute to exit the predicate, note
1224 the retry is pointing to this pseudo clause */
1225 ncp->opc = Yap_opcode(_trust_fail);
1226 /* we're only missing what to do when we actually exit the procedure
1227 */
1228 /* and close the code */
1229 ncp = NEXTOP(ncp, e);
1230 ncp->opc = Yap_opcode(_Ystop);
1231 ncp->y_u.l.l = cl->ClCode;
1232 // if (!(p->PredFlags & MultiFileFlag) && p->src.OwnerFile == AtomNil)
1233 // p->src.OwnerFile = Yap_ConsultingFile(PASS_REGS1);
1234}
1235
1236/* p is already locked */
1237static void asserta_stat_clause(PredEntry *p, yamop *q, int spy_flag) {
1238 StaticClause *cl = ClauseCodeToStaticClause(q);
1239
1240 p->cs.p_code.NOfClauses++;
1241 if (is_logupd(p)) {
1242 LogUpdClause *clp = ClauseCodeToLogUpdClause(p->cs.p_code.FirstClause),
1243 *clq = ClauseCodeToLogUpdClause(q);
1244 clq->ClPrev = NULL;
1245 clq->ClNext = clp;
1246 clp->ClPrev = clq;
1247 p->cs.p_code.FirstClause = q;
1248 if (p->PredFlags & (SpiedPredFlag | CountPredFlag | ProfiledPredFlag)) {
1249 p->OpcodeOfPred = Yap_opcode(_spy_pred);
1250 p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
1251 } else if (!(p->PredFlags & IndexedPredFlag)) {
1252 p->OpcodeOfPred = INDEX_OPCODE;
1253 p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
1254 }
1255#if defined(YAPOR) || defined(THREADS)
1256 if (p->ModuleOfPred != IDB_MODULE &&
1257 !(p->PredFlags & ThreadLocalPredFlag)) {
1258 p->OpcodeOfPred = LOCKPRED_OPCODE;
1259 p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
1260 }
1261#endif
1262 return;
1263 }
1264 cl->ClNext = ClauseCodeToStaticClause(p->cs.p_code.FirstClause);
1265 p->cs.p_code.FirstClause = q;
1266 p->cs.p_code.TrueCodeOfPred = q;
1267 if (p->PredFlags & (SpiedPredFlag | CountPredFlag | ProfiledPredFlag)) {
1268 p->OpcodeOfPred = Yap_opcode(_spy_pred);
1269 p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
1270 } else if (!(p->PredFlags & IndexedPredFlag)) {
1271 p->OpcodeOfPred = INDEX_OPCODE;
1272 p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
1273 }
1274}
1275
1276/* p is already locked */
1277static void asserta_dynam_clause(PredEntry *p, yamop *cp) {
1278 yamop *q;
1279 DynamicClause *cl = ClauseCodeToDynamicClause(cp);
1280 q = cp;
1281 LOCK(ClauseCodeToDynamicClause(p->cs.p_code.FirstClause)->ClLock);
1282 /* also, keep backpointers for the days we'll delete all the clause */
1283 ClauseCodeToDynamicClause(p->cs.p_code.FirstClause)->ClPrevious = q;
1284 cl->ClPrevious = (yamop *)(p->CodeOfPred);
1285 cl->ClFlags |= DynamicMask;
1286 UNLOCK(ClauseCodeToDynamicClause(p->cs.p_code.FirstClause)->ClLock);
1287 q->y_u.Otapl.d = p->cs.p_code.FirstClause;
1288 q->y_u.Otapl.s = p->ArityOfPE;
1289 q->y_u.Otapl.p = p;
1290 if (p->PredFlags & ProfiledPredFlag)
1291 cp->opc = Yap_opcode(_profiled_retry_and_mark);
1292 else if (p->PredFlags & CountPredFlag)
1293 cp->opc = Yap_opcode(_count_retry_and_mark);
1294 else
1295 cp->opc = Yap_opcode(_retry_and_mark);
1296 cp->y_u.Otapl.s = p->ArityOfPE;
1297 cp->y_u.Otapl.p = p;
1298 p->cs.p_code.FirstClause = cp;
1299 q = p->CodeOfPred;
1300 q->y_u.Otapl.d = cp;
1301 q->y_u.Otapl.s = p->ArityOfPE;
1302 q->y_u.Otapl.p = p;
1303}
1304
1305/* p is already locked */
1306static void assertz_stat_clause(PredEntry *p, yamop *cp, int spy_flag) {
1307 yamop *pt;
1308
1309 p->cs.p_code.NOfClauses++;
1310 pt = p->cs.p_code.LastClause;
1311 if (is_logupd(p)) {
1312 LogUpdClause *clp = ClauseCodeToLogUpdClause(cp),
1313 *clq = ClauseCodeToLogUpdClause(pt);
1314
1315 clq->ClNext = clp;
1316 clp->ClPrev = clq;
1317 clp->ClNext = NULL;
1318 p->cs.p_code.LastClause = cp;
1319 if (!(p->PredFlags & IndexedPredFlag)) {
1320 p->OpcodeOfPred = INDEX_OPCODE;
1321 p->cs.p_code.TrueCodeOfPred = p->CodeOfPred =
1322 (yamop *)(&(p->OpcodeOfPred));
1323 }
1324#if defined(YAPOR) || defined(THREADS)
1325 if (p->ModuleOfPred != IDB_MODULE &&
1326 !(p->PredFlags & ThreadLocalPredFlag)) {
1327 p->OpcodeOfPred = LOCKPRED_OPCODE;
1328 p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
1329 }
1330#endif
1331 if (p->PredFlags & (SpiedPredFlag | CountPredFlag | ProfiledPredFlag)) {
1332 p->OpcodeOfPred = Yap_opcode(_spy_pred);
1333 p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
1334 }
1335 return;
1336 } else {
1337 StaticClause *cl = ClauseCodeToStaticClause(pt);
1338
1339 cl->ClNext = ClauseCodeToStaticClause(cp);
1340 }
1341 if (p->cs.p_code.FirstClause == p->cs.p_code.LastClause) {
1342 if (!(p->PredFlags & (SpiedPredFlag | CountPredFlag | ProfiledPredFlag))) {
1343 p->OpcodeOfPred = INDEX_OPCODE;
1344 p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
1345 }
1346 }
1347 p->cs.p_code.LastClause = cp;
1348}
1349
1350/* p is already locked */
1351static void assertz_dynam_clause(PredEntry *p, yamop *cp) {
1352 yamop *q;
1353 DynamicClause *cl = ClauseCodeToDynamicClause(cp);
1354
1355 q = p->cs.p_code.LastClause;
1356 LOCK(ClauseCodeToDynamicClause(q)->ClLock);
1357 q->y_u.Otapl.d = cp;
1358 p->cs.p_code.LastClause = cp;
1359 /* also, keep backpointers for the days we'll delete all the clause */
1360 cl->ClPrevious = q;
1361 cl->ClFlags |= DynamicMask;
1362 UNLOCK(ClauseCodeToDynamicClause(q)->ClLock);
1363 q = (yamop *)cp;
1364 if (p->PredFlags & ProfiledPredFlag)
1365 q->opc = Yap_opcode(_profiled_retry_and_mark);
1366 else if (p->PredFlags & CountPredFlag)
1367 q->opc = Yap_opcode(_count_retry_and_mark);
1368 else
1369 q->opc = Yap_opcode(_retry_and_mark);
1370 q->y_u.Otapl.d = p->CodeOfPred;
1371 q->y_u.Otapl.s = p->ArityOfPE;
1372 q->y_u.Otapl.p = p;
1373 p->cs.p_code.NOfClauses++;
1374}
1375
1376void Yap_AssertzClause(PredEntry *p, yamop *cp) {
1377 if (p->PredFlags & DynamicPredFlag) {
1378 if (p->cs.p_code.FirstClause == NULL) {
1379 add_first_dynamic(p, cp, FALSE);
1380 } else {
1381 assertz_dynam_clause(p, cp);
1382 }
1383 } else {
1384 if (p->cs.p_code.FirstClause == NULL) {
1385 add_first_static(p, cp, FALSE);
1386 } else {
1387 assertz_stat_clause(p, cp, FALSE);
1388 }
1389 }
1390}
1391
1392static void expand_consult(USES_REGS1) {
1393 consult_obj *new, *old;
1394
1395
1396 /* now double consult capacity */
1397 if ( LOCAL_ConsultLow==NULL) {
1398 new = (consult_obj *)Yap_AllocCodeSpace(sizeof(consult_obj) * InitialConsultCapacity);
1399 LOCAL_ConsultCapacity = InitialConsultCapacity;
1400 LOCAL_ConsultLow = new + LOCAL_ConsultCapacity;
1401 LOCAL_ConsultSp = LOCAL_ConsultLow ;
1402 LOCAL_ConsultBase = LOCAL_ConsultLow;
1403 } else {
1404 UInt OldConsultCapacity = LOCAL_ConsultCapacity;
1405 size_t used = LOCAL_ConsultLow-LOCAL_ConsultSp ;
1406 size_t parents = LOCAL_ConsultLow-LOCAL_ConsultBase ;
1407 old = LOCAL_ConsultLow- LOCAL_ConsultCapacity;
1408 size_t slack = LOCAL_ConsultSp-old;
1409 LOCAL_ConsultCapacity += InitialConsultCapacity;
1410 /* I assume it always works ;-) */
1411 new = (consult_obj *)Yap_ReallocCodeSpace(old,
1412 sizeof(consult_obj) * LOCAL_ConsultCapacity);
1413 LOCAL_ConsultLow = new + LOCAL_ConsultCapacity;
1414 LOCAL_ConsultSp = LOCAL_ConsultLow - used ;
1415 LOCAL_ConsultBase = LOCAL_ConsultLow - parents;
1416 /* start copying */
1417 memcpy(new+(slack+InitialConsultCapacity), new+slack,
1418 (OldConsultCapacity-slack) * sizeof(consult_obj));
1419 }
1420
1421}
1422
1423static int not_was_reconsulted(PredEntry *p, Term t, int mode) {
1424 CACHE_REGS
1425 register consult_obj *fp;
1426 Prop p0 = AbsProp((PropEntry *)p);
1427
1428 if (p == LOCAL_LastAssertedPred)
1429 return FALSE;
1430 if (!LOCAL_ConsultSp) {
1431 InitConsultStack();
1432 }
1433 if (p->cs.p_code.NOfClauses) {
1434 for (fp = LOCAL_ConsultSp; fp < LOCAL_ConsultBase; ++fp)
1435 if (fp->p == p0)
1436 break;
1437 } else {
1438 fp = LOCAL_ConsultBase;
1439 }
1440 if (fp != LOCAL_ConsultBase) {
1441 LOCAL_LastAssertedPred = p;
1442 return false; /* careful */
1443 } else if (mode) { // consulting again a predicate in the original file.
1444 if ((p->cs.p_code.NOfClauses &&
1445 p->src.OwnerFile == Yap_ConsultingFile(PASS_REGS1) &&
1446 p->src.OwnerFile != AtomNil && !(p->PredFlags & MultiFileFlag) &&
1447 p->src.OwnerFile != AtomUserIn)) {
1448 // if (p->ArityOfPE)
1449 // printf("+ %s %s
1450 //%d\n",NameOfFunctor(p->FunctorOfPred)->StrOfAE,p->src.OwnerFile->StrOfAE,
1451 // p->cs.p_code.NOfClauses);
1452 retract_all(p, Yap_static_in_use(p, TRUE));
1453 }
1454 // printf("- %s
1455 //%s\n",NameOfFunctor(p->FunctorOfPred)->StrOfAE,p->src.OwnerFile->StrOfAE);
1456 }
1457 if (mode) {
1458
1459 if (LOCAL_ConsultSp <= LOCAL_ConsultLow -( + LOCAL_ConsultCapacity- 6)) {
1460 expand_consult();
1461 }
1462 --LOCAL_ConsultSp;
1463 LOCAL_ConsultSp->p = p0;
1464 if (LOCAL_ConsultBase != LOCAL_ConsultLow &&
1465 LOCAL_ConsultBase[1].mode &&
1466 !(p->PredFlags & MultiFileFlag)) /* we are in reconsult mode */ {
1467 retract_all(p, Yap_static_in_use(p, TRUE));
1468 }
1469 // p->src.OwnerFile = Yap_ConsultingFile(PASS_REGS1);
1470 }
1471 LOCAL_LastAssertedPred = p;
1472 return TRUE; /* careful */
1473}
1474
1475static void addcl_permission_error(AtomEntry *ap, Int Arity, int in_use) {
1476 CACHE_REGS
1477
1478 LOCAL_Error_TYPE = PERMISSION_ERROR_MODIFY_STATIC_PROCEDURE;
1479 LOCAL_ErrorMessage = Malloc(256);
1480
1481 if (in_use) {
1482 if (Arity == 0)
1483 sprintf(LOCAL_ErrorMessage, "static predicate %s is in use", ap->StrOfAE);
1484 else
1485 sprintf(LOCAL_ErrorMessage,
1486 "static predicate %s/" Int_FORMAT " is in use", ap->StrOfAE,
1487 Arity);
1488 } else {
1489 if (Arity == 0)
1490 sprintf(LOCAL_ErrorMessage, "system predicate %s", ap->StrOfAE);
1491 else
1492 sprintf(LOCAL_ErrorMessage, "system predicate %s/" Int_FORMAT,
1493 ap->StrOfAE, Arity);
1494 }
1495}
1496
1497PredEntry *Yap_PredFromClause(Term t USES_REGS) {
1498 Term cmod = LOCAL_SourceModule;
1499 arity_t extra_arity = 0;
1500
1501 if (IsVarTerm(t))
1502 return NULL;
1503 while (IsApplTerm(t)) {
1504 Functor f = FunctorOfTerm(t);
1505 if (f == FunctorModule) {
1506 // module
1507 cmod = ArgOfTerm(1, t);
1508 if (!IsAtomTerm(cmod))
1509 return NULL;
1510 t = ArgOfTerm(2, t);
1511 } else if (f == FunctorAssert) {
1512 t = ArgOfTerm(1, t);
1513 } else if (f == FunctorComma
1514
1515 && extra_arity == 2) {
1516 t = ArgOfTerm(1, t);
1517 } else if (f == FunctorDoubleArrow) {
1518 extra_arity = 2;
1519 t = ArgOfTerm(1, t);
1520 } else if (f == FunctorQuery || f == FunctorAssert1) {
1521 // directives
1522 return NULL;
1523 } else {
1524 if (extra_arity) {
1525 f = Yap_MkFunctor(NameOfFunctor(f), ArityOfFunctor(f) + 2);
1526 }
1527 return RepPredProp(Yap_GetPredPropByFunc(f, cmod));
1528 }
1529 }
1530 if (IsAtomTerm(t)) {
1531 if (extra_arity) {
1532 Functor f = Yap_MkFunctor(AtomOfTerm(t), 2);
1533 return RepPredProp(Yap_GetPredPropByFunc(f, cmod));
1534 }
1535 return RepPredProp(Yap_GetPredPropByAtom(AtomOfTerm(t), cmod));
1536 }
1537 // ints, lists
1538
1539 return NULL;
1540}
1541
1542bool Yap_discontiguous(PredEntry *ap, Term mode USES_REGS) {
1543 register consult_obj *fp;
1544
1545 if (ap->PredFlags & (DiscontiguousPredFlag | MultiFileFlag) ||
1546 falseGlobalPrologFlag(DISCONTIGUOUS_WARNINGS_FLAG))
1547 return false;
1548 if ((mode != TermConsult && mode != TermReconsult))
1549 return false;
1550 if (!LOCAL_ConsultSp) {
1551 return false;
1552 }
1553
1554 if (ap == LOCAL_LastAssertedPred)
1555 return false;
1556 if (ap->cs.p_code.NOfClauses) {
1557 Term repeat = AbsPair((CELL *)AbsPredProp(ap));
1558 for (fp = LOCAL_ConsultSp; fp < LOCAL_ConsultBase; ++fp)
1559 if (fp->p == AbsPredProp(ap)) {
1560 // detect repeated warnings
1561 if (LOCAL_ConsultSp < LOCAL_ConsultLow-(LOCAL_ConsultCapacity - 6)) {
1562 expand_consult();
1563 }
1564 --LOCAL_ConsultSp;
1565 LOCAL_ConsultSp->r = repeat;
1566 return true;
1567 } else if (fp->r == repeat && ap->cs.p_code.NOfClauses > 4) {
1568 return false;
1569 }
1570 }
1571 return false;
1572}
1573
1574static Int p_is_discontiguous(USES_REGS1) { /* '$is_multifile'(+S,+Mod) */
1575 PredEntry *pe;
1576 Int out;
1577
1578 pe = Yap_get_pred(Deref(ARG1), Deref(ARG2), "discontiguous");
1579 if (EndOfPAEntr(pe))
1580 return FALSE;
1581 PELOCK(27, pe);
1582 out = (pe->PredFlags & DiscontiguousPredFlag);
1583 UNLOCKPE(44, pe);
1584 return (out);
1585}
1586
1587static Int
1588 p_new_discontiguous(USES_REGS1) { /* '$new_discontiguous'(+N,+Ar,+Mod) */
1589 Atom at;
1590 int arity;
1591 PredEntry *pe;
1592 Term t = Deref(ARG1);
1593 Term mod = Deref(ARG3);
1594
1595 if (IsVarTerm(t))
1596 return false;
1597 if (IsAtomTerm(t))
1598 at = AtomOfTerm(t);
1599 else
1600 return false;
1601 t = Deref(ARG2);
1602 if (IsVarTerm(t))
1603 return false;
1604 if (IsIntTerm(t))
1605 arity = IntOfTerm(t);
1606 else
1607 return false;
1608 if (arity == 0)
1609 pe = RepPredProp(PredPropByAtom(at, mod));
1610 else
1611 pe = RepPredProp(PredPropByFunc(Yap_MkFunctor(at, arity), mod));
1612 PELOCK(26, pe);
1613 pe->PredFlags |= DiscontiguousPredFlag;
1614 /* mutifile-predicates are weird, they do not seat really on the default
1615 * module */
1616 if (pe->cs.p_code.NOfClauses == 0) {
1617 pe->cs.p_code.TrueCodeOfPred = pe->CodeOfPred =
1618 (yamop *)(&pe->OpcodeOfPred);
1619 pe->OpcodeOfPred = FAIL_OPCODE;
1620 }
1621 UNLOCKPE(43, pe);
1622 return (TRUE);
1623}
1624
1625bool Yap_multiple(PredEntry *ap, Term mode USES_REGS) {
1626 register consult_obj *fp;
1627
1628 if ((ap->PredFlags & (MultiFileFlag | LogUpdatePredFlag | DynamicPredFlag)) ||
1629 mode != TermReconsult)
1630 return false;
1631 if (LOCAL_consult_level == 0)
1632 return false;
1633 for (fp = LOCAL_ConsultSp; fp < LOCAL_ConsultBase; ++fp)
1634 if (fp->p == AbsPredProp(ap)) {
1635 return false;
1636 }
1637 return ap->cs.p_code.NOfClauses > 0 && ap->src.OwnerFile != AtomNil &&
1638 Yap_ConsultingFile(PASS_REGS1) != ap->src.OwnerFile &&
1639 LOCAL_Including != MkAtomTerm(ap->src.OwnerFile);
1640}
1641
1642static int is_fact(Term t) {
1643 Term a1;
1644
1645 if (IsAtomTerm(t))
1646 return TRUE;
1647 if (FunctorOfTerm(t) != FunctorAssert)
1648 return TRUE;
1649 a1 = ArgOfTerm(2, t);
1650 if (a1 == MkAtomTerm(AtomTrue))
1651 return TRUE;
1652 return FALSE;
1653}
1654
1655Int Yap_source_line_no(void) {
1656 CACHE_REGS
1657 int sno;
1658 if ((sno = Yap_CheckAlias(AtomLoopStream)) >= 0) {
1659 // if(sno ==0)
1660 // return(AtomUserIn);
1661 return GLOBAL_Stream[sno].linecount;
1662 }
1663 if (LOCAL_consult_level == 0) {
1664 return GLOBAL_Stream[0].linecount;
1665 } else {
1666 return 1;
1667 }
1668}
1669
1670Int Yap_source_line_pos(void) {
1671 CACHE_REGS
1672 int sno;
1673 if ((sno = Yap_CheckAlias(AtomLoopStream)) >= 0) {
1674 // if(sno ==0)
1675 // return(AtomUserIn);
1676 return GLOBAL_Stream[sno].charcount-GLOBAL_Stream[sno].linestart;
1677 }
1678 if (LOCAL_consult_level == 0) {
1679 return GLOBAL_Stream[0].charcount-GLOBAL_Stream[0].linestart;
1680 } else {
1681 return 1;
1682 }
1683
1684}
1685
1686Atom Yap_source_file_name(void) {
1687 CACHE_REGS
1688 return Yap_ConsultingFile(PASS_REGS1);
1689}
1690
1698bool Yap_constPred(PredEntry *p) {
1699 pred_flags_t pflags;
1700 pflags = p->PredFlags;
1701
1702 if (pflags &
1703 ((UserCPredFlag | CArgsPredFlag | NumberDBPredFlag | AtomDBPredFlag |
1704 TestPredFlag | AsmPredFlag | CPredFlag | BinaryPredFlag)))
1705 return true;
1706
1707 if (p->PredFlags &
1708 (SysExportPredFlag | MultiFileFlag | DynamicPredFlag | LogUpdatePredFlag))
1709 return false;
1710 if (Yap_isSystemModule(p->ModuleOfPred)) {
1711 if (p->cs.p_code.NOfClauses == 0) {
1712 p->src.OwnerFile = Yap_source_file_name();
1713 return false;
1714 }
1715 if (p->src.OwnerFile == Yap_source_file_name()) {
1716 return false;
1717 }
1718 }
1719
1720 return false;
1721}
1722
1723bool Yap_addclause(Term t, yamop *cp, Term tmode, Term mod, Term *t5ref)
1724/*
1725 *
1726 mode
1727 0 assertz
1728 1 consult
1729 2 asserta
1730*/
1731{
1732 CACHE_REGS
1733 PredEntry *p;
1734 int spy_flag = FALSE;
1735 Atom at;
1736 arity_t Arity;
1737 pred_flags_t pflags;
1738 Term tf;
1739 int mode;
1740
1741 if (tmode == TermConsult) {
1742 mode = CONSULT;
1743 } else if (tmode == TermReconsult) {
1744 mode = RECONSULT;
1745 } else if (tmode == TermAsserta) {
1746 mode = ASSERTA;
1747 } else if (tmode == TermAssertz) {
1748 mode = ASSERTZ;
1749 } else if (tmode == TermAssertaStatic) {
1750 mode = ASSERTA_STATIC;
1751 } else if (tmode == TermAssertzStatic) {
1752 mode = ASSERTZ_STATIC;
1753 } else {
1754 Yap_Error(DOMAIN_ERROR_OUT_OF_RANGE, tmode,
1755 "compilation mode used to assert");
1756 return false;
1757 }
1758 if (IsApplTerm(t) && FunctorOfTerm(t) == FunctorAssert)
1759 tf = ArgOfTerm(1, t);
1760 else
1761 tf = t;
1762 tf = Yap_YapStripModule(tf, &mod);
1763
1764 if (IsAtomTerm(tf)) {
1765 at = AtomOfTerm(tf);
1766 p = RepPredProp(PredPropByAtom(at, mod));
1767 Arity = 0;
1768 } else {
1769 Functor f = FunctorOfTerm(tf);
1770 Arity = ArityOfFunctor(f);
1771 at = NameOfFunctor(f);
1772 p = RepPredProp(PredPropByFunc(f, mod));
1773 }
1774 PELOCK(20, p);
1775 /* we are redefining a prolog module predicate */
1776 if (Yap_constPred(p)) {
1777 addcl_permission_error(RepAtom(at), Arity, FALSE);
1778 UNLOCKPE(30, p);
1779 return false;
1780 }
1781 Yap_PutValue(AtomAbol, TermNil);
1782 pflags = p->PredFlags;
1783 /* we are redefining a prolog module predicate */
1784 if (pflags & MegaClausePredFlag) {
1785 split_megaclause(p);
1786 }
1787 /* The only problem we have now is when we need to throw away
1788 Indexing blocks
1789 */
1790 if (pflags & IndexedPredFlag) {
1791 if (p->cs.p_code.NOfClauses >1 )
1792 Yap_AddClauseToIndex(p, cp, (mode == ASSERTA || mode == ASSERTA_STATIC));
1793 else
1794 p->PredFlags &= ~ IndexedPredFlag;
1795 }
1796 if (pflags & (SpiedPredFlag | CountPredFlag | ProfiledPredFlag)) {
1797 spy_flag = true;
1798 }
1799
1800 if (Yap_discontiguous(p, tmode PASS_REGS)) {
1801 Term disc[3], sc[4];
1802 yap_error_descriptor_t *e = calloc(1,sizeof(yap_error_descriptor_t));
1803 Yap_MkErrorRecord( e, __FILE__, __FUNCTION__, __LINE__, WARNING_DISCONTIGUOUS, t, "discontiguous warning");
1804 if (p->ArityOfPE) {
1805 disc[0] = MkAtomTerm(NameOfFunctor(p->FunctorOfPred));
1806 } else {
1807 disc[0] = MkAtomTerm((Atom)(p->FunctorOfPred));
1808 }
1809 disc[1] = MkIntTerm(p->ArityOfPE);
1810 disc[2] = Yap_Module_Name(p);
1811 sc[0] = Yap_MkApplTerm(Yap_MkFunctor(AtomDiscontiguous, 3), 3, disc);
1812 sc[1] = MkIntegerTerm(Yap_source_line_no());
1813 sc[2] = MkAtomTerm(LOCAL_SourceFileName);
1814 sc[3] = t;
1815 t = Yap_MkApplTerm(Yap_MkFunctor(AtomStyleCheck, 4), 4, sc);
1816 sc[0] = t;
1817 sc[1] = MkSysError(e);
1818 Yap_PrintWarning(Yap_MkApplTerm(Yap_MkFunctor(AtomError, 2), 2, sc));
1819 } else if (Yap_multiple(p, tmode PASS_REGS)) {
1820 Term disc[4], sc[4];
1821 yap_error_descriptor_t *e = calloc(1,sizeof(yap_error_descriptor_t));
1822 Yap_MkErrorRecord( e, __FILE__, __FUNCTION__, __LINE__, WARNING_MULTIPLE, t, "multiple warning");
1823 if (p->ArityOfPE) {
1824 disc[0] = MkAtomTerm(NameOfFunctor(p->FunctorOfPred));
1825 } else {
1826 disc[0] = MkAtomTerm((Atom)(p->FunctorOfPred));
1827 }
1828 disc[1] = MkIntTerm(p->ArityOfPE);
1829 disc[2] = Yap_Module_Name(p);
1830 disc[3] = MkAtomTerm(p->src.OwnerFile);
1831 sc[0] = Yap_MkApplTerm(Yap_MkFunctor(AtomMultiple, 4), 4, disc);
1832 sc[1] = MkIntegerTerm(Yap_source_line_no());
1833 sc[2] = MkAtomTerm(LOCAL_SourceFileName);
1834 sc[3] = t;
1835 t = Yap_MkApplTerm(Yap_MkFunctor(AtomStyleCheck, 4), 4, sc);
1836 sc[0]= t;
1837 sc[1] = MkSysError(e);
1838 Yap_PrintWarning(Yap_MkApplTerm(Yap_MkFunctor(AtomError, 2), 2, sc));
1839 }
1840 if (mode == CONSULT||mode==RECONSULT)
1841 not_was_reconsulted(p, t, true);
1842 /* always check if we have a valid error first */
1843 if (LOCAL_ErrorMessage &&
1844 LOCAL_Error_TYPE == PERMISSION_ERROR_MODIFY_STATIC_PROCEDURE) {
1845 UNLOCKPE(31, p);
1846 return false;
1847 }
1848 if (pflags & UDIPredFlag) {
1849 Yap_new_udi_clause(p, cp, t);
1850 }
1851 if (!is_dynamic(p)) {
1852 if (pflags & LogUpdatePredFlag) {
1853 LogUpdClause *clp = ClauseCodeToLogUpdClause(cp);
1854 clp->ClFlags |= LogUpdMask;
1855 if (is_fact(t)) {
1856 clp->ClFlags |= FactMask;
1857 clp->lusl.ClLine = Yap_source_line_no();
1858 }
1859 } else {
1860 StaticClause *clp = ClauseCodeToStaticClause(cp);
1861 clp->ClFlags |= StaticMask;
1862 if (is_fact(t) && !(p->PredFlags & TabledPredFlag)) {
1863 clp->ClFlags |= FactMask;
1864 clp->usc.ClLine = Yap_source_line_no();
1865 }
1866 }
1867 if (compile_mode)
1868 p->PredFlags = p->PredFlags | CompiledPredFlag;
1869 else
1870 p->PredFlags = p->PredFlags | CompiledPredFlag;
1871 }
1872 if (p->cs.p_code.FirstClause == NULL) {
1873 p->PredFlags &= ~UndefPredFlag;
1874 if (!(pflags & DynamicPredFlag)) {
1875 add_first_static(p, cp, spy_flag);
1876 /* make sure we have a place to jump to */
1877 if (p->OpcodeOfPred == UNDEF_OPCODE ||
1878 p->OpcodeOfPred == FAIL_OPCODE) { /* log updates */
1879 p->CodeOfPred = p->cs.p_code.TrueCodeOfPred;
1880 p->OpcodeOfPred = ((yamop *)(p->CodeOfPred))->opc;
1881 }
1882#if defined(YAPOR) || defined(THREADS)
1883 if (p->PredFlags & LogUpdatePredFlag &&
1884 !(p->PredFlags & ThreadLocalPredFlag) &&
1885 p->ModuleOfPred != IDB_MODULE) {
1886 p->OpcodeOfPred = LOCKPRED_OPCODE;
1887 p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
1888 }
1889#endif
1890 } else {
1891 add_first_dynamic(p, cp, spy_flag);
1892 }
1893 } else if (mode == ASSERTA || mode == ASSERTA_STATIC) {
1894 if (pflags & DynamicPredFlag)
1895 asserta_dynam_clause(p, cp);
1896 else
1897 asserta_stat_clause(p, cp, spy_flag);
1898 } else if (pflags & DynamicPredFlag)
1899 assertz_dynam_clause(p, cp);
1900 else {
1901 assertz_stat_clause(p, cp, spy_flag);
1902 if (p->OpcodeOfPred != INDEX_OPCODE &&
1903 p->OpcodeOfPred != Yap_opcode(_spy_pred)) {
1904 p->CodeOfPred = p->cs.p_code.TrueCodeOfPred;
1905 p->OpcodeOfPred = ((yamop *)(p->CodeOfPred))->opc;
1906 }
1907#if defined(YAPOR) || defined(THREADS)
1908 if (p->PredFlags & LogUpdatePredFlag &&
1909 !(p->PredFlags & ThreadLocalPredFlag) &&
1910 p->ModuleOfPred != IDB_MODULE) {
1911 p->OpcodeOfPred = LOCKPRED_OPCODE;
1912 p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
1913 }
1914#endif
1915 }
1916 UNLOCKPE(32, p);
1917 if (pflags & LogUpdatePredFlag) {
1918 LogUpdClause *cl = (LogUpdClause *)ClauseCodeToLogUpdClause(cp);
1919 tf = MkDBRefTerm((DBRef)cl);
1920#if MULTIPLE_STACKS
1921 TRAIL_CLREF(cl); /* So that fail will erase it */
1922 INC_CLREF_COUNT(cl);
1923#else
1924 if (!(cl->ClFlags & InUseMask)) {
1925 cl->ClFlags |= InUseMask;
1926 TRAIL_CLREF(cl); /* So that fail will erase it */
1927 }
1928#endif
1929 } else {
1930 tf = Yap_MkStaticRefTerm(ClauseCodeToStaticClause(cp), p);
1931 }
1932 if (mod == PROLOG_MODULE)
1933 mod = TermProlog;
1934 if (pflags & MultiFileFlag) {
1935 /* add Info on new clause for multifile predicates to the DB */
1936 Term t[5], tn;
1937 t[0] = MkAtomTerm(Yap_ConsultingFile(PASS_REGS1));
1938 t[1] = MkAtomTerm(at);
1939 t[2] = MkIntegerTerm(Arity);
1940 t[3] = mod;
1941 t[4] = tf;
1942 tn = Yap_MkApplTerm(FunctorMultiFileClause, 5, t);
1943 Yap_Recordz(AtomMultiFile, tn);
1944 }
1945 if (t5ref ) {
1946 if (!Yap_unify(*t5ref, tf)) {
1947 return false;
1948 }
1949 }
1950 return true;
1951}
1952
1953void Yap_EraseMegaClause(yamop *cl, PredEntry *ap) {
1954 /* just make it fail */
1955 cl->opc = Yap_opcode(_op_fail);
1956}
1957
1958void Yap_EraseStaticClause(StaticClause *cl, PredEntry *ap, Term mod) {
1959
1960 /* ok, first I need to find out the parent predicate */
1961 if (ap->PredFlags & MegaClausePredFlag) {
1962 split_megaclause(ap);
1963 }
1964 if (ap->PredFlags & IndexedPredFlag)
1965 RemoveIndexation(ap);
1966 ap->cs.p_code.NOfClauses--;
1967 if (ap->cs.p_code.FirstClause == cl->ClCode) {
1968 /* got rid of first clause */
1969 if (ap->cs.p_code.LastClause == cl->ClCode) {
1970 /* got rid of all clauses */
1971 ap->cs.p_code.LastClause = ap->cs.p_code.FirstClause = NULL;
1972 if (is_live(ap)) {
1973 ap->cs.p_code.TrueCodeOfPred = ap->CodeOfPred =
1974 (yamop *)(&ap->OpcodeOfPred);
1975 ap->OpcodeOfPred = FAIL_OPCODE;
1976 } else {
1977 ap->OpcodeOfPred = UNDEF_OPCODE;
1978 ap->PredFlags |= UndefPredFlag;
1979 }
1980 ap->cs.p_code.TrueCodeOfPred = (yamop *)(&(ap->OpcodeOfPred));
1981 } else {
1982 yamop *ncl = cl->ClNext->ClCode;
1983 ap->cs.p_code.FirstClause = ncl;
1984 ap->cs.p_code.TrueCodeOfPred = ncl;
1985 ap->OpcodeOfPred = ncl->opc;
1986 }
1987 } else {
1988 StaticClause *pcl = ClauseCodeToStaticClause(ap->cs.p_code.FirstClause),
1989 *ocl = NULL;
1990
1991 while (pcl != cl) {
1992 ocl = pcl;
1993 pcl = pcl->ClNext;
1994 }
1995 if (ocl) {
1996 ocl->ClNext = cl->ClNext;
1997 }
1998 if (cl->ClCode == ap->cs.p_code.LastClause) {
1999 ap->cs.p_code.LastClause = ocl->ClCode;
2000 }
2001 }
2002 if (ap->cs.p_code.NOfClauses == 1) {
2003 assert(ap->cs.p_code.FirstClause);
2004 ap->cs.p_code.TrueCodeOfPred = ap->cs.p_code.FirstClause;
2005 ap->OpcodeOfPred = ap->cs.p_code.TrueCodeOfPred->opc;
2006 }
2007 if (cl->ClFlags & HasBlobsMask || Yap_static_in_use(ap, TRUE)) {
2008 LOCK(DeadStaticClausesLock);
2009 cl->ClNext = DeadStaticClauses;
2010 DeadStaticClauses = cl;
2011 UNLOCK(DeadStaticClausesLock);
2012 } else {
2013 Yap_InformOfRemoval(cl);
2014 Yap_ClauseSpace -= cl->ClSize;
2015 Yap_FreeCodeSpace((char *)cl);
2016 }
2017 if (ap->cs.p_code.NOfClauses == 0) {
2018 ap->CodeOfPred = ap->cs.p_code.TrueCodeOfPred;
2019 } else if (ap->cs.p_code.NOfClauses > 1) {
2020 ap->OpcodeOfPred = INDEX_OPCODE;
2021 ap->CodeOfPred = ap->cs.p_code.TrueCodeOfPred =
2022 (yamop *)(&(ap->OpcodeOfPred));
2023 } else if (ap->PredFlags &
2024 (SpiedPredFlag | CountPredFlag | ProfiledPredFlag)) {
2025 ap->OpcodeOfPred = Yap_opcode(_spy_pred);
2026 ap->CodeOfPred = ap->cs.p_code.TrueCodeOfPred =
2027 (yamop *)(&(ap->OpcodeOfPred));
2028 } else {
2029 ap->CodeOfPred = ap->cs.p_code.TrueCodeOfPred;
2030 }
2031#if defined(YAPOR) || defined(THREADS)
2032 if (ap->PredFlags & LogUpdatePredFlag &&
2033 !(ap->PredFlags & ThreadLocalPredFlag) &&
2034 ap->ModuleOfPred != IDB_MODULE) {
2035 ap->OpcodeOfPred = LOCKPRED_OPCODE;
2036 ap->CodeOfPred = (yamop *)(&(ap->OpcodeOfPred));
2037 }
2038#endif
2039}
2040
2041void Yap_add_logupd_clause(PredEntry *pe, LogUpdClause *cl, int mode) {
2042 yamop *cp = cl->ClCode;
2043
2044 if ( pe->PredFlags & IndexedPredFlag) {
2045 if (pe->cs.p_code.NOfClauses >1 )
2046 Yap_AddClauseToIndex(pe, cp, mode == ASSERTA);
2047 else
2048 pe->PredFlags &= ~ IndexedPredFlag;
2049 }
2050 if (pe->cs.p_code.FirstClause == NULL) {
2051 add_first_static(pe, cp, FALSE);
2052 /* make sure we have a place to jump to */
2053 if (pe->OpcodeOfPred == UNDEF_OPCODE ||
2054 pe->OpcodeOfPred == FAIL_OPCODE) { /* log updates */
2055#if defined(YAPOR) || defined(THREADS)
2056 if (pe->PredFlags & LogUpdatePredFlag &&
2057 !(pe->PredFlags & ThreadLocalPredFlag) &&
2058 pe->ModuleOfPred != IDB_MODULE) {
2059 pe->OpcodeOfPred = LOCKPRED_OPCODE;
2060 pe->CodeOfPred = (yamop *)(&(pe->OpcodeOfPred));
2061 } else {
2062#endif
2063 pe->CodeOfPred = pe->cs.p_code.TrueCodeOfPred;
2064 pe->OpcodeOfPred = ((yamop *)(pe->CodeOfPred))->opc;
2065#if defined(YAPOR) || defined(THREADS)
2066 }
2067#endif
2068 }
2069 } else if (mode == ASSERTA) {
2070 asserta_stat_clause(pe, cp, FALSE);
2071 } else {
2072 assertz_stat_clause(pe, cp, FALSE);
2073 }
2074}
2075
2076/* This predicate finds all what you need to be about a predicate to be
2077 asserted.
2078*/
2079static Int may_update_predicate(USES_REGS1) {
2080 Term head, body, type;
2081 Term t = Deref(ARG1);
2082 Term mod = CurrentModule;
2083 t = Yap_YapStripModule(t,&mod);
2084 if (IsApplTerm(t) && FunctorOfTerm(t) == FunctorAssert) {
2085 head = Yap_YapStripModule(ArgOfTerm(1,t),&mod);
2086 body = ArgOfTerm(2,t);
2087 } else {
2088 head = t;
2089 body = TermTrue;
2090 }
2091 PredEntry *pe = Yap_get_pred(head, mod,"compile clause");
2092 bool asserting_dynamic = Deref(ARG5) == TermDynamic;
2093 if (!pe || pe->OpcodeOfPred==UNDEF_OPCODE) {
2094 type = TermUndefined;
2095 } else if ( pe->PredFlags & LogUpdatePredFlag){
2096 type = TermDynamic;
2097 } else {
2098 type = TermStatic;
2099 }
2100 if (asserting_dynamic) {
2101 if (type == TermUndefined) {
2102 type = TermDynamic;
2103 if (!pe) {
2104 if (IsAtomTerm(head)) {
2105 pe = RepPredProp(Yap_GetPredPropByAtom(AtomOfTerm(head), mod));
2106 } else {
2107 pe = RepPredProp(PredPropByFunc(FunctorOfTerm(head), mod));
2108 }
2109 Yap_MkLogPred(pe);
2110 }
2111 }
2112 }
2113 return Yap_unify(ARG3,head) &&
2114 Yap_unify(ARG2,mod==PROLOG_MODULE?TermProlog:mod) &&
2115 Yap_unify(ARG4,body) &&
2116 Yap_unify(ARG6,type) &&
2117 Yap_unify(ARG7,((pe && pe->PredFlags & MultiFileFlag) ? TermMulti : TermFalse));
2118 }
2119
2120static Int p_compile(USES_REGS1) { /* '$compile'(+C,+Flags,+C0,-Ref) */
2121 Term t = Deref(ARG1);
2122 Term t1 = Deref(ARG2);
2123 Term mod = Deref(ARG4);
2124 yamop *code_adr;
2125
2126 if (LOCAL_ActiveError) {
2127 memset(LOCAL_ActiveError,0,sizeof(*LOCAL_ActiveError));
2128 }
2129 LOCAL_Error_TYPE = YAP_NO_ERROR;
2130 if (IsVarTerm(t1) || !IsAtomicTerm(t1))
2131 return false;
2132 if (IsVarTerm(mod) || !IsAtomTerm(mod))
2133 return false;
2134 /* separate assert in current file from reconsult
2135 if (mode == assertz && LOCAL_consult_level && mod == CurrentModule)
2136 mode = consult;
2137 */
2138 code_adr = Yap_cclause(t, 5, mod, Deref(ARG3)); /* vsc: give the number of
2139 arguments to cclause() in case there is a
2140 overflow */
2141 t = Deref(ARG1); /* just in case there was an heap overflow */
2142 if (!LOCAL_ErrorMessage) {
2143 YAPEnterCriticalSection();
2144 Yap_addclause(t, code_adr, t1, mod, &ARG5);
2145 YAPLeaveCriticalSection();
2146 }
2147 yap_error_number err;
2148 if ((err=LOCAL_Error_TYPE) != YAP_NO_ERROR) {
2149 LOCAL_Error_TYPE = YAP_NO_ERROR;
2150 Yap_ThrowError(err, ARG1, LOCAL_ErrorMessage);
2151 YAPLeaveCriticalSection();
2152 return false;
2153 }
2154 return true;
2155}
2156
2168Atom Yap_ConsultingFile(USES_REGS1) {
2169 int sno;
2170 if ((sno = Yap_CheckAlias(AtomLoopStream)) >= 0) {
2171 // if(sno ==0)
2172 // return(AtomUserIn);
2173 Atom at = StreamFullName(sno);
2174 if (at) return at;
2175 }
2176 if (LOCAL_SourceFileName != NULL) {
2177 return LOCAL_SourceFileName;
2178 }
2179 if (LOCAL_consult_level == 0) {
2180 return (AtomUserIn);
2181 } else {
2182 return (Yap_ULookupAtom(LOCAL_ConsultBase[2].f_name));
2183 }
2184}
2185
2186/* consult file *file*, *mode* may be one of either consult or reconsult */
2187void Yap_init_consult(int mode, const char *filenam) {
2188 CACHE_REGS
2189 if (!LOCAL_ConsultSp) {
2190 InitConsultStack();
2191 }
2192 if (LOCAL_ConsultSp < LOCAL_ConsultLow-(LOCAL_ConsultCapacity - 6)) {
2193 expand_consult();
2194 }
2195 LOCAL_ConsultSp--;
2196 LOCAL_ConsultSp->f_name = (const unsigned char *)filenam;
2197 LOCAL_ConsultSp--;
2198 LOCAL_ConsultSp->mode = mode;
2199 LOCAL_ConsultSp--;
2200 LOCAL_ConsultSp->c = (LOCAL_ConsultBase - LOCAL_ConsultSp);
2201 LOCAL_ConsultBase = LOCAL_ConsultSp;
2202#if !defined(YAPOR) && !defined(YAPOR_SBA)
2203/* if (LOCAL_consult_level == 0)
2204 do_toggle_static_predicates_in_use(TRUE); */
2205#endif
2206 LOCAL_consult_level++;
2207 LOCAL_LastAssertedPred = NULL;
2208}
2209
2210static Int p_startconsult(USES_REGS1) { /* '$start_consult'(+Mode) */
2211 Term t;
2212 char *smode = RepAtom(AtomOfTerm(Deref(ARG1)))->StrOfAE;
2213 int mode;
2214
2215 mode = strcmp("consult", (char *)smode);
2216 Yap_init_consult(mode, RepAtom(AtomOfTerm(Deref(ARG2)))->StrOfAE);
2217 t = MkIntTerm(LOCAL_consult_level);
2218 Yap_AddAlias(AtomLoopStream,Yap_CheckStream(ARG3,
2219 Input_Stream_f |
2220 Socket_Stream_f,
2221 "compile/1"));
2222 return (Yap_unify_constant(ARG4, t));
2223}
2224
2225static Int being_consulted(USES_REGS1) { /* '$start_consult'(+Mode) */
2226
2227 const char *s = RepAtom(AtomOfTerm(Deref(ARG1)))->StrOfAE;
2228 union CONSULT_OBJ *base = LOCAL_ConsultSp;
2229 if (!base || LOCAL_ConsultBase == LOCAL_ConsultSp || !s || s[0] == '\0')
2230 return false;
2231 base += base->c;
2232 while (base < LOCAL_ConsultLow &&base[0].c ) {
2233 if (!strcmp((const char *)(base[2].f_name),s))
2234 return true;
2235 base = base+base->c;
2236 }
2237 return false;
2238}
2239
2240static Int p_showconslultlev(USES_REGS1) {
2241 Term t;
2242 if (LOCAL_consult_level < 0)
2243 LOCAL_consult_level=0;
2244 t = MkIntTerm(LOCAL_consult_level);
2245 return (Yap_unify_constant(ARG1, t));
2246}
2247
2248static void end_consult(USES_REGS1) {
2249 if (LOCAL_consult_level>1)
2250 LOCAL_ConsultSp = LOCAL_ConsultBase;
2251 LOCAL_ConsultBase = LOCAL_ConsultSp + LOCAL_ConsultSp->c;
2252 LOCAL_ConsultSp += 3;
2253 LOCAL_consult_level--;
2254
2255LOCAL_LastAssertedPred = NULL;
2256#if !defined(YAPOR) && !defined(YAPOR_SBA)
2257/* if (LOCAL_consult_level == 0)
2258 do_toggle_static_predicates_in_use(FALSE);*/
2259#endif
2260}
2261
2262void Yap_end_consult(void) {
2263 CACHE_REGS
2264 end_consult(PASS_REGS1);
2265}
2266
2267static Int p_endconsult(USES_REGS1) { /* '$end_consult' */
2268 end_consult(PASS_REGS1);
2269 return (TRUE);
2270}
2271
2272static void purge_clauses(PredEntry *pred) {
2273 if (pred->PredFlags & UDIPredFlag) {
2274 Yap_udi_abolish(pred);
2275 }
2276 if (pred->cs.p_code.NOfClauses ) {
2277 if (pred->PredFlags & IndexedPredFlag)
2278 RemoveIndexation(pred);
2279 Yap_PutValue(AtomAbol, MkAtomTerm(AtomTrue));
2280 retract_all(pred, Yap_static_in_use(pred, TRUE));
2281 }
2282}
2283
2284void Yap_Abolish(PredEntry *pred) {
2285 purge_clauses(pred);
2286 pred->src.OwnerFile = AtomNil;
2287}
2288
2289static Int p_purge_clauses(USES_REGS1) { /* '$purge_clauses'(+Func) */
2290 PredEntry *pred;
2291 Term t = Deref(ARG1);
2292 Term mod = Deref(ARG2);
2293 MegaClause *before = DeadMegaClauses;
2294
2295 Yap_PutValue(AtomAbol, MkAtomTerm(AtomNil));
2296 if (IsVarTerm(t))
2297 return FALSE;
2298 if (IsVarTerm(mod) || !IsAtomTerm(mod)) {
2299 return FALSE;
2300 }
2301 if (IsAtomTerm(t)) {
2302 Atom at = AtomOfTerm(t);
2303 pred = RepPredProp(PredPropByAtom(at, mod));
2304 } else if (IsApplTerm(t)) {
2305 Functor fun = FunctorOfTerm(t);
2306 pred = RepPredProp(PredPropByFunc(fun, mod));
2307 } else
2308 return (FALSE);
2309 PELOCK(21, pred);
2310 if (pred->PredFlags & StandardPredFlag) {
2311 UNLOCKPE(33, pred);
2312 Yap_Error(PERMISSION_ERROR_MODIFY_STATIC_PROCEDURE, t, "assert/1");
2313 return (FALSE);
2314 }
2315 purge_clauses(pred);
2316 UNLOCKPE(34, pred);
2317 /* try to use the garbage collector to recover the mega clause,
2318 in case the objs pointing to it are dead themselves */
2319 if (DeadMegaClauses != before) {
2320 gc_entry_info_t info;
2321 Yap_track_cpred( 0, P, 0, &info);
2322 if (!Yap_gc(&info)) {
2323 Yap_Error(RESOURCE_ERROR_STACK, TermNil, LOCAL_ErrorMessage);
2324 return FALSE;
2325 }
2326 }
2327 return TRUE;
2328}
2329
2330static Int p_sys_export(USES_REGS1) { /* '$set_spy'(+Fun,+M) */
2331 PredEntry *pred;
2332 Term t, mod;
2333
2334 t = Deref(ARG1);
2335 mod = Deref(ARG2);
2336 if (IsVarTerm(mod) || !IsAtomTerm(mod))
2337 return (FALSE);
2338 if (IsVarTerm(t))
2339 return (FALSE);
2340 if (IsAtomTerm(t)) {
2341 Atom at = AtomOfTerm(t);
2342 pred = RepPredProp(Yap_PredPropByAtomNonThreadLocal(at, mod));
2343 } else if (IsApplTerm(t)) {
2344 Functor fun = FunctorOfTerm(t);
2345 pred = RepPredProp(Yap_PredPropByFunctorNonThreadLocal(fun, mod));
2346 } else {
2347 return (FALSE);
2348 }
2349 PELOCK(100, pred);
2350 pred->PredFlags |= SysExportPredFlag;
2351 UNLOCKPE(100, pred);
2352 return TRUE;
2353}
2354
2355/******************************************************************
2356
2357 INFO ABOUT PREDICATES
2358
2359******************************************************************/
2360
2361static Int
2362 number_of_clauses(USES_REGS1) { /* '$number_of_clauses'(Predicate,M,N) */
2363 Term t = Deref(ARG1);
2364 Term mod = Deref(ARG2);
2365 int ncl = 0;
2366 Prop pe;
2367
2368 if (IsVarTerm(mod) || !IsAtomTerm(mod)) {
2369 return (FALSE);
2370 }
2371 if (IsAtomTerm(t)) {
2372 Atom a = AtomOfTerm(t);
2373 pe = Yap_GetPredPropByAtom(a, mod);
2374 } else if (IsApplTerm(t)) {
2375 register Functor f = FunctorOfTerm(t);
2376 pe = Yap_GetPredPropByFunc(f, mod);
2377 } else {
2378 return (FALSE);
2379 }
2380 if (EndOfPAEntr(pe))
2381 return FALSE;
2382 PELOCK(24, RepPredProp(pe));
2383 ncl = RepPredProp(pe)->cs.p_code.NOfClauses;
2384 UNLOCKPE(41, RepPredProp(pe));
2385 return (Yap_unify_constant(ARG3, MkIntegerTerm(ncl)));
2386}
2387
2388/* @pred '$new_multifile'(+G,+Mod)
2389 * sets the multi-file flag
2390 * */
2391static Int new_multifile(USES_REGS1) {
2392 PredEntry *pe;
2393 Atom at;
2394 arity_t arity;
2395
2396 pe = Yap_new_pred(Deref(ARG1), Deref(ARG2), false, "multifile");
2397 if (EndOfPAEntr(pe))
2398 return FALSE;
2399 PELOCK(30, pe);
2400 arity = pe->ArityOfPE;
2401 if (arity == 0)
2402 at = (Atom)pe->FunctorOfPred;
2403 else
2404 at = NameOfFunctor(pe->FunctorOfPred);
2405
2406 if (pe->PredFlags & MultiFileFlag) {
2407 UNLOCKPE(26, pe);
2408 return true;
2409 }
2410 if (pe->PredFlags & (TabledPredFlag | ForeignPredFlags)) {
2411 UNLOCKPE(26, pe);
2412 addcl_permission_error(RepAtom(at), arity, FALSE);
2413 return false;
2414 }
2415 if (pe->cs.p_code.NOfClauses) {
2416 UNLOCKPE(26, pe);
2417 addcl_permission_error(RepAtom(at), arity, FALSE);
2418 return false;
2419 }
2420 pe->PredFlags &= ~UndefPredFlag;
2421 pe->PredFlags |= MultiFileFlag;
2422 /* mutifile-predicates are weird, they do not seat really on the default
2423 * module */
2424 if (!(pe->PredFlags & (DynamicPredFlag | LogUpdatePredFlag))) {
2425 /* static */
2426 pe->PredFlags |= (SourcePredFlag | CompiledPredFlag);
2427 }
2428 pe->src.OwnerFile = Yap_ConsultingFile(PASS_REGS1);
2429 if (pe->cs.p_code.NOfClauses == 0) {
2430 pe->CodeOfPred = pe->cs.p_code.TrueCodeOfPred = FAILCODE;
2431 pe->OpcodeOfPred = FAIL_OPCODE;
2432 }
2433 UNLOCKPE(43, pe);
2434 return true;
2435}
2436
2437static Int p_is_multifile(USES_REGS1) { /* '$is_multifile'(+S,+Mod) */
2438 PredEntry *pe;
2439 bool out;
2440
2441 pe = Yap_get_pred(Deref(ARG1), Deref(ARG2), "$is_multifile");
2442 if (EndOfPAEntr(pe))
2443 return FALSE;
2444 PELOCK(27, pe);
2445
2446 out = (pe->PredFlags & MultiFileFlag);
2447 UNLOCKPE(44, pe);
2448 return (out);
2449}
2450
2451static Int new_system_predicate(
2452 USES_REGS1) { /* '$new_system_predicate'(+N,+Ar,+Mod) */
2453 Atom at;
2454 arity_t arity;
2455 PredEntry *pe;
2456 Term t = Deref(ARG1);
2457 Term mod = Deref(ARG3);
2458
2459 if (IsVarTerm(t))
2460 return (FALSE);
2461 if (IsAtomTerm(t))
2462 at = AtomOfTerm(t);
2463 else
2464 return (FALSE);
2465 t = Deref(ARG2);
2466 if (IsVarTerm(t))
2467 return (FALSE);
2468 if (IsIntTerm(t))
2469 arity = IntOfTerm(t);
2470 else
2471 return FALSE;
2472 if (arity == 0)
2473 pe = RepPredProp(PredPropByAtom(at, mod));
2474 else
2475 pe = RepPredProp(PredPropByFunc(Yap_MkFunctor(at, arity), mod));
2476 PELOCK(26, pe);
2477 if (pe->PredFlags & (LogUpdatePredFlag | DynamicPredFlag | MultiFileFlag)) {
2478 UNLOCKPE(43, pe);
2479 return false;
2480 }
2481 pe->PredFlags |= (StandardPredFlag);
2482 UNLOCKPE(43, pe);
2483 return (true);
2484}
2485
2486static Int
2487 p_is_system_predicate(USES_REGS1) { /* '$is_multifile'(+S,+Mod) */
2488 PredEntry *pe;
2489 Term t1 = Deref(ARG1);
2490
2491 // pe = Yap_get_pred(t1, Deref(ARG2), "system_predicate");
2492 // if (!pe)
2493 pe = Yap_get_pred(t1, Deref(ARG2), "system_predicate");
2494 // if (!pe) pe = Yap_get_pred(t1, USER_MODULE, "system_predicate");
2495 if (EndOfPAEntr(pe))
2496 return FALSE;
2497 return (pe->ModuleOfPred == 0);
2498 // return true;
2499 // PELOCK(27, pe);
2500 // out = (pe->PredFlags & SystemPredFlags);
2501 // UNLOCKPE(44, pe);
2502 // return (out);
2503}
2504
2505static Int
2506 p_is_opaque_predicate(USES_REGS1) { /* '$is_multifile'(+S,+Mod) */
2507 PredEntry *pe;
2508 Term t1 = Deref(ARG1);
2509 bool out;
2510
2511 // pe = Yap_get_pred(t1, Deref(ARG2), "system_predicate");
2512 // if (!pe)
2513 pe = Yap_get_pred(t1, Deref(ARG2), "system_predicate");
2514 // if (!pe) pe = Yap_get_pred(t1, USER_MODULE, "system_predicate");
2515 if (EndOfPAEntr(pe))
2516 return FALSE;
2517 return (pe->ModuleOfPred == 0 ||
2518 pe->PredFlags & (SystemPredFlags | ForeignPredFlags));
2519 UNLOCKPE(44, pe);
2520 return (out);
2521}
2522
2523static Int p_is_thread_local(USES_REGS1) { /* '$is_dynamic'(+P) */
2524 PredEntry *pe;
2525 bool out;
2526
2527 pe = Yap_get_pred(Deref(ARG1), Deref(ARG2), "$is_log_updatable");
2528 if (EndOfPAEntr(pe))
2529 return FALSE;
2530 PELOCK(27, pe);
2531 out = (pe->PredFlags & ThreadLocalPredFlag);
2532 UNLOCKPE(45, pe);
2533 return (out);
2534}
2535
2536static Int p_is_private(USES_REGS1) { /* '$is_dynamic'(+P) */
2537 PredEntry *pe;
2538 bool out;
2539
2540 pe = Yap_get_pred(Deref(ARG1), Deref(ARG2), "$is_private");
2541 if (EndOfPAEntr(pe))
2542 return FALSE;
2543 PELOCK(27, pe);
2544 out = (pe->PredFlags & NoTracePredFlag);
2545 UNLOCKPE(45, pe);
2546 return (out);
2547}
2548
2549static Int p_is_log_updatable(USES_REGS1) { /* '$is_dynamic'(+P) */
2550 PredEntry *pe;
2551 bool out;
2552
2553 pe = Yap_get_pred(Deref(ARG1), Deref(ARG2), "$is_log_updatable");
2554 if (EndOfPAEntr(pe))
2555 return FALSE;
2556 PELOCK(27, pe);
2557 out = (pe->PredFlags & LogUpdatePredFlag);
2558 UNLOCKPE(45, pe);
2559 return (out);
2560}
2561
2562static Int p_is_source(USES_REGS1) { /* '$is_dynamic'(+P) */
2563 PredEntry *pe;
2564 bool out;
2565
2566 pe = Yap_get_pred(Deref(ARG1), Deref(ARG2), "$is_source");
2567 if (EndOfPAEntr(pe))
2568 return false;
2569 PELOCK(28, pe);
2570 if (pe->PredFlags & SystemPredFlags) {
2571 UNLOCKPE(46, pe);
2572 return false;
2573 }
2574 out = (pe->PredFlags & (SourcePredFlag | LogUpdatePredFlag |
2575 MegaClausePredFlag | DynamicPredFlag));
2576 UNLOCKPE(46, pe);
2577 return out;
2578}
2579
2580static Int p_is_exo(USES_REGS1) { /* '$is_dynamic'(+P) */
2581 PredEntry *pe;
2582 bool out;
2583 MegaClause *mcl;
2584
2585 pe = Yap_get_pred(Deref(ARG1), Deref(ARG2), "$is_exo");
2586 if (EndOfPAEntr(pe))
2587 return FALSE;
2588 PELOCK(28, pe);
2589 out = (pe->PredFlags & MegaClausePredFlag);
2590 if (out) {
2591 mcl = ClauseCodeToMegaClause(pe->cs.p_code.FirstClause);
2592 out = mcl->ClFlags & ExoMask;
2593 }
2594 UNLOCKPE(46, pe);
2595 return (out);
2596}
2597static Term gpred(PredEntry *pe)
2598{
2599 Term out = TermStaticProcedure;
2600 MegaClause *mcl;
2601 if ( pe->OpcodeOfPred == UNDEF_OPCODE)
2602 return TermUndefined;
2603 PELOCK(28, pe);
2604 out = (pe->PredFlags & LogUpdatePredFlag ? TermUpdatableProcedure : out);
2605 out = (pe->PredFlags & SourcePredFlag ? TermSourceProcedure : out);
2606 out = (pe->PredFlags & SystemPredFlags ? TermSystemProcedure : out);
2607 out = (pe->PredFlags & MegaClausePredFlag ? TermMegaProcedure : out);
2608 if (out==TermMegaProcedure) {
2609 mcl = ClauseCodeToMegaClause(pe->cs.p_code.FirstClause);
2610 out = ( mcl->ClFlags & ExoMask ? TermExoProcedure : out);
2611 }
2612 out = (pe->PredFlags & NoTracePredFlag ? TermPrivateProcedure : out);
2613 UNLOCKPE(45, pe);
2614 return (out);
2615
2616
2617}
2618static Int predicate_type(USES_REGS1) { /* '$is_dynamic'(+P) */
2619 PredEntry *pe;
2620 pe = Yap_get_pred(Deref(ARG1), Deref(ARG2), "$is_exo");
2621 if (pe == NULL)
2622 return false;
2623 return Yap_unify(ARG3, gpred(pe));
2624 }
2625
2626static Int owner_file(USES_REGS1) { /* '$owner_file'(+P,M,F) */
2627 PredEntry *pe;
2628 Atom owner;
2629
2630 pe = Yap_get_pred(Deref(ARG1), Deref(ARG2), "$is_source");
2631 if (EndOfPAEntr(pe))
2632 return false;
2633 PELOCK(29, pe);
2634 if (pe->ModuleOfPred == IDB_MODULE) {
2635 UNLOCKPE(47, pe);
2636 return false;
2637 }
2638 if (pe->PredFlags & MultiFileFlag) {
2639 UNLOCKPE(48, pe);
2640 return false;
2641 }
2642 if (is_system(pe) || is_foreign(pe)) {
2643 UNLOCKPE(48, pe);
2644 return false;
2645 }
2646 owner = pe->src.OwnerFile;
2647 UNLOCKPE(49, pe);
2648 if (owner == AtomNil || owner == NULL)
2649 return false;
2650 return Yap_unify(ARG3, MkAtomTerm(owner));
2651}
2652
2653static Int p_set_owner_file(USES_REGS1) { /* '$owner_file'(+P,M,F) */
2654 PredEntry *pe;
2655
2656 pe = Yap_get_pred(Deref(ARG1), Deref(ARG2), "$is_source");
2657 if (EndOfPAEntr(pe))
2658 return FALSE;
2659 PELOCK(29, pe);
2660 if (pe->ModuleOfPred == IDB_MODULE) {
2661 UNLOCKPE(47, pe);
2662 return FALSE;
2663 }
2664 if (pe->PredFlags & MultiFileFlag) {
2665 UNLOCKPE(48, pe);
2666 return FALSE;
2667 }
2668 pe->src.OwnerFile = AtomOfTerm(Deref(ARG3));
2669 UNLOCKPE(49, pe);
2670 return TRUE;
2671}
2672
2673static Int mk_dynamic(USES_REGS1) { /* '$make_dynamic'(+P) */
2674 PredEntry *pe;
2675 Atom at;
2676 arity_t arity;
2677
2678 pe = Yap_new_pred(Deref(ARG1), CurrentModule, true, "dynamic");
2679 if (EndOfPAEntr(pe))
2680 return FALSE;
2681 PELOCK(30, pe);
2682 arity = pe->ArityOfPE;
2683 if (arity == 0)
2684 at = (Atom)pe->FunctorOfPred;
2685 else
2686 at = NameOfFunctor(pe->FunctorOfPred);
2687
2688 if (pe->PredFlags &
2689 (UserCPredFlag | CArgsPredFlag | NumberDBPredFlag | AtomDBPredFlag |
2690 TestPredFlag | AsmPredFlag | CPredFlag | BinaryPredFlag)) {
2691 UNLOCKPE(30, pe);
2692 addcl_permission_error(RepAtom(at), arity, FALSE);
2693 return false;
2694 }
2695 if (pe->PredFlags & LogUpdatePredFlag) {
2696 UNLOCKPE(26, pe);
2697 return true;
2698 }
2699 if (pe->PredFlags & DynamicPredFlag) {
2700 UNLOCKPE(26, pe);
2701 return true;
2702 }
2703 if (pe->cs.p_code.NOfClauses != 0) {
2704 UNLOCKPE(26, pe);
2705 addcl_permission_error(RepAtom(at), arity, FALSE);
2706 return false;
2707 }
2708 if (pe->OpcodeOfPred == UNDEF_OPCODE) {
2709 pe->OpcodeOfPred = FAIL_OPCODE;
2710 pe->PredFlags &= ~UndefPredFlag;
2711 }
2712 pe->src.OwnerFile = Yap_ConsultingFile(PASS_REGS1);
2713 pe->PredFlags |= LogUpdatePredFlag;
2714 UNLOCKPE(50, pe);
2715 return true;
2716}
2717
2718static Int p_is_dynamic(USES_REGS1) { /* '$is_dynamic'(+P) */
2719 PredEntry *pe;
2720 bool out;
2721
2722 pe = Yap_get_pred(Deref(ARG1), Deref(ARG2), "$is_dynamic");
2723 if (EndOfPAEntr(pe))
2724 return FALSE;
2725 PELOCK(31, pe);
2726 out = (pe->PredFlags & (DynamicPredFlag | LogUpdatePredFlag));
2727 UNLOCKPE(51, pe);
2728 return (out);
2729}
2730
2731/* @pred '$new_multifile'(+G,+Mod)
2732 * sets the multi-file flag
2733 * */
2734static Int new_meta_pred(USES_REGS1) {
2735 PredEntry *pe;
2736
2737 pe = Yap_new_pred(Deref(ARG1), Deref(ARG2), false, "meta_predicate");
2738 if (EndOfPAEntr(pe))
2739 return FALSE;
2740 PELOCK(30, pe);
2741
2742 if (pe->PredFlags & MetaPredFlag) {
2743 UNLOCKPE(26, pe);
2744 return true;
2745 }
2746 if (pe->cs.p_code.NOfClauses) {
2747 UNLOCKPE(26, pe);
2748 //addcl_permission_error(RepAtom(at), arity, FALSE);
2749 return false;
2750 }
2751 pe->PredFlags |= MetaPredFlag;
2752 if (!(pe->PredFlags & (DynamicPredFlag | LogUpdatePredFlag))) {
2753 /* static */
2754 pe->PredFlags |= (SourcePredFlag | CompiledPredFlag);
2755 }
2756 UNLOCKPE(43, pe);
2757 return true;
2758}
2759
2760static Int p_is_metapredicate(USES_REGS1) { /* '$is_metapredicate'(+P) */
2761 PredEntry *pe;
2762 bool out;
2763
2764 pe = Yap_get_pred(Deref(ARG1), Deref(ARG2), "$is_meta");
2765 if (EndOfPAEntr(pe))
2766 return FALSE;
2767 PELOCK(32, pe);
2768 out = (pe->PredFlags & MetaPredFlag);
2769 UNLOCKPE(52, pe);
2770 return out;
2771}
2772static Int proxy_predicate(USES_REGS1) { /* '$is_metapredicate'(+P) */
2773 PredEntry *pe;
2774
2775 pe = Yap_get_pred(Deref(ARG1), Deref(ARG2), "$is_meta");
2776 if (EndOfPAEntr(pe))
2777
2778 return FALSE;
2779 PELOCK(32, pe);
2780 pe->PredFlags |= ProxyPredFlag;
2781 UNLOCKPE(52, pe);
2782 return true;
2783}
2784
2785static Int pred_exists(USES_REGS1) { /* '$pred_exists'(+P,+M) */
2786 PredEntry *pe;
2787 bool out;
2788 pe = Yap_get_pred(Deref(ARG1), Deref(ARG2), "$exists");
2789 if (EndOfPAEntr(pe))
2790 return false;
2791 PELOCK(34, pe);
2792 if (pe->PredFlags & HiddenPredFlag) {
2793 UNLOCKPE(54, pe);
2794 return false;
2795 }
2796 out = (is_live(pe) || pe->OpcodeOfPred != UNDEF_OPCODE);
2797 out &= ~(pe->PredFlags & ProxyPredFlag);
2798 UNLOCKPE(55, pe);
2799 return out;
2800}
2801
2802static Int p_set_pred_module(USES_REGS1) { /* '$set_pred_module'(+P,+Mod)
2803 */
2804 PredEntry *pe;
2805
2806 pe = Yap_get_pred(Deref(ARG1), CurrentModule, "set_pred_module/1");
2807 if (EndOfPAEntr(pe))
2808 return FALSE;
2809 PELOCK(35, pe);
2810 pe->ModuleOfPred = Deref(ARG2);
2811 UNLOCKPE(56, pe);
2812 return (TRUE);
2813}
2814
2815static Int p_set_pred_owner(USES_REGS1) { /* '$set_pred_module'(+P,+File)
2816 */
2817 PredEntry *pe;
2818 Term a2 = Deref(ARG2);
2819
2820 pe = Yap_get_pred(Deref(ARG1), CurrentModule, "set_pred_module/1");
2821 if (EndOfPAEntr(pe))
2822 return FALSE;
2823 PELOCK(35, pe);
2824 if (pe->PredFlags &
2825 (UserCPredFlag | CArgsPredFlag | NumberDBPredFlag | AtomDBPredFlag |
2826 TestPredFlag | AsmPredFlag | CPredFlag | BinaryPredFlag)) {
2827 UNLOCKPE(56, pe);
2828 return FALSE;
2829 }
2830 if (IsVarTerm(a2)) {
2831 Yap_Error(INSTANTIATION_ERROR, a2, "load_files/2");
2832 UNLOCKPE(56, pe);
2833 return FALSE;
2834 }
2835 if (!IsAtomTerm(a2)) {
2836 Yap_Error(TYPE_ERROR_ATOM, a2, "load_files/2");
2837 UNLOCKPE(56, pe);
2838 return FALSE;
2839 }
2840 pe->src.OwnerFile = AtomOfTerm(a2);
2841 UNLOCKPE(56, pe);
2842 return (TRUE);
2843}
2844
2849static Int undefp_handler(USES_REGS1) { /* '$undefp_handler'(P,Mod) */
2850 PredEntry *pe;
2851 Term mod = CurrentModule;
2852 if (ARG1 == MkIntTerm(0)) {
2853 UndefHook = NULL;
2854 return true;
2855 }
2856 pe = Yap_get_pred(Deref(ARG1), mod, "undefined/1");
2857 if (EndOfPAEntr(pe))
2858 return false;
2859 PELOCK(59, pe);
2860 if (pe->OpcodeOfPred == UNDEF_OPCODE) {
2861 UNLOCKPE(59, pe);
2862 return false;
2863 }
2864 UndefHook = pe;
2865 UNLOCKPE(59, pe);
2866 return true;
2867}
2868
2869static Int p_undefined(USES_REGS1) { /* '$undefined'(P,Mod) */
2870 PredEntry *pe;
2871
2872 pe = Yap_get_pred(Deref(ARG1), Deref(ARG2), "undefined/1");
2873 if (EndOfPAEntr(pe))
2874 return TRUE;
2875 PELOCK(36, pe);
2876 if (!is_live(pe) && pe->OpcodeOfPred == UNDEF_OPCODE) {
2877 UNLOCKPE(58, pe);
2878 return TRUE;
2879 }
2880 UNLOCKPE(59, pe);
2881 return FALSE;
2882}
2883
2884/*
2885 * this predicate should only be called when all clauses for the dynamic
2886 * predicate were remove, otherwise chaos will follow!!
2887 */
2888
2889static Int p_kill_dynamic(USES_REGS1) { /* '$kill_dynamic'(P,M) */
2890 PredEntry *pe;
2891
2892 pe = Yap_get_pred(Deref(ARG1), Deref(ARG2), "kill_dynamic/1");
2893 if (EndOfPAEntr(pe))
2894 return TRUE;
2895 PELOCK(37, pe);
2896 if (!(pe->PredFlags & (DynamicPredFlag | LogUpdatePredFlag))) {
2897 UNLOCKPE(60, pe);
2898 return FALSE;
2899 }
2900 if (pe->cs.p_code.LastClause != pe->cs.p_code.FirstClause) {
2901 UNLOCKPE(61, pe);
2902 return (FALSE);
2903 }
2904 pe->cs.p_code.LastClause = pe->cs.p_code.FirstClause = NULL;
2905 pe->OpcodeOfPred = UNDEF_OPCODE;
2906 pe->cs.p_code.TrueCodeOfPred = pe->CodeOfPred =
2907 (yamop *)(&(pe->OpcodeOfPred));
2908 pe->PredFlags = UndefPredFlag;
2909 UNLOCKPE(62, pe);
2910 return (TRUE);
2911}
2912
2913static Int p_optimizer_on(USES_REGS1) { /* '$optimizer_on' */
2914 optimizer_on = TRUE;
2915 return (TRUE);
2916}
2917
2918static Int p_optimizer_off(USES_REGS1) { /* '$optimizer_off' */
2919 optimizer_on = FALSE;
2920 return (TRUE);
2921}
2922
2923static Int p_is_profiled(USES_REGS1) {
2924 Term t = Deref(ARG1);
2925 char *s;
2926
2927 if (IsVarTerm(t)) {
2928 Term ta;
2929
2930 if (trueGlobalPrologFlag(PROFILING_FLAG))
2931 ta = MkAtomTerm(AtomOn);
2932 else
2933 ta = MkAtomTerm(AtomOff);
2934 YapBind((CELL *)t, ta);
2935 return (TRUE);
2936 } else if (!IsAtomTerm(t))
2937 return (FALSE);
2938 s = (char *)RepAtom(AtomOfTerm(t))->StrOfAE;
2939 if (strcmp(s, "on") == 0) {
2940 Yap_InitComma();
2941 return (TRUE);
2942 } else if (strcmp(s, "off") == 0) {
2943 PROFILING = FALSE;
2944 Yap_InitComma();
2945 return (TRUE);
2946 }
2947 return (FALSE);
2948}
2949
2950static Int p_profile_info(USES_REGS1) {
2951 Term mod = Deref(ARG1);
2952 Term tfun = Deref(ARG2);
2953 Term out;
2954 PredEntry *pe;
2955 Term p[3];
2956
2957 if (IsVarTerm(mod) || !IsAtomTerm(mod))
2958 return (FALSE);
2959 if (IsVarTerm(tfun)) {
2960 return (FALSE);
2961 } else if (IsApplTerm(tfun)) {
2962 Functor f = FunctorOfTerm(tfun);
2963 if (IsExtensionFunctor(f)) {
2964 return (FALSE);
2965 }
2966 pe = RepPredProp(Yap_GetPredPropByFunc(f, mod));
2967 } else if (IsAtomTerm(tfun)) {
2968 pe = RepPredProp(Yap_GetPredPropByAtom(AtomOfTerm(tfun), mod));
2969 } else {
2970 return (FALSE);
2971 }
2972 if (EndOfPAEntr(pe))
2973 return (FALSE);
2974 LOCK(pe->StatisticsForPred->lock);
2975 if (!(pe->StatisticsForPred->NOfEntries)) {
2976 UNLOCK(pe->StatisticsForPred->lock);
2977 return (FALSE);
2978 }
2979 p[0] = Yap_MkULLIntTerm(pe->StatisticsForPred->NOfEntries);
2980 p[1] = Yap_MkULLIntTerm(pe->StatisticsForPred->NOfHeadSuccesses);
2981 p[2] = Yap_MkULLIntTerm(pe->StatisticsForPred->NOfRetries);
2982 UNLOCK(pe->StatisticsForPred->lock);
2983 out = Yap_MkApplTerm(Yap_MkFunctor(AtomProfile, 3), 3, p);
2984 return (Yap_unify(ARG3, out));
2985}
2986
2987static Int p_profile_reset(USES_REGS1) {
2988 Term mod = Deref(ARG1);
2989 Term tfun = Deref(ARG2);
2990 PredEntry *pe;
2991
2992 if (IsVarTerm(mod) || !IsAtomTerm(mod))
2993 return (FALSE);
2994 if (IsVarTerm(tfun)) {
2995 return (FALSE);
2996 } else if (IsApplTerm(tfun)) {
2997 Functor f = FunctorOfTerm(tfun);
2998 if (IsExtensionFunctor(f)) {
2999 return (FALSE);
3000 }
3001 pe = RepPredProp(Yap_GetPredPropByFunc(f, mod));
3002 } else if (IsAtomTerm(tfun)) {
3003 pe = RepPredProp(Yap_GetPredPropByAtom(AtomOfTerm(tfun), mod));
3004 } else {
3005 return (FALSE);
3006 }
3007 if (EndOfPAEntr(pe))
3008 return (FALSE);
3009 LOCK(pe->StatisticsForPred->lock);
3010 pe->StatisticsForPred->NOfEntries = 0;
3011 pe->StatisticsForPred->NOfHeadSuccesses = 0;
3012 pe->StatisticsForPred->NOfRetries = 0;
3013 UNLOCK(pe->StatisticsForPred->lock);
3014 return (TRUE);
3015}
3016
3017static Int p_is_call_counted(USES_REGS1) {
3018 Term t = Deref(ARG1);
3019 char *s;
3020
3021 if (IsVarTerm(t)) {
3022 Term ta;
3023
3024 if (CALL_COUNTING)
3025 ta = MkAtomTerm(AtomOn);
3026 else
3027 ta = MkAtomTerm(AtomOff);
3028 YapBind((CELL *)t, ta);
3029 return (TRUE);
3030 } else if (!IsAtomTerm(t))
3031 return (FALSE);
3032 s = (char *)RepAtom(AtomOfTerm(t))->StrOfAE;
3033 if (strcmp(s, "on") == 0) {
3034 CALL_COUNTING = TRUE;
3035 Yap_InitComma();
3036 return (TRUE);
3037 } else if (strcmp(s, "off") == 0) {
3038 CALL_COUNTING = FALSE;
3039 Yap_InitComma();
3040 return (TRUE);
3041 }
3042 return (FALSE);
3043}
3044
3045static Int p_call_count_info(USES_REGS1) {
3046 return (Yap_unify(MkIntegerTerm(LOCAL_ReductionsCounter), ARG1) &&
3047 Yap_unify(MkIntegerTerm(LOCAL_PredEntriesCounter), ARG2) &&
3048 Yap_unify(MkIntegerTerm(LOCAL_PredEntriesCounter), ARG3));
3049}
3050
3051static Int p_call_count_reset(USES_REGS1) {
3052 LOCAL_ReductionsCounter = 0;
3053 LOCAL_ReductionsCounterOn = FALSE;
3054 LOCAL_PredEntriesCounter = 0;
3055 LOCAL_PredEntriesCounterOn = FALSE;
3056 LOCAL_RetriesCounter = 0;
3057 LOCAL_RetriesCounterOn = FALSE;
3058 return (TRUE);
3059}
3060
3061static Int p_call_count_set(USES_REGS1) {
3062 int do_calls = IntOfTerm(ARG2);
3063 int do_retries = IntOfTerm(ARG4);
3064 int do_entries = IntOfTerm(ARG6);
3065
3066 if (do_calls)
3067 LOCAL_ReductionsCounter = IntegerOfTerm(Deref(ARG1));
3068 LOCAL_ReductionsCounterOn = do_calls;
3069 if (do_retries)
3070 LOCAL_RetriesCounter = IntegerOfTerm(Deref(ARG3));
3071 LOCAL_RetriesCounterOn = do_retries;
3072 if (do_entries)
3073 LOCAL_PredEntriesCounter = IntegerOfTerm(Deref(ARG5));
3074 LOCAL_PredEntriesCounterOn = do_entries;
3075 return (TRUE);
3076}
3077
3078static Int p_clean_up_dead_clauses(USES_REGS1) {
3079 while (DeadStaticClauses != NULL) {
3080 char *pt = (char *)DeadStaticClauses;
3081 Yap_ClauseSpace -= DeadStaticClauses->ClSize;
3082 DeadStaticClauses = DeadStaticClauses->ClNext;
3083 Yap_InformOfRemoval(pt);
3084 Yap_FreeCodeSpace(pt);
3085 }
3086 while (DeadStaticIndices != NULL) {
3087 char *pt = (char *)DeadStaticIndices;
3088 if (DeadStaticIndices->ClFlags & SwitchTableMask)
3089 Yap_IndexSpace_SW -= DeadStaticIndices->ClSize;
3090 else
3091 Yap_IndexSpace_Tree -= DeadStaticIndices->ClSize;
3092 DeadStaticIndices = DeadStaticIndices->SiblingIndex;
3093 Yap_InformOfRemoval(pt);
3094 Yap_FreeCodeSpace(pt);
3095 }
3096 while (DeadMegaClauses != NULL) {
3097 char *pt = (char *)DeadMegaClauses;
3098 Yap_ClauseSpace -= DeadMegaClauses->ClSize;
3099 DeadMegaClauses = DeadMegaClauses->ClNext;
3100 Yap_InformOfRemoval(pt);
3101 Yap_FreeCodeSpace(pt);
3102 }
3103 return TRUE;
3104}
3105
3106void Yap_HidePred(PredEntry *pe) {
3107
3108 pe->PredFlags |= (HiddenPredFlag | NoSpyPredFlag | NoTracePredFlag);
3109}
3110
3111static Int /* $system_predicate(P) */
3112p_stash_predicate(USES_REGS1) {
3113 PredEntry *pe;
3114
3115 Term mod = TermCurrentModule;
3116 pe = Yap_get_pred(Deref(ARG1), mod , "stash");
3117 if (EndOfPAEntr(pe))
3118 return FALSE;
3119 Yap_HidePred(pe);
3120 return TRUE;
3121}
3122
3123static Int /* $system_predicate(P) */
3124hide_predicate(USES_REGS1) {
3125 Term mod = CurrentModule;
3126 Term t = Yap_YapStripModule(Deref(ARG1), &mod);
3127 if (mod == 0) mod = TermProlog;
3128 PredEntry *pe = Yap_get_pred(t, mod, "hide_predicate/1");
3129
3130 if (EndOfPAEntr(pe))
3131 return false;
3132 Prop p;
3133 if (pe->ArityOfPE) {
3134 p = pe->FunctorOfPred->PropsOfFE;
3135 } else {
3136 p = RepAtom((Atom)pe->FunctorOfPred)->PropsOfAE;
3137 }
3138 while (p) {
3139 if (p == AbsPredProp(pe)) {
3140 break;
3141 } else {
3142 p = p->NextOfPE;
3143 }
3144 }
3145 pe->PredFlags |= (HiddenPredFlag | NoSpyPredFlag | NoTracePredFlag);
3146 return true;
3147}
3148
3149static Int /* $hidden_predicate(P) */
3150p_hidden_predicate(USES_REGS1) {
3151 PredEntry *pe;
3152
3153 Term t1 = Deref(ARG1);
3154 Term mod = Deref(ARG2);
3155
3156restart_system_pred:
3157 if (IsVarTerm(t1))
3158 return (FALSE);
3159 if (IsAtomTerm(t1)) {
3160 pe = RepPredProp(Yap_GetPredPropByAtom(AtomOfTerm(t1), mod));
3161 } else if (IsApplTerm(t1)) {
3162 Functor funt = FunctorOfTerm(t1);
3163 if (IsExtensionFunctor(funt)) {
3164 return (FALSE);
3165 }
3166 if (funt == FunctorModule) {
3167 Term nmod = ArgOfTerm(1, t1);
3168 if (IsVarTerm(nmod)) {
3169 Yap_Error(INSTANTIATION_ERROR, ARG1, "hide_predicate/1");
3170 return (FALSE);
3171 }
3172 if (!IsAtomTerm(nmod)) {
3173 Yap_Error(TYPE_ERROR_ATOM, ARG1, "hide_predicate/1");
3174 return (FALSE);
3175 }
3176 t1 = ArgOfTerm(2, t1);
3177 goto restart_system_pred;
3178 }
3179 pe = RepPredProp(Yap_GetPredPropByFunc(funt, mod));
3180 } else if (IsPairTerm(t1)) {
3181 return (TRUE);
3182 } else
3183 return (FALSE);
3184 if (EndOfPAEntr(pe))
3185 return (FALSE);
3186 return (pe->PredFlags & HiddenPredFlag);
3187}
3188
3189static Int fetch_next_lu_clause(PredEntry *pe, yamop *i_code, yhandle_t yth, yhandle_t ytb,
3190 yhandle_t ytr, yamop *cp_ptr, int first_time) {
3191 CACHE_REGS
3192 LogUpdClause *cl;
3193 Term rtn;
3194 cl = Yap_FollowIndexingCode(
3195 pe, i_code, yth, NEXTOP(PredLogUpdClause->CodeOfPred, Otapl), cp_ptr);
3196 if (cl == NULL) {
3197 UNLOCK(pe->PELock);
3198 return FALSE;
3199 }
3200 rtn = MkDBRefTerm((DBRef)cl);
3201#if MULTIPLE_STACKS
3202 TRAIL_CLREF(cl); /* So that fail will erase it */
3203 INC_CLREF_COUNT(cl);
3204#else
3205 if (!(cl->ClFlags & InUseMask)) {
3206 cl->ClFlags |= InUseMask;
3207 TRAIL_CLREF(cl); /* So that fail will erase it */
3208 }
3209#endif
3210 if (cl->ClFlags & FactMask) {
3211 if (!Yap_unify_constant(Yap_GetFromHandle(yth+1), MkAtomTerm(AtomTrue)) ||
3212 !Yap_unify(Yap_GetFromHandle(yth+2), rtn)) {
3213 UNLOCK(pe->PELock);
3214 return FALSE;
3215 }
3216 if (pe->ArityOfPE) {
3217 Term th = Yap_GetFromHandle(yth);
3218 Functor f = FunctorOfTerm(th);
3219 arity_t arity = ArityOfFunctor(f), i;
3220 CELL *pt = RepAppl(th) + 1;
3221
3222 for (i = 0; i < arity; i++) {
3223 XREGS[i + 1] = pt[i];
3224 }
3225 /* don't need no ENV */
3226 if (first_time && P->opc != EXECUTE_CPRED_OP_CODE) {
3227 CP = P;
3228 ENV = YENV;
3229 YENV = ASP;
3230 YENV[E_CB] = (CELL)B;
3231 }
3232 P = cl->ClCode;
3233#if defined(YAPOR) || defined(THREADS)
3234 if (pe->PredFlags & ThreadLocalPredFlag) {
3235 /* we don't actually need to execute code */
3236 UNLOCK(pe->PELock);
3237 } else {
3238 PP = pe;
3239 }
3240#endif
3241 } else {
3242 /* we don't actually need to execute code */
3243 UNLOCK(pe->PELock);
3244 }
3245 return TRUE;
3246 } else {
3247 Term t;
3248
3249 while ((t = Yap_FetchClauseTermFromDB(cl->lusl.ClSource)) == 0L) {
3250
3251 if (first_time) {
3252 if (LOCAL_Error_TYPE == RESOURCE_ERROR_ATTRIBUTED_VARIABLES) {
3253 LOCAL_Error_TYPE = YAP_NO_ERROR;
3254 if (!Yap_growglobal(NULL)) {
3255 UNLOCK(pe->PELock);
3256 Yap_Error(RESOURCE_ERROR_ATTRIBUTED_VARIABLES, TermNil,
3257 LOCAL_ErrorMessage);
3258 return FALSE;
3259 }
3260 } else {
3261 LOCAL_Error_TYPE = YAP_NO_ERROR;
3262 if (!Yap_dogc(PASS_REGS1)) {
3263 UNLOCK(pe->PELock);
3264 Yap_Error(RESOURCE_ERROR_STACK, TermNil, LOCAL_ErrorMessage);
3265 return FALSE;
3266 }
3267 }
3268 } else {
3269 if (!Yap_dogc(PASS_REGS1)) {
3270 UNLOCK(pe->PELock);
3271 Yap_Error(RESOURCE_ERROR_STACK, TermNil, LOCAL_ErrorMessage);
3272 return FALSE;
3273 }
3274 }
3275 }
3276 UNLOCK(pe->PELock);
3277 return (Yap_unify(Yap_GetFromHandle(yth), ArgOfTerm(1, t)) &&
3278 Yap_unify(Yap_GetFromHandle(yth+1), ArgOfTerm(2, t)) &&
3279 Yap_unify(Yap_GetFromHandle(yth+2), rtn));
3280 }
3281}
3282
3283static Int /* $hidden_predicate(P) */
3284p_log_update_clause(USES_REGS1) {
3285 PredEntry *pe;
3286
3287 Term t1 = Deref(ARG1);
3288 Int ret;
3289 yamop *new_cp;
3290
3291 if (P->opc == EXECUTE_CPRED_OP_CODE) {
3292 new_cp = CP;
3293 } else {
3294 new_cp = P;
3295 }
3296 pe = Yap_get_pred(t1, Deref(ARG2), "clause/3");
3297 if (pe == NULL || EndOfPAEntr(pe)||pe->ModuleOfPred == TermIDB)
3298 cut_fail();
3299 if ((pe->PredFlags & LogUpdatePredFlag) == 0 && (pe->OpcodeOfPred != UNDEF_OPCODE)) {
3300 Yap_ThrowError(PERMISSION_ERROR_ACCESS_PRIVATE_PROCEDURE, Yap_PredicateIndicator(t1, ARG2), " must be dynamic or have source property" );
3301 }
3302 PELOCK(41, pe);
3303 yhandle_t yth, ytb, ytr;
3304 Yap_RebootHandles(worker_id);
3305 yth = Yap_InitHandle(t1);
3306 ytb = Yap_InitHandle(Deref(ARG3));
3307 ytr = Yap_InitHandle(Deref(ARG4));
3308 ret = fetch_next_lu_clause(pe, pe->CodeOfPred, yth, ytb, ytr, new_cp, true);
3309 Yap_PopHandle(ytr);
3310 Yap_PopHandle(ytb);
3311 Yap_PopHandle(yth);
3312 return ret;
3313}
3314
3315static Int /* $hidden_predicate(P) */
3316p_continue_log_update_clause(USES_REGS1) {
3317 PredEntry *pe = (PredEntry *)IntegerOfTerm(Deref(ARG1));
3318 yamop *ipc = (yamop *)IntegerOfTerm(ARG2);
3319
3320 PELOCK(42, pe);
3321 yhandle_t yth, ytb, ytr;
3322 yth = Yap_InitHandle(Deref(ARG3));
3323 ytb = Yap_InitHandle(Deref(ARG4));
3324 ytr = Yap_InitHandle(Deref(ARG5));
3325 Int rc = fetch_next_lu_clause(pe, ipc, yth, ytb, ytr, B->cp_cp,
3326 FALSE);
3327 Yap_PopHandle(ytr);
3328 Yap_PopHandle(ytb);
3329 Yap_PopHandle(yth);
3330 return rc;
3331}
3332
3333static Int fetch_next_lu_clause_erase(PredEntry *pe, yamop *i_code, yhandle_t yth,
3334 yhandle_t ytb, yhandle_t ytr, yamop *cp_ptr,
3335 int first_time) {
3336 CACHE_REGS
3337 LogUpdClause *cl;
3338 Term rtn;
3339 cl = Yap_FollowIndexingCode(pe, i_code, yth,
3340 NEXTOP(PredLogUpdClauseErase->CodeOfPred, Otapl),
3341 cp_ptr);
3342 /* don't do this!! I might have stored a choice-point and changed ASP
3343 Yap_RecoverSlots(3);
3344 */
3345 if (cl == NULL) {
3346 UNLOCK(pe->PELock);
3347 return FALSE;
3348 }
3349 rtn = MkDBRefTerm((DBRef)cl);
3350#if MULTIPLE_STACKS
3351 TRAIL_CLREF(cl); /* So that fail will erase it */
3352 INC_CLREF_COUNT(cl);
3353#else
3354 if (!(cl->ClFlags & InUseMask)) {
3355 cl->ClFlags |= InUseMask;
3356 TRAIL_CLREF(cl); /* So that fail will erase it */
3357 }
3358#endif
3359 if (cl->ClFlags & FactMask) {
3360 if (!Yap_unify_constant(Yap_GetFromHandle(ytb), MkAtomTerm(AtomTrue)) || !Yap_unify(Yap_GetFromHandle(ytr), rtn)) {
3361 UNLOCK(pe->PELock);
3362 return FALSE;
3363 }
3364 if (pe->ArityOfPE) {
3365 Term th = Yap_GetFromHandle(yth);
3366 Functor f = FunctorOfTerm(th);
3367 arity_t arity = ArityOfFunctor(f), i;
3368 CELL *pt = RepAppl(th) + 1;
3369
3370 for (i = 0; i < arity; i++) {
3371 XREGS[i + 1] = pt[i];
3372 }
3373 /* don't need no ENV */
3374 if (first_time && P->opc != EXECUTE_CPRED_OP_CODE) {
3375 CP = P;
3376 ENV = YENV;
3377 YENV = ASP;
3378 YENV[E_CB] = (CELL)B;
3379 }
3380 P = cl->ClCode;
3381#if defined(YAPOR) || defined(THREADS)
3382 if (pe->PredFlags & ThreadLocalPredFlag) {
3383 /* we don't actually need to execute code */
3384 UNLOCK(pe->PELock);
3385 } else {
3386 PP = pe;
3387 }
3388#endif
3389 } else {
3390 /* we don't actually need to execute code */
3391 UNLOCK(pe->PELock);
3392 }
3393 Yap_ErLogUpdCl(cl);
3394 return TRUE;
3395 } else {
3396 Term t;
3397 Int res;
3398
3399 while ((t = Yap_FetchClauseTermFromDB(cl->lusl.ClSource)) == 0L) {
3400 if (first_time) {
3401 if (LOCAL_Error_TYPE == RESOURCE_ERROR_ATTRIBUTED_VARIABLES) {
3402 LOCAL_Error_TYPE = YAP_NO_ERROR;
3403 if (!Yap_locked_growglobal(NULL)) {
3404 UNLOCK(pe->PELock);
3405 Yap_Error(RESOURCE_ERROR_ATTRIBUTED_VARIABLES, TermNil,
3406 LOCAL_ErrorMessage);
3407 return FALSE;
3408 }
3409 } else {
3410 LOCAL_Error_TYPE = YAP_NO_ERROR;
3411 if (!Yap_dogc(PASS_REGS1)) {
3412 UNLOCK(pe->PELock);
3413 Yap_Error(RESOURCE_ERROR_STACK, TermNil, LOCAL_ErrorMessage);
3414 return FALSE;
3415 }
3416 }
3417
3418 } else {
3419 if (!Yap_dogc(PASS_REGS1)) {
3420 UNLOCK(pe->PELock);
3421 Yap_Error(RESOURCE_ERROR_STACK, TermNil, LOCAL_ErrorMessage);
3422 return FALSE;
3423 }
3424
3425 }
3426 }
3427 res = Yap_unify(Yap_GetFromHandle(yth), ArgOfTerm(1, t)) && Yap_unify(Yap_GetFromHandle(ytb), ArgOfTerm(2, t)) &&
3428 Yap_unify(Yap_GetFromHandle(ytr), rtn);
3429 if (res)
3430 Yap_ErLogUpdCl(cl);
3431 UNLOCK(pe->PELock);
3432 return res;
3433 }
3434}
3435
3436static Int /* $hidden_predicate(P) */
3437p_log_update_clause_erase(USES_REGS1) {
3438 PredEntry *pe;
3439 Term t1 = Deref(ARG1);
3440 Int ret;
3441 yamop *new_cp;
3442
3443 if (P->opc == EXECUTE_CPRED_OP_CODE) {
3444 new_cp = CP;
3445 } else {
3446 new_cp = P;
3447 }
3448 pe = Yap_get_pred(t1, Deref(ARG2), "clause/3");
3449 if (pe == NULL || EndOfPAEntr(pe)|| pe->OpcodeOfPred == UNDEF_OPCODE)
3450 return FALSE;
3451 if ((pe->PredFlags & LogUpdatePredFlag) == 0 && (pe->OpcodeOfPred != UNDEF_OPCODE)) {
3452 Yap_ThrowError(PERMISSION_ERROR_ACCESS_PRIVATE_PROCEDURE, Yap_PredicateIndicator(t1, ARG2), " must be dynamic or have source property" );
3453 }
3454 PELOCK(43, pe);
3455 yhandle_t yth, ytb, ytr;
3456 yth = Yap_InitHandle(t1);
3457 ytb = Yap_InitHandle(Deref(ARG3));
3458 ytr = Yap_InitHandle(Deref(ARG4));
3459 ret = fetch_next_lu_clause_erase(pe, pe->CodeOfPred, yth, ytb, ytr, new_cp,
3460 TRUE);
3461 Yap_PopHandle(ytr);
3462 Yap_PopHandle(ytb);
3463 Yap_PopHandle(yth);
3464 return ret;
3465}
3466
3467static Int /* $hidden_predicate(P) */
3468p_continue_log_update_clause_erase(USES_REGS1) {
3469 PredEntry *pe = (PredEntry *)IntegerOfTerm(Deref(ARG1));
3470 yamop *ipc = (yamop *)IntegerOfTerm(ARG2);
3471
3472 PELOCK(44, pe);
3473 yhandle_t yth, ytb, ytr;
3474 yth = Yap_InitHandle(Deref(ARG3));
3475 ytb = Yap_InitHandle(Deref(ARG5));
3476 ytr = Yap_InitHandle(Deref(ARG6));
3477 Int rc= fetch_next_lu_clause_erase(pe, ipc, yth, ytb, ytr, B->cp_cp,
3478 FALSE);
3479 Yap_PopHandle(ytr);
3480 Yap_PopHandle(ytb);
3481 Yap_PopHandle(yth);
3482 return rc;
3483}
3484
3485static void adjust_cl_timestamp(LogUpdClause *cl, UInt *arp, UInt *base) {
3486 UInt clstamp = cl->ClTimeEnd;
3487 if (cl->ClTimeEnd != TIMESTAMP_EOT) {
3488 while (arp[0] > clstamp)
3489 arp--;
3490 if (arp[0] == clstamp) {
3491 cl->ClTimeEnd = (arp - base);
3492 } else {
3493 cl->ClTimeEnd = (arp - base) + 1;
3494 }
3495 }
3496 clstamp = cl->ClTimeStart;
3497 while (arp[0] > clstamp)
3498 arp--;
3499 if (arp[0] == clstamp) {
3500 cl->ClTimeStart = (arp - base);
3501 } else {
3502 cl->ClTimeStart = (arp - base) + 1;
3503 }
3504 clstamp = cl->ClTimeEnd;
3505}
3506
3507static Term replace_integer(Term orig, UInt new) {
3508 CELL *pt;
3509
3510 if (IntInBnd((Int) new))
3511 return MkIntTerm(new);
3512 /* should create an old integer */
3513 if (!IsApplTerm(orig)) {
3514 CACHE_REGS
3515 Yap_Error(SYSTEM_ERROR_INTERNAL, orig,
3516 "%uld-->%uld where it should increase",
3517 (unsigned long int)IntegerOfTerm(orig), (unsigned long int)new);
3518 return MkIntegerTerm(new);
3519 }
3520 /* appl->appl */
3521 /* replace integer in situ */
3522 pt = RepAppl(orig) + 1;
3523 *pt = new;
3524 return orig;
3525}
3526
3527static UInt tree_index_ssz(StaticIndex *x) {
3528 UInt sz = x->ClSize;
3529 x = x->ChildIndex;
3530 while (x != NULL) {
3531 sz += tree_index_ssz(x);
3532 x = x->SiblingIndex;
3533 }
3534 return sz;
3535}
3536
3537static UInt index_ssz(StaticIndex *x, PredEntry *pe) {
3538 UInt sz = 0;
3539 yamop *ep = ExpandClausesFirst;
3540 if (pe->PredFlags & MegaClausePredFlag) {
3541 MegaClause *mcl = ClauseCodeToMegaClause(pe->cs.p_code.FirstClause);
3542 if (mcl->ClFlags & ExoMask) {
3543 struct index_t *i = ((struct index_t **)(pe->cs.p_code.FirstClause))[0];
3544 sz = 0;
3545
3546 while (i) {
3547 sz = i->size + sz;
3548 i = i->next;
3549 }
3550 return sz;
3551 }
3552 }
3553 /* expand clause blocks */
3554 while (ep) {
3555 if (ep->y_u.sssllp.p == pe)
3556 sz += (UInt)NEXTOP((yamop *)NULL, sssllp) +
3557 ep->y_u.sssllp.s1 * sizeof(yamop *);
3558 ep = ep->y_u.sssllp.snext;
3559 }
3560 /* main indexing tree */
3561 sz += tree_index_ssz(x);
3562 return sz;
3563}
3564
3565#ifdef DEBUG
3566static Int predicate_lu_cps(USES_REGS1) {
3567 return Yap_unify(ARG1, MkIntegerTerm(Yap_LiveCps)) &&
3568 Yap_unify(ARG2, MkIntegerTerm(Yap_FreedCps)) &&
3569 Yap_unify(ARG3, MkIntegerTerm(Yap_DirtyCps)) &&
3570 Yap_unify(ARG4, MkIntegerTerm(Yap_NewCps));
3571}
3572#endif
3573
3574static Int static_statistics(PredEntry *pe) {
3575 CACHE_REGS
3576 UInt sz = sizeof(PredEntry), cls = 0, isz = 0;
3577 StaticClause *cl = ClauseCodeToStaticClause(pe->cs.p_code.FirstClause);
3578
3579 if (pe->cs.p_code.NOfClauses > 1 &&
3580 pe->cs.p_code.TrueCodeOfPred != pe->cs.p_code.FirstClause) {
3581 isz = index_ssz(ClauseCodeToStaticIndex(pe->cs.p_code.TrueCodeOfPred), pe);
3582 }
3583 if (pe->PredFlags & MegaClausePredFlag) {
3584 MegaClause *mcl = ClauseCodeToMegaClause(pe->cs.p_code.FirstClause);
3585 return Yap_unify(ARG3, MkIntegerTerm(mcl->ClSize / mcl->ClItemSize)) &&
3586 Yap_unify(ARG4, MkIntegerTerm(mcl->ClSize)) &&
3587 Yap_unify(ARG5, MkIntegerTerm(isz));
3588 }
3589 if (pe->cs.p_code.NOfClauses) {
3590 do {
3591 cls++;
3592 sz += cl->ClSize;
3593 if (cl->ClCode == pe->cs.p_code.LastClause)
3594 break;
3595 cl = cl->ClNext;
3596 } while (TRUE);
3597 }
3598 return Yap_unify(ARG3, MkIntegerTerm(cls)) &&
3599 Yap_unify(ARG4, MkIntegerTerm(sz)) &&
3600 Yap_unify(ARG5, MkIntegerTerm(isz));
3601}
3602
3603static Int p_static_pred_statistics(USES_REGS1) {
3604 Int out;
3605 PredEntry *pe;
3606
3607 pe = Yap_get_pred(Deref(ARG1), Deref(ARG2), "predicate_statistics");
3608 if (pe == NIL)
3609 return (FALSE);
3610 PELOCK(50, pe);
3611 if (pe->PredFlags & (DynamicPredFlag | LogUpdatePredFlag | UserCPredFlag |
3612 AsmPredFlag | CPredFlag | BinaryPredFlag)) {
3613 /* should use '$recordedp' in this case */
3614 UNLOCK(pe->PELock);
3615 return FALSE;
3616 }
3617 out = static_statistics(pe);
3618 UNLOCK(pe->PELock);
3619 return out;
3620}
3621
3622static Int predicate_erased_statistics(USES_REGS1) {
3623 UInt sz = 0, cls = 0;
3624 UInt isz = 0, icls = 0;
3625 PredEntry *pe;
3626 LogUpdClause *cl = DBErasedList;
3627 LogUpdIndex *icl = DBErasedIList;
3628 Term tpred = ArgOfTerm(2, Deref(ARG1));
3629 Term tmod = ArgOfTerm(1, Deref(ARG1));
3630
3631 if (EndOfPAEntr(pe =
3632 Yap_get_pred(tpred, tmod, "predicate_erased_statistics")))
3633 return FALSE;
3634 while (cl) {
3635 if (cl->ClPred == pe) {
3636 cls++;
3637 sz += cl->ClSize;
3638 }
3639 cl = cl->ClNext;
3640 }
3641 while (icl) {
3642 if (pe == icl->ClPred) {
3643 icls++;
3644 isz += icl->ClSize;
3645 }
3646 icl = icl->SiblingIndex;
3647 }
3648 return Yap_unify(ARG2, MkIntegerTerm(cls)) &&
3649 Yap_unify(ARG3, MkIntegerTerm(sz)) &&
3650 Yap_unify(ARG4, MkIntegerTerm(icls)) &&
3651 Yap_unify(ARG5, MkIntegerTerm(isz));
3652}
3653
3654void Yap_UpdateTimestamps(PredEntry *ap) {
3655 CACHE_REGS
3656 choiceptr bptr = B;
3657 yamop *cl0 = NEXTOP(PredLogUpdClause0->CodeOfPred, Otapl);
3658 yamop *cl = NEXTOP(PredLogUpdClause->CodeOfPred, Otapl);
3659 yamop *cle = NEXTOP(PredLogUpdClauseErase->CodeOfPred, Otapl);
3660 arity_t ar = ap->ArityOfPE;
3661 UInt *arp, *top, *base;
3662 LogUpdClause *lcl;
3663
3664#if THREADS
3665 Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "Timestamp overflow %p", ap);
3666 return;
3667#endif
3668 if (!ap->cs.p_code.NOfClauses)
3669 return;
3670restart:
3671 *--ASP = TIMESTAMP_EOT;
3672 top = arp = (UInt *)ASP;
3673 while (bptr) {
3674 op_numbers opnum = Yap_op_from_opcode(bptr->cp_ap->opc);
3675
3676 switch (opnum) {
3677 case _retry_logical:
3678 case _count_retry_logical:
3679 case _profiled_retry_logical:
3680 case _trust_logical:
3681 case _count_trust_logical:
3682 case _profiled_trust_logical:
3683 if (bptr->cp_ap->y_u.OtaLl.d->ClPred == ap) {
3684 UInt ts = IntegerOfTerm(bptr->cp_args[ar]);
3685 if (ts != arp[0]) {
3686 if (arp - HR < 1024) {
3687 goto overflow;
3688 }
3689 /* be thrifty, have this in case there is a hole */
3690 if (ts != arp[0] - 1) {
3691 UInt x = arp[0];
3692 *--arp = x;
3693 }
3694 *--arp = ts;
3695 }
3696 }
3697 bptr = bptr->cp_b;
3698 break;
3699 case _retry:
3700 if ((bptr->cp_ap == cl0 || bptr->cp_ap == cl || bptr->cp_ap == cle) &&
3701 ((PredEntry *)IntegerOfTerm(bptr->cp_args[0]) == ap)) {
3702 UInt ts = IntegerOfTerm(bptr->cp_args[5]);
3703 if (ts != arp[0]) {
3704 if (arp - HR < 1024) {
3705 goto overflow;
3706 }
3707 if (ts != arp[0] - 1) {
3708 UInt x = arp[0];
3709 *--arp = x;
3710 }
3711 *--arp = ts;
3712 }
3713 }
3714 bptr = bptr->cp_b;
3715 break;
3716 default:
3717 bptr = bptr->cp_b;
3718 continue;
3719 }
3720 }
3721 if (*arp)
3722 *--arp = 0L;
3723 base = arp;
3724 lcl = ClauseCodeToLogUpdClause(ap->cs.p_code.FirstClause);
3725 while (lcl) {
3726 adjust_cl_timestamp(lcl, top - 1, base);
3727 lcl = lcl->ClNext;
3728 }
3729 lcl = DBErasedList;
3730 while (lcl) {
3731 if (lcl->ClPred == ap)
3732 adjust_cl_timestamp(lcl, top - 1, base);
3733 lcl = lcl->ClNext;
3734 }
3735 arp = top - 1;
3736 bptr = B;
3737 while (bptr) {
3738 op_numbers opnum = Yap_op_from_opcode(bptr->cp_ap->opc);
3739
3740 switch (opnum) {
3741 case _retry_logical:
3742 case _count_retry_logical:
3743 case _profiled_retry_logical:
3744 case _trust_logical:
3745 case _count_trust_logical:
3746 case _profiled_trust_logical:
3747 if (bptr->cp_ap->y_u.OtaLl.d->ClPred == ap) {
3748 UInt ts = IntegerOfTerm(bptr->cp_args[ar]);
3749 while (ts != arp[0])
3750 arp--;
3751 bptr->cp_args[ar] = replace_integer(bptr->cp_args[ar], arp - base);
3752 }
3753 bptr = bptr->cp_b;
3754 break;
3755 case _retry:
3756 if ((bptr->cp_ap == cl0 || bptr->cp_ap == cl || bptr->cp_ap == cle) &&
3757 ((PredEntry *)IntegerOfTerm(bptr->cp_args[0]) == ap)) {
3758 UInt ts = IntegerOfTerm(bptr->cp_args[5]);
3759 while (ts != arp[0])
3760 arp--;
3761 bptr->cp_args[5] = replace_integer(bptr->cp_args[5], arp - base);
3762 }
3763 bptr = bptr->cp_b;
3764 break;
3765 default:
3766 bptr = bptr->cp_b;
3767 continue;
3768 }
3769 }
3770 return;
3771overflow:
3772 if (!Yap_growstack(64 * 1024)) {
3773 Yap_Error(RESOURCE_ERROR_STACK, TermNil, LOCAL_ErrorMessage);
3774 return;
3775 }
3776 goto restart;
3777}
3778
3779static Int fetch_next_static_clause(PredEntry *pe, yamop *i_code, yhandle_t yth,
3780 yhandle_t ytb, yhandle_t ytr, yamop *cp_ptr,
3781 int first_time) {
3782 CACHE_REGS
3783 StaticClause *cl;
3784 Term rtn;
3785 cl = (StaticClause *)Yap_FollowIndexingCode(
3786 pe, i_code, yth, NEXTOP(PredStaticClause->CodeOfPred, Otapl), cp_ptr);
3787 /*
3788 don't do this!! I might have stored a choice-point and changed ASP
3789 Yap_RecoverSlots(3);
3790 */
3791 if (cl == NULL || pe->OpcodeOfPred == UNDEF_OPCODE) {
3792 UNLOCKPE(45, pe);
3793 return false;
3794 }
3795 if (pe->PredFlags & MegaClausePredFlag) {
3796 yamop *code = (yamop *)cl;
3797 rtn = Yap_MkMegaRefTerm(pe, code);
3798 if (!Yap_unify(Yap_GetFromHandle(ytb), MkAtomTerm(AtomTrue)) || !Yap_unify(Yap_GetFromHandle(ytr), rtn)) {
3799 UNLOCKPE(45, pe);
3800 return FALSE;
3801 }
3802 if (pe->ArityOfPE) {
3803 Term th = Yap_GetFromHandle(yth);
3804 Functor f = FunctorOfTerm(th);
3805 arity_t arity = ArityOfFunctor(f), i;
3806 CELL *pt = RepAppl(th) + 1;
3807
3808 for (i = 0; i < arity; i++) {
3809 XREGS[i + 1] = pt[i];
3810 }
3811 /* don't need no ENV */
3812 if (first_time && P->opc != EXECUTE_CPRED_OP_CODE) {
3813 CP = P;
3814 ENV = YENV;
3815 YENV = ASP;
3816 YENV[E_CB] = (CELL)B;
3817 }
3818 P = code;
3819 }
3820 UNLOCKPE(45, pe);
3821 return TRUE;
3822 }
3823 rtn = Yap_MkStaticRefTerm(cl, pe);
3824 if (cl->ClFlags & FactMask) {
3825 if (!Yap_unify(Yap_GetFromHandle(ytb), TermTrue) || !Yap_unify(Yap_GetFromHandle(ytr), rtn)) {
3826 UNLOCKPE(45, pe);
3827 return FALSE;
3828 }
3829
3830 if (pe->ArityOfPE) {
3831 Term th = Yap_GetFromHandle(yth);
3832 Functor f = FunctorOfTerm(th);
3833 arity_t arity = ArityOfFunctor(f), i;
3834 CELL *pt = RepAppl(th) + 1;
3835
3836 for (i = 0; i < arity; i++) {
3837 XREGS[i + 1] = pt[i];
3838 }
3839 /* don't need no ENV */
3840 if (first_time && P->opc != EXECUTE_CPRED_OP_CODE) {
3841 CP = P;
3842 ENV = YENV;
3843 YENV = ASP;
3844 YENV[E_CB] = (CELL)B;
3845 }
3846 P = cl->ClCode;
3847 }
3848 UNLOCKPE(45, pe);
3849 return true;
3850 } else {
3851 Term t;
3852
3853 if (!(pe->PredFlags & SourcePredFlag)) {
3854 /* no source */
3855 rtn = Yap_MkStaticRefTerm(cl, pe);
3856 UNLOCKPE(45, pe);
3857 return Yap_unify(Yap_GetFromHandle(ytr), rtn);
3858 }
3859 while ((t = Yap_FetchClauseTermFromDB(cl->usc.ClSource)) == 0L) {
3860 if (first_time) {
3861 if (LOCAL_Error_TYPE == RESOURCE_ERROR_ATTRIBUTED_VARIABLES) {
3862 LOCAL_Error_TYPE = YAP_NO_ERROR;
3863 if (!Yap_growglobal(NULL)) {
3864 Yap_Error(RESOURCE_ERROR_ATTRIBUTED_VARIABLES, TermNil,
3865 LOCAL_ErrorMessage);
3866 UNLOCKPE(45, pe);
3867 return FALSE;
3868 }
3869 } else {
3870 LOCAL_Error_TYPE = YAP_NO_ERROR;
3871 gc_entry_info_t info;
3872 Yap_track_cpred( 0, P, 0,&info);
3873 // p should be past the enbironment mang Obpp
3874 info.a = 7;
3875 if (!Yap_gc(&info)) {
3876 Yap_Error(RESOURCE_ERROR_STACK, TermNil, LOCAL_ErrorMessage);
3877 UNLOCKPE(45, pe);
3878 return FALSE;
3879 }
3880 }
3881 } else {
3882 LOCAL_Error_TYPE = YAP_NO_ERROR;
3883 if (!Yap_dogc(PASS_REGS1)) {
3884 Yap_Error(RESOURCE_ERROR_STACK, TermNil, LOCAL_ErrorMessage);
3885 UNLOCKPE(45, pe);
3886 return FALSE;
3887 }
3888 }
3889 }
3890 rtn = Yap_MkStaticRefTerm(cl, pe);
3891 UNLOCKPE(45, pe);
3892 if (!IsApplTerm(t) || FunctorOfTerm(t) != FunctorAssert) {
3893 return (Yap_unify(Yap_GetFromHandle(yth), t) && Yap_unify(Yap_GetFromHandle(ytb), TermTrue) &&
3894 Yap_unify(Yap_GetFromHandle(ytr), rtn));
3895 } else {
3896 return (Yap_unify(Yap_GetFromHandle(yth), ArgOfTerm(1, t)) &&
3897 Yap_unify(Yap_GetFromHandle(ytb), ArgOfTerm(2, t)) && Yap_unify(Yap_GetFromHandle(ytr), rtn));
3898 }
3899 }
3900}
3901
3902static Int /* $hidden_predicate(P) */
3903p_static_clause(USES_REGS1) {
3904 PredEntry *pe;
3905 Term t1 = Deref(ARG1);
3906 yamop *new_cp;
3907 yhandle_t yth, ytb, ytr;
3908 yth = Yap_InitHandle(t1);
3909 ytb = Yap_InitHandle(Deref(ARG3));
3910 ytr = Yap_InitHandle(Deref(ARG4));
3911
3912 if (P->opc == EXECUTE_CPRED_OP_CODE) {
3913 new_cp = CP;
3914 } else {
3915 new_cp = P;
3916 }
3917 pe = Yap_get_pred(t1, Deref(ARG2), "clause/3");
3918 if (pe == NULL || EndOfPAEntr(pe) || pe->OpcodeOfPred == UNDEF_OPCODE || pe->PredFlags & LogUpdatePredFlag)
3919 return false;
3920 if ((pe->PredFlags & SourcePredFlag) == 0) {
3921 Yap_ThrowError(PERMISSION_ERROR_ACCESS_PRIVATE_PROCEDURE, Yap_PredicateIndicator(t1, ARG2), " must be dynamic or have source property" );
3922 }
3923 PELOCK(46, pe);
3924 Int rc= fetch_next_static_clause(pe, pe->CodeOfPred, yth, ytb, ytr, new_cp,
3925 true);
3926 Yap_PopHandle(ytr);
3927 Yap_PopHandle(ytb);
3928 Yap_PopHandle(yth);
3929 return rc;
3930}
3931
3932static Int /* $hidden_predicate(P) */
3933p_continue_static_clause(USES_REGS1) {
3934 PredEntry *pe = (PredEntry *)IntegerOfTerm(Deref(ARG1));
3935 yamop *ipc = (yamop *)IntegerOfTerm(ARG2);
3936 yhandle_t yth, ytb, ytr;
3937 yth = Yap_InitHandle(Deref(ARG3));
3938 ytb = Yap_InitHandle(Deref(ARG4));
3939 ytr = Yap_InitHandle( Deref(ARG5));
3940
3941 PELOCK(48, pe);
3942 Int rc= fetch_next_static_clause(pe, ipc, yth, ytb, ytr, B->cp_ap,
3943 false);
3944 Yap_PopHandle(ytr);
3945 Yap_PopHandle(ytb);
3946 Yap_PopHandle(yth);
3947 return rc;
3948}
3949
3950static UInt compute_dbcl_size(arity_t arity) {
3951 UInt sz;
3952 switch (arity) {
3953 case 2:
3954 sz = (UInt)NEXTOP((yamop *)NULL, cc);
3955 break;
3956 case 3:
3957 sz = (UInt)NEXTOP((yamop *)NULL, ccc);
3958 break;
3959 case 4:
3960 sz = (UInt)NEXTOP((yamop *)NULL, cccc);
3961 break;
3962 case 5:
3963 sz = (UInt)NEXTOP((yamop *)NULL, ccccc);
3964 break;
3965 case 6:
3966 sz = (UInt)NEXTOP((yamop *)NULL, cccccc);
3967 break;
3968 default:
3969 sz = arity * (UInt)NEXTOP((yamop *)NULL, xc);
3970 break;
3971 }
3972 return (UInt)NEXTOP((yamop *)sz, p);
3973}
3974
3975#define DerefAndCheck(t, V) \
3976 t = Deref(V); \
3977 if (IsVarTerm(t) || !(IsAtomOrIntTerm(t))) \
3978 Yap_Error(TYPE_ERROR_ATOM, t0, "load_db");
3979
3980static int store_dbcl_size(yamop *pc, arity_t arity, Term t0, PredEntry *pe) {
3981 Term t;
3982 CELL *tp = RepAppl(t0) + 1;
3983 switch (arity) {
3984 case 2:
3985 pc->opc = Yap_opcode(_get_2atoms);
3986 DerefAndCheck(t, tp[0]);
3987 pc->y_u.cc.c1 = t;
3988 DerefAndCheck(t, tp[1]);
3989 pc->y_u.cc.c2 = t;
3990 pc = NEXTOP(pc, cc);
3991 break;
3992 case 3:
3993 pc->opc = Yap_opcode(_get_3atoms);
3994 DerefAndCheck(t, tp[0]);
3995 pc->y_u.ccc.c1 = t;
3996 DerefAndCheck(t, tp[1]);
3997 pc->y_u.ccc.c2 = t;
3998 DerefAndCheck(t, tp[2]);
3999 pc->y_u.ccc.c3 = t;
4000 pc = NEXTOP(pc, ccc);
4001 break;
4002 case 4:
4003 pc->opc = Yap_opcode(_get_4atoms);
4004 DerefAndCheck(t, tp[0]);
4005 pc->y_u.cccc.c1 = t;
4006 DerefAndCheck(t, tp[1]);
4007 pc->y_u.cccc.c2 = t;
4008 DerefAndCheck(t, tp[2]);
4009 pc->y_u.cccc.c3 = t;
4010 DerefAndCheck(t, tp[3]);
4011 pc->y_u.cccc.c4 = t;
4012 pc = NEXTOP(pc, cccc);
4013 break;
4014 case 5:
4015 pc->opc = Yap_opcode(_get_5atoms);
4016 DerefAndCheck(t, tp[0]);
4017 pc->y_u.ccccc.c1 = t;
4018 DerefAndCheck(t, tp[1]);
4019 pc->y_u.ccccc.c2 = t;
4020 DerefAndCheck(t, tp[2]);
4021 pc->y_u.ccccc.c3 = t;
4022 DerefAndCheck(t, tp[3]);
4023 pc->y_u.ccccc.c4 = t;
4024 DerefAndCheck(t, tp[4]);
4025 pc->y_u.ccccc.c5 = t;
4026 pc = NEXTOP(pc, ccccc);
4027 break;
4028 case 6:
4029 pc->opc = Yap_opcode(_get_6atoms);
4030 DerefAndCheck(t, tp[0]);
4031 pc->y_u.cccccc.c1 = t;
4032 DerefAndCheck(t, tp[1]);
4033 pc->y_u.cccccc.c2 = t;
4034 DerefAndCheck(t, tp[2]);
4035 pc->y_u.cccccc.c3 = t;
4036 DerefAndCheck(t, tp[3]);
4037 pc->y_u.cccccc.c4 = t;
4038 DerefAndCheck(t, tp[4]);
4039 pc->y_u.cccccc.c5 = t;
4040 DerefAndCheck(t, tp[5]);
4041 pc->y_u.cccccc.c6 = t;
4042 pc = NEXTOP(pc, cccccc);
4043 break;
4044 default: {
4045 arity_t i;
4046 for (i = 0; i < arity; i++) {
4047 pc->opc = Yap_opcode(_get_atom);
4048#if PRECOMPUTE_REGADDRESS
4049 pc->y_u.xc.x = (CELL)(XREGS + (i + 1));
4050#else
4051 pc->y_u.xc.x = i + 1;
4052#endif
4053 DerefAndCheck(t, tp[0]);
4054 pc->y_u.xc.c = t;
4055 tp++;
4056 pc = NEXTOP(pc, xc);
4057 }
4058 } break;
4059 }
4060 pc->opc = Yap_opcode(_procceed);
4061 pc->y_u.p.p = pe;
4062 return TRUE;
4063}
4064
4065static Int
4066 p_dbload_get_space(USES_REGS1) { /* '$number_of_clauses'(Predicate,M,N) */
4067 Term t = Deref(ARG1);
4068 Term mod = Deref(ARG2);
4069 Term tn = Deref(ARG3);
4070 arity_t arity;
4071 Prop pe;
4072 PredEntry *ap;
4073 UInt sz;
4074 MegaClause *mcl;
4075 yamop *ptr;
4076 UInt ncls;
4077 UInt required;
4078
4079 if (IsVarTerm(mod) || !IsAtomTerm(mod)) {
4080 return (FALSE);
4081 }
4082 if (IsAtomTerm(t)) {
4083 Atom a = AtomOfTerm(t);
4084 arity = 0;
4085 pe = PredPropByAtom(a, mod);
4086 } else if (IsApplTerm(t)) {
4087 register Functor f = FunctorOfTerm(t);
4088 arity = ArityOfFunctor(f);
4089 pe = PredPropByFunc(f, mod);
4090 } else {
4091 return FALSE;
4092 }
4093 if (EndOfPAEntr(pe))
4094 return FALSE;
4095 ap = RepPredProp(pe);
4096 if (ap->PredFlags & (DynamicPredFlag | LogUpdatePredFlag
4097#ifdef TABLING
4098 | TabledPredFlag
4099#endif /* TABLING */
4100 )) {
4101 Yap_Error(PERMISSION_ERROR_MODIFY_STATIC_PROCEDURE, t,
4102 "dbload_get_space/4");
4103 return FALSE;
4104 }
4105 if (IsVarTerm(tn) || !IsIntegerTerm(tn)) {
4106 return FALSE;
4107 }
4108 ncls = IntegerOfTerm(tn);
4109 if (ncls <= 1) {
4110 return FALSE;
4111 }
4112
4113 sz = compute_dbcl_size(arity);
4114 required = sz * ncls + sizeof(MegaClause) + (UInt)NEXTOP((yamop *)NULL, l);
4115#ifdef DEBUG
4116 total_megaclause += required;
4117 nof_megaclauses++;
4118#endif
4119 while (!(mcl = (MegaClause *)Yap_AllocCodeSpace(required))) {
4120 if (!Yap_growheap(FALSE, required, NULL)) {
4121 /* just fail, the system will keep on going */
4122 return FALSE;
4123 }
4124 }
4125 Yap_ClauseSpace += required;
4126 /* cool, it's our turn to do the conversion */
4127 mcl->ClFlags = MegaMask;
4128 mcl->ClSize = sz * ncls;
4129 mcl->ClPred = ap;
4130 mcl->ClItemSize = sz;
4131 mcl->ClNext = NULL;
4132 ap->cs.p_code.FirstClause = ap->cs.p_code.LastClause = mcl->ClCode;
4133 ap->PredFlags |= (MegaClausePredFlag);
4134 ap->cs.p_code.NOfClauses = ncls;
4135 if (ap->PredFlags & (SpiedPredFlag | CountPredFlag | ProfiledPredFlag)) {
4136 ap->OpcodeOfPred = Yap_opcode(_spy_pred);
4137 } else {
4138 ap->OpcodeOfPred = INDEX_OPCODE;
4139 }
4140 ap->CodeOfPred = ap->cs.p_code.TrueCodeOfPred =
4141 (yamop *)(&(ap->OpcodeOfPred));
4142 ptr = (yamop *)((ADDR)mcl->ClCode + ncls * sz);
4143 ptr->opc = Yap_opcode(_Ystop);
4144 return Yap_unify(ARG4, MkIntegerTerm((Int)mcl));
4145}
4146
4147static Int p_dbassert(USES_REGS1) { /* '$number_of_clauses'(Predicate,M,N) */
4148 Term thandle = Deref(ARG2);
4149 Term tn = Deref(ARG3);
4150 PredEntry *pe;
4151 MegaClause *mcl;
4152 Int n;
4153
4154 if (IsVarTerm(thandle) || !IsIntegerTerm(thandle)) {
4155 return FALSE;
4156 }
4157 mcl = (MegaClause *)IntegerOfTerm(thandle);
4158 if (IsVarTerm(tn) || !IsIntegerTerm(tn)) {
4159 return FALSE;
4160 }
4161 n = IntegerOfTerm(tn);
4162 pe = mcl->ClPred;
4163 return store_dbcl_size((yamop *)((ADDR)mcl->ClCode + n * (mcl->ClItemSize)),
4164 pe->ArityOfPE, Deref(ARG1), pe);
4165}
4166
4167#define CL_PROP_ERASED 0
4168#define CL_PROP_PRED 1
4169#define CL_PROP_FILE 2
4170#define CL_PROP_FACT 3
4171#define CL_PROP_LINE 4
4172#define CL_PROP_STREAM 5
4173
4174/* instance(+Ref,?Term) */
4175static Int instance_property(USES_REGS1) {
4176 Term t1 = Deref(ARG1);
4177 DBRef dbr;
4178
4179 Int op = IntOfTerm(Deref(ARG2));
4180
4181 if (IsVarTerm(t1) || !IsDBRefTerm(t1)) {
4182 if (IsApplTerm(t1)) {
4183 if (FunctorOfTerm(t1) == FunctorStaticClause) {
4184 StaticClause *cl = Yap_ClauseFromTerm(t1);
4185
4186 if (op == CL_PROP_ERASED) {
4187 if (cl->ClFlags & ErasedMask) {
4188 if (!Yap_unify(ARG3, MkAtomTerm(AtomTrue)))
4189 return FALSE;
4190 } else {
4191 if (!Yap_unify(ARG3, MkAtomTerm(AtomFalse)))
4192 return FALSE;
4193 }
4194 }
4195 if (op == CL_PROP_PRED || op == CL_PROP_FILE || op == CL_PROP_STREAM) {
4196 PredEntry *ap = (PredEntry *)IntegerOfTerm(ArgOfTerm(2, t1));
4197 if (!ap) {
4198 return FALSE;
4199 }
4200 if (op == CL_PROP_FILE) {
4201 if (ap->src.OwnerFile)
4202 return Yap_unify(ARG3, MkAtomTerm(ap->src.OwnerFile));
4203 else
4204 return FALSE;
4205 } else {
4206 Term t[2];
4207
4208 if (ap->ArityOfPE == 0) {
4209 t[1] = MkAtomTerm((Atom)ap->FunctorOfPred);
4210 } else {
4211 Functor nf = ap->FunctorOfPred;
4212 arity_t arity = ArityOfFunctor(nf);
4213 Atom name = NameOfFunctor(nf);
4214
4215 t[0] = MkAtomTerm(name);
4216 t[1] = MkIntegerTerm(arity);
4217 t[1] = Yap_MkApplTerm(FunctorSlash, 2, t);
4218 }
4219 if (ap->ModuleOfPred == PROLOG_MODULE) {
4220 t[0] = MkAtomTerm(AtomProlog);
4221 } else {
4222 t[0] = ap->ModuleOfPred;
4223 }
4224 return Yap_unify(ARG3, Yap_MkApplTerm(FunctorModule, 2, t));
4225 }
4226 }
4227 if (op == CL_PROP_FACT) {
4228 if (cl->ClFlags & FactMask) {
4229 return Yap_unify(ARG3, MkAtomTerm(AtomTrue));
4230 } else {
4231 return Yap_unify(ARG3, MkAtomTerm(AtomFalse));
4232 }
4233 }
4234 if (op == CL_PROP_LINE) {
4235 if (cl->ClFlags & FactMask) {
4236 return Yap_unify(ARG3, MkIntTerm(cl->usc.ClLine));
4237 } else if (cl->ClFlags & SrcMask) {
4238 return Yap_unify(ARG3, MkIntTerm(cl->usc.ClSource->ag.line_number));
4239 } else
4240 return Yap_unify(ARG3, MkIntTerm(0));
4241 }
4242 } else if (FunctorOfTerm(t1) == FunctorMegaClause) {
4243 PredEntry *ap = (PredEntry *)IntegerOfTerm(ArgOfTerm(1, t1));
4244 MegaClause *mcl = ClauseCodeToMegaClause(ap->cs.p_code.FirstClause);
4245
4246 if (op == CL_PROP_ERASED) {
4247 return FALSE;
4248 }
4249 if (op == CL_PROP_PRED || op == CL_PROP_FILE || op == CL_PROP_STREAM) {
4250 if (op == CL_PROP_FILE) {
4251 if (ap->src.OwnerFile)
4252 return Yap_unify(ARG3, MkAtomTerm(ap->src.OwnerFile));
4253 else
4254 return FALSE;
4255 } else {
4256 Functor nf = ap->FunctorOfPred;
4257 arity_t arity = ArityOfFunctor(nf);
4258 Atom name = NameOfFunctor(nf);
4259 Term t[2];
4260
4261 t[0] = MkAtomTerm(name);
4262 t[1] = MkIntegerTerm(arity);
4263 t[1] = Yap_MkApplTerm(FunctorSlash, 2, t);
4264 if (ap->ModuleOfPred == PROLOG_MODULE) {
4265 t[0] = MkAtomTerm(AtomProlog);
4266 } else {
4267 t[0] = ap->ModuleOfPred;
4268 }
4269 return Yap_unify(ARG3, Yap_MkApplTerm(FunctorModule, 2, t));
4270 }
4271 }
4272 if (op == CL_PROP_FACT) {
4273 return Yap_unify(ARG3, MkAtomTerm(AtomTrue));
4274 }
4275 if (op == CL_PROP_LINE) {
4276 return Yap_unify(ARG3, MkIntTerm(mcl->ClLine));
4277 }
4278 }
4279 }
4280 } else if ((dbr = DBRefOfTerm(t1))->Flags & LogUpdMask) {
4281 LogUpdClause *cl = (LogUpdClause *)dbr;
4282
4283 if (op == CL_PROP_ERASED) {
4284 if (cl->ClFlags & ErasedMask) {
4285 if (!Yap_unify(ARG3, MkAtomTerm(AtomTrue)))
4286 return FALSE;
4287 } else {
4288 if (!Yap_unify(ARG3, MkAtomTerm(AtomFalse)))
4289 return FALSE;
4290 }
4291 }
4292 if (op == CL_PROP_PRED || op == CL_PROP_FILE) {
4293 PredEntry *ap = cl->ClPred;
4294 Term t[2];
4295
4296 if (op == CL_PROP_FILE) {
4297 if (ap->src.OwnerFile)
4298 return Yap_unify(ARG3, MkAtomTerm(ap->src.OwnerFile));
4299 else
4300 return FALSE;
4301 }
4302 if (ap->ArityOfPE == 0) {
4303 t[1] = MkAtomTerm((Atom)ap->FunctorOfPred);
4304 } else {
4305 Functor nf = ap->FunctorOfPred;
4306 arity_t arity = ArityOfFunctor(nf);
4307 Atom name = NameOfFunctor(nf);
4308
4309 t[0] = MkAtomTerm(name);
4310 t[1] = MkIntegerTerm(arity);
4311 t[1] = Yap_MkApplTerm(FunctorSlash, 2, t);
4312 }
4313 if (ap->ModuleOfPred == PROLOG_MODULE) {
4314 t[0] = MkAtomTerm(AtomProlog);
4315 } else {
4316 t[0] = ap->ModuleOfPred;
4317 }
4318 return Yap_unify(ARG3, Yap_MkApplTerm(FunctorModule, 2, t));
4319 }
4320 if (op == CL_PROP_FACT) {
4321 if (cl->ClFlags & FactMask) {
4322 return Yap_unify(ARG3, MkAtomTerm(AtomTrue));
4323 } else {
4324 return Yap_unify(ARG3, MkAtomTerm(AtomFalse));
4325 }
4326 }
4327 if (op == CL_PROP_LINE) {
4328 if (cl->ClFlags & FactMask) {
4329 return Yap_unify(ARG3, MkIntTerm(cl->lusl.ClLine));
4330 } else if (cl->ClFlags & SrcMask) {
4331 return Yap_unify(ARG3, MkIntTerm(cl->lusl.ClSource->ag.line_number));
4332 } else
4333 return Yap_unify(ARG3, MkIntTerm(0));
4334 }
4335 }
4336 return FALSE;
4337}
4338
4339static Int p_nth_instance(USES_REGS1) {
4340 PredEntry *pe;
4341 arity_t pred_arity;
4342 Functor pred_f;
4343 Term pred_module;
4344 Term t4 = Deref(ARG4);
4345
4346 if (IsVarTerm(t4)) {
4347 // we must know I or count;
4348 Term TCount;
4349 Int Count;
4350
4351 TCount = Deref(ARG3);
4352 if (IsVarTerm(TCount)) {
4353 return FALSE; // backtrack?
4354 }
4355 if (!IsIntegerTerm(TCount)) {
4356 Yap_Error(TYPE_ERROR_INTEGER, TCount, "nth_instance/3");
4357 return FALSE;
4358 }
4359 Count = IntegerOfTerm(TCount);
4360 if (Count <= 0) {
4361 if (Count)
4362 Yap_Error(DOMAIN_ERROR_NOT_LESS_THAN_ZERO, TCount, "nth_clause/3");
4363 else
4364 Yap_Error(DOMAIN_ERROR_NOT_ZERO, TCount, "nth_clause/3");
4365 return FALSE;
4366 }
4367 pe = Yap_get_pred(Deref(ARG1), Deref(ARG2), "nth_clause/3");
4368 if (pe) {
4369 PELOCK(47, pe);
4370 }
4371 if (Deref(ARG2) == IDB_MODULE) {
4372 return Yap_db_nth_recorded(pe, Count PASS_REGS);
4373 } else {
4374 Int CurSlot, sl4;
4375 arity_t i;
4376 void *cl0;
4377
4378 if (!pe)
4379 return FALSE;
4380 if (!(pe->PredFlags & (SourcePredFlag | LogUpdatePredFlag))) {
4381 UNLOCK(pe->PELock);
4382 return FALSE;
4383 }
4384 CurSlot = Yap_StartSlots();
4385 /* I have pe and n */
4386 sl4 = Yap_InitSlot(ARG4);
4387 /* in case we have to index or to expand code */
4388 for (i = 1; i <= pe->ArityOfPE; i++) {
4389 XREGS[i] = MkVarTerm();
4390 }
4391 if (pe->OpcodeOfPred == INDEX_OPCODE) {
4392 IPred(pe, 0, CP);
4393 }
4394 cl0 = Yap_NthClause(pe, Count);
4395 ARG4 = Yap_GetFromSlot(sl4);
4396 LOCAL_CurSlot = CurSlot;
4397 if (cl0 == NULL) {
4398 UNLOCK(pe->PELock);
4399 return FALSE;
4400 }
4401 if (pe->PredFlags & LogUpdatePredFlag) {
4402 LogUpdClause *cl = cl0;
4403
4404#if MULTIPLE_STACKS
4405 TRAIL_CLREF(cl); /* So that fail will erase it */
4406 INC_CLREF_COUNT(cl);
4407#else
4408 if (!(cl->ClFlags & InUseMask)) {
4409 cl->ClFlags |= InUseMask;
4410 TRAIL_CLREF(cl); /* So that fail will erase it */
4411 }
4412#endif
4413 UNLOCK(pe->PELock);
4414 return Yap_unify(MkDBRefTerm((DBRef)cl), ARG4);
4415 } else if (pe->PredFlags & MegaClausePredFlag) {
4416 MegaClause *mcl = ClauseCodeToMegaClause(pe->cs.p_code.FirstClause);
4417 if (mcl->ClFlags & ExoMask) {
4418 UNLOCK(pe->PELock);
4419 return Yap_unify(Yap_MkExoRefTerm(pe, Count - 1), ARG4);
4420 }
4421 /* fast access to nth element, all have same size */
4422 UNLOCK(pe->PELock);
4423 return Yap_unify(Yap_MkMegaRefTerm(pe, cl0), ARG4);
4424 } else {
4425 UNLOCK(pe->PELock);
4426 return Yap_unify(Yap_MkStaticRefTerm(cl0, pe), ARG4);
4427 }
4428 }
4429 }
4430 /* t4 is bound, we have a reference */
4431 if (IsDBRefTerm(t4)) {
4432 DBRef ref = DBRefOfTerm(t4);
4433 if (ref->Flags & LogUpdMask) {
4434 LogUpdClause *cl = (LogUpdClause *)ref;
4435 LogUpdClause *ocl;
4436 UInt icl = 0;
4437
4438 pe = cl->ClPred;
4439 PELOCK(66, pe);
4440 if (cl->ClFlags & ErasedMask) {
4441 UNLOCK(pe->PELock);
4442 return FALSE;
4443 }
4444 ocl = ClauseCodeToLogUpdClause(pe->cs.p_code.FirstClause);
4445 do {
4446 icl++;
4447 if (cl == ocl)
4448 break;
4449 ocl = ocl->ClNext;
4450 } while (ocl != NULL);
4451 UNLOCK(pe->PELock);
4452 if (ocl == NULL) {
4453 return FALSE;
4454 }
4455 if (!Yap_unify(ARG3, MkIntegerTerm(icl))) {
4456 return FALSE;
4457 }
4458 } else {
4459 return Yap_unify_immediate_ref(ref PASS_REGS);
4460 }
4461 } else if (IsApplTerm(t4)) {
4462 Functor f = FunctorOfTerm(t4);
4463
4464 if (f == FunctorStaticClause) {
4465 StaticClause *cl = Yap_ClauseFromTerm(t4), *cl0;
4466 pe = (PredEntry *)IntegerOfTerm(ArgOfTerm(2, t4));
4467 Int i;
4468
4469 if (!pe) {
4470 return FALSE;
4471 }
4472 if (!pe->cs.p_code.NOfClauses)
4473 return FALSE;
4474 cl0 = ClauseCodeToStaticClause(pe->cs.p_code.FirstClause);
4475 // linear scan
4476 for (i = 1; i < pe->cs.p_code.NOfClauses; i++) {
4477 if (cl0 == cl) {
4478 if (!Yap_unify(MkIntTerm(i), ARG3))
4479 return FALSE;
4480 break;
4481 }
4482 }
4483 } else if (f == FunctorMegaClause) {
4484 MegaClause *mcl;
4485 yamop *cl = Yap_MegaClauseFromTerm(t4);
4486 Int i;
4487
4488 pe = Yap_MegaClausePredicateFromTerm(t4);
4489 mcl = ClauseCodeToMegaClause(pe->cs.p_code.FirstClause);
4490 i = ((char *)cl - (char *)mcl->ClCode) / mcl->ClItemSize;
4491 if (!Yap_unify(MkIntTerm(i), ARG3))
4492 return FALSE;
4493 } else if (f == FunctorExoClause) {
4494 Int i;
4495
4496 pe = Yap_ExoClausePredicateFromTerm(t4);
4497 i = Yap_ExoClauseFromTerm(t4);
4498 if (!Yap_unify(MkIntTerm(i + 1), ARG3)) {
4499 return FALSE;
4500 }
4501 } else {
4502 Yap_Error(TYPE_ERROR_REFERENCE, t4, "nth_clause/3");
4503 return FALSE;
4504 }
4505 } else {
4506 Yap_Error(TYPE_ERROR_REFERENCE, t4, "nth_clause/3");
4507 return FALSE;
4508 }
4509 pred_module = pe->ModuleOfPred;
4510 if (pred_module != IDB_MODULE) {
4511 pred_f = pe->FunctorOfPred;
4512 pred_arity = pe->ArityOfPE;
4513 } else {
4514 if (pe->PredFlags & NumberDBPredFlag) {
4515 pred_f = (Functor)MkIntegerTerm(pe->src.IndxId);
4516 pred_arity = 0;
4517 } else {
4518 pred_f = pe->FunctorOfPred;
4519 if (pe->PredFlags & AtomDBPredFlag) {
4520 pred_arity = 0;
4521 } else {
4522 pred_arity = ArityOfFunctor(pred_f);
4523 }
4524 }
4525 }
4526 if (pred_arity) {
4527 if (!Yap_unify(ARG1, Yap_MkNewApplTerm(pred_f, pred_arity)))
4528 return FALSE;
4529 } else {
4530 if (!Yap_unify(ARG1, MkAtomTerm((Atom)pred_f)))
4531 return FALSE;
4532 }
4533 if (pred_module == PROLOG_MODULE) {
4534 if (!Yap_unify(ARG2, TermProlog))
4535 return FALSE;
4536 } else {
4537 if (!Yap_unify(ARG2, pred_module))
4538 return FALSE;
4539 }
4540 return TRUE;
4541}
4542
4543static Int including(USES_REGS1) {
4544 bool rc = Yap_unify(ARG1, LOCAL_Including);
4545 if (!rc)
4546 return FALSE;
4547 LOCAL_Including = Deref(ARG2);
4548 return true;
4549}
4550
4551static Int predicate_flags(
4552 USES_REGS1) { /* $predicate_flags(+Functor,+Mod,?OldFlags,?NewFlags) */
4553 PredEntry *pe;
4554 pred_flags_t newFl;
4555 Term t1 = Deref(ARG1);
4556 Term mod = Deref(ARG2);
4557
4558 if (IsVarTerm(mod) || !IsAtomTerm(mod)) {
4559 return false;
4560 }
4561 if (IsVarTerm(t1))
4562 return (FALSE);
4563 if (IsAtomTerm(t1)) {
4564 while ((pe = RepPredProp(PredPropByAtom(AtomOfTerm(t1), mod))) == NULL) {
4565 if (!Yap_growheap(FALSE, 0, NULL)) {
4566 Yap_Error(RESOURCE_ERROR_HEAP, ARG1, "while generating new predicate");
4567 return FALSE;
4568 }
4569 t1 = Deref(ARG1);
4570 mod = Deref(ARG2);
4571 }
4572 } else if (IsApplTerm(t1)) {
4573 Functor funt = FunctorOfTerm(t1);
4574 while ((pe = RepPredProp(PredPropByFunc(funt, mod))) == NULL) {
4575 if (!Yap_growheap(FALSE, 0, NULL)) {
4576 Yap_Error(RESOURCE_ERROR_HEAP, ARG1, "while generating new predicate");
4577 return FALSE;
4578 }
4579 t1 = Deref(ARG1);
4580 mod = Deref(ARG2);
4581 }
4582 } else
4583 return (FALSE);
4584 if (EndOfPAEntr(pe))
4585 return (FALSE);
4586 PELOCK(92, pe);
4587 if (!Yap_unify_constant(ARG3, MkIntegerTerm(pe->PredFlags))) {
4588 UNLOCK(pe->PELock);
4589 return (FALSE);
4590 }
4591 ARG4 = Deref(ARG4);
4592 if (IsVarTerm(ARG4)) {
4593 UNLOCK(pe->PELock);
4594 return (TRUE);
4595 } else if (!IsIntegerTerm(ARG4)) {
4596 Term te = Yap_Eval(ARG4);
4597
4598 if (IsIntegerTerm(te)) {
4599 newFl = IntegerOfTerm(te);
4600 } else {
4601 UNLOCK(pe->PELock);
4602 Yap_Error(TYPE_ERROR_INTEGER, ARG4, "flags");
4603 return (FALSE);
4604 }
4605 } else
4606 newFl = IntegerOfTerm(ARG4);
4607 pe->PredFlags = newFl;
4608 UNLOCK(pe->PELock);
4609 return TRUE;
4610}
4611
4612static bool pred_flag_clause(Functor f, Term mod, const char *name,
4613 pred_flags_t val USES_REGS) {
4614 Term tn;
4615
4616 Term s[2];
4617 s[0] = MkAtomTerm(Yap_LookupAtom(name));
4618#if SIZEOF_INT_P == 8
4619 s[1] = MkIntegerTerm(val);
4620#elif USE_GMP
4621 {
4622 char text[64];
4623 MP_INT rop;
4624
4625#ifdef _WIN32
4626 snprintf(text, 64, "%I64d", (long long int)val);
4627#elif HAVE_SNPRINTF
4628 snprintf(text, 64, "%lld", (long long int)val);
4629#else
4630 sprintf(text, "%lld", (long long int)val);
4631#endif
4632 mpz_init_set_str(&rop, text, 10);
4633 s[1] = Yap_MkBigIntTerm((void *)&rop);
4634 }
4635#endif
4636 tn = Yap_MkApplTerm(f, 2, s);
4637 yamop *code_adr = Yap_cclause(tn, 2, mod, tn); /* vsc: give the number of
4638 arguments to cclause() in case there is a overflow
4639 */
4640 if (LOCAL_ErrorMessage) {
4641 return false;
4642 }
4643 return Yap_addclause(tn, code_adr, TermAssertz, mod, NULL);
4644}
4645
4646struct pred_entry *Yap_MkLogPred(struct pred_entry *pe) {
4647 pe->PredFlags = LogUpdatePredFlag;
4648 pe->OpcodeOfPred = FAIL_OPCODE;
4649 pe->cs.p_code.TrueCodeOfPred = pe->CodeOfPred = FAILCODE;
4650 return pe;
4651}
4652
4653static Int init_pred_flag_vals(USES_REGS1) {
4654 Functor f;
4655 Term mod = Deref(ARG2), t = Deref(ARG1);
4656
4657 if (IsAtomTerm(t)) {
4658 return false;
4659 } else if (IsApplTerm(t)) {
4660 f = FunctorOfTerm(t);
4661 arity_t Arity = ArityOfFunctor(f);
4662 if (Arity != 2)
4663 return false;
4664 } else {
4665 return false;
4666 }
4667 pred_flag_clause(f, mod, "asm", AsmPredFlag PASS_REGS);
4668 pred_flag_clause(f, mod, "atom_db", AtomDBPredFlag PASS_REGS);
4669 pred_flag_clause(f, mod, "back_c", BackCPredFlag PASS_REGS);
4670 pred_flag_clause(f, mod, "c", CPredFlag PASS_REGS);
4671 pred_flag_clause(f, mod, "c_args", CArgsPredFlag PASS_REGS);
4672 pred_flag_clause(f, mod, "compiled", CompiledPredFlag PASS_REGS);
4673 pred_flag_clause(f, mod, "count", CountPredFlag PASS_REGS);
4674 pred_flag_clause(f, mod, "discontiguous", DiscontiguousPredFlag PASS_REGS);
4675 pred_flag_clause(f, mod, "immediate_update", DynamicPredFlag PASS_REGS);
4676 pred_flag_clause(f, mod, "hidden", HiddenPredFlag PASS_REGS);
4677 pred_flag_clause(f, mod, "in_use", InUsePredFlag PASS_REGS);
4678 pred_flag_clause(f, mod, "indexed", IndexedPredFlag PASS_REGS);
4679 pred_flag_clause(f, mod, "log_update", LogUpdatePredFlag PASS_REGS);
4680 pred_flag_clause(f, mod, "mega_clause", MegaClausePredFlag PASS_REGS);
4681 pred_flag_clause(f, mod, "meta", MetaPredFlag PASS_REGS);
4682 pred_flag_clause(f, mod, "module_transparent",
4683 ModuleTransparentPredFlag PASS_REGS);
4684 pred_flag_clause(f, mod, "multi", MultiFileFlag PASS_REGS);
4685 pred_flag_clause(f, mod, "number_db", NumberDBPredFlag PASS_REGS);
4686 pred_flag_clause(f, mod, "profiled", ProfiledPredFlag PASS_REGS);
4687 pred_flag_clause(f, mod, "quasi_quotation", QuasiQuotationPredFlag PASS_REGS);
4688 pred_flag_clause(f, mod, "safe", SafePredFlag PASS_REGS);
4689 pred_flag_clause(f, mod, "sequential", SequentialPredFlag PASS_REGS);
4690 pred_flag_clause(f, mod, "source", SourcePredFlag PASS_REGS);
4691 pred_flag_clause(f, mod, "spied", SpiedPredFlag PASS_REGS);
4692 pred_flag_clause(f, mod, "standard", StandardPredFlag PASS_REGS);
4693 pred_flag_clause(f, mod, "swi_env", SWIEnvPredFlag PASS_REGS);
4694 pred_flag_clause(f, mod, "sync", SyncPredFlag PASS_REGS);
4695 pred_flag_clause(f, mod, "sys_export", SysExportPredFlag PASS_REGS);
4696 pred_flag_clause(f, mod, "tabled", TabledPredFlag PASS_REGS);
4697 pred_flag_clause(f, mod, "test", TestPredFlag PASS_REGS);
4698 pred_flag_clause(f, mod, "thread_local", ThreadLocalPredFlag PASS_REGS);
4699 pred_flag_clause(f, mod, "udi", UDIPredFlag PASS_REGS);
4700 pred_flag_clause(f, mod, "user_c", UserCPredFlag PASS_REGS);
4701 pred_flag_clause(f, mod, "system", SystemPredFlags PASS_REGS);
4702 pred_flag_clause(f, mod, "foreign", ForeignPredFlags PASS_REGS);
4703 return true;
4704}
4705
4706void Yap_InitCdMgr(void) {
4707 CACHE_REGS
4708 Term cm = CurrentModule;
4709
4710 Yap_InitCPred("$init_pred_flag_vals", 2, init_pred_flag_vals, SyncPredFlag);
4711 Yap_InitCPred("$start_consult", 4, p_startconsult,
4712 SafePredFlag | SyncPredFlag);
4713 Yap_InitCPred("$show_consult_level", 1, p_showconslultlev, SafePredFlag);
4714 Yap_InitCPred("$end_consult", 0, p_endconsult, SafePredFlag | SyncPredFlag);
4715 Yap_InitCPred("$being_consulted", 1, being_consulted, SafePredFlag | SyncPredFlag);
4716 /* gc() may happen during compilation, hence these predicates are
4717 now unsafe */
4718 Yap_InitCPred("$predicate_flags", 4, predicate_flags, SyncPredFlag);
4719 Yap_InitCPred("$compile", 5, p_compile, SyncPredFlag);
4720 Yap_InitCPred("$purge_clauses", 2, p_purge_clauses,
4721 SafePredFlag | SyncPredFlag);
4722 Yap_InitCPred("$is_dynamic", 2, p_is_dynamic, TestPredFlag | SafePredFlag);
4723 Yap_InitCPred("$is_metapredicate", 2, p_is_metapredicate,
4724 TestPredFlag | SafePredFlag);
4725 Yap_InitCPred("$is_meta_predicate", 2, p_is_metapredicate,
4726 TestPredFlag | SafePredFlag);
4727 Yap_InitCPred("$proxy_predicate", 2, proxy_predicate,
4728 SafePredFlag);
4729 Yap_InitCPred("$is_log_updatable", 2, p_is_log_updatable,
4730 TestPredFlag | SafePredFlag);
4731 Yap_InitCPred("$is_thread_local", 2, p_is_thread_local,
4732 TestPredFlag | SafePredFlag);
4733 Yap_InitCPred("$is_source", 2, p_is_source, TestPredFlag | SafePredFlag);
4734 Yap_InitCPred("$predicate_type", 3, predicate_type, SafePredFlag);
4735 Yap_InitCPred("$is_exo", 2, p_is_exo, TestPredFlag | SafePredFlag);
4736 Yap_InitCPred("$owner_file", 3, owner_file, SafePredFlag);
4737 Yap_InitCPred("$set_owner_file", 3, p_set_owner_file, SafePredFlag);
4738 Yap_InitCPred("$mk_dynamic", 1, mk_dynamic, SafePredFlag);
4739 Yap_InitCPred("$new_meta_pred", 2, new_meta_pred, SafePredFlag);
4740 Yap_InitCPred("$sys_export", 2, p_sys_export, TestPredFlag | SafePredFlag);
4741 Yap_InitCPred("$may_update_predicate", 7, may_update_predicate, SyncPredFlag | HiddenPredFlag);
4742 Yap_InitCPred("$pred_exists", 2, pred_exists, TestPredFlag | SafePredFlag);
4743 Yap_InitCPred("$number_of_clauses", 3, number_of_clauses,
4744 SafePredFlag | SyncPredFlag);
4745 Yap_InitCPred("$undefined", 2, p_undefined, SafePredFlag | TestPredFlag);
4746 Yap_InitCPred("$undefp_handler", 1, undefp_handler,
4747 SafePredFlag | TestPredFlag);
4748 Yap_InitCPred("$optimizer_on", 0, p_optimizer_on,
4749 SafePredFlag | SyncPredFlag);
4750 Yap_InitCPred("$clean_up_dead_clauses", 0, p_clean_up_dead_clauses,
4751 SyncPredFlag);
4752 Yap_InitCPred("$optimizer_off", 0, p_optimizer_off,
4753 SafePredFlag | SyncPredFlag);
4754 Yap_InitCPred("$kill_dynamic", 2, p_kill_dynamic,
4755 SafePredFlag | SyncPredFlag);
4756 Yap_InitCPred("$new_multifile", 2, new_multifile,
4757 SafePredFlag | SyncPredFlag | HiddenPredFlag);
4758 Yap_InitCPred("$is_multifile", 2, p_is_multifile,
4759 TestPredFlag | SafePredFlag);
4760 Yap_InitCPred("$is_private", 2, p_is_private,
4761 TestPredFlag | SafePredFlag);
4762 Yap_InitCPred("$new_system_predicate", 3, new_system_predicate,
4763 SafePredFlag | SyncPredFlag);
4764 Yap_InitCPred("$is_system_predicate", 2, p_is_system_predicate,
4765 TestPredFlag | SafePredFlag);
4766 Yap_InitCPred("$is_opaque_predicate", 2, p_is_opaque_predicate,
4767 TestPredFlag | SafePredFlag);
4768 Yap_InitCPred("$new_discontiguous", 3, p_new_discontiguous,
4769 SafePredFlag | SyncPredFlag);
4770 Yap_InitCPred("$is_discontiguous", 2, p_is_discontiguous,
4771 TestPredFlag | SafePredFlag);
4772 Yap_InitCPred("$is_profiled", 1, p_is_profiled, SafePredFlag | SyncPredFlag);
4773 Yap_InitCPred("$profile_info", 3, p_profile_info,
4774 SafePredFlag | SyncPredFlag);
4775 Yap_InitCPred("$profile_reset", 2, p_profile_reset,
4776 SafePredFlag | SyncPredFlag);
4777 Yap_InitCPred("$is_call_counted", 1, p_is_call_counted,
4778 SafePredFlag | SyncPredFlag);
4779 Yap_InitCPred("$call_count_info", 3, p_call_count_info,
4780 SafePredFlag | SyncPredFlag);
4781 Yap_InitCPred("$call_count_set", 6, p_call_count_set,
4782 SafePredFlag | SyncPredFlag);
4783 Yap_InitCPred("$call_count_reset", 0, p_call_count_reset,
4784 SafePredFlag | SyncPredFlag);
4785 Yap_InitCPred("$set_pred_module", 2, p_set_pred_module, SafePredFlag);
4786 Yap_InitCPred("$set_pred_owner", 2, p_set_pred_owner, SafePredFlag);
4787 Yap_InitCPred("hide_predicate", 1, hide_predicate, SafePredFlag);
4788 Yap_InitCPred("$stash_predicate", 2, p_stash_predicate, SafePredFlag);
4789 Yap_InitCPred("$hidden_predicate", 2, p_hidden_predicate, SafePredFlag);
4790 Yap_InitCPred("$log_update_clause", 4, p_log_update_clause, SyncPredFlag);
4791 Yap_InitCPred("$continue_log_update_clause", 5, p_continue_log_update_clause,
4792 SafePredFlag | SyncPredFlag);
4793 Yap_InitCPred("$log_update_clause_erase", 4, p_log_update_clause_erase,
4794 SyncPredFlag);
4795 Yap_InitCPred("$continue_log_update_clause_erase", 5,
4796 p_continue_log_update_clause_erase,
4797 SafePredFlag | SyncPredFlag);
4798 Yap_InitCPred("$static_clause", 4, p_static_clause, SyncPredFlag);
4799 Yap_InitCPred("$continue_static_clause", 5, p_continue_static_clause,
4800 SafePredFlag | SyncPredFlag);
4801 Yap_InitCPred("$static_pred_statistics", 5, p_static_pred_statistics,
4802 SyncPredFlag);
4803 Yap_InitCPred("instance_property", 3, instance_property,
4804 SafePredFlag | SyncPredFlag);
4805 Yap_InitCPred("$fetch_nth_clause", 4, p_nth_instance, SyncPredFlag);
4806 CurrentModule = DBLOAD_MODULE;
4807 Yap_InitCPred("dbload_get_space", 4, p_dbload_get_space, 0L);
4808 Yap_InitCPred("dbassert", 3, p_dbassert, 0L);
4809 CurrentModule = cm;
4810 Yap_InitCPred("$predicate_erased_statistics", 5,
4811 predicate_erased_statistics, SyncPredFlag);
4812 Yap_InitCPred("$including", 2, including, SyncPredFlag | HiddenPredFlag);
4813#ifdef DEBUG
4814 Yap_InitCPred("$predicate_lu_cps", 4, predicate_lu_cps, 0L);
4815#endif
4816}
Main definitions.
void * Malloc(size_t sz USES_REGS)
allocate a temporary text block
Definition: alloc.c:1759
Term MkSysError(yap_error_descriptor_t *i)
Wrap the error descriptor as exception/2.
Definition: errors.c:841
bool Yap_MkErrorRecord(yap_error_descriptor_t *r, const char *file, const char *function, int lineno, yap_error_number type, Term where, const char *s)
complete an error descriptor:
Definition: errors.c:882
Definition: heapgc.h:272
Definition: Yatom.h:544
all we need to know about an error/throw
Definition: YapError.h:205
Definition: amidefs.h:264