YAP 7.1.0
dbload.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 $ 8
15 *************************************************************************/
16
17#include "Yap.h"
18#include "YapEval.h"
19#include "clause.h"
20#include "tracer.h"
21#include "yapio.h"
22
23#include <Yatom.h>
24#include <assert.h>
25#include <heapgc.h>
26#include <iopreds.h>
27
28
29
30#ifdef DEBUG
31static UInt total_megaclause, total_released, nof_megaclauses;
32#endif
33
34/******************************************************************
35
36 Mega Clauses
37
38******************************************************************/
39
40#define OrArgAdjust(P)
41#define TabEntryAdjust(P)
42#define DoubleInCodeAdjust(D)
43#define IntegerInCodeAdjust(D)
44#define IntegerAdjust(D) (D)
45#define PtoPredAdjust(X) (X)
46#define PtoOpAdjust(X) (X)
47#define PtoLUClauseAdjust(P) (P)
48#define PtoLUIndexAdjust(P) (P)
49#define XAdjust(X) (X)
50#define YAdjust(X) (X)
51#define AtomTermAdjust(X) (X)
52#define CellPtoHeapAdjust(X) (X)
53#define FuncAdjust(X) (X)
54#define CodeAddrAdjust(X) (X)
55#define CodeComposedTermAdjust(X) (X)
56#define ConstantAdjust(X) (X)
57#define ArityAdjust(X) (X)
58#define OpcodeAdjust(X) (X)
59#define ModuleAdjust(X) (X)
60#define ExternalFunctionAdjust(X) (X)
61#define AdjustSwitchTable(X, Y, Z)
62#define DBGroundTermAdjust(X) (X)
63#define rehash(A, B, C)
64
65static Term BlobTermInCodeAdjust(Term t) {
66 CACHE_REGS
67#if TAGS_FAST_OPS
68 return t - LOCAL_ClDiff;
69#else
70 return t + LOCAL_ClDiff;
71#endif
72}
73
74static Term ConstantTermAdjust(Term t) {
75 if (IsAtomTerm(t))
76 return AtomTermAdjust(t);
77 return t;
78}
79
80#include "rclause.h"
81
82
83void Yap_BuildMegaClause(PredEntry *ap) {
84 CACHE_REGS
85 StaticClause *cl;
86 UInt sz;
87 MegaClause *mcl;
88 yamop *ptr;
89 size_t required;
90 UInt has_blobs = 0;
91
92 if (ap->PredFlags & (DynamicPredFlag | LogUpdatePredFlag | MegaClausePredFlag
93#ifdef TABLING
94 | TabledPredFlag
95#endif /* TABLING */
96 | UDIPredFlag) ||
97 ap->FirstClause == NULL || ap->NOfClauses < 16) {
98 return;
99 }
100 cl = ClauseCodeToStaticClause(ap->FirstClause);
101 sz = cl->ClSize;
102 while (TRUE) {
103 if (!(cl->ClFlags & FactMask))
104 return; /* no mega clause, sorry */
105 if (cl->ClSize != sz)
106 return; /* no mega clause, sorry */
107 if (cl->ClCode == ap->LastClause)
108 break;
109 has_blobs |= (cl->ClFlags & HasBlobsMask);
110 cl = cl->ClNext;
111 }
112 /* ok, we got the chance for a mega clause */
113 if (has_blobs) {
114 sz -= sizeof(StaticClause);
115 } else {
116 sz -= (UInt)NEXTOP((yamop *)NULL, p) + sizeof(StaticClause);
117 }
118 required = sz * ap->NOfClauses + sizeof(MegaClause) +
119 (UInt)NEXTOP((yamop *)NULL, l);
120 while (!(mcl = (MegaClause *)Yap_AllocCodeSpace(required))) {
121 if (!Yap_growheap(FALSE, required, NULL)) {
122 /* just fail, the system will keep on going */
123 return;
124 }
125 }
126#ifdef DEBUG
127 total_megaclause += required;
128 cl = ClauseCodeToStaticClause(ap->FirstClause);
129 total_released += ap->NOfClauses * cl->ClSize;
130 nof_megaclauses++;
131#endif
132 Yap_ClauseSpace += required;
133 /* cool, it's our turn to do the conversion */
134 mcl->ClFlags = MegaMask | has_blobs;
135 mcl->ClSize = required;
136 mcl->ClPred = ap;
137 mcl->ClItemSize = sz;
138 mcl->ClNext = NULL;
139 cl = ClauseCodeToStaticClause(ap->FirstClause);
140 mcl->ClLine = cl->usc.ClLine;
141 ptr = mcl->ClCode;
142 while (TRUE) {
143 memmove((void *)ptr, (void *)cl->ClCode, sz);
144 if (has_blobs) {
145 LOCAL_ClDiff = (char *)(ptr) - (char *)cl->ClCode;
146 restore_opcodes(ptr, NULL PASS_REGS);
147 }
148 ptr = (yamop *)((char *)ptr + sz);
149 if (cl->ClCode == ap->LastClause)
150 break;
151 cl = cl->ClNext;
152 }
153 ptr->opc = Yap_opcode(_Ystop);
154 cl = ClauseCodeToStaticClause(ap->FirstClause);
155 /* recover the space spent on the original clauses */
156 while (TRUE) {
157 StaticClause *ncl, *curcl = cl;
158
159 ncl = cl->ClNext;
160 Yap_InformOfRemoval(cl);
161 Yap_ClauseSpace -= cl->ClSize;
162 Yap_FreeCodeSpace((ADDR)cl);
163 if (curcl->ClCode == ap->LastClause)
164 break;
165 cl = ncl;
166 }
167 ap->FirstClause = ap->LastClause = mcl->ClCode;
168 ap->PredFlags |= MegaClausePredFlag;
169 Yap_inform_profiler_of_clause(mcl, (char *)mcl + required, ap, GPROF_MEGA);
170}
171
172void Yap_split_megaclause(PredEntry *ap) {
173 StaticClause *start = NULL, *prev = NULL;
174 MegaClause *mcl;
175 yamop *ptr;
176 UInt ncls = ap->NOfClauses, i;
177
178 mcl = ClauseCodeToMegaClause(ap->FirstClause);
179 if (mcl->ClFlags & ExoMask) {
180 Yap_Error(PERMISSION_ERROR_MODIFY_STATIC_PROCEDURE, Yap_PredicateToIndicator(ap),
181 "while deleting clause from exo predicate %s/%d\n",
182 RepAtom(NameOfFunctor(ap->FunctorOfPred))->StrOfAE,
183 ap->ArityOfPE);
184 return;
185 }
186 for (i = 0, ptr = mcl->ClCode; i < ncls; i++) {
187 StaticClause *new = (StaticClause *)Yap_AllocCodeSpace(
188 sizeof(StaticClause) + mcl->ClItemSize +
189 (UInt)NEXTOP((yamop *)NULL, p));
190 if (new == NULL) {
191 if (!Yap_growheap(FALSE,
192 (sizeof(StaticClause) + mcl->ClItemSize) * (ncls - i),
193 NULL)) {
194 while (start) {
195 StaticClause *cl = start;
196 start = cl->ClNext;
197 Yap_InformOfRemoval(cl);
198 Yap_ClauseSpace -= cl->ClSize;
199 Yap_FreeCodeSpace((char *)cl);
200 }
201 if (ap->ArityOfPE) {
202 Yap_Error(RESOURCE_ERROR_HEAP, TermNil,
203 "while breaking up mega clause for %s/%d\n",
204 RepAtom(NameOfFunctor(ap->FunctorOfPred))->StrOfAE,
205 ap->ArityOfPE);
206 } else {
207 Yap_Error(RESOURCE_ERROR_HEAP, TermNil,
208 "while breaking up mega clause for %s\n",
209 RepAtom((Atom)ap->FunctorOfPred)->StrOfAE);
210 }
211 return;
212 }
213 break;
214 }
215 Yap_ClauseSpace +=
216 sizeof(StaticClause) + mcl->ClItemSize + (UInt)NEXTOP((yamop *)NULL, p);
217 new->ClFlags = StaticMask | FactMask;
218 new->ClSize = mcl->ClItemSize;
219 new->usc.ClLine = Yap_source_line_no();
220 new->ClNext = NULL;
221 memmove((void *)new->ClCode, (void *)ptr, mcl->ClItemSize);
222 if (prev) {
223 prev->ClNext = new;
224 } else {
225 start = new;
226 }
227 ptr = (yamop *)((char *)ptr + mcl->ClItemSize);
228 prev = new;
229 }
230 ap->PredFlags &= ~MegaClausePredFlag;
231 ap->FirstClause = start->ClCode;
232 ap->LastClause = prev->ClCode;
233}
234
235
236static UInt compute_dbcl_size(arity_t arity) {
237 UInt sz;
238 switch (arity) {
239 case 2:
240 sz = (UInt)NEXTOP((yamop *)NULL, cc);
241 break;
242 case 3:
243 sz = (UInt)NEXTOP((yamop *)NULL, ccc);
244 break;
245 case 4:
246 sz = (UInt)NEXTOP((yamop *)NULL, cccc);
247 break;
248 case 5:
249 sz = (UInt)NEXTOP((yamop *)NULL, ccccc);
250 break;
251 case 6:
252 sz = (UInt)NEXTOP((yamop *)NULL, cccccc);
253 break;
254 default:
255 sz = arity * (UInt)NEXTOP((yamop *)NULL, xc);
256 break;
257 }
258 return (UInt)NEXTOP((yamop *)sz, p);
259}
260
261#define DerefAndCheck(t, V) \
262 t = Deref(V); \
263 if (IsVarTerm(t) || !(IsAtomOrIntTerm(t))) \
264 Yap_Error(TYPE_ERROR_ATOM, t0, "load_db");
265
266static int store_dbcl_size(yamop *pc, arity_t arity, Term t0, PredEntry *pe) {
267 Term t;
268 CELL *tp = RepAppl(t0) + 1;
269 switch (arity) {
270 case 2:
271 pc->opc = Yap_opcode(_get_2atoms);
272 DerefAndCheck(t, tp[0]);
273 pc->y_u.cc.c1 = t;
274 DerefAndCheck(t, tp[1]);
275 pc->y_u.cc.c2 = t;
276 pc = NEXTOP(pc, cc);
277 break;
278 case 3:
279 pc->opc = Yap_opcode(_get_3atoms);
280 DerefAndCheck(t, tp[0]);
281 pc->y_u.ccc.c1 = t;
282 DerefAndCheck(t, tp[1]);
283 pc->y_u.ccc.c2 = t;
284 DerefAndCheck(t, tp[2]);
285 pc->y_u.ccc.c3 = t;
286 pc = NEXTOP(pc, ccc);
287 break;
288 case 4:
289 pc->opc = Yap_opcode(_get_4atoms);
290 DerefAndCheck(t, tp[0]);
291 pc->y_u.cccc.c1 = t;
292 DerefAndCheck(t, tp[1]);
293 pc->y_u.cccc.c2 = t;
294 DerefAndCheck(t, tp[2]);
295 pc->y_u.cccc.c3 = t;
296 DerefAndCheck(t, tp[3]);
297 pc->y_u.cccc.c4 = t;
298 pc = NEXTOP(pc, cccc);
299 break;
300 case 5:
301 pc->opc = Yap_opcode(_get_5atoms);
302 DerefAndCheck(t, tp[0]);
303 pc->y_u.ccccc.c1 = t;
304 DerefAndCheck(t, tp[1]);
305 pc->y_u.ccccc.c2 = t;
306 DerefAndCheck(t, tp[2]);
307 pc->y_u.ccccc.c3 = t;
308 DerefAndCheck(t, tp[3]);
309 pc->y_u.ccccc.c4 = t;
310 DerefAndCheck(t, tp[4]);
311 pc->y_u.ccccc.c5 = t;
312 pc = NEXTOP(pc, ccccc);
313 break;
314 case 6:
315 pc->opc = Yap_opcode(_get_6atoms);
316 DerefAndCheck(t, tp[0]);
317 pc->y_u.cccccc.c1 = t;
318 DerefAndCheck(t, tp[1]);
319 pc->y_u.cccccc.c2 = t;
320 DerefAndCheck(t, tp[2]);
321 pc->y_u.cccccc.c3 = t;
322 DerefAndCheck(t, tp[3]);
323 pc->y_u.cccccc.c4 = t;
324 DerefAndCheck(t, tp[4]);
325 pc->y_u.cccccc.c5 = t;
326 DerefAndCheck(t, tp[5]);
327 pc->y_u.cccccc.c6 = t;
328 pc = NEXTOP(pc, cccccc);
329 break;
330 default: {
331 arity_t i;
332 for (i = 0; i < arity; i++) {
333 pc->opc = Yap_opcode(_get_atom);
334#if PRECOMPUTE_REGADDRESS
335 pc->y_u.xc.x = (CELL)(XREGS + (i + 1));
336#else
337 pc->y_u.xc.x = i + 1;
338#endif
339 DerefAndCheck(t, tp[0]);
340 pc->y_u.xc.c = t;
341 tp++;
342 pc = NEXTOP(pc, xc);
343 }
344 } break;
345 }
346 pc->opc = Yap_opcode(_procceed);
347 pc->y_u.p.p = pe;
348 return TRUE;
349}
350
351static Int
352 p_dbload_get_space(USES_REGS1) { /* '$number_of_clauses'(Predicate,M,N) */
353 Term t = Deref(ARG1);
354 Term mod = Deref(ARG2);
355 Term tn = Deref(ARG3);
356 arity_t arity;
357 Prop pe;
358 PredEntry *ap;
359 UInt sz;
360 MegaClause *mcl;
361 yamop *ptr;
362 UInt ncls;
363 UInt required;
364
365 if (IsVarTerm(mod) || !IsAtomTerm(mod)) {
366 return (FALSE);
367 }
368 if (IsAtomTerm(t)) {
369 Atom a = AtomOfTerm(t);
370 arity = 0;
371 pe = PredPropByAtom(a, mod);
372 } else if (IsApplTerm(t)) {
373 register Functor f = FunctorOfTerm(t);
374 arity = ArityOfFunctor(f);
375 pe = PredPropByFunc(f, mod);
376 } else {
377 return FALSE;
378 }
379 if (EndOfPAEntr(pe))
380 return FALSE;
381 ap = RepPredProp(pe);
382 if (ap->PredFlags & (DynamicPredFlag | LogUpdatePredFlag
383#ifdef TABLING
384 | TabledPredFlag
385#endif /* TABLING */
386 )) {
387 Yap_Error(PERMISSION_ERROR_MODIFY_STATIC_PROCEDURE, Yap_PredicateToIndicator(ap),
388 "dbload_get_space/4");
389 return FALSE;
390 }
391 if (IsVarTerm(tn) || !IsIntegerTerm(tn)) {
392 return FALSE;
393 }
394 ncls = IntegerOfTerm(tn);
395 if (ncls <= 1) {
396 return FALSE;
397 }
398
399 sz = compute_dbcl_size(arity);
400 required = sz * ncls + sizeof(MegaClause) + (UInt)NEXTOP((yamop *)NULL, l);
401#ifdef DEBUG
402 total_megaclause += required;
403 nof_megaclauses++;
404#endif
405 while (!(mcl = (MegaClause *)Yap_AllocCodeSpace(required))) {
406 if (!Yap_growheap(FALSE, required, NULL)) {
407 /* just fail, the system will keep on going */
408 return FALSE;
409 }
410 }
411 Yap_ClauseSpace += required;
412 /* cool, it's our turn to do the conversion */
413 mcl->ClFlags = MegaMask;
414 mcl->ClSize = sz * ncls;
415 mcl->ClPred = ap;
416 mcl->ClItemSize = sz;
417 mcl->ClNext = NULL;
418 ap->FirstClause = ap->LastClause = mcl->ClCode;
419 ap->PredFlags |= (MegaClausePredFlag);
420 ap->NOfClauses = ncls;
421 if (ap->PredFlags & (SpiedPredFlag | CountPredFlag | ProfiledPredFlag)) {
422 ap->OpcodeOfPred = Yap_opcode(_spy_pred);
423 } else {
424 ap->OpcodeOfPred = INDEX_OPCODE;
425 }
426 ap->CodeOfPred = ap->TrueCodeOfPred =
427 (yamop *)(&(ap->OpcodeOfPred));
428 ptr = (yamop *)((ADDR)mcl->ClCode + ncls * sz);
429 ptr->opc = Yap_opcode(_Ystop);
430 return Yap_unify(ARG4, MkIntegerTerm((Int)mcl));
431}
432
433static Int p_dbassert(USES_REGS1) { /* '$number_of_clauses'(Predicate,M,N) */
434 Term thandle = Deref(ARG2);
435 Term tn = Deref(ARG3);
436 PredEntry *pe;
437 MegaClause *mcl;
438 Int n;
439
440 if (IsVarTerm(thandle) || !IsIntegerTerm(thandle)) {
441 return FALSE;
442 }
443 mcl = (MegaClause *)IntegerOfTerm(thandle);
444 if (IsVarTerm(tn) || !IsIntegerTerm(tn)) {
445 return FALSE;
446 }
447 n = IntegerOfTerm(tn);
448 pe = mcl->ClPred;
449 return store_dbcl_size((yamop *)((ADDR)mcl->ClCode + n * (mcl->ClItemSize)),
450 pe->ArityOfPE, Deref(ARG1), pe);
451}
452
453void Yap_InitDBLoadPreds(void) {
454 CACHE_REGS
455 //CurrentModule = DBLOAD_MODULE;
456 Yap_InitCPred("$dbload_get_space", 4, p_dbload_get_space, 0L);
457 Yap_InitCPred("$dbassert", 3, p_dbassert, 0L);
458 //CurrentModule = cm;
459}
Yap.h
Main definitions.
pred_entry
Definition: Yatom.h:544
static_clause
Definition: clause.h:127
static_mega_clause
Definition: clause.h:140
yami
Definition: amidefs.h:264