1 /* Part of SWI-Prolog
2
3 Author: Jan Wielemaker
4 E-mail: J.Wielemaker@vu.nl
5 WWW: http://www.swi-prolog.org
6 Copyright (c) 1985-2020, University of Amsterdam
7 VU University Amsterdam
8 CWI, Amsterdam
9 All rights reserved.
10
11 Redistribution and use in source and binary forms, with or without
12 modification, are permitted provided that the following conditions
13 are met:
14
15 1. Redistributions of source code must retain the above copyright
16 notice, this list of conditions and the following disclaimer.
17
18 2. Redistributions in binary form must reproduce the above copyright
19 notice, this list of conditions and the following disclaimer in
20 the documentation and/or other materials provided with the
21 distribution.
22
23 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
24 "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
25 LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
26 FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
27 COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
28 INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
29 BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
30 LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
31 CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
32 LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
33 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
34 POSSIBILITY OF SUCH DAMAGE.
35 */
36
37 /*#define O_DEBUG 1*/
38 #include "pl-incl.h"
39 #include "pl-comp.h"
40 #include "pl-arith.h"
41 #include "pl-dbref.h"
42 #include "pl-termwalk.c"
43 #include "pl-dict.h"
44 #include "pl-event.h"
45
46 #define WORDS_PER_PLINT (sizeof(int64_t)/sizeof(word))
47
48 static RecordList lookupRecordList(word);
49 static RecordList isCurrentRecordList(word, int must_be_non_empty);
50 static void freeRecordRef(RecordRef r);
51 static void unallocRecordList(RecordList rl);
52 static int is_external(const char *rec, size_t len);
53
54 #define RECORDA 0
55 #define RECORDZ 1
56
57 #undef LD
58 #define LD LOCAL_LD
59
60 static void
free_recordlist_symbol(void * name,void * value)61 free_recordlist_symbol(void *name, void *value)
62 { RecordList l = value;
63
64 unallocRecordList(l);
65 }
66
67
68 void
initRecords(void)69 initRecords(void)
70 { GD->recorded_db.record_lists = newHTable(8);
71 GD->recorded_db.record_lists->free_symbol = free_recordlist_symbol;
72 }
73
74
75 void
cleanupRecords(void)76 cleanupRecords(void)
77 { Table t;
78
79 if ( (t=GD->recorded_db.record_lists) )
80 { GD->recorded_db.record_lists = NULL;
81 destroyHTable(t);
82 }
83 }
84
85
86 /* MT: locked by caller (record())
87 */
88
89 static RecordList
lookupRecordList(word key)90 lookupRecordList(word key)
91 { GET_LD
92 RecordList l;
93
94 if ( (l = lookupHTable(GD->recorded_db.record_lists, (void *)key)) )
95 { return l;
96 } else
97 { if ( isAtom(key) ) /* can also be functor_t */
98 PL_register_atom(key);
99 l = allocHeapOrHalt(sizeof(*l));
100 memset(l, 0, sizeof(*l));
101 l->key = key;
102 addNewHTable(GD->recorded_db.record_lists, (void *)key, l);
103
104 return l;
105 }
106 }
107
108
109 static RecordRef
firstRecordRecordList(RecordList rl)110 firstRecordRecordList(RecordList rl)
111 { RecordRef record;
112
113 for(record = rl->firstRecord; record; record = record->next)
114 { if ( false(record->record, R_ERASED) )
115 return record;
116 }
117
118 return NULL;
119 }
120
121
122 static RecordList
isCurrentRecordList(word key,int must_be_non_empty)123 isCurrentRecordList(word key, int must_be_non_empty)
124 { GET_LD
125 RecordList rl;
126
127 if ( (rl = lookupHTable(GD->recorded_db.record_lists, (void *)key)) )
128 { if ( must_be_non_empty )
129 { RecordRef record;
130
131 PL_LOCK(L_RECORD);
132 record = firstRecordRecordList(rl);
133 PL_UNLOCK(L_RECORD);
134
135 return record ? rl : NULL;
136 } else
137 { return rl;
138 }
139 }
140
141 return NULL;
142 }
143
144
145 static void
remove_record(RecordRef r)146 remove_record(RecordRef r)
147 { RecordList l = r->list;
148
149 if ( r->prev )
150 r->prev->next = r->next;
151 else
152 l->firstRecord = r->next;
153
154 if ( r->next )
155 r->next->prev = r->prev;
156 else
157 l->lastRecord = r->prev;
158
159 freeRecordRef(r);
160 }
161
162 /* MT: Locked by called
163 */
164
165 static void
cleanRecordList(RecordList rl)166 cleanRecordList(RecordList rl)
167 { RecordRef r, next=NULL;
168
169 for(r = rl->firstRecord; r; r = next )
170 { next = r->next;
171
172 if ( true(r->record, R_ERASED) )
173 remove_record(r);
174 }
175 }
176
177
178 /* unallocRecordList() is used when memory is cleaned for PL_cleanup().
179 We set R_NOLOCK to avoid needless update of the atom references in
180 freeRecord().
181 */
182
183 static void
unallocRecordList(RecordList rl)184 unallocRecordList(RecordList rl)
185 { RecordRef r, n;
186
187 for(r = rl->firstRecord; r; r=n)
188 { n = r->next;
189
190 set(r->record, R_NOLOCK);
191 freeRecordRef(r);
192 }
193
194 freeHeap(rl, sizeof(*rl));
195 }
196
197
198 /*******************************
199 * HEAP STORAGE *
200 *******************************/
201
202
203 #undef uint
204 #undef uchar
205 #define uint unsigned int
206 #define uchar unsigned char
207
208 #ifndef offsetof
209 #define offsetof(structure, field) ((int) &(((structure *)NULL)->field))
210 #endif
211
212 #define SIZERECORD(flags) \
213 ((flags & R_DUPLICATE) ? offsetof(struct record, buffer[0]) : \
214 offsetof(struct record, references)) \
215
216 #define dataRecord(r) ((char *)addPointer(r, SIZERECORD(r->flags)))
217
218 typedef enum
219 { ENONE = 0,
220 EFAST_SERIALIZE
221 } cerror;
222
223 typedef struct
224 { tmp_buffer code; /* code buffer */
225 tmp_buffer vars; /* variable pointers */
226 size_t size; /* size on global stack */
227 uint nvars; /* # variables */
228 int external; /* Allow for external storage */
229 int lock; /* lock compiled atoms */
230 cerror error; /* generated error */
231 word econtext[1]; /* error context */
232 } compile_info, *CompileInfo;
233
234 #define PL_TYPE_VARIABLE (1) /* variable */
235 #define PL_TYPE_ATOM (2) /* atom */
236 #define PL_TYPE_INTEGER (3) /* big integer */
237 #define PL_TYPE_TAGGED_INTEGER (4) /* tagged integer */
238 #define PL_TYPE_FLOAT (5) /* double */
239 #define PL_TYPE_STRING (6) /* string */
240 #define PL_TYPE_COMPOUND (7) /* compound term */
241 #define PL_TYPE_CONS (8) /* list-cell */
242 #define PL_TYPE_NIL (9) /* [] */
243 #define PL_TYPE_DICT (10) /* The C'dict' atom */
244
245 #define PL_TYPE_EXT_ATOM (11) /* External (inlined) atom */
246 #define PL_TYPE_EXT_WATOM (12) /* External (inlined) wide atom */
247 #define PL_TYPE_EXT_COMPOUND (13) /* External (inlined) functor */
248 #define PL_TYPE_EXT_FLOAT (14) /* float in standard-byte order */
249 #define PL_TYPE_ATTVAR (15) /* Attributed variable */
250 #define PL_REC_ALLOCVAR (16) /* Allocate a variable on global */
251 #define PL_REC_CYCLE (17) /* cyclic reference */
252 #define PL_REC_MPZ (18) /* GMP integer */
253 #define PL_REC_MPQ (19) /* GMP rational */
254
255 #define PL_TYPE_EXT_COMPOUND_V2 (20) /* Read V2 external records */
256
257 static const int v2_map[] =
258 { 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, /* variable..string */
259 11, 12, PL_TYPE_EXT_COMPOUND_V2, 14, 15, 16, 17, 18
260 };
261
262 static const int *v_maps[8] = /* 3 bits, cannot overflow */
263 { NULL,
264 NULL,
265 v2_map
266 };
267
268
269 static inline void
addUnalignedBuf(TmpBuffer b,void * ptr,size_t bytes)270 addUnalignedBuf(TmpBuffer b, void *ptr, size_t bytes)
271 { if ( b->top + bytes > b->max )
272 { if ( !growBuffer((Buffer)b, bytes) )
273 outOfCore();
274 }
275 memcpy(b->top, ptr, bytes);
276 b->top += bytes;
277 }
278
279 static inline void
addOpCode(CompileInfo info,int code)280 addOpCode(CompileInfo info, int code)
281 { addBuffer(&info->code, code, uchar);
282 DEBUG(9, Sdprintf("Added %d, now %d big\n",
283 code, sizeOfBuffer(&info->code)));
284 }
285
286
287 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
288 addSizeInt() deals with integers that should be large enough to specify
289 the size of an object on the stack. This counts for variables, arities,
290 sizes of strings and atoms, etc.
291
292 Encoding: 7-bits per byte, MSF. All but the last (LSB) have the 8-th bit
293 set. This format allows for arbitrary bit integers and is architecture
294 independent.
295 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
296
297 static inline void
addUintBuffer(Buffer b,size_t val)298 addUintBuffer(Buffer b, size_t val)
299 { if ( !(val & ~0x7f) )
300 { addBuffer(b, (uchar)val, uchar);
301 } else
302 { int zips = ((sizeof(val))*8+7-1)/7 - 1;
303 int leading = TRUE;
304
305 for(; zips >= 0; zips--)
306 { uint d = (uint)((val >> zips*7) & 0x7f);
307
308 if ( d || !leading )
309 { if ( zips != 0 )
310 d |= 0x80;
311 addBuffer(b, d, uchar);
312 leading = FALSE;
313 }
314 }
315 }
316 }
317
318
319 static inline void
addSizeInt(CompileInfo info,size_t val)320 addSizeInt(CompileInfo info, size_t val)
321 { addUintBuffer((Buffer)&info->code, val);
322 }
323
324
325 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
326 Add a signed intptr_t value. First byte is number of bytes, remaining
327 are value-bytes, starting at most-significant. When loading, we restore
328 the bytes in the least significant positions and perform a left and
329 right shift to restore the sign. This means that a positive number must
330 always have a 0 at the left side in the encoding. So, if bit 7 is the
331 MSB, we must store 2 bytes.
332 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
333
334 static void
addInt64(CompileInfo info,int64_t v)335 addInt64(CompileInfo info, int64_t v)
336 { int i;
337
338 if ( v == 0 )
339 { i = 1;
340 } else if ( v == PLMININT )
341 { i = sizeof(v);
342 } else
343 { int64_t a = v > 0 ? v :- v;
344
345 i = (MSB64(a)+9)/8;
346 }
347
348 addBuffer(&info->code, i, uchar);
349
350 while( --i >= 0 )
351 { int b = (int)(v>>(i*8)) & 0xff;
352
353 addBuffer(&info->code, b, uchar);
354 }
355 }
356
357
358 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
359 Floats. If we are adding floats for external use they will be stored in
360 normalised byte-order. Otherwise they are stored verbatim.
361 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
362
363 #ifdef WORDS_BIGENDIAN
364 static const int double_byte_order[] = { 7,6,5,4,3,2,1,0 };
365 #else
366 static const int double_byte_order[] = { 0,1,2,3,4,5,6,7 };
367 #endif
368
369
370 static inline void
addFloat(CompileInfo info,void * val)371 addFloat(CompileInfo info, void *val)
372 { if ( info->external )
373 { unsigned char *cl = val;
374 unsigned int i;
375
376 addOpCode(info, PL_TYPE_EXT_FLOAT);
377 for(i=0; i<sizeof(double); i++)
378 addBuffer(&info->code, cl[double_byte_order[i]], uchar);
379 } else
380 { addOpCode(info, PL_TYPE_FLOAT);
381
382 addUnalignedBuf(&info->code, val, sizeof(double));
383 }
384 }
385
386
387 static inline void
addWord(CompileInfo info,word w)388 addWord(CompileInfo info, word w)
389 { addUnalignedBuf(&info->code, &w, sizeof(word));
390 }
391
392
393 static inline void
addChars(CompileInfo info,size_t len,const char * data)394 addChars(CompileInfo info, size_t len, const char *data)
395 { addSizeInt(info, len);
396
397 addMultipleBuffer(&info->code, data, len, char);
398 }
399
400
401 static inline void
addAtomValue(CompileInfo info,Atom a)402 addAtomValue(CompileInfo info, Atom a)
403 { addSizeInt(info, a->length);
404 addMultipleBuffer(&info->code, a->name, a->length, char);
405 }
406
407
408 static int
addAtom(CompileInfo info,atom_t a)409 addAtom(CompileInfo info, atom_t a)
410 { if ( a == ATOM_nil )
411 { addOpCode(info, PL_TYPE_NIL);
412 } else if ( a == ATOM_dict )
413 { addOpCode(info, PL_TYPE_DICT);
414 } else if ( unlikely(info->external) )
415 { Atom ap = atomValue(a);
416
417 if ( true(ap->type, PL_BLOB_TEXT) )
418 { if ( isUCSAtom(ap) )
419 addOpCode(info, PL_TYPE_EXT_WATOM);
420 else
421 addOpCode(info, PL_TYPE_EXT_ATOM);
422
423 addAtomValue(info, ap);
424 } else
425 { info->error = EFAST_SERIALIZE;
426 info->econtext[0] = a;
427 return FALSE;
428 }
429 } else
430 { addOpCode(info, PL_TYPE_ATOM);
431 addWord(info, a);
432 if ( info->lock )
433 PL_register_atom(a);
434 }
435
436 return TRUE;
437 }
438
439
440 static int
addFunctor(CompileInfo info,functor_t f)441 addFunctor(CompileInfo info, functor_t f)
442 { if ( f == FUNCTOR_dot2 )
443 { addOpCode(info, PL_TYPE_CONS);
444 } else
445 { if ( info->external )
446 { FunctorDef fd = valueFunctor(f);
447
448 addOpCode(info, PL_TYPE_EXT_COMPOUND);
449 addSizeInt(info, fd->arity);
450 return addAtom(info, fd->name);
451 } else
452 { addOpCode(info, PL_TYPE_COMPOUND);
453 addWord(info, f);
454 }
455 }
456
457 return TRUE;
458 }
459
460
461 typedef struct
462 { Functor term;
463 functor_t fdef;
464 } cycle_mark;
465
466
467 #define mkAttVarP(p) ((Word)((word)(p) | 0x1L))
468 #define isAttVarP(p) ((word)(p) & 0x1)
469 #define valAttVarP(p) ((Word)((word)(p) & ~0x1L))
470
471 static int
compile_term_to_heap(term_agenda * agenda,CompileInfo info ARG_LD)472 compile_term_to_heap(term_agenda *agenda, CompileInfo info ARG_LD)
473 { Word p;
474
475 while( (p=nextTermAgenda(agenda)) )
476 { word w;
477
478 again:
479 w = *p;
480
481 switch(tag(w))
482 { case TAG_VAR:
483 { intptr_t n = info->nvars++;
484
485 *p = (n<<7)|TAG_ATOM|STG_GLOBAL;
486 addBuffer(&info->vars, p, Word);
487 addOpCode(info, PL_TYPE_VARIABLE);
488 addSizeInt(info, n);
489
490 continue;
491 }
492 #if O_ATTVAR
493 case TAG_ATTVAR:
494 { intptr_t n = info->nvars++;
495 Word ap = valPAttVar(w);
496
497 if ( isEmptyBuffer(&info->code) )
498 { addOpCode(info, PL_REC_ALLOCVAR); /* only an attributed var */
499 info->size++;
500 }
501
502 addBuffer(&info->vars, *p, word); /* save value */
503 *p = (n<<7)|TAG_ATOM|STG_GLOBAL;
504 addBuffer(&info->vars, mkAttVarP(p), Word);
505 addOpCode(info, PL_TYPE_ATTVAR);
506 addSizeInt(info, n);
507 info->size += 3;
508 DEBUG(MSG_REC_ATTVAR, Sdprintf("Added attvar %d\n", n));
509
510 p = ap;
511 deRef(p);
512 goto again;
513 }
514 #endif
515 case TAG_ATOM:
516 { if ( storage(w) == STG_GLOBAL ) /* this is a variable */
517 { intptr_t n = ((intptr_t)(w) >> 7);
518
519 addOpCode(info, PL_TYPE_VARIABLE);
520 addSizeInt(info, n);
521 DEBUG(9, Sdprintf("Added var-link %d\n", n));
522 } else
523 { if ( !addAtom(info, w) )
524 return FALSE;
525 DEBUG(9, Sdprintf("Added '%s'\n", stringAtom(w)));
526 }
527
528 continue;
529 }
530 case TAG_INTEGER:
531 { int64_t val;
532
533 if ( isTaggedInt(w) )
534 { val = valInt(w);
535 addOpCode(info, PL_TYPE_TAGGED_INTEGER);
536 addInt64(info, val);
537 } else
538 { number n;
539
540 info->size += wsizeofIndirect(w) + 2;
541
542 get_rational(w, &n);
543 switch(n.type)
544 { case V_INTEGER:
545 addOpCode(info, PL_TYPE_INTEGER);
546 addInt64(info, n.value.i);
547 break;
548 #ifdef O_GMP
549 case V_MPZ:
550 addOpCode(info, PL_REC_MPZ);
551 addMPZToBuffer((Buffer)&info->code, n.value.mpz);
552 break;
553 case V_MPQ:
554 addOpCode(info, PL_REC_MPQ);
555 addMPQToBuffer((Buffer)&info->code, n.value.mpq);
556 break;
557 #endif
558 default:
559 assert(0);
560 }
561 }
562
563 continue;
564 }
565 case TAG_STRING:
566 { Word f = addressIndirect(w);
567 size_t n = wsizeofInd(*f);
568 size_t pad = padHdr(*f); /* see also getCharsString() */
569 size_t l = n*sizeof(word)-pad;
570
571 info->size += n+2;
572 addOpCode(info, PL_TYPE_STRING);
573 addChars(info, l, (const char *)(f+1)); /* +1 to skip header */
574
575 continue;
576 }
577 case TAG_FLOAT:
578 { info->size += WORDS_PER_DOUBLE + 2;
579 addFloat(info, valIndirectP(w));
580
581 continue;
582 }
583 case TAG_COMPOUND:
584 { Functor f = valueTerm(w);
585 int arity;
586 word functor;
587
588 #if O_CYCLIC
589 if ( isInteger(f->definition) )
590 { addOpCode(info, PL_REC_CYCLE);
591 addSizeInt(info, valInt(f->definition));
592
593 DEBUG(1, Sdprintf("Added cycle for offset = %d\n",
594 valInt(f->definition)));
595
596 continue;
597 } else
598 { cycle_mark mark;
599
600 arity = arityFunctor(f->definition);
601 functor = f->definition;
602
603 mark.term = f;
604 mark.fdef = f->definition;
605 if ( !pushSegStack(&LD->cycle.lstack, mark, cycle_mark) )
606 return FALSE;
607 f->definition = (functor_t)consUInt(info->size);
608 /* overflow test (should not be possible) */
609 DEBUG(CHK_SECURE, assert(valUInt(f->definition) == (uintptr_t)info->size));
610 }
611 #endif
612
613 info->size += arity+1;
614 if ( !addFunctor(info, functor) )
615 return FALSE;
616 DEBUG(9, if ( GD->io_initialised )
617 Sdprintf("Added %s/%d\n",
618 stringAtom(valueFunctor(functor)->name),
619 arityFunctor(functor)));
620 if ( !pushWorkAgenda(agenda, arity, f->arguments) )
621 return FALSE;
622 continue;
623 }
624 default:
625 assert(0);
626 }
627 }
628
629 return TRUE;
630 }
631
632
633 #if O_CYCLIC
634
635 static void
init_cycle(ARG1_LD)636 init_cycle(ARG1_LD)
637 { LD->cycle.lstack.unit_size = sizeof(cycle_mark);
638 }
639
640
641 static void
unvisit(ARG1_LD)642 unvisit(ARG1_LD)
643 { cycle_mark mark;
644
645 while( popSegStack(&LD->cycle.lstack, &mark, cycle_mark) )
646 { mark.term->definition = mark.fdef;
647 }
648 }
649
650 #else
651
init_cycle(ARG1_LD)652 static void init_cycle(ARG1_LD) {}
unvisit(ARG1_LD)653 static void unvisit(ARG1_LD) {}
654
655 #endif
656
657 static void
restoreVars(compile_info * info)658 restoreVars(compile_info *info)
659 { Word *p = topBuffer(&info->vars, Word);
660 Word *b = baseBuffer(&info->vars, Word);
661
662 while(p > b)
663 { p--;
664 if (isAttVarP(*p) )
665 { *valAttVarP(*p) = (word)p[-1];
666 p--;
667 } else
668 setVar(**p);
669 }
670 discardBuffer(&info->vars);
671 }
672
673
674 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
675 compileTermToHeap__LD() is the core of the recorded database.
676
677 Returns NULL if there is insufficient memory. Otherwise the result of
678 the allocation function. The default allocation function is
679 PL_malloc_atomic_unmanaged().
680 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
681
682 Record
compileTermToHeap__LD(term_t t,void * (* allocate)(void * closure,size_t size),void * closure,int flags ARG_LD)683 compileTermToHeap__LD(term_t t,
684 void* (*allocate)(void *closure, size_t size),
685 void* closure,
686 int flags ARG_LD)
687 { compile_info info;
688 Record record;
689 size_t size;
690 size_t rsize = SIZERECORD(flags);
691 term_agenda agenda;
692 int rc;
693
694 DEBUG(CHK_SECURE, checkData(valTermRef(t)));
695
696 init_cycle(PASS_LD1);
697 initBuffer(&info.code);
698 initBuffer(&info.vars);
699 info.size = 0;
700 info.nvars = 0;
701 info.external = (flags & R_EXTERNAL);
702 info.lock = !(info.external || (flags&R_NOLOCK));
703
704 initTermAgenda(&agenda, 1, valTermRef(t));
705 rc = compile_term_to_heap(&agenda, &info PASS_LD);
706 clearTermAgenda(&agenda);
707 restoreVars(&info);
708 unvisit(PASS_LD1);
709
710 if ( rc )
711 { size = rsize + sizeOfBuffer(&info.code);
712 if ( allocate )
713 record = (*allocate)(closure, size);
714 else
715 record = PL_malloc_atomic_unmanaged(size);
716
717 if ( record )
718 {
719 #ifdef REC_MAGIC
720 record->magic = REC_MAGIC;
721 #endif
722 record->gsize = (unsigned int)info.size; /* only 28-bit */
723 record->nvars = info.nvars;
724 record->size = (int)size;
725 record->flags = flags;
726 if ( flags & R_DUPLICATE )
727 { record->references = 1;
728 }
729 memcpy(addPointer(record, rsize), info.code.base, sizeOfBuffer(&info.code));
730 }
731 } else
732 { record = NULL;
733 }
734 discardBuffer(&info.code);
735
736 DEBUG(3, Sdprintf("--> record at %p\n", record));
737
738 return record;
739 }
740
741
742 int
variantRecords(const Record r1,const Record r2)743 variantRecords(const Record r1, const Record r2)
744 { return ( r1->size == r2->size &&
745 memcpy(r1, r2, r1->size) == 0
746 );
747 }
748
749
750 /*******************************
751 * EXTERNAL RECORDS *
752 *******************************/
753
754 #define REC_32 0x01 /* word is 32-bits */
755 #define REC_64 0x02 /* word is 64-bits */
756 #define REC_INT 0x04 /* Record just contains int */
757 #define REC_ATOM 0x08 /* Record just contains atom */
758 #define REC_GROUND 0x10 /* Record is ground */
759 #define REC_VMASK 0xe0 /* Version mask */
760 #define REC_VSHIFT 5 /* shift for version mask */
761
762 #define REC_SZMASK (REC_32|REC_64) /* SIZE_MASK */
763
764 #if SIZEOF_VOIDP == 8
765 #define REC_SZ REC_64
766 #else
767 #define REC_SZ REC_32
768 #endif
769
770 #define REC_HDR (REC_SZ|(PL_REC_VERSION<<REC_VSHIFT))
771 #define REC_COMPAT(m) (((m)&(REC_VMASK|REC_SZMASK)) == REC_HDR)
772
773 typedef struct record_data
774 { int simple; /* no header */
775 compile_info info;
776 tmp_buffer hdr;
777 } record_data;
778
779
780 static void
discard_record_data(record_data * data)781 discard_record_data(record_data *data)
782 { discardBuffer(&data->info.code);
783 if ( !data->simple )
784 discardBuffer(&data->hdr);
785 }
786
787 static int
rec_error(CompileInfo info)788 rec_error(CompileInfo info)
789 { switch(info->error)
790 { case EFAST_SERIALIZE:
791 { GET_LD
792 term_t t;
793
794 return ( (t=PL_new_term_ref()) &&
795 PL_put_atom(t, info->econtext[0]) &&
796 PL_permission_error("fast_serialize", "blob", t) );
797 }
798 default:
799 assert(0);
800 return FALSE;
801 }
802 }
803
804
805 static int
compile_external_record(term_t t,record_data * data ARG_LD)806 compile_external_record(term_t t, record_data *data ARG_LD)
807 { Word p;
808 int first = REC_HDR;
809 term_agenda agenda;
810 int scode, rc;
811
812 DEBUG(CHK_SECURE, checkData(valTermRef(t)));
813 p = valTermRef(t);
814 deRef(p);
815
816 init_cycle(PASS_LD1);
817 initBuffer(&data->info.code);
818 data->info.external = TRUE;
819 data->info.lock = FALSE;
820
821 if ( isInteger(*p) ) /* integer-only record */
822 { int64_t v;
823
824 if ( isTaggedInt(*p) )
825 v = valInt(*p);
826 else if ( isBignum(*p) )
827 v = valBignum(*p);
828 else
829 goto general;
830
831 first |= (REC_INT|REC_GROUND);
832 addOpCode(&data->info, first);
833 addInt64(&data->info, v);
834 data->simple = TRUE;
835
836 return TRUE;
837 } else if ( isAtom(*p) ) /* atom-only record */
838 { first |= (REC_ATOM|REC_GROUND);
839 addOpCode(&data->info, first);
840 if ( !addAtom(&data->info, *p) )
841 return FALSE;
842 data->simple = TRUE;
843
844 return TRUE;
845 }
846
847 /* the real stuff */
848 general:
849 data->simple = FALSE;
850 initBuffer(&data->info.vars);
851 data->info.size = 0;
852 data->info.nvars = 0;
853
854 initTermAgenda(&agenda, 1, p);
855 rc = compile_term_to_heap(&agenda, &data->info PASS_LD);
856 clearTermAgenda(&agenda);
857 if ( data->info.nvars == 0 )
858 first |= REC_GROUND;
859 restoreVars(&data->info);
860 unvisit(PASS_LD1);
861 if ( !rc )
862 return rec_error(&data->info);
863 scode = (int)sizeOfBuffer(&data->info.code);
864
865 initBuffer(&data->hdr);
866 addBuffer(&data->hdr, first, uchar); /* magic code */
867 addUintBuffer((Buffer)&data->hdr, scode); /* code size */
868 addUintBuffer((Buffer)&data->hdr, data->info.size); /* size on stack */
869 if ( data->info.nvars > 0 )
870 addUintBuffer((Buffer)&data->hdr, data->info.nvars);/* Number of variables */
871 return TRUE;
872 }
873
874
875 char *
PL_record_external(term_t t,size_t * len)876 PL_record_external(term_t t, size_t *len)
877 { GET_LD
878 record_data data;
879
880 if ( compile_external_record(t, &data PASS_LD) )
881 { if ( data.simple )
882 { int scode = (int)sizeOfBuffer(&data.info.code);
883 char *rec = malloc(scode);
884
885 if ( rec )
886 { memcpy(rec, data.info.code.base, scode);
887 discard_record_data(&data);
888 *len = scode;
889
890 return rec;
891 } else
892 { discard_record_data(&data);
893 PL_no_memory();
894
895 return NULL;
896 }
897 } else
898 { int shdr = (int)sizeOfBuffer(&data.hdr);
899 int scode = (int)sizeOfBuffer(&data.info.code);
900 char *rec = malloc(shdr + scode);
901
902 if ( rec )
903 { memcpy(rec, data.hdr.base, shdr);
904 memcpy(rec+shdr, data.info.code.base, scode);
905 discard_record_data(&data);
906 *len = shdr + scode;
907
908 return rec;
909 } else
910 { discard_record_data(&data);
911 PL_no_memory();
912
913 return NULL;
914 }
915 }
916 } else
917 { return NULL;
918 }
919 }
920
921
922 /*******************************
923 * FASTRW *
924 *******************************/
925
926 static
927 PRED_IMPL("fast_term_serialized", 2, fast_term_serialized, 0)
928 { PRED_LD
929 char *rec;
930 size_t len;
931
932 term_t term = A1;
933 term_t string = A2;
934
935 if ( PL_is_variable(string) )
936 { record_data data;
937
938 if ( compile_external_record(term, &data PASS_LD) )
939 { if ( data.simple )
940 { int rc;
941
942 len = sizeOfBuffer(&data.info.code);
943 rc = PL_unify_string_nchars(string, len, data.info.code.base);
944 discard_record_data(&data);
945
946 return rc;
947 } else
948 { size_t shdr = sizeOfBuffer(&data.hdr);
949 size_t scode = sizeOfBuffer(&data.info.code);
950 Word p;
951
952 if ( (p=allocString(shdr+scode+1 PASS_LD)) )
953 { char *q = (char *)&p[1];
954 word w = consPtr(p, TAG_STRING|STG_GLOBAL);
955
956 *q++ = 'B';
957 memcpy(q, data.hdr.base, shdr);
958 memcpy(q+shdr, data.info.code.base, scode);
959
960 return _PL_unify_atomic(string, w);
961 } else
962 { discard_record_data(&data);
963 return FALSE;
964 }
965 }
966 } else
967 { return FALSE;
968 }
969 } else if ( PL_get_nchars(string, &len, &rec,
970 CVT_STRING|BUF_STACK|REP_ISO_LATIN_1|CVT_EXCEPTION) )
971 { term_t tmp;
972
973 return ( (tmp = PL_new_term_ref()) &&
974 is_external(rec, len) &&
975 PL_recorded_external(rec, tmp) &&
976 PL_unify(term, tmp) );
977 } else
978 { return FALSE;
979 }
980 }
981
982 /** fast_write(+Stream, +Term)
983 */
984
985 static
986 PRED_IMPL("fast_write", 2, fast_write, 0)
987 { PRED_LD
988 IOSTREAM *out;
989
990 if ( PL_get_stream(A1, &out, SIO_OUTPUT) )
991 { record_data data;
992 int rc;
993
994 if ( out->encoding == ENC_OCTET )
995 { if ( (rc=compile_external_record(A2, &data PASS_LD)) )
996 { if ( data.simple )
997 { size_t len = sizeOfBuffer(&data.info.code);
998
999 rc = (Sfwrite(data.info.code.base, 1, len, out) == len);
1000 } else
1001 { size_t shdr = sizeOfBuffer(&data.hdr);
1002 size_t scode = sizeOfBuffer(&data.info.code);
1003
1004 rc = ( Sfwrite(data.hdr.base, 1, shdr, out) == shdr &&
1005 Sfwrite(data.info.code.base, 1, scode, out) == scode
1006 );
1007 }
1008
1009 discard_record_data(&data);
1010 }
1011 } else
1012 { rc = PL_permission_error("fast_write", "stream", A1);
1013 }
1014
1015 return PL_release_stream(out) && rc;
1016 }
1017
1018 return FALSE;
1019 }
1020
1021
1022 #define FASTRW_FAST 512
1023
1024 static char *
readSizeInt(IOSTREAM * in,char * to,size_t * sz)1025 readSizeInt(IOSTREAM *in, char *to, size_t *sz)
1026 { size_t r = 0;
1027 int d;
1028 char *t = to;
1029
1030 do
1031 { d = Sgetc(in);
1032
1033 if ( d == -1 )
1034 { PL_syntax_error("fastrw_size", in);
1035 return NULL;
1036 }
1037
1038 *t++ = d;
1039 if ( t-to > 10 )
1040 return NULL;
1041 r = (r<<7)|(d&0x7f);
1042 } while((d & 0x80));
1043
1044 *sz = r;
1045
1046 return t;
1047 }
1048
1049 static char *
realloc_record(char * rec,char ** np,size_t size)1050 realloc_record(char *rec, char **np, size_t size)
1051 { size_t hdr = *np-rec;
1052 size_t tsize = hdr + size;
1053 char *nrec;
1054
1055 if ( tsize <= FASTRW_FAST )
1056 { return rec;
1057 } else if ( (nrec = malloc(tsize)) )
1058 { memcpy(nrec, rec, hdr);
1059 *np = nrec+hdr;
1060
1061 return nrec;
1062 } else
1063 { PL_no_memory();
1064 return NULL;
1065 }
1066 }
1067
1068
1069 static
1070 PRED_IMPL("fast_read", 2, fast_read, 0)
1071 { PRED_LD
1072 IOSTREAM *in;
1073
1074 if ( PL_get_stream(A1, &in, SIO_INPUT) )
1075 { int rc;
1076
1077 if ( in->encoding == ENC_OCTET )
1078 { int m = Sgetc(in);
1079 char fast[FASTRW_FAST];
1080 char *rec = fast;
1081
1082 switch(m)
1083 { case -1:
1084 rc = PL_unify_atom(A2, ATOM_end_of_file);
1085 goto out;
1086 case REC_HDR|REC_INT|REC_GROUND:
1087 { int size = Sgetc(in)&0xff;
1088
1089 if ( size <= 8 )
1090 { rec[0] = m;
1091 rec[1] = size;
1092 if ( Sfread(&rec[2], 1, size, in) != size )
1093 rc = PL_syntax_error("fastrw_integer", in);
1094 else
1095 rc = TRUE;
1096 } else
1097 { rc = PL_syntax_error("fastrw_integer", in);
1098 }
1099 break;
1100 }
1101 case REC_HDR|REC_ATOM|REC_GROUND:
1102 { uchar op = Sgetc(in);
1103
1104 switch(op)
1105 { case PL_TYPE_NIL:
1106 rc = PL_unify_nil(A2);
1107 goto out;
1108 case PL_TYPE_DICT:
1109 rc = PL_unify_atom(A2, ATOM_dict);
1110 goto out;
1111 case PL_TYPE_EXT_WATOM:
1112 case PL_TYPE_EXT_ATOM:
1113 { size_t bytes;
1114 char *np;
1115
1116 rec[0] = m;
1117 rec[1] = op;
1118
1119 if ( (np=readSizeInt(in, &rec[2], &bytes)) &&
1120 (rec = realloc_record(rec, &np, bytes)) &&
1121 Sfread(np, 1, bytes, in) == bytes )
1122 rc = TRUE;
1123 else
1124 rc = PL_syntax_error("fastrw_atom", in);
1125 break;
1126 }
1127 default:
1128 rc = PL_syntax_error("fastrw_atom_type", in);
1129 }
1130 break;
1131 }
1132 case REC_HDR|REC_GROUND:
1133 case REC_HDR:
1134 { char *np;
1135 size_t codes, gsize, nvars;
1136
1137 rec[0] = m;
1138
1139 if ( (np=readSizeInt(in, &rec[1], &codes)) &&
1140 (np=readSizeInt(in, np, &gsize)) &&
1141 ((m&REC_GROUND) || (np=readSizeInt(in, np, &nvars))) &&
1142 (rec = realloc_record(rec, &np, codes)) &&
1143 Sfread(np, 1, codes, in) == codes )
1144 rc = TRUE;
1145 else
1146 rc = PL_syntax_error("fastrw_term", in);
1147 break;
1148 }
1149 default:
1150 rc = PL_syntax_error("fastrw_magic_expected", in);
1151 }
1152
1153 if ( rc )
1154 { term_t tmp;
1155
1156 rc = ( (tmp = PL_new_term_ref()) &&
1157 PL_recorded_external(rec, tmp) &&
1158 PL_unify(A2, tmp) );
1159 }
1160
1161 if ( rec != fast )
1162 free(rec);
1163 } else
1164 { rc = PL_permission_error("fast_read", "stream", A1);
1165 }
1166
1167 out:
1168 return PL_release_stream(in) && rc;
1169 }
1170
1171 return FALSE;
1172 }
1173
1174
1175 /*******************************
1176 * HEAP --> STACK *
1177 *******************************/
1178
1179 #define MAX_FAST_VARS 100
1180
1181 typedef struct
1182 { const char *data;
1183 const char *base; /* start of data */
1184 const int *version_map; /* translate op-codes */
1185 Word *vars;
1186 Word gbase; /* base of term on global stack */
1187 Word gstore; /* current storage location */
1188 uint nvars; /* Variables seen */
1189 uint dicts; /* # dicts found */
1190 TmpBuffer avars; /* Values stored for attvars */
1191 Word vars_buf[MAX_FAST_VARS];
1192 } copy_info, *CopyInfo;
1193
1194 static void skipSizeInt(CopyInfo b);
1195
1196 static inline int
init_copy_vars(copy_info * info,uint n)1197 init_copy_vars(copy_info *info, uint n)
1198 { if ( n > 0 )
1199 { Word *p;
1200
1201 if ( n <= MAX_FAST_VARS )
1202 info->vars = info->vars_buf;
1203 else if ( (info->vars = malloc(sizeof(Word)*n)) == NULL )
1204 return MEMORY_OVERFLOW;
1205
1206 for(p = info->vars; n-- > 0;)
1207 *p++ = NULL;
1208 } else
1209 { info->vars = NULL;
1210 }
1211
1212 return TRUE;
1213 }
1214
1215 static inline void
free_copy_vars(const copy_info * info)1216 free_copy_vars(const copy_info *info)
1217 { if ( info->vars != info->vars_buf )
1218 free(info->vars);
1219 }
1220
1221
1222 #define fetchBuf(b, var, type) \
1223 do \
1224 { memcpy(var, (b)->data, sizeof(type)); \
1225 (b)->data += sizeof(type); \
1226 } while(0)
1227 #define fetchMultipleBuf(b, var, times, type) \
1228 do \
1229 { memcpy(var, (b)->data, times*sizeof(type)); \
1230 (b)->data += times*sizeof(type); \
1231 } while(0)
1232 #define skipBuf(b, type) \
1233 ((b)->data += sizeof(type))
1234
1235
1236 static inline int
fetchOpCode(CopyInfo b)1237 fetchOpCode(CopyInfo b)
1238 { uchar tag;
1239
1240 fetchBuf(b, &tag, uchar);
1241 DEBUG(9, Sdprintf("fetchOpCode() --> %d, (at %d)\n",
1242 tag, b->data-b->base));
1243 return likely(b->version_map==NULL) ? tag : b->version_map[tag];
1244 }
1245
1246
1247 static size_t
fetchSizeInt(CopyInfo b)1248 fetchSizeInt(CopyInfo b)
1249 { size_t r = 0;
1250 size_t d;
1251
1252 do
1253 { d = *b->data++;
1254
1255 r = (r<<7)|(d&0x7f);
1256 } while((d & 0x80));
1257
1258 return r;
1259 }
1260
1261
1262 static int64_t
fetchInt64(CopyInfo b)1263 fetchInt64(CopyInfo b)
1264 { uint64_t val = 0;
1265 uint bytes = *b->data++;
1266 uint64_t sign = 1ULL << (bytes * 8 - 1);
1267
1268 while(bytes-- > 0)
1269 val = (val << 8) | (*b->data++ & 0xff);
1270
1271 return (int64_t)((val ^ sign) - sign);
1272 }
1273
1274
1275 static word
fetchWord(CopyInfo b)1276 fetchWord(CopyInfo b)
1277 { word val;
1278
1279 fetchBuf(b, &val, word);
1280
1281 return val;
1282 }
1283
1284
1285 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1286 Fetch a float. Note that the destination might not be double-aligned!
1287 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1288
1289 static void
fetchFloat(CopyInfo b,void * f)1290 fetchFloat(CopyInfo b, void *f)
1291 { fetchBuf(b, f, double);
1292 }
1293
1294
1295 static void
fetchExtFloat(CopyInfo b,void * f)1296 fetchExtFloat(CopyInfo b, void *f)
1297 { unsigned char *dst = f;
1298 unsigned int i;
1299
1300 for(i=0; i<sizeof(double); i++)
1301 dst[double_byte_order[i]] = *b->data++;
1302 }
1303
1304
1305 static void
fetchAtom(CopyInfo b,atom_t * a)1306 fetchAtom(CopyInfo b, atom_t *a)
1307 { unsigned int len = fetchSizeInt(b);
1308
1309 *a = lookupAtom(b->data, len);
1310
1311 (b)->data += len;
1312 }
1313
1314
1315 static void
fetchAtomW(CopyInfo b,atom_t * a)1316 fetchAtomW(CopyInfo b, atom_t *a)
1317 { unsigned int len = fetchSizeInt(b);
1318
1319 *a = lookupUCSAtom((const pl_wchar_t*)b->data, len/sizeof(pl_wchar_t));
1320
1321 (b)->data += len;
1322 }
1323
1324
1325 static void
fetchChars(CopyInfo b,unsigned len,Word to)1326 fetchChars(CopyInfo b, unsigned len, Word to)
1327 { fetchMultipleBuf(b, (char *)to, len, char);
1328 }
1329
1330
1331 static int
copy_record(Word p,CopyInfo b ARG_LD)1332 copy_record(Word p, CopyInfo b ARG_LD)
1333 { term_agenda agenda;
1334 int is_compound = FALSE;
1335 int tag;
1336
1337 do
1338 {
1339 right_recursion:
1340 switch( (tag = fetchOpCode(b)) )
1341 { case PL_TYPE_VARIABLE:
1342 { intptr_t n = fetchSizeInt(b);
1343
1344 if ( b->vars[n] )
1345 { if ( p > b->vars[n] ) /* ensure the reference is in the */
1346 *p = makeRef(b->vars[n]); /* right direction! */
1347 else
1348 { *p = *b->vars[n]; /* wrong way. make sure b->vars[n] */
1349 *b->vars[n] = makeRef(p); /* stays at the real variable */
1350 b->vars[n] = p; /* NOTE: also links attvars! */
1351 }
1352 } else
1353 { setVar(*p);
1354 b->vars[n] = p;
1355 }
1356
1357 continue;
1358 }
1359 case PL_REC_ALLOCVAR:
1360 { setVar(*b->gstore);
1361 *p = makeRefG(b->gstore);
1362 p = b->gstore++;
1363 goto right_recursion;
1364 }
1365 #if O_ATTVAR
1366 case PL_TYPE_ATTVAR:
1367 { intptr_t n = fetchSizeInt(b);
1368
1369 DEBUG(MSG_REC_ATTVAR,
1370 Sdprintf("Restore attvar %ld at %p\n", (long)n, &b->gstore[1]));
1371 register_attvar(b->gstore PASS_LD);
1372 b->gstore[1] = consPtr(&b->gstore[2], TAG_ATTVAR|STG_GLOBAL);
1373 *p = makeRefG(&b->gstore[1]);
1374 b->vars[n] = p;
1375 p = &b->gstore[2];
1376 b->gstore += 3;
1377 goto right_recursion;
1378 }
1379 #endif
1380 case PL_TYPE_NIL:
1381 { *p = ATOM_nil;
1382 continue;
1383 }
1384 case PL_TYPE_DICT:
1385 { *p = ATOM_dict;
1386 continue;
1387 }
1388 case PL_TYPE_ATOM:
1389 { *p = fetchWord(b);
1390 continue;
1391 }
1392 case PL_TYPE_EXT_ATOM:
1393 { fetchAtom(b, p);
1394 PL_unregister_atom(*p);
1395 continue;
1396 }
1397 case PL_TYPE_EXT_WATOM:
1398 { fetchAtomW(b, p);
1399 PL_unregister_atom(*p);
1400 continue;
1401 }
1402 case PL_TYPE_TAGGED_INTEGER:
1403 { int64_t val = fetchInt64(b);
1404 *p = consInt(val);
1405 continue;
1406 }
1407 case PL_TYPE_INTEGER:
1408 { size_t i;
1409 union
1410 { int64_t i64;
1411 word w[WORDS_PER_PLINT];
1412 } val;
1413
1414 val.i64 = fetchInt64(b);
1415
1416 *p = consPtr(b->gstore, TAG_INTEGER|STG_GLOBAL);
1417 *b->gstore++ = mkIndHdr(WORDS_PER_PLINT, TAG_INTEGER);
1418 for(i=0; i<WORDS_PER_PLINT; i++)
1419 *b->gstore++ = val.w[i];
1420 *b->gstore++ = mkIndHdr(WORDS_PER_PLINT, TAG_INTEGER);
1421 continue;
1422 }
1423 #ifdef O_GMP
1424 case PL_REC_MPZ:
1425 b->data = loadMPZFromCharp(b->data, p, &b->gstore);
1426 continue;
1427 case PL_REC_MPQ:
1428 b->data = loadMPQFromCharp(b->data, p, &b->gstore);
1429 continue;
1430 #endif
1431 case PL_TYPE_FLOAT:
1432 case PL_TYPE_EXT_FLOAT:
1433 { *p = consPtr(b->gstore, TAG_FLOAT|STG_GLOBAL);
1434 *b->gstore++ = mkIndHdr(WORDS_PER_DOUBLE, TAG_FLOAT);
1435 if ( tag == PL_TYPE_FLOAT )
1436 fetchFloat(b, b->gstore);
1437 else
1438 fetchExtFloat(b, b->gstore);
1439 b->gstore += WORDS_PER_DOUBLE;
1440 *b->gstore++ = mkIndHdr(WORDS_PER_DOUBLE, TAG_FLOAT);
1441 continue;
1442 }
1443 case PL_TYPE_STRING:
1444 { size_t lw, len = fetchSizeInt(b);
1445 int pad;
1446 word hdr;
1447
1448 lw = (len+sizeof(word))/sizeof(word); /* see globalNString() */
1449 pad = (lw*sizeof(word) - len);
1450 *p = consPtr(b->gstore, TAG_STRING|STG_GLOBAL);
1451 *b->gstore++ = hdr = mkStrHdr(lw, pad);
1452 b->gstore[lw-1] = 0L; /* zero-padding */
1453 fetchChars(b, len, b->gstore);
1454 b->gstore += lw;
1455 *b->gstore++ = hdr;
1456 continue;
1457 }
1458 #ifdef O_CYCLIC
1459 case PL_REC_CYCLE:
1460 { unsigned offset = fetchSizeInt(b);
1461 Word ct = b->gbase+offset;
1462
1463 *p = consPtr(ct, TAG_COMPOUND|STG_GLOBAL);
1464 continue;
1465 }
1466 #endif
1467 { word fdef;
1468 int arity;
1469 case PL_TYPE_COMPOUND:
1470
1471 fdef = fetchWord(b);
1472 arity = arityFunctor(fdef);
1473
1474 compound:
1475 *p = consPtr(b->gstore, TAG_COMPOUND|STG_GLOBAL);
1476 *b->gstore++ = fdef;
1477 p = b->gstore;
1478 b->gstore += arity;
1479 if ( !is_compound )
1480 { is_compound = TRUE;
1481 initTermAgenda(&agenda, arity, p);
1482 } else
1483 { if ( !pushWorkAgenda(&agenda, arity, p) )
1484 return MEMORY_OVERFLOW;
1485 }
1486 continue;
1487 case PL_TYPE_EXT_COMPOUND:
1488 { atom_t name;
1489 int opcode_atom;
1490
1491 arity = (int)fetchSizeInt(b);
1492 opcode_atom = fetchOpCode(b);
1493 switch(opcode_atom)
1494 { case PL_TYPE_EXT_ATOM:
1495 fetchAtom(b, &name);
1496 break;
1497 case PL_TYPE_EXT_WATOM:
1498 fetchAtomW(b, &name);
1499 break;
1500 case PL_TYPE_NIL:
1501 name = ATOM_nil;
1502 break;
1503 case PL_TYPE_DICT:
1504 b->dicts++;
1505 name = ATOM_dict;
1506 break;
1507 default:
1508 name = 0;
1509 assert(0);
1510 }
1511
1512 fdef = lookupFunctorDef(name, arity);
1513 goto compound;
1514 }
1515 case PL_TYPE_EXT_COMPOUND_V2:
1516 { atom_t name;
1517
1518 arity = (int)fetchSizeInt(b);
1519 fetchAtom(b, &name);
1520 fdef = lookupFunctorDef(name, arity);
1521 goto compound;
1522 }
1523 }
1524 case PL_TYPE_CONS:
1525 { *p = consPtr(b->gstore, TAG_COMPOUND|STG_GLOBAL);
1526 *b->gstore++ = FUNCTOR_dot2;
1527 p = b->gstore;
1528 b->gstore += 2;
1529 if ( !is_compound )
1530 { is_compound = TRUE;
1531 initTermAgenda(&agenda, 2, p);
1532 } else
1533 { if ( !pushWorkAgenda(&agenda, 2, p) )
1534 return MEMORY_OVERFLOW;
1535 }
1536 continue;
1537 }
1538 default:
1539 assert(0);
1540 }
1541 } while ( is_compound && (p=nextTermAgendaNoDeRef(&agenda)) );
1542
1543 return TRUE;
1544 }
1545
1546
1547 int
copyRecordToGlobal(term_t copy,Record r,int flags ARG_LD)1548 copyRecordToGlobal(term_t copy, Record r, int flags ARG_LD)
1549 { copy_info b;
1550 int rc;
1551
1552 DEBUG(3, Sdprintf("PL_recorded(%p)\n", r));
1553
1554 #ifdef REC_MAGIC
1555 assert(r->magic == REC_MAGIC);
1556 #endif
1557 if ( !hasGlobalSpace(r->gsize) )
1558 { if ( (rc=ensureGlobalSpace(r->gsize, flags)) != TRUE )
1559 return rc;
1560 }
1561 b.base = b.data = dataRecord(r);
1562 b.gbase = b.gstore = gTop;
1563 b.version_map = NULL;
1564
1565 if ( (rc=init_copy_vars(&b, r->nvars)) == TRUE )
1566 { gTop += r->gsize;
1567 rc = copy_record(valTermRef(copy), &b PASS_LD);
1568 free_copy_vars(&b);
1569 }
1570 if ( rc != TRUE )
1571 return rc;
1572
1573 assert(b.gstore == gTop);
1574 DEBUG(CHK_SECURE, checkData(valTermRef(copy)));
1575
1576 return TRUE;
1577 }
1578
1579
1580 static int
is_external(const char * rec,size_t len)1581 is_external(const char *rec, size_t len)
1582 { if ( len >= 2 )
1583 { copy_info info;
1584 uchar m;
1585
1586 info.data = info.base = rec;
1587 fetchBuf(&info, &m, uchar);
1588
1589 switch(m)
1590 { case REC_HDR|REC_INT|REC_GROUND:
1591 { uint bytes = *info.data++;
1592 return len == bytes+2;
1593 }
1594 case REC_HDR|REC_ATOM|REC_GROUND:
1595 { uchar code;
1596
1597 fetchBuf(&info, &code, uchar);
1598 switch(code)
1599 { case PL_TYPE_NIL:
1600 case PL_TYPE_DICT:
1601 return len == 2;
1602 case PL_TYPE_EXT_WATOM:
1603 case PL_TYPE_EXT_ATOM:
1604 { size_t bytes = fetchSizeInt(&info);
1605 return len == (info.data-info.base)+bytes;
1606 }
1607 }
1608 }
1609 case REC_HDR|REC_GROUND:
1610 case REC_HDR:
1611 { size_t codes = fetchSizeInt(&info);
1612 skipSizeInt(&info); /* global stack size */
1613 if ( !(m & REC_GROUND) )
1614 skipSizeInt(&info); /* # variables */
1615 return len == (info.data-info.base)+codes;
1616 }
1617 default:
1618 assert(0);
1619 }
1620 }
1621
1622 return FALSE;
1623 }
1624
1625
1626 #ifdef O_ATOMGC
1627
1628 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1629 We could consider some optimisation here, notably as this stuff in
1630 inderlying findall() and friends. I guess we can get rid of the
1631 recursion. Other options: combine into copyRecordToGlobal()
1632 (recorded+erase), add a list of atoms as a separate entity.
1633 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1634
1635 static void
skipAtom(CopyInfo b)1636 skipAtom(CopyInfo b)
1637 { uint len = fetchSizeInt(b);
1638
1639 b->data += len;
1640 }
1641
1642
1643 static void
skipSizeInt(CopyInfo b)1644 skipSizeInt(CopyInfo b)
1645 { while( b->data[0] & 0x80 )
1646 b->data++;
1647 b->data++;
1648 }
1649
1650
1651 static void
skipLong(CopyInfo b)1652 skipLong(CopyInfo b)
1653 { b->data += b->data[0] + 1;
1654 }
1655
1656
1657 static void
scanAtomsRecord(CopyInfo b,void (* func)(atom_t a))1658 scanAtomsRecord(CopyInfo b, void (*func)(atom_t a))
1659 { size_t work = 0;
1660
1661 do
1662 { switch( fetchOpCode(b) )
1663 { case PL_TYPE_VARIABLE:
1664 case PL_REC_CYCLE:
1665 { skipSizeInt(b);
1666 continue;
1667 }
1668 case PL_REC_ALLOCVAR:
1669 work++;
1670 continue;
1671 #ifdef O_ATTVAR
1672 case PL_TYPE_ATTVAR:
1673 { skipSizeInt(b);
1674 work++;
1675 continue;
1676 }
1677 #endif
1678 case PL_TYPE_NIL:
1679 { (*func)(ATOM_nil);
1680 continue;
1681 }
1682 case PL_TYPE_DICT:
1683 { (*func)(ATOM_dict);
1684 continue;
1685 }
1686 case PL_TYPE_ATOM:
1687 { atom_t a = fetchWord(b);
1688
1689 (*func)(a);
1690 continue;
1691 }
1692 case PL_TYPE_EXT_ATOM:
1693 case PL_TYPE_EXT_WATOM:
1694 { skipAtom(b);
1695 continue;
1696 }
1697 case PL_TYPE_TAGGED_INTEGER:
1698 case PL_TYPE_INTEGER:
1699 { skipLong(b);
1700 continue;
1701 }
1702 #ifdef O_GMP
1703 case PL_REC_MPZ:
1704 b->data = skipMPZOnCharp(b->data);
1705 continue;
1706 case PL_REC_MPQ:
1707 b->data = skipMPQOnCharp(b->data);
1708 continue;
1709 #endif
1710 case PL_TYPE_FLOAT:
1711 case PL_TYPE_EXT_FLOAT:
1712 { skipBuf(b, double);
1713 continue;
1714 }
1715 case PL_TYPE_STRING:
1716 { uint len = fetchSizeInt(b);
1717 b->data += len;
1718 continue;
1719 }
1720 case PL_TYPE_COMPOUND:
1721 { word fdef = fetchWord(b);
1722 int arity;
1723
1724 arity = arityFunctor(fdef);
1725 work += arity;
1726 continue;
1727 }
1728 case PL_TYPE_EXT_COMPOUND:
1729 { intptr_t arity = fetchSizeInt(b);
1730
1731 skipAtom(b);
1732 work += arity;
1733 continue;
1734 }
1735 case PL_TYPE_CONS:
1736 { work += 2;
1737 continue;
1738 }
1739 default:
1740 assert(0);
1741 }
1742 } while ( work-- );
1743 }
1744
1745 #endif /*O_ATOMGC*/
1746
1747
1748 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1749 markAtomsRecord(Record record ARG_LD) must be called on all records that
1750 use the R_NOLOCK option.
1751 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1752
1753 void
markAtomsRecord(Record record)1754 markAtomsRecord(Record record)
1755 {
1756 #ifdef O_ATOMGC
1757 copy_info ci;
1758
1759 #ifdef REC_MAGIC
1760 assert(record->magic == REC_MAGIC);
1761 #endif
1762
1763 ci.base = ci.data = dataRecord(record);
1764 ci.version_map = NULL;
1765 scanAtomsRecord(&ci, markAtom);
1766 assert(ci.data == addPointer(record, record->size));
1767 #endif
1768 }
1769
1770
1771 #ifdef O_DEBUG_ATOMGC
1772 void
unregister_atom_rec(atom_t a)1773 unregister_atom_rec(atom_t a)
1774 { PL_unregister_atom(a);
1775 }
1776 #endif
1777
1778
1779 bool
freeRecord(Record record)1780 freeRecord(Record record)
1781 { if ( true(record, R_DUPLICATE) && --record->references > 0 )
1782 succeed;
1783
1784 #ifdef O_ATOMGC
1785 if ( false(record, (R_EXTERNAL|R_NOLOCK)) )
1786 { copy_info ci;
1787
1788 DEBUG(3, Sdprintf("freeRecord(%p)\n", record));
1789
1790 ci.base = ci.data = dataRecord(record);
1791 ci.version_map = NULL;
1792 #ifdef O_DEBUG_ATOMGC
1793 scanAtomsRecord(&ci, unregister_atom_rec);
1794 #else
1795 scanAtomsRecord(&ci, PL_unregister_atom);
1796 #endif
1797 assert(ci.data == addPointer(record, record->size));
1798 }
1799 #endif
1800
1801 PL_free(record);
1802
1803 succeed;
1804 }
1805
1806
1807 void
unallocRecordRef(RecordRef r)1808 unallocRecordRef(RecordRef r)
1809 { freeHeap(r, sizeof(*r));
1810 }
1811
1812
1813 static void
freeRecordRef(RecordRef r)1814 freeRecordRef(RecordRef r)
1815 { int reclaim_now = false(r->record, R_DBREF);
1816
1817 freeRecord(r->record);
1818 if ( reclaim_now )
1819 freeHeap(r, sizeof(*r));
1820 else
1821 r->record = NULL;
1822 }
1823
1824
1825 /*******************************
1826 * EXTERNAL RECORDS *
1827 *******************************/
1828
1829 int
PL_recorded_external(const char * rec,term_t t)1830 PL_recorded_external(const char *rec, term_t t)
1831 { GET_LD
1832 copy_info b;
1833 uint gsize;
1834 uchar m;
1835 int rc;
1836
1837 b.base = b.data = rec;
1838 b.version_map = NULL;
1839 fetchBuf(&b, &m, uchar);
1840
1841 if ( !REC_COMPAT(m) )
1842 { if ( (m&REC_SZMASK) != REC_SZ )
1843 { Sdprintf("PL_recorded_external(): "
1844 "Incompatible word-length (%d)\n",
1845 (m&REC_32) ? 32 : 64);
1846 fail;
1847 } else
1848 { int save_version = (m&REC_VMASK)>>REC_VSHIFT;
1849
1850 b.version_map = v_maps[save_version];
1851 if ( !b.version_map )
1852 { Sdprintf("PL_recorded_external(): "
1853 "Incompatible version (%d, current %d)\n",
1854 save_version, PL_REC_VERSION);
1855 fail;
1856 }
1857 }
1858 }
1859
1860 if ( m & (REC_INT|REC_ATOM) ) /* primitive cases */
1861 { if ( m & REC_INT )
1862 { int64_t v = fetchInt64(&b);
1863
1864 rc = PL_put_int64(t, v);
1865 } else
1866 { atom_t a;
1867 int code = fetchOpCode(&b);
1868
1869 switch(code)
1870 { case PL_TYPE_NIL:
1871 return PL_put_nil(t);
1872 case PL_TYPE_DICT:
1873 return PL_put_atom(t, ATOM_dict);
1874 case PL_TYPE_EXT_ATOM:
1875 fetchAtom(&b, &a);
1876 break;
1877 case PL_TYPE_EXT_WATOM:
1878 fetchAtomW(&b, &a);
1879 break;
1880 default:
1881 a = 0;
1882 assert(0);
1883 }
1884 rc = PL_put_atom(t, a);
1885 PL_unregister_atom(a);
1886 }
1887
1888 return rc;
1889 }
1890
1891 skipSizeInt(&b); /* code-size */
1892 gsize = fetchSizeInt(&b);
1893 if ( !(b.gbase = b.gstore = allocGlobal(gsize)) )
1894 return FALSE; /* global stack overflow */
1895 b.dicts = 0;
1896 if ( !(m & REC_GROUND) )
1897 { uint nvars = fetchSizeInt(&b);
1898
1899 if ( (rc=init_copy_vars(&b, nvars)) == TRUE )
1900 { rc = copy_record(valTermRef(t), &b PASS_LD);
1901 free_copy_vars(&b);
1902 }
1903 } else
1904 { rc = copy_record(valTermRef(t), &b PASS_LD);
1905 }
1906
1907 if ( rc != TRUE )
1908 return raiseStackOverflow(rc);
1909
1910 assert(b.gstore == gTop);
1911
1912 if ( b.dicts )
1913 resortDictsInTerm(t);
1914 DEBUG(CHK_SECURE, checkData(valTermRef(t)));
1915
1916 return TRUE;
1917 }
1918
1919
1920 int
PL_erase_external(char * rec)1921 PL_erase_external(char *rec)
1922 { PL_free(rec);
1923 return TRUE;
1924 }
1925
1926
1927 /********************************
1928 * PROLOG CONNECTION *
1929 *********************************/
1930
1931 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1932 The key is stored as an atom, integer or functor header as found on the
1933 global-stack. A functor is a type with the same mask as an atom, but
1934 using the STG_GLOBAL storage indicator. So, the first line denotes a
1935 real atom.
1936 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
1937
1938 bool
unifyKey(term_t key,word val)1939 unifyKey(term_t key, word val)
1940 { GET_LD
1941
1942 if ( isAtom(val) || isTaggedInt(val) )
1943 { return _PL_unify_atomic(key, val);
1944 } else
1945 { return PL_unify_functor(key, (functor_t) val);
1946 }
1947 }
1948
1949
1950 int
getKeyEx(term_t key,word * w ARG_LD)1951 getKeyEx(term_t key, word *w ARG_LD)
1952 { Word k = valTermRef(key);
1953 deRef(k);
1954
1955 if ( isAtom(*k) || isTaggedInt(*k) )
1956 *w = *k;
1957 else if ( isTerm(*k) )
1958 *w = (word)functorTerm(*k);
1959 else
1960 return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_key, key);
1961
1962 succeed;
1963 }
1964
1965
1966 static
1967 PRED_IMPL("current_key", 1, current_key, PL_FA_NONDETERMINISTIC)
1968 { PRED_LD
1969 fid_t fid;
1970 TableEnum e;
1971 word k = 0L;
1972
1973
1974 switch( CTX_CNTRL )
1975 { case FRG_FIRST_CALL:
1976 { if ( PL_is_variable(A1) )
1977 { e = newTableEnum(GD->recorded_db.record_lists);
1978 break;
1979 } else if ( getKeyEx(A1, &k PASS_LD) &&
1980 isCurrentRecordList(k, TRUE) )
1981 succeed;
1982
1983 fail;
1984 }
1985 case FRG_REDO:
1986 e = CTX_PTR;
1987 break;
1988 case FRG_CUTTED:
1989 e = CTX_PTR;
1990 freeTableEnum(e);
1991 /*FALLTHROUGH*/
1992 default: /* fool gcc */
1993 return TRUE;
1994 }
1995
1996 if ( (fid = PL_open_foreign_frame()) )
1997 { void *sk, *sv;
1998
1999 while(advanceTableEnum(e, &sk, &sv))
2000 { RecordList rl = sv;
2001 RecordRef record;
2002
2003 PL_LOCK(L_RECORD);
2004 record = firstRecordRecordList(rl);
2005 PL_UNLOCK(L_RECORD);
2006
2007 if ( record && unifyKey(A1, rl->key) )
2008 { PL_close_foreign_frame(fid);
2009
2010 ForeignRedoPtr(e);
2011 }
2012
2013 PL_rewind_foreign_frame(fid);
2014 }
2015
2016 PL_close_foreign_frame(fid);
2017 }
2018
2019 freeTableEnum(e);
2020 return FALSE;
2021 }
2022
2023
2024 static bool
record(term_t key,term_t term,term_t ref,int az)2025 record(term_t key, term_t term, term_t ref, int az)
2026 { GET_LD
2027 RecordList l;
2028 RecordRef r;
2029 Record copy;
2030 word k = 0L;
2031
2032 DEBUG(3, Sdprintf("record() of ");
2033 PL_write_term(Serror, term, 1200, PL_WRT_ATTVAR_WRITE);
2034 Sdprintf("\n"));
2035
2036 if ( !getKeyEx(key, &k PASS_LD) )
2037 fail;
2038 if ( ref && !PL_is_variable(ref) )
2039 return PL_uninstantiation_error(ref);
2040
2041 if ( !(copy = compileTermToHeap(term, 0)) )
2042 return PL_no_memory();
2043 r = allocHeapOrHalt(sizeof(*r));
2044 r->record = copy;
2045 if ( ref && !PL_unify_recref(ref, r) )
2046 { PL_erase(copy);
2047 freeHeap(r, sizeof(*r));
2048 return FALSE;
2049 }
2050
2051 PL_LOCK(L_RECORD);
2052 l = lookupRecordList(k);
2053 r->list = l;
2054
2055 if ( !l->firstRecord )
2056 { r->next = r->prev = NULL;
2057 l->firstRecord = l->lastRecord = r;
2058 } else if ( az == RECORDA )
2059 { r->prev = NULL;
2060 r->next = l->firstRecord;
2061 l->firstRecord->prev = r;
2062 l->firstRecord = r;
2063 } else
2064 { r->next = NULL;
2065 r->prev = l->lastRecord;
2066 l->lastRecord->next = r;
2067 l->lastRecord = r;
2068 }
2069
2070 PL_UNLOCK(L_RECORD);
2071
2072 succeed;
2073 }
2074
2075
2076 static
2077 PRED_IMPL("recorda", va, recorda, 0)
2078 { return record(A1, A2, CTX_ARITY == 3 ? A3 : 0, RECORDA);
2079 }
2080
2081
2082 static
2083 PRED_IMPL("recordz", va, recordz, 0)
2084 { return record(A1, A2, CTX_ARITY == 3 ? A3 : 0, RECORDZ);
2085 }
2086
2087
2088 /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2089 recorded/2,3. The state enumerates keys using the `e` member if the key
2090 is unbound on entry. The `r` member is the current record.
2091
2092 Enumeration first scans the records and then, if `e` is set, advanced to
2093 the next key.
2094
2095 All manipulation on the state is done whild holding L_RECORD.
2096 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
2097
2098 typedef struct
2099 { TableEnum e; /* enumerating over keys */
2100 RecordRef r; /* current record */
2101 int saved;
2102 } recorded_state;
2103
2104 static recorded_state *
save_state(recorded_state * state)2105 save_state(recorded_state *state)
2106 { if ( state->saved )
2107 { return state;
2108 } else
2109 { recorded_state *newstate = allocForeignState(sizeof(*state));
2110 memcpy(newstate, state, sizeof(*state));
2111 newstate->saved = TRUE;
2112 return newstate;
2113 }
2114 }
2115
2116 /* MT: must hold L_RECORD */
2117
2118 static void
free_state(recorded_state * state)2119 free_state(recorded_state *state)
2120 { if ( state->e )
2121 freeTableEnum(state->e);
2122 if ( state->r )
2123 { RecordList rl = state->r->list;
2124
2125 if ( --rl->references == 0 && true(rl, RL_DIRTY) )
2126 cleanRecordList(rl);
2127 }
2128 if ( state->saved )
2129 freeForeignState(state, sizeof(*state));
2130 }
2131
2132
2133 /* set state to the next non-erased record. Cleanup the record
2134 list if we reached the end.
2135 */
2136
2137 static RecordRef
advance_state(recorded_state * state)2138 advance_state(recorded_state *state)
2139 { RecordRef r = state->r;
2140
2141 do
2142 { if ( !r->next )
2143 { RecordList rl = r->list;
2144
2145 if ( --rl->references == 0 && true(rl, RL_DIRTY) )
2146 cleanRecordList(rl);
2147 }
2148 r = r->next;
2149 } while ( r && true(r->record, R_ERASED) );
2150
2151 state->r = r;
2152 return r;
2153 }
2154
2155
2156 static
2157 PRED_IMPL("recorded", va, recorded, PL_FA_NONDETERMINISTIC)
2158 { PRED_LD
2159 recorded_state state_buf;
2160 recorded_state *state = &state_buf;
2161 word k = 0L;
2162 int rc;
2163 fid_t fid;
2164
2165 term_t key = A1;
2166 term_t term = A2;
2167 term_t ref = (CTX_ARITY == 3 ? A3 : 0);
2168
2169 switch( CTX_CNTRL )
2170 { case FRG_FIRST_CALL:
2171 { if ( ref && !PL_is_variable(ref) ) /* recorded(?,?,+) */
2172 { RecordRef record;
2173
2174 if ( PL_get_recref(ref, &record) )
2175 { PL_LOCK(L_RECORD);
2176 if ( unifyKey(key, record->list->key) )
2177 { term_t copy = PL_new_term_ref();
2178
2179 if ( (rc=copyRecordToGlobal(copy, record->record,
2180 ALLOW_GC PASS_LD)) < 0 )
2181 rc = raiseStackOverflow(rc);
2182 else
2183 rc = PL_unify(term, copy);
2184 } else
2185 rc = FALSE;
2186 PL_UNLOCK(L_RECORD);
2187
2188 return rc;
2189 }
2190 return FALSE;
2191 }
2192
2193 memset(state, 0, sizeof(*state));
2194 if ( PL_is_variable(key) )
2195 { state->e = newTableEnum(GD->recorded_db.record_lists);
2196 PL_LOCK(L_RECORD);
2197 } else if ( getKeyEx(key, &k PASS_LD) )
2198 { RecordList rl;
2199
2200 if ( !(rl = isCurrentRecordList(k, TRUE)) )
2201 return FALSE;
2202 PL_LOCK(L_RECORD);
2203 rl->references++;
2204 state->r = rl->firstRecord;
2205 } else
2206 { return FALSE;
2207 }
2208 break;
2209 }
2210 case FRG_REDO:
2211 { state = CTX_PTR;
2212 PL_LOCK(L_RECORD);
2213 break;
2214 }
2215 case FRG_CUTTED:
2216 { state = CTX_PTR;
2217 PL_LOCK(L_RECORD);
2218 free_state(state);
2219 PL_UNLOCK(L_RECORD);
2220 }
2221 /*FALLTHROUGH*/
2222 default:
2223 succeed;
2224 }
2225
2226 /* Now holding L_RECORD */
2227 if ( (fid = PL_open_foreign_frame()) )
2228 { int answered = FALSE;
2229 term_t copy = 0;
2230
2231 while( !answered )
2232 { for( ; state->r; advance_state(state) )
2233 { RecordRef record;
2234
2235 next:
2236 record = state->r;
2237
2238 if ( !copy && !(copy = PL_new_term_ref()) )
2239 goto error;
2240 if ( (rc=copyRecordToGlobal(copy, record->record, ALLOW_GC PASS_LD)) < 0 )
2241 { raiseStackOverflow(rc);
2242 goto error;
2243 }
2244
2245 if ( PL_unify(term, copy) &&
2246 (!ref || PL_unify_recref(ref, record)) )
2247 { if ( state->e && !unifyKey(key, record->list->key) )
2248 goto error; /* stack overflow */
2249 } else
2250 { if ( PL_exception(0) )
2251 goto error;
2252 PL_rewind_foreign_frame(fid);
2253 continue;
2254 }
2255
2256 answered = TRUE;
2257
2258 if ( record->next )
2259 { state->r = record->next;
2260 PL_UNLOCK(L_RECORD);
2261 PL_close_foreign_frame(fid);
2262 ForeignRedoPtr(save_state(state));
2263 }
2264 }
2265
2266 if ( state->e )
2267 { void *sk, *sv;
2268
2269 while(advanceTableEnum(state->e, &sk, &sv))
2270 { RecordList rl = sv;
2271 RecordRef r;
2272
2273 if ( (r=firstRecordRecordList(rl)) )
2274 { rl->references++;
2275 state->r = r;
2276 if ( answered )
2277 break;
2278 goto next; /* try next list */
2279 }
2280 }
2281 }
2282
2283 if ( answered )
2284 { PL_close_foreign_frame(fid);
2285 if ( state->e )
2286 { PL_UNLOCK(L_RECORD);
2287 ForeignRedoPtr(save_state(state));
2288 } else
2289 { free_state(state);
2290 PL_UNLOCK(L_RECORD);
2291 return TRUE;
2292 }
2293 }
2294
2295 break;
2296 }
2297
2298 error:
2299 PL_close_foreign_frame(fid);
2300 }
2301
2302 free_state(state);
2303 PL_UNLOCK(L_RECORD);
2304
2305 return FALSE;
2306 }
2307
2308
2309 /** instance(+Ref, -Term)
2310 */
2311
2312 static
2313 PRED_IMPL("instance", 2, instance, 0)
2314 { PRED_LD
2315 void *ptr;
2316 db_ref_type type;
2317
2318 term_t ref = A1;
2319 term_t term = A2;
2320
2321 if ( !(ptr=PL_get_dbref(ref, &type)) )
2322 return FALSE;
2323
2324 if ( type == DB_REF_CLAUSE )
2325 { ClauseRef cref = ptr;
2326 Clause clause = cref->value.clause;
2327 gen_t generation = generationFrame(environment_frame);
2328
2329 if ( true(clause, GOAL_CLAUSE) ||
2330 !visibleClause(clause, generation) )
2331 return FALSE;
2332
2333 if ( true(clause, UNIT_CLAUSE) )
2334 { term_t head = PL_new_term_ref();
2335
2336 return ( decompile(clause, head, 0) &&
2337 PL_unify_term(term,
2338 PL_FUNCTOR, FUNCTOR_prove2,
2339 PL_TERM, head,
2340 PL_ATOM, ATOM_true) );
2341 } else
2342 { return decompile(clause, term, 0);
2343 }
2344 } else
2345 { RecordRef rref = ptr;
2346 term_t t = PL_new_term_ref();
2347
2348 if ( copyRecordToGlobal(t, rref->record, ALLOW_GC PASS_LD) == TRUE )
2349 return PL_unify(term, t);
2350 }
2351
2352 return FALSE;
2353 }
2354
2355
2356
2357 static
2358 PRED_IMPL("erase", 1, erase, 0)
2359 { void *ptr;
2360 RecordList l;
2361 db_ref_type type;
2362
2363 term_t ref = A1;
2364
2365 if ( !(ptr=PL_get_dbref(ref, &type)) )
2366 return FALSE;
2367
2368 if ( type == DB_REF_CLAUSE )
2369 { ClauseRef cref = ptr;
2370 Clause clause = cref->value.clause;
2371 Definition def = clause->predicate;
2372
2373 if ( !true(def, P_DYNAMIC) )
2374 return PL_error("erase", 1, NULL, ERR_PERMISSION,
2375 ATOM_clause, ATOM_erase, ref);
2376
2377 return retractClauseDefinition(def, clause);
2378 } else
2379 { RecordRef r = ptr;
2380 int rc;
2381
2382 rc = callEventHook(PLEV_ERASED_RECORD, r);
2383
2384 PL_LOCK(L_RECORD);
2385 l = r->list;
2386 if ( l->references ) /* a recorded has choicepoints */
2387 { set(r->record, R_ERASED);
2388 set(l, RL_DIRTY);
2389 } else
2390 { remove_record(r);
2391 }
2392 PL_UNLOCK(L_RECORD);
2393 return rc;
2394 }
2395 }
2396
2397 /*******************************
2398 * PUBLISH PREDICATES *
2399 *******************************/
2400
2401 #define NDET PL_FA_NONDETERMINISTIC
2402
2403 BeginPredDefs(rec)
2404 PRED_SHARE("recorded", 2, recorded, NDET)
2405 PRED_SHARE("recorded", 3, recorded, NDET)
2406 PRED_SHARE("recordz", 2, recordz, 0)
2407 PRED_SHARE("recordz", 3, recordz, 0)
2408 PRED_SHARE("recorda", 2, recorda, 0)
2409 PRED_SHARE("recorda", 3, recorda, 0)
2410 PRED_DEF("erase", 1, erase, 0)
2411 PRED_DEF("instance", 2, instance, 0)
2412 PRED_DEF("current_key", 1, current_key, NDET)
2413
2414 PRED_DEF("fast_term_serialized", 2, fast_term_serialized, 0)
2415 PRED_DEF("fast_write", 2, fast_write, 0)
2416 PRED_DEF("fast_read", 2, fast_read, 0)
2417 EndPredDefs
2418