/* Part of SWI-Prolog Author: Jan Wielemaker E-mail: J.Wielemaker@vu.nl WWW: http://www.swi-prolog.org Copyright (c) 1985-2020, University of Amsterdam VU University Amsterdam CWI, Amsterdam All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ /*#define O_DEBUG 1*/ #include "pl-rec.h" #include "pl-comp.h" #include "pl-arith.h" #include "pl-dbref.h" #include "pl-termwalk.c" #include "pl-dict.h" #include "pl-event.h" #include "pl-fli.h" #include "pl-pro.h" #include "pl-funct.h" #include "pl-gc.h" #include "pl-proc.h" #define WORDS_PER_PLINT (sizeof(int64_t)/sizeof(word)) static RecordList lookupRecordList(word); static RecordList isCurrentRecordList(word, int must_be_non_empty); static void freeRecordRef(RecordRef r); static void unallocRecordList(RecordList rl); static int is_external(const char *rec, size_t len); #undef LD #define LD LOCAL_LD static void free_recordlist_symbol(void *name, void *value) { RecordList l = value; unallocRecordList(l); } void initRecords(void) { GD->recorded_db.record_lists = newHTable(8); GD->recorded_db.record_lists->free_symbol = free_recordlist_symbol; } void cleanupRecords(void) { Table t; if ( (t=GD->recorded_db.record_lists) ) { GD->recorded_db.record_lists = NULL; destroyHTable(t); } } /* MT: locked by caller (record()) */ static RecordList lookupRecordList(word key) { GET_LD RecordList l; if ( (l = lookupHTable(GD->recorded_db.record_lists, (void *)key)) ) { return l; } else { if ( isAtom(key) ) /* can also be functor_t */ PL_register_atom(key); l = allocHeapOrHalt(sizeof(*l)); memset(l, 0, sizeof(*l)); l->key = key; addNewHTable(GD->recorded_db.record_lists, (void *)key, l); return l; } } static RecordRef firstRecordRecordList(RecordList rl) { RecordRef record; for(record = rl->firstRecord; record; record = record->next) { if ( false(record->record, R_ERASED) ) return record; } return NULL; } static RecordList isCurrentRecordList(word key, int must_be_non_empty) { GET_LD RecordList rl; if ( (rl = lookupHTable(GD->recorded_db.record_lists, (void *)key)) ) { if ( must_be_non_empty ) { RecordRef record; PL_LOCK(L_RECORD); record = firstRecordRecordList(rl); PL_UNLOCK(L_RECORD); return record ? rl : NULL; } else { return rl; } } return NULL; } static void remove_record(RecordRef r) { RecordList l = r->list; if ( r->prev ) r->prev->next = r->next; else l->firstRecord = r->next; if ( r->next ) r->next->prev = r->prev; else l->lastRecord = r->prev; freeRecordRef(r); } /* MT: Locked by called */ static void cleanRecordList(RecordList rl) { RecordRef r, next=NULL; for(r = rl->firstRecord; r; r = next ) { next = r->next; if ( true(r->record, R_ERASED) ) remove_record(r); } } /* unallocRecordList() is used when memory is cleaned for PL_cleanup(). We set R_NOLOCK to avoid needless update of the atom references in freeRecord(). */ static void unallocRecordList(RecordList rl) { RecordRef r, n; for(r = rl->firstRecord; r; r=n) { n = r->next; set(r->record, R_NOLOCK); freeRecordRef(r); } freeHeap(rl, sizeof(*rl)); } /******************************* * HEAP STORAGE * *******************************/ #undef uint #undef uchar #define uint unsigned int #define uchar unsigned char #ifndef offsetof #define offsetof(structure, field) ((int) &(((structure *)NULL)->field)) #endif #define SIZERECORD(flags) \ ((flags & R_DUPLICATE) ? offsetof(struct record, buffer[0]) : \ offsetof(struct record, references)) \ #define dataRecord(r) ((char *)addPointer(r, SIZERECORD(r->flags))) typedef enum { ENONE = 0, EFAST_SERIALIZE } cerror; typedef struct { tmp_buffer code; /* code buffer */ tmp_buffer vars; /* variable pointers */ size_t size; /* size on global stack */ uint nvars; /* # variables */ int external; /* Allow for external storage */ int lock; /* lock compiled atoms */ cerror error; /* generated error */ word econtext[1]; /* error context */ } compile_info, *CompileInfo; #define PL_TYPE_VARIABLE (1) /* variable */ #define PL_TYPE_ATOM (2) /* atom */ #define PL_TYPE_INTEGER (3) /* big integer */ #define PL_TYPE_TAGGED_INTEGER (4) /* tagged integer */ #define PL_TYPE_FLOAT (5) /* double */ #define PL_TYPE_STRING (6) /* string */ #define PL_TYPE_COMPOUND (7) /* compound term */ #define PL_TYPE_CONS (8) /* list-cell */ #define PL_TYPE_NIL (9) /* [] */ #define PL_TYPE_DICT (10) /* The C'dict' atom */ #define PL_TYPE_EXT_ATOM (11) /* External (inlined) atom */ #define PL_TYPE_EXT_WATOM (12) /* External (inlined) wide atom */ #define PL_TYPE_EXT_COMPOUND (13) /* External (inlined) functor */ #define PL_TYPE_EXT_FLOAT (14) /* float in standard-byte order */ #define PL_TYPE_ATTVAR (15) /* Attributed variable */ #define PL_REC_ALLOCVAR (16) /* Allocate a variable on global */ #define PL_REC_CYCLE (17) /* cyclic reference */ #define PL_REC_MPZ (18) /* GMP integer */ #define PL_REC_MPQ (19) /* GMP rational */ #define PL_TYPE_EXT_COMPOUND_V2 (20) /* Read V2 external records */ static const int v2_map[] = { 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, /* variable..string */ 11, 12, PL_TYPE_EXT_COMPOUND_V2, 14, 15, 16, 17, 18 }; static const int *v_maps[8] = /* 3 bits, cannot overflow */ { NULL, NULL, v2_map }; static inline void addUnalignedBuf(TmpBuffer b, void *ptr, size_t bytes) { if ( b->top + bytes > b->max ) { if ( !growBuffer((Buffer)b, bytes) ) outOfCore(); } memcpy(b->top, ptr, bytes); b->top += bytes; } static inline void addOpCode(CompileInfo info, int code) { addBuffer(&info->code, code, uchar); DEBUG(9, Sdprintf("Added %d, now %d big\n", code, sizeOfBuffer(&info->code))); } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - addSizeInt() deals with integers that should be large enough to specify the size of an object on the stack. This counts for variables, arities, sizes of strings and atoms, etc. Encoding: 7-bits per byte, MSF. All but the last (LSB) have the 8-th bit set. This format allows for arbitrary bit integers and is architecture independent. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ static inline void addUintBuffer(Buffer b, size_t val) { if ( !(val & ~0x7f) ) { addBuffer(b, (uchar)val, uchar); } else { int zips = ((sizeof(val))*8+7-1)/7 - 1; int leading = TRUE; for(; zips >= 0; zips--) { uint d = (uint)((val >> zips*7) & 0x7f); if ( d || !leading ) { if ( zips != 0 ) d |= 0x80; addBuffer(b, d, uchar); leading = FALSE; } } } } static inline void addSizeInt(CompileInfo info, size_t val) { addUintBuffer((Buffer)&info->code, val); } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Add a signed intptr_t value. First byte is number of bytes, remaining are value-bytes, starting at most-significant. When loading, we restore the bytes in the least significant positions and perform a left and right shift to restore the sign. This means that a positive number must always have a 0 at the left side in the encoding. So, if bit 7 is the MSB, we must store 2 bytes. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ static void addInt64(CompileInfo info, int64_t v) { int i; if ( v == 0 ) { i = 1; } else if ( v == PLMININT ) { i = sizeof(v); } else { int64_t a = v > 0 ? v :- v; i = (MSB64(a)+9)/8; } addBuffer(&info->code, i, uchar); while( --i >= 0 ) { int b = (int)(v>>(i*8)) & 0xff; addBuffer(&info->code, b, uchar); } } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Floats. If we are adding floats for external use they will be stored in normalised byte-order. Otherwise they are stored verbatim. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ #ifdef WORDS_BIGENDIAN static const int double_byte_order[] = { 7,6,5,4,3,2,1,0 }; #else static const int double_byte_order[] = { 0,1,2,3,4,5,6,7 }; #endif static inline void addFloat(CompileInfo info, void *val) { if ( info->external ) { unsigned char *cl = val; unsigned int i; addOpCode(info, PL_TYPE_EXT_FLOAT); for(i=0; icode, cl[double_byte_order[i]], uchar); } else { addOpCode(info, PL_TYPE_FLOAT); addUnalignedBuf(&info->code, val, sizeof(double)); } } static inline void addWord(CompileInfo info, word w) { addUnalignedBuf(&info->code, &w, sizeof(word)); } static inline void addChars(CompileInfo info, size_t len, const char *data) { addSizeInt(info, len); addMultipleBuffer(&info->code, data, len, char); } static inline void addAtomValue(CompileInfo info, Atom a) { addSizeInt(info, a->length); addMultipleBuffer(&info->code, a->name, a->length, char); } static int addAtom(CompileInfo info, atom_t a) { if ( a == ATOM_nil ) { addOpCode(info, PL_TYPE_NIL); } else if ( a == ATOM_dict ) { addOpCode(info, PL_TYPE_DICT); } else if ( unlikely(info->external) ) { Atom ap = atomValue(a); if ( true(ap->type, PL_BLOB_TEXT) ) { if ( isUCSAtom(ap) ) addOpCode(info, PL_TYPE_EXT_WATOM); else addOpCode(info, PL_TYPE_EXT_ATOM); addAtomValue(info, ap); } else { info->error = EFAST_SERIALIZE; info->econtext[0] = a; return FALSE; } } else { addOpCode(info, PL_TYPE_ATOM); addWord(info, a); if ( info->lock ) PL_register_atom(a); } return TRUE; } static int addFunctor(CompileInfo info, functor_t f) { if ( f == FUNCTOR_dot2 ) { addOpCode(info, PL_TYPE_CONS); } else { if ( info->external ) { FunctorDef fd = valueFunctor(f); addOpCode(info, PL_TYPE_EXT_COMPOUND); addSizeInt(info, fd->arity); return addAtom(info, fd->name); } else { addOpCode(info, PL_TYPE_COMPOUND); addWord(info, f); } } return TRUE; } typedef struct { Functor term; functor_t fdef; } cycle_mark; #define mkAttVarP(p) ((Word)((word)(p) | 0x1L)) #define isAttVarP(p) ((word)(p) & 0x1) #define valAttVarP(p) ((Word)((word)(p) & ~0x1L)) #define compile_term_to_heap(agenda, info) LDFUNC(compile_term_to_heap, agenda, info) static int compile_term_to_heap(DECL_LD term_agenda *agenda, CompileInfo info) { Word p; while( (p=nextTermAgenda(agenda)) ) { word w; again: w = *p; switch(tag(w)) { case TAG_VAR: { intptr_t n = info->nvars++; *p = (n<<7)|TAG_ATOM|STG_GLOBAL; addBuffer(&info->vars, p, Word); addOpCode(info, PL_TYPE_VARIABLE); addSizeInt(info, n); continue; } #if O_ATTVAR case TAG_ATTVAR: { intptr_t n = info->nvars++; Word ap = valPAttVar(w); if ( isEmptyBuffer(&info->code) ) { addOpCode(info, PL_REC_ALLOCVAR); /* only an attributed var */ info->size++; } addBuffer(&info->vars, *p, word); /* save value */ *p = (n<<7)|TAG_ATOM|STG_GLOBAL; addBuffer(&info->vars, mkAttVarP(p), Word); addOpCode(info, PL_TYPE_ATTVAR); addSizeInt(info, n); info->size += 3; DEBUG(MSG_REC_ATTVAR, Sdprintf("Added attvar %d\n", n)); p = ap; deRef(p); goto again; } #endif case TAG_ATOM: { if ( storage(w) == STG_GLOBAL ) /* this is a variable */ { intptr_t n = ((intptr_t)(w) >> 7); addOpCode(info, PL_TYPE_VARIABLE); addSizeInt(info, n); DEBUG(9, Sdprintf("Added var-link %d\n", n)); } else { if ( !addAtom(info, w) ) return FALSE; DEBUG(9, Sdprintf("Added '%s'\n", stringAtom(w))); } continue; } case TAG_INTEGER: { int64_t val; if ( isTaggedInt(w) ) { val = valInt(w); addOpCode(info, PL_TYPE_TAGGED_INTEGER); addInt64(info, val); } else { number n; info->size += wsizeofIndirect(w) + 2; get_rational(w, &n); switch(n.type) { case V_INTEGER: addOpCode(info, PL_TYPE_INTEGER); addInt64(info, n.value.i); break; #if O_BIGNUM case V_MPZ: addOpCode(info, PL_REC_MPZ); addMPZToBuffer((Buffer)&info->code, n.value.mpz); break; case V_MPQ: addOpCode(info, PL_REC_MPQ); addMPQToBuffer((Buffer)&info->code, n.value.mpq); break; #endif default: assert(0); } } continue; } case TAG_STRING: { Word f = addressIndirect(w); size_t n = wsizeofInd(*f); size_t pad = padHdr(*f); /* see also getCharsString() */ size_t l = n*sizeof(word)-pad; info->size += n+2; addOpCode(info, PL_TYPE_STRING); addChars(info, l, (const char *)(f+1)); /* +1 to skip header */ continue; } case TAG_FLOAT: { info->size += WORDS_PER_DOUBLE + 2; addFloat(info, valIndirectP(w)); continue; } case TAG_COMPOUND: { Functor f = valueTerm(w); int arity; word functor; #if O_CYCLIC if ( isInteger(f->definition) ) { addOpCode(info, PL_REC_CYCLE); addSizeInt(info, valInt(f->definition)); DEBUG(1, Sdprintf("Added cycle for offset = %d\n", valInt(f->definition))); continue; } else { cycle_mark mark; arity = arityFunctor(f->definition); functor = f->definition; mark.term = f; mark.fdef = f->definition; if ( !pushSegStack(&LD->cycle.lstack, mark, cycle_mark) ) return FALSE; f->definition = (functor_t)consUInt(info->size); /* overflow test (should not be possible) */ DEBUG(CHK_SECURE, assert(valUInt(f->definition) == (uintptr_t)info->size)); } #endif info->size += arity+1; if ( !addFunctor(info, functor) ) return FALSE; DEBUG(9, if ( GD->io_initialised ) Sdprintf("Added %s/%d\n", stringAtom(valueFunctor(functor)->name), arityFunctor(functor))); if ( !pushWorkAgenda(agenda, arity, f->arguments) ) return FALSE; continue; } default: assert(0); } } return TRUE; } #if USE_LD_MACROS #define init_cycle(_) LDFUNC(init_cycle, _) #define unvisit(_) LDFUNC(unvisit, _) #endif /*USE_LD_MACROS*/ #if O_CYCLIC static void init_cycle(DECL_LD) { LD->cycle.lstack.unit_size = sizeof(cycle_mark); } static void unvisit(DECL_LD) { cycle_mark mark; while( popSegStack(&LD->cycle.lstack, &mark, cycle_mark) ) { mark.term->definition = mark.fdef; } } #else static void init_cycle(DECL_LD) {} static void unvisit(DECL_LD) {} #endif static void restoreVars(compile_info *info) { Word *p = topBuffer(&info->vars, Word); Word *b = baseBuffer(&info->vars, Word); while(p > b) { p--; if (isAttVarP(*p) ) { *valAttVarP(*p) = (word)p[-1]; p--; } else setVar(**p); } discardBuffer(&info->vars); } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - compileTermToHeap_ex() is the core of the recorded database. Returns NULL if there is insufficient memory. Otherwise the result of the allocation function. The default allocation function is PL_malloc_atomic_unmanaged(). - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ Record compileTermToHeap_ex(DECL_LD term_t t, void* (*allocate)(void *closure, size_t size), void* closure, int flags) { compile_info info; Record record; size_t size; size_t rsize = SIZERECORD(flags); term_agenda agenda; int rc; DEBUG(CHK_SECURE, checkData(valTermRef(t))); init_cycle(); initBuffer(&info.code); initBuffer(&info.vars); info.size = 0; info.nvars = 0; info.external = (flags & R_EXTERNAL); info.lock = !(info.external || (flags&R_NOLOCK)); initTermAgenda(&agenda, 1, valTermRef(t)); rc = compile_term_to_heap(&agenda, &info); clearTermAgenda(&agenda); restoreVars(&info); unvisit(); if ( rc ) { size = rsize + sizeOfBuffer(&info.code); if ( allocate ) record = (*allocate)(closure, size); else record = PL_malloc_atomic_unmanaged(size); if ( record ) { #ifdef REC_MAGIC record->magic = REC_MAGIC; #endif record->gsize = (unsigned int)info.size; /* only 28-bit */ record->nvars = info.nvars; record->size = (int)size; record->flags = flags; if ( flags & R_DUPLICATE ) { record->references = 1; } memcpy(addPointer(record, rsize), info.code.base, sizeOfBuffer(&info.code)); } } else { record = NULL; } discardBuffer(&info.code); DEBUG(3, Sdprintf("--> record at %p\n", record)); return record; } int variantRecords(const Record r1, const Record r2) { return ( r1->size == r2->size && memcpy(r1, r2, r1->size) == 0 ); } /******************************* * EXTERNAL RECORDS * *******************************/ #define REC_32 0x01 /* word is 32-bits */ #define REC_64 0x02 /* word is 64-bits */ #define REC_INT 0x04 /* Record just contains int */ #define REC_ATOM 0x08 /* Record just contains atom */ #define REC_GROUND 0x10 /* Record is ground */ #define REC_VMASK 0xe0 /* Version mask */ #define REC_VSHIFT 5 /* shift for version mask */ #define REC_SZMASK (REC_32|REC_64) /* SIZE_MASK */ #if SIZEOF_VOIDP == 8 #define REC_SZ REC_64 #else #define REC_SZ REC_32 #endif #define REC_HDR (REC_SZ|(PL_REC_VERSION<info.code); if ( !data->simple ) discardBuffer(&data->hdr); } static int rec_error(CompileInfo info) { switch(info->error) { case EFAST_SERIALIZE: { GET_LD term_t t; return ( (t=PL_new_term_ref()) && PL_put_atom(t, info->econtext[0]) && PL_permission_error("fast_serialize", "blob", t) ); } default: assert(0); return FALSE; } } #define compile_external_record(t, data) LDFUNC(compile_external_record, t, data) static int compile_external_record(DECL_LD term_t t, record_data *data) { Word p; int first = REC_HDR; term_agenda agenda; int scode, rc; DEBUG(CHK_SECURE, checkData(valTermRef(t))); p = valTermRef(t); deRef(p); init_cycle(); initBuffer(&data->info.code); data->info.external = TRUE; data->info.lock = FALSE; if ( isInteger(*p) ) /* integer-only record */ { int64_t v; if ( isTaggedInt(*p) ) v = valInt(*p); else if ( isBignum(*p) ) v = valBignum(*p); else /* GMP integers */ goto general; first |= (REC_INT|REC_GROUND); addOpCode(&data->info, first); addInt64(&data->info, v); data->simple = TRUE; return TRUE; } else if ( isAtom(*p) ) /* atom-only record */ { first |= (REC_ATOM|REC_GROUND); addOpCode(&data->info, first); if ( !addAtom(&data->info, *p) ) return FALSE; data->simple = TRUE; return TRUE; } /* the real stuff */ general: data->simple = FALSE; initBuffer(&data->info.vars); data->info.size = 0; data->info.nvars = 0; initTermAgenda(&agenda, 1, p); rc = compile_term_to_heap(&agenda, &data->info); clearTermAgenda(&agenda); if ( data->info.nvars == 0 ) first |= REC_GROUND; restoreVars(&data->info); unvisit(); if ( !rc ) return rec_error(&data->info); scode = (int)sizeOfBuffer(&data->info.code); initBuffer(&data->hdr); addBuffer(&data->hdr, first, uchar); /* magic code */ addUintBuffer((Buffer)&data->hdr, scode); /* code size */ addUintBuffer((Buffer)&data->hdr, data->info.size); /* size on stack */ if ( data->info.nvars > 0 ) addUintBuffer((Buffer)&data->hdr, data->info.nvars);/* Number of variables */ return TRUE; } char * PL_record_external(term_t t, size_t *len) { GET_LD record_data data; if ( compile_external_record(t, &data) ) { if ( data.simple ) { size_t scode = sizeOfBuffer(&data.info.code); char *rec = malloc(scode); if ( rec ) { memcpy(rec, data.info.code.base, scode); discard_record_data(&data); *len = scode; return rec; } else { discard_record_data(&data); PL_no_memory(); return NULL; } } else { size_t shdr = sizeOfBuffer(&data.hdr); size_t scode = sizeOfBuffer(&data.info.code); char *rec = malloc(shdr + scode); if ( rec ) { memcpy(rec, data.hdr.base, shdr); memcpy(rec+shdr, data.info.code.base, scode); discard_record_data(&data); *len = shdr + scode; return rec; } else { discard_record_data(&data); PL_no_memory(); return NULL; } } } else { return NULL; } } /******************************* * FASTRW * *******************************/ static PRED_IMPL("fast_term_serialized", 2, fast_term_serialized, 0) { PRED_LD char *rec; size_t len; term_t term = A1; term_t string = A2; if ( PL_is_variable(string) ) { record_data data; if ( compile_external_record(term, &data) ) { if ( data.simple ) { int rc; len = sizeOfBuffer(&data.info.code); rc = PL_unify_string_nchars(string, len, data.info.code.base); discard_record_data(&data); return rc; } else { int rc; size_t shdr = sizeOfBuffer(&data.hdr); size_t scode = sizeOfBuffer(&data.info.code); Word p; if ( (p=allocString(shdr+scode+1)) ) { char *q = (char *)&p[1]; word w = consPtr(p, TAG_STRING|STG_GLOBAL); *q++ = 'B'; memcpy(q, data.hdr.base, shdr); memcpy(q+shdr, data.info.code.base, scode); rc = _PL_unify_atomic(string, w); discard_record_data(&data); return rc; } else { discard_record_data(&data); return FALSE; } } } else { return FALSE; } } else if ( PL_get_nchars(string, &len, &rec, CVT_STRING|BUF_STACK|REP_ISO_LATIN_1|CVT_EXCEPTION) ) { term_t tmp; return ( (tmp = PL_new_term_ref()) && is_external(rec, len) && PL_recorded_external(rec, tmp) && PL_unify(term, tmp) ); } else { return FALSE; } } /** fast_write(+Stream, +Term) */ static PRED_IMPL("fast_write", 2, fast_write, 0) { PRED_LD IOSTREAM *out; if ( PL_get_stream(A1, &out, SIO_OUTPUT) ) { record_data data; int rc; if ( out->encoding == ENC_OCTET ) { if ( (rc=compile_external_record(A2, &data)) ) { if ( data.simple ) { size_t len = sizeOfBuffer(&data.info.code); rc = (Sfwrite(data.info.code.base, 1, len, out) == len); } else { size_t shdr = sizeOfBuffer(&data.hdr); size_t scode = sizeOfBuffer(&data.info.code); rc = ( Sfwrite(data.hdr.base, 1, shdr, out) == shdr && Sfwrite(data.info.code.base, 1, scode, out) == scode ); } discard_record_data(&data); } } else { rc = PL_permission_error("fast_write", "stream", A1); } return PL_release_stream(out) && rc; } return FALSE; } #define FASTRW_FAST 512 static char * readSizeInt(IOSTREAM *in, char *to, size_t *sz) { size_t r = 0; int d; char *t = to; do { d = Sgetc(in); if ( d == -1 ) { PL_syntax_error("fastrw_size", in); return NULL; } *t++ = d; if ( t-to > 10 ) return NULL; r = (r<<7)|(d&0x7f); } while((d & 0x80)); *sz = r; return t; } static char * realloc_record(char *rec, char **np, size_t size) { size_t hdr = *np-rec; size_t tsize = hdr + size; char *nrec; if ( tsize <= FASTRW_FAST ) { return rec; } else if ( (nrec = malloc(tsize)) ) { memcpy(nrec, rec, hdr); *np = nrec+hdr; return nrec; } else { PL_no_memory(); return NULL; } } static PRED_IMPL("fast_read", 2, fast_read, 0) { PRED_LD IOSTREAM *in; if ( PL_get_stream(A1, &in, SIO_INPUT) ) { int rc; if ( in->encoding == ENC_OCTET ) { int m = Sgetc(in); char fast[FASTRW_FAST]; char *rec = fast; switch(m) { case -1: rc = PL_unify_atom(A2, ATOM_end_of_file); goto out; case REC_HDR|REC_INT|REC_GROUND: { int size = Sgetc(in)&0xff; if ( size <= 8 ) { rec[0] = m; rec[1] = size; if ( Sfread(&rec[2], 1, size, in) != size ) rc = PL_syntax_error("fastrw_integer", in); else rc = TRUE; } else { rc = PL_syntax_error("fastrw_integer", in); } break; } case REC_HDR|REC_ATOM|REC_GROUND: { uchar op = Sgetc(in); switch(op) { case PL_TYPE_NIL: rc = PL_unify_nil(A2); goto out; case PL_TYPE_DICT: rc = PL_unify_atom(A2, ATOM_dict); goto out; case PL_TYPE_EXT_WATOM: case PL_TYPE_EXT_ATOM: { size_t bytes; char *np; rec[0] = m; rec[1] = op; if ( (np=readSizeInt(in, &rec[2], &bytes)) && (rec = realloc_record(rec, &np, bytes)) && Sfread(np, 1, bytes, in) == bytes ) rc = TRUE; else rc = PL_syntax_error("fastrw_atom", in); break; } default: rc = PL_syntax_error("fastrw_atom_type", in); } break; } case REC_HDR|REC_GROUND: case REC_HDR: { char *np; size_t codes, gsize, nvars; rec[0] = m; if ( (np=readSizeInt(in, &rec[1], &codes)) && (np=readSizeInt(in, np, &gsize)) && ((m&REC_GROUND) || (np=readSizeInt(in, np, &nvars))) && (rec = realloc_record(rec, &np, codes)) && Sfread(np, 1, codes, in) == codes ) rc = TRUE; else rc = PL_syntax_error("fastrw_term", in); break; } default: rc = PL_syntax_error("fastrw_magic_expected", in); } if ( rc ) { term_t tmp; rc = ( (tmp = PL_new_term_ref()) && PL_recorded_external(rec, tmp) && PL_unify(A2, tmp) ); } if ( rec != fast ) free(rec); } else { rc = PL_permission_error("fast_read", "stream", A1); } out: return PL_release_stream(in) && rc; } return FALSE; } /******************************* * HEAP --> STACK * *******************************/ #define MAX_FAST_VARS 100 typedef struct { const char *data; const char *base; /* start of data */ const int *version_map; /* translate op-codes */ Word *vars; Word gbase; /* base of term on global stack */ Word gstore; /* current storage location */ uint nvars; /* Variables seen */ uint dicts; /* # dicts found */ TmpBuffer avars; /* Values stored for attvars */ Word vars_buf[MAX_FAST_VARS]; } copy_info, *CopyInfo; static void skipSizeInt(CopyInfo b); static inline int init_copy_vars(copy_info *info, uint n) { if ( n > 0 ) { Word *p; if ( n <= MAX_FAST_VARS ) info->vars = info->vars_buf; else if ( (info->vars = malloc(sizeof(Word)*n)) == NULL ) return MEMORY_OVERFLOW; for(p = info->vars; n-- > 0;) *p++ = NULL; } else { info->vars = NULL; } return TRUE; } static inline void free_copy_vars(const copy_info *info) { if ( info->vars != info->vars_buf ) free(info->vars); } #define fetchBuf(b, var, type) \ do \ { memcpy(var, (b)->data, sizeof(type)); \ (b)->data += sizeof(type); \ } while(0) #define fetchMultipleBuf(b, var, times, type) \ do \ { memcpy(var, (b)->data, times*sizeof(type)); \ (b)->data += times*sizeof(type); \ } while(0) #define skipBuf(b, type) \ ((b)->data += sizeof(type)) static inline int fetchOpCode(CopyInfo b) { uchar tag; fetchBuf(b, &tag, uchar); DEBUG(9, Sdprintf("fetchOpCode() --> %d, (at %d)\n", tag, b->data-b->base)); return likely(b->version_map==NULL) ? tag : b->version_map[tag]; } static size_t fetchSizeInt(CopyInfo b) { size_t r = 0; size_t d; do { d = *b->data++; r = (r<<7)|(d&0x7f); } while((d & 0x80)); return r; } static int64_t fetchInt64(CopyInfo b) { uint64_t val = 0; uint bytes = *b->data++; uint64_t sign = 1ULL << (bytes * 8 - 1); while(bytes-- > 0) val = (val << 8) | (*b->data++ & 0xff); return (int64_t)((val ^ sign) - sign); } static word fetchWord(CopyInfo b) { word val; fetchBuf(b, &val, word); return val; } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Fetch a float. Note that the destination might not be double-aligned! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ static void fetchFloat(CopyInfo b, void *f) { fetchBuf(b, f, double); } static void fetchExtFloat(CopyInfo b, void *f) { unsigned char *dst = f; unsigned int i; for(i=0; idata++; } #define fetchAtom(b, a) LDFUNC(fetchAtom, b, a) static void fetchAtom(DECL_LD CopyInfo b, atom_t *a) { unsigned int len = fetchSizeInt(b); *a = lookupAtom(b->data, len); (b)->data += len; } static void fetchAtomW(CopyInfo b, atom_t *a) { unsigned int len = fetchSizeInt(b); *a = lookupUCSAtom((const pl_wchar_t*)b->data, len/sizeof(pl_wchar_t)); (b)->data += len; } static void fetchChars(CopyInfo b, unsigned len, Word to) { fetchMultipleBuf(b, (char *)to, len, char); } #define copy_record(p, b) LDFUNC(copy_record, p, b) static int copy_record(DECL_LD Word p, CopyInfo b) { term_agenda agenda; int is_compound = FALSE; int tag; do { right_recursion: switch( (tag = fetchOpCode(b)) ) { case PL_TYPE_VARIABLE: { intptr_t n = fetchSizeInt(b); if ( b->vars[n] ) { if ( p > b->vars[n] ) /* ensure the reference is in the */ { *p = makeRefG(b->vars[n]); /* right direction! */ } else { *p = *b->vars[n]; /* wrong way. make sure b->vars[n] */ *b->vars[n] = makeRefG(p); /* stays at the real variable */ b->vars[n] = p; /* NOTE: also links attvars! */ } } else { setVar(*p); b->vars[n] = p; } continue; } case PL_REC_ALLOCVAR: { setVar(*b->gstore); *p = makeRefG(b->gstore); p = b->gstore++; goto right_recursion; } #if O_ATTVAR case PL_TYPE_ATTVAR: { intptr_t n = fetchSizeInt(b); DEBUG(MSG_REC_ATTVAR, Sdprintf("Restore attvar %ld at %p\n", (long)n, &b->gstore[1])); register_attvar(b->gstore); b->gstore[1] = consPtr(&b->gstore[2], TAG_ATTVAR|STG_GLOBAL); *p = makeRefG(&b->gstore[1]); b->vars[n] = p; p = &b->gstore[2]; b->gstore += 3; goto right_recursion; } #endif case PL_TYPE_NIL: { *p = ATOM_nil; continue; } case PL_TYPE_DICT: { *p = ATOM_dict; continue; } case PL_TYPE_ATOM: { *p = fetchWord(b); continue; } case PL_TYPE_EXT_ATOM: { fetchAtom(b, p); PL_unregister_atom(*p); continue; } case PL_TYPE_EXT_WATOM: { fetchAtomW(b, p); PL_unregister_atom(*p); continue; } case PL_TYPE_TAGGED_INTEGER: { int64_t val = fetchInt64(b); *p = consInt(val); continue; } case PL_TYPE_INTEGER: { size_t i; union { int64_t i64; word w[WORDS_PER_PLINT]; } val; val.i64 = fetchInt64(b); *p = consPtr(b->gstore, TAG_INTEGER|STG_GLOBAL); *b->gstore++ = mkIndHdr(WORDS_PER_PLINT, TAG_INTEGER); for(i=0; igstore++ = val.w[i]; *b->gstore++ = mkIndHdr(WORDS_PER_PLINT, TAG_INTEGER); continue; } #if O_BIGNUM case PL_REC_MPZ: b->data = loadMPZFromCharp(b->data, p, &b->gstore); continue; case PL_REC_MPQ: b->data = loadMPQFromCharp(b->data, p, &b->gstore); continue; #endif case PL_TYPE_FLOAT: case PL_TYPE_EXT_FLOAT: { *p = consPtr(b->gstore, TAG_FLOAT|STG_GLOBAL); *b->gstore++ = mkIndHdr(WORDS_PER_DOUBLE, TAG_FLOAT); if ( tag == PL_TYPE_FLOAT ) fetchFloat(b, b->gstore); else fetchExtFloat(b, b->gstore); b->gstore += WORDS_PER_DOUBLE; *b->gstore++ = mkIndHdr(WORDS_PER_DOUBLE, TAG_FLOAT); continue; } case PL_TYPE_STRING: { size_t lw, len = fetchSizeInt(b); int pad; word hdr; lw = (len+sizeof(word))/sizeof(word); /* see globalNString() */ pad = (lw*sizeof(word) - len); *p = consPtr(b->gstore, TAG_STRING|STG_GLOBAL); *b->gstore++ = hdr = mkStrHdr(lw, pad); b->gstore[lw-1] = 0L; /* zero-padding */ fetchChars(b, len, b->gstore); b->gstore += lw; *b->gstore++ = hdr; continue; } #ifdef O_CYCLIC case PL_REC_CYCLE: { unsigned offset = fetchSizeInt(b); Word ct = b->gbase+offset; *p = consPtr(ct, TAG_COMPOUND|STG_GLOBAL); continue; } #endif { word fdef; int arity; case PL_TYPE_COMPOUND: fdef = fetchWord(b); arity = arityFunctor(fdef); compound: *p = consPtr(b->gstore, TAG_COMPOUND|STG_GLOBAL); *b->gstore++ = fdef; p = b->gstore; b->gstore += arity; if ( !is_compound ) { is_compound = TRUE; initTermAgenda(&agenda, arity, p); } else { if ( !pushWorkAgenda(&agenda, arity, p) ) return MEMORY_OVERFLOW; } continue; case PL_TYPE_EXT_COMPOUND: { atom_t name; int opcode_atom; arity = (int)fetchSizeInt(b); opcode_atom = fetchOpCode(b); switch(opcode_atom) { case PL_TYPE_EXT_ATOM: fetchAtom(b, &name); break; case PL_TYPE_EXT_WATOM: fetchAtomW(b, &name); break; case PL_TYPE_NIL: name = ATOM_nil; break; case PL_TYPE_DICT: b->dicts++; name = ATOM_dict; break; default: name = 0; assert(0); } fdef = lookupFunctorDef(name, arity); goto compound; } case PL_TYPE_EXT_COMPOUND_V2: { atom_t name; arity = (int)fetchSizeInt(b); fetchAtom(b, &name); fdef = lookupFunctorDef(name, arity); goto compound; } } case PL_TYPE_CONS: { *p = consPtr(b->gstore, TAG_COMPOUND|STG_GLOBAL); *b->gstore++ = FUNCTOR_dot2; p = b->gstore; b->gstore += 2; if ( !is_compound ) { is_compound = TRUE; initTermAgenda(&agenda, 2, p); } else { if ( !pushWorkAgenda(&agenda, 2, p) ) return MEMORY_OVERFLOW; } continue; } default: assert(0); } } while ( is_compound && (p=nextTermAgendaNoDeRef(&agenda)) ); return TRUE; } int copyRecordToGlobal(DECL_LD term_t copy, Record r, int flags) { copy_info b; int rc; DEBUG(3, Sdprintf("PL_recorded(%p)\n", r)); #ifdef REC_MAGIC assert(r->magic == REC_MAGIC); #endif if ( !hasGlobalSpace(r->gsize) ) { if ( (rc=ensureGlobalSpace(r->gsize, flags)) != TRUE ) return rc; } b.base = b.data = dataRecord(r); b.gbase = b.gstore = gTop; b.version_map = NULL; if ( (rc=init_copy_vars(&b, r->nvars)) == TRUE ) { gTop += r->gsize; rc = copy_record(valTermRef(copy), &b); free_copy_vars(&b); } if ( rc != TRUE ) return rc; assert(b.gstore == gTop); DEBUG(CHK_SECURE, checkData(valTermRef(copy))); return TRUE; } static int is_external(const char *rec, size_t len) { if ( len >= 2 ) { copy_info info; uchar m; info.data = info.base = rec; fetchBuf(&info, &m, uchar); switch(m) { case REC_HDR|REC_INT|REC_GROUND: { uint bytes = *info.data++; return len == bytes+2; } case REC_HDR|REC_ATOM|REC_GROUND: { uchar code; fetchBuf(&info, &code, uchar); switch(code) { case PL_TYPE_NIL: case PL_TYPE_DICT: return len == 2; case PL_TYPE_EXT_WATOM: case PL_TYPE_EXT_ATOM: { size_t bytes = fetchSizeInt(&info); return len == (info.data-info.base)+bytes; } } } case REC_HDR|REC_GROUND: case REC_HDR: { size_t codes = fetchSizeInt(&info); skipSizeInt(&info); /* global stack size */ if ( !(m & REC_GROUND) ) skipSizeInt(&info); /* # variables */ return len == (info.data-info.base)+codes; } default: assert(0); } } return FALSE; } #ifdef O_ATOMGC /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - We could consider some optimisation here, notably as this stuff in inderlying findall() and friends. I guess we can get rid of the recursion. Other options: combine into copyRecordToGlobal() (recorded+erase), add a list of atoms as a separate entity. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ static void skipAtom(CopyInfo b) { uint len = fetchSizeInt(b); b->data += len; } static void skipSizeInt(CopyInfo b) { while( b->data[0] & 0x80 ) b->data++; b->data++; } static void skipLong(CopyInfo b) { b->data += b->data[0] + 1; } static void scanAtomsRecord(CopyInfo b, void (*func)(atom_t a)) { size_t work = 0; do { switch( fetchOpCode(b) ) { case PL_TYPE_VARIABLE: case PL_REC_CYCLE: { skipSizeInt(b); continue; } case PL_REC_ALLOCVAR: work++; continue; #ifdef O_ATTVAR case PL_TYPE_ATTVAR: { skipSizeInt(b); work++; continue; } #endif case PL_TYPE_NIL: { (*func)(ATOM_nil); continue; } case PL_TYPE_DICT: { (*func)(ATOM_dict); continue; } case PL_TYPE_ATOM: { atom_t a = fetchWord(b); (*func)(a); continue; } case PL_TYPE_EXT_ATOM: case PL_TYPE_EXT_WATOM: { skipAtom(b); continue; } case PL_TYPE_TAGGED_INTEGER: case PL_TYPE_INTEGER: { skipLong(b); continue; } #ifdef O_BIGNUM case PL_REC_MPZ: b->data = skipMPZOnCharp(b->data); continue; case PL_REC_MPQ: b->data = skipMPQOnCharp(b->data); continue; #endif case PL_TYPE_FLOAT: case PL_TYPE_EXT_FLOAT: { skipBuf(b, double); continue; } case PL_TYPE_STRING: { uint len = fetchSizeInt(b); b->data += len; continue; } case PL_TYPE_COMPOUND: { word fdef = fetchWord(b); int arity; arity = arityFunctor(fdef); work += arity; continue; } case PL_TYPE_EXT_COMPOUND: { intptr_t arity = fetchSizeInt(b); skipAtom(b); work += arity; continue; } case PL_TYPE_CONS: { work += 2; continue; } default: assert(0); } } while ( work-- ); } #endif /*O_ATOMGC*/ /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - markAtomsRecord(DECL_LD Record record) must be called on all records that use the R_NOLOCK option. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ void markAtomsRecord(Record record) { #ifdef O_ATOMGC copy_info ci; #ifdef REC_MAGIC assert(record->magic == REC_MAGIC); #endif ci.base = ci.data = dataRecord(record); ci.version_map = NULL; scanAtomsRecord(&ci, markAtom); assert(ci.data == addPointer(record, record->size)); #endif } #ifdef O_DEBUG_ATOMGC static void unregister_atom_rec(atom_t a) { PL_unregister_atom(a); } #endif bool freeRecord(Record record) { if ( true(record, R_DUPLICATE) && --record->references > 0 ) succeed; #ifdef O_ATOMGC if ( false(record, (R_EXTERNAL|R_NOLOCK)) ) { copy_info ci; DEBUG(3, Sdprintf("freeRecord(%p)\n", record)); ci.base = ci.data = dataRecord(record); ci.version_map = NULL; #ifdef O_DEBUG_ATOMGC scanAtomsRecord(&ci, unregister_atom_rec); #else scanAtomsRecord(&ci, PL_unregister_atom); #endif assert(ci.data == addPointer(record, record->size)); } #endif PL_free(record); succeed; } void unallocRecordRef(RecordRef r) { freeHeap(r, sizeof(*r)); } static void freeRecordRef(RecordRef r) { int reclaim_now = false(r->record, R_DBREF); freeRecord(r->record); if ( reclaim_now ) freeHeap(r, sizeof(*r)); else r->record = NULL; } /******************************* * EXTERNAL RECORDS * *******************************/ int PL_recorded_external(const char *rec, term_t t) { GET_LD copy_info b; uint gsize; uchar m; int rc; b.base = b.data = rec; b.version_map = NULL; fetchBuf(&b, &m, uchar); if ( !REC_COMPAT(m) ) { if ( (m&REC_SZMASK) != REC_SZ ) { Sdprintf("PL_recorded_external(): " "Incompatible word-length (%d)\n", (m&REC_32) ? 32 : 64); fail; } else { int save_version = (m&REC_VMASK)>>REC_VSHIFT; b.version_map = v_maps[save_version]; if ( !b.version_map ) { Sdprintf("PL_recorded_external(): " "Incompatible version (%d, current %d)\n", save_version, PL_REC_VERSION); fail; } } } if ( m & (REC_INT|REC_ATOM) ) /* primitive cases */ { if ( m & REC_INT ) { int64_t v = fetchInt64(&b); rc = PL_put_int64(t, v); } else { atom_t a; int code = fetchOpCode(&b); switch(code) { case PL_TYPE_NIL: return PL_put_nil(t); case PL_TYPE_DICT: return PL_put_atom(t, ATOM_dict); case PL_TYPE_EXT_ATOM: fetchAtom(&b, &a); break; case PL_TYPE_EXT_WATOM: fetchAtomW(&b, &a); break; default: a = 0; assert(0); } rc = PL_put_atom(t, a); PL_unregister_atom(a); } return rc; } skipSizeInt(&b); /* code-size */ gsize = fetchSizeInt(&b); if ( !(b.gbase = b.gstore = allocGlobal(gsize)) ) return FALSE; /* global stack overflow */ b.dicts = 0; if ( !(m & REC_GROUND) ) { uint nvars = fetchSizeInt(&b); if ( (rc=init_copy_vars(&b, nvars)) == TRUE ) { rc = copy_record(valTermRef(t), &b); free_copy_vars(&b); } } else { rc = copy_record(valTermRef(t), &b); } if ( rc != TRUE ) return raiseStackOverflow(rc); assert(b.gstore == gTop); if ( b.dicts ) resortDictsInTerm(t); DEBUG(CHK_SECURE, checkData(valTermRef(t))); return TRUE; } int PL_erase_external(char *rec) { PL_free(rec); return TRUE; } /******************************** * PROLOG CONNECTION * *********************************/ /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - The key is stored as an atom, integer or functor header as found on the global-stack. A functor is a type with the same mask as an atom, but using the STG_GLOBAL storage indicator. So, the first line denotes a real atom. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ bool unifyKey(term_t key, word val) { GET_LD if ( isAtom(val) || isTaggedInt(val) ) { return _PL_unify_atomic(key, val); } else { return PL_unify_functor(key, (functor_t) val); } } int getKeyEx(DECL_LD term_t key, word *w) { Word k = valTermRef(key); deRef(k); if ( isAtom(*k) || isTaggedInt(*k) ) *w = *k; else if ( isTerm(*k) ) *w = (word)functorTerm(*k); else return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_key, key); succeed; } static PRED_IMPL("current_key", 1, current_key, PL_FA_NONDETERMINISTIC) { PRED_LD fid_t fid; TableEnum e; word k = 0L; switch( CTX_CNTRL ) { case FRG_FIRST_CALL: { if ( PL_is_variable(A1) ) { e = newTableEnum(GD->recorded_db.record_lists); break; } else if ( getKeyEx(A1, &k) && isCurrentRecordList(k, TRUE) ) succeed; fail; } case FRG_REDO: e = CTX_PTR; break; case FRG_CUTTED: e = CTX_PTR; freeTableEnum(e); /*FALLTHROUGH*/ default: /* fool gcc */ return TRUE; } if ( (fid = PL_open_foreign_frame()) ) { void *sk, *sv; while(advanceTableEnum(e, &sk, &sv)) { RecordList rl = sv; RecordRef record; PL_LOCK(L_RECORD); record = firstRecordRecordList(rl); PL_UNLOCK(L_RECORD); if ( record && unifyKey(A1, rl->key) ) { PL_close_foreign_frame(fid); ForeignRedoPtr(e); } PL_rewind_foreign_frame(fid); } PL_close_foreign_frame(fid); } freeTableEnum(e); return FALSE; } static bool record(term_t key, term_t term, term_t ref, record_az az) { GET_LD word k = 0L; DEBUG(3, Sdprintf("record() of "); PL_write_term(Serror, term, 1200, PL_WRT_ATTVAR_WRITE); Sdprintf("\n")); if ( !getKeyEx(key, &k) ) fail; if ( ref && !PL_is_variable(ref) ) return PL_uninstantiation_error(ref); return PL_record_az(k, term, ref, az); } int PL_record_az(word k, term_t term, term_t ref, record_az az) { GET_LD RecordList l; RecordRef r; Record copy; if ( !(copy = compileTermToHeap(term, 0)) ) return PL_no_memory(); r = allocHeapOrHalt(sizeof(*r)); r->record = copy; if ( ref && !PL_unify_recref(ref, r) ) { PL_erase(copy); freeHeap(r, sizeof(*r)); return FALSE; } PL_LOCK(L_RECORD); l = lookupRecordList(k); r->list = l; if ( !l->firstRecord ) { r->next = r->prev = NULL; l->firstRecord = l->lastRecord = r; } else if ( az == RECORDA ) { r->prev = NULL; r->next = l->firstRecord; l->firstRecord->prev = r; l->firstRecord = r; } else { r->next = NULL; r->prev = l->lastRecord; l->lastRecord->next = r; l->lastRecord = r; } PL_UNLOCK(L_RECORD); succeed; } static PRED_IMPL("recorda", va, recorda, 0) { return record(A1, A2, CTX_ARITY == 3 ? A3 : 0, RECORDA); } static PRED_IMPL("recordz", va, recordz, 0) { return record(A1, A2, CTX_ARITY == 3 ? A3 : 0, RECORDZ); } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - recorded/2,3. The state enumerates keys using the `e` member if the key is unbound on entry. The `r` member is the current record. Enumeration first scans the records and then, if `e` is set, advanced to the next key. All manipulation on the state is done whild holding L_RECORD. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ typedef struct { TableEnum e; /* enumerating over keys */ RecordRef r; /* current record */ int saved; } recorded_state; static recorded_state * save_state(recorded_state *state) { if ( state->saved ) { return state; } else { recorded_state *newstate = allocForeignState(sizeof(*state)); memcpy(newstate, state, sizeof(*state)); newstate->saved = TRUE; return newstate; } } /* MT: must hold L_RECORD */ static void free_state(recorded_state *state) { if ( state->e ) freeTableEnum(state->e); if ( state->r ) { RecordList rl = state->r->list; if ( --rl->references == 0 && true(rl, RL_DIRTY) ) cleanRecordList(rl); } if ( state->saved ) freeForeignState(state, sizeof(*state)); } /* set state to the next non-erased record. Cleanup the record list if we reached the end. */ static RecordRef advance_state(recorded_state *state) { RecordRef r = state->r; do { if ( !r->next ) { RecordList rl = r->list; if ( --rl->references == 0 && true(rl, RL_DIRTY) ) cleanRecordList(rl); } r = r->next; } while ( r && true(r->record, R_ERASED) ); state->r = r; return r; } static PRED_IMPL("recorded", va, recorded, PL_FA_NONDETERMINISTIC) { PRED_LD recorded_state state_buf; recorded_state *state = &state_buf; word k = 0L; int rc; fid_t fid; term_t key = A1; term_t term = A2; term_t ref = (CTX_ARITY == 3 ? A3 : 0); switch( CTX_CNTRL ) { case FRG_FIRST_CALL: { if ( ref && !PL_is_variable(ref) ) /* recorded(?,?,+) */ { RecordRef record; if ( PL_get_recref(ref, &record) ) { PL_LOCK(L_RECORD); if ( unifyKey(key, record->list->key) ) { term_t copy = PL_new_term_ref(); if ( (rc=copyRecordToGlobal(copy, record->record, ALLOW_GC)) < 0 ) rc = raiseStackOverflow(rc); else rc = PL_unify(term, copy); } else rc = FALSE; PL_UNLOCK(L_RECORD); return rc; } return FALSE; } memset(state, 0, sizeof(*state)); if ( PL_is_variable(key) ) { state->e = newTableEnum(GD->recorded_db.record_lists); PL_LOCK(L_RECORD); } else if ( getKeyEx(key, &k) ) { RecordList rl; if ( !(rl = isCurrentRecordList(k, TRUE)) ) return FALSE; PL_LOCK(L_RECORD); rl->references++; state->r = rl->firstRecord; if ( true(state->r->record, R_ERASED) ) advance_state(state); } else { return FALSE; } break; } case FRG_REDO: { state = CTX_PTR; PL_LOCK(L_RECORD); break; } case FRG_CUTTED: { state = CTX_PTR; PL_LOCK(L_RECORD); free_state(state); PL_UNLOCK(L_RECORD); } /*FALLTHROUGH*/ default: succeed; } /* Now holding L_RECORD */ if ( (fid = PL_open_foreign_frame()) ) { int answered = FALSE; term_t copy = 0; while( !answered ) { for( ; state->r; advance_state(state) ) { RecordRef record; next: record = state->r; if ( !copy && !(copy = PL_new_term_ref()) ) goto error; if ( (rc=copyRecordToGlobal(copy, record->record, ALLOW_GC)) < 0 ) { raiseStackOverflow(rc); goto error; } if ( PL_unify(term, copy) && (!ref || PL_unify_recref(ref, record)) ) { if ( state->e && !unifyKey(key, record->list->key) ) goto error; /* stack overflow */ } else { if ( PL_exception(0) ) goto error; PL_rewind_foreign_frame(fid); continue; } answered = TRUE; if ( record->next ) { state->r = record->next; PL_UNLOCK(L_RECORD); PL_close_foreign_frame(fid); ForeignRedoPtr(save_state(state)); } } if ( state->e ) { void *sk, *sv; while(advanceTableEnum(state->e, &sk, &sv)) { RecordList rl = sv; RecordRef r; if ( (r=firstRecordRecordList(rl)) ) { rl->references++; state->r = r; if ( answered ) break; goto next; /* try next list */ } } } if ( answered ) { PL_close_foreign_frame(fid); if ( state->e ) { PL_UNLOCK(L_RECORD); ForeignRedoPtr(save_state(state)); } else { free_state(state); PL_UNLOCK(L_RECORD); return TRUE; } } break; } error: PL_close_foreign_frame(fid); } free_state(state); PL_UNLOCK(L_RECORD); return FALSE; } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Rewrite `p ?=> g1, g2, !, body` to `p, g1, g2 => body`. TBD: Also use this to move rule/2,3 to C? - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ #define fixup_ssu(in, out) LDFUNC(fixup_ssu, in, out) static int fixup_ssu(DECL_LD term_t in, term_t out) { term_t head = PL_new_term_ref(); term_t body = PL_new_term_ref(); term_t guard = PL_new_term_ref(); _PL_get_arg(1, in, head); _PL_get_arg(2, in, body); while ( PL_is_functor(body, FUNCTOR_comma2) ) { term_t g = PL_new_term_ref(); atom_t a; if ( !g ) return FALSE; _PL_get_arg(1, body, g); _PL_get_arg(2, body, body); if ( PL_get_atom(g, &a) && a == ATOM_cut ) { if ( !PL_put_term(guard, --g) ) return FALSE; while(--g > guard) { if ( !PL_cons_functor(guard, FUNCTOR_comma2, g, guard) || !PL_cons_functor(head, FUNCTOR_comma2, head, guard) ) return FALSE; } return PL_unify_term(out, PL_FUNCTOR, FUNCTOR_ssu_commit2, PL_TERM, head, PL_TERM, body); } } return PL_unify(in, out); } /** instance(+Ref, -Term) */ static PRED_IMPL("instance", 2, instance, 0) { PRED_LD void *ptr; db_ref_type type; term_t ref = A1; term_t term = A2; if ( !(ptr=PL_get_dbref(ref, &type)) ) return FALSE; if ( type == DB_REF_CLAUSE ) { ClauseRef cref = ptr; Clause clause = cref->value.clause; gen_t generation = generationFrame(environment_frame); if ( true(clause, GOAL_CLAUSE) || !visibleClause(clause, generation) ) return FALSE; if ( true(clause, UNIT_CLAUSE) ) { term_t head = PL_new_term_ref(); return ( decompile(clause, head, 0) && PL_unify_term(term, PL_FUNCTOR, FUNCTOR_prove2, PL_TERM, head, PL_ATOM, ATOM_true) ); } else if ( true(clause, SSU_CHOICE_CLAUSE) ) { term_t tmp = PL_new_term_ref(); return ( decompile(clause, tmp, 0) && fixup_ssu(tmp, term) ); } else { return decompile(clause, term, 0); } } else { RecordRef rref = ptr; term_t t = PL_new_term_ref(); if ( copyRecordToGlobal(t, rref->record, ALLOW_GC) == TRUE ) return PL_unify(term, t); } return FALSE; } static PRED_IMPL("erase", 1, erase, 0) { void *ptr; RecordList l; db_ref_type type; term_t ref = A1; if ( !(ptr=PL_get_dbref(ref, &type)) ) return FALSE; if ( type == DB_REF_CLAUSE ) { ClauseRef cref = ptr; Clause clause = cref->value.clause; Definition def = clause->predicate; if ( !true(def, P_DYNAMIC) ) return PL_error("erase", 1, NULL, ERR_PERMISSION, ATOM_clause, ATOM_erase, ref); return retractClauseDefinition(def, clause, TRUE); } else { RecordRef r = ptr; int rc; rc = callEventHook(PLEV_ERASED_RECORD, r); PL_LOCK(L_RECORD); l = r->list; if ( l->references ) /* a recorded has choicepoints */ { set(r->record, R_ERASED); set(l, RL_DIRTY); } else { remove_record(r); } PL_UNLOCK(L_RECORD); return rc; } } /******************************* * PUBLISH PREDICATES * *******************************/ #define NDET PL_FA_NONDETERMINISTIC BeginPredDefs(rec) PRED_SHARE("recorded", 2, recorded, NDET) PRED_SHARE("recorded", 3, recorded, NDET) PRED_SHARE("recordz", 2, recordz, 0) PRED_SHARE("recordz", 3, recordz, 0) PRED_SHARE("recorda", 2, recorda, 0) PRED_SHARE("recorda", 3, recorda, 0) PRED_DEF("erase", 1, erase, 0) PRED_DEF("instance", 2, instance, 0) PRED_DEF("current_key", 1, current_key, NDET) PRED_DEF("fast_term_serialized", 2, fast_term_serialized, 0) PRED_DEF("fast_write", 2, fast_write, 0) PRED_DEF("fast_read", 2, fast_read, 0) EndPredDefs