static AtomEntry * lookupBlob(void *blob, size_t len, PL_blob_t *type) { BlobPropEntry *b; AtomEntry *ae; LOCK(SWI_Blobs_Lock); if (type->flags & PL_BLOB_UNIQUE) { /* just keep a linked chain for now */ ae = SWI_Blobs; while (ae) { if (ae->PropsOfAE && RepBlobProp(ae->PropsOfAE)->blob_t == type && ae->rep.blob->length == len && !memcmp(ae->rep.blob->data, blob, len)) { UNLOCK(SWI_Blobs_Lock); return ae; } ae = RepAtom(ae->NextOfAE); } } b = (BlobPropEntry *)Yap_AllocCodeSpace(sizeof(BlobPropEntry)); if (!b) { UNLOCK(SWI_Blobs_Lock); return NULL; } b->NextOfPE = NIL; b->KindOfPE = BlobProperty; b->blob_t = type; ae = (AtomEntry *)Yap_AllocCodeSpace(sizeof(AtomEntry)+len+sizeof(size_t)); if (!ae) { UNLOCK(SWI_Blobs_Lock); return NULL; } NOfBlobs++; INIT_RWLOCK(ae->ARWLock); ae->PropsOfAE = AbsBlobProp(b); ae->NextOfAE = AbsAtom(SWI_Blobs); ae->rep.blob->length = len; memcpy(ae->rep.blob->data, blob, len); SWI_Blobs = ae; UNLOCK(SWI_Blobs_Lock); if (NOfBlobs > NOfBlobsMax) { Yap_signal(YAP_CDOVF_SIGNAL); } return ae; }
static char *Yap_AlwaysAllocCodeSpace(UInt size) { char *out; while (!(out = Yap_AllocCodeSpace(size))) { if (!Yap_growheap(FALSE, size, NULL)) { return NULL; } } return out; }
static void InitDBErasedMarker(void) { DBErasedMarker = (DBRef)Yap_AllocCodeSpace(sizeof(DBStruct)); Yap_LUClauseSpace += sizeof(DBStruct); DBErasedMarker->id = FunctorDBRef; DBErasedMarker->Flags = ErasedMask; DBErasedMarker->Code = NULL; DBErasedMarker->DBT.DBRefs = NULL; DBErasedMarker->Parent = NULL; }
Atom Yap_LookupMaybeWideAtomWithLength( const wchar_t *atom, size_t len0) { /* lookup atom in atom table */ Atom at; int wide = FALSE; size_t i = 0; while (i < len0) { // primary support for atoms with null chars wchar_t c = atom[i]; if (c > 255) { wide = TRUE; break; } if (c == '\0') { len0 = i; break; } i++; } if (wide) { wchar_t *ptr0; ptr0 = (wchar_t *)Yap_AllocCodeSpace(sizeof(wchar_t) * (len0 + 1)); if (!ptr0) return NIL; memcpy(ptr0, atom, len0 * sizeof(wchar_t)); ptr0[len0] = '\0'; at = LookupWideAtom(ptr0); Yap_FreeCodeSpace((char *)ptr0); return at; } else { unsigned char *ptr0; ptr0 = Yap_AllocCodeSpace((len0 + 1)); if (!ptr0) return NIL; for (i = 0; i < len0; i++) ptr0[i] = atom[i]; ptr0[len0] = '\0'; at = LookupAtom(ptr0); Yap_FreeCodeSpace(ptr0); return at; } }
/****** we now have one extra user indexed predicate. We assume these are few, so we can do with a linked list. ******/ static int add_udi_block(void *info, PredEntry *p, UdiControlBlock cmd) { UdiInfo blk = (UdiInfo)Yap_AllocCodeSpace(sizeof(struct udi_info)); if (!blk) return FALSE; blk->next = UdiControlBlocks; UdiControlBlocks = blk; blk->p = p; blk->functions = cmd; blk->cb = info; return TRUE; }
Atom Yap_LookupMaybeWideAtomWithLength(wchar_t *atom, size_t len) { /* lookup atom in atom table */ wchar_t *p = atom, c; size_t len0 = 0; Atom at; int wide = FALSE; while ((c = *p++)) { if (c > 255) wide = TRUE; len0++; if (len0 == len) break; } if (p[0] == '\0' && wide) return LookupWideAtom(atom); else if (wide) { wchar_t *ptr, *ptr0; p = atom; ptr0 = ptr = (wchar_t *)Yap_AllocCodeSpace(sizeof(wchar_t)*(len+1)); if (!ptr) return NIL; while (len--) {*ptr++ = *p++;} ptr[0] = '\0'; at = LookupWideAtom(ptr0); Yap_FreeCodeSpace((char *)ptr0); return at; } else { char *ptr, *ptr0; /* not really a wide atom */ p = atom; ptr0 = ptr = Yap_AllocCodeSpace(len+1); if (!ptr) return NIL; while (len--) {*ptr++ = *p++;} ptr[0] = '\0'; at = LookupAtom(ptr0); Yap_FreeCodeSpace(ptr0); return at; } }
Atom Yap_LookupAtomWithLength(const char *atom, size_t len0) { /* lookup atom in atom table */ Atom at; unsigned char *ptr; /* not really a wide atom */ ptr = Yap_AllocCodeSpace(len0 + 1); if (!ptr) return NIL; memcpy(ptr, atom, len0); ptr[len0] = '\0'; at = LookupAtom(ptr); Yap_FreeCodeSpace(ptr); return at; }
static void InitLogDBErasedMarker(void) { LogDBErasedMarker = (LogUpdClause *)Yap_AllocCodeSpace( sizeof(LogUpdClause) + (UInt)NEXTOP((yamop *)NULL, e)); Yap_LUClauseSpace += sizeof(LogUpdClause) + (UInt)NEXTOP((yamop *)NULL, e); LogDBErasedMarker->Id = FunctorDBRef; LogDBErasedMarker->ClFlags = ErasedMask | LogUpdMask; LogDBErasedMarker->lusl.ClSource = NULL; LogDBErasedMarker->ClRefCount = 0; LogDBErasedMarker->ClExt = NULL; LogDBErasedMarker->ClPrev = NULL; LogDBErasedMarker->ClNext = NULL; LogDBErasedMarker->ClSize = (UInt)NEXTOP(((LogUpdClause *)NULL)->ClCode, e); LogDBErasedMarker->ClCode->opc = Yap_opcode(_op_fail); INIT_CLREF_COUNT(LogDBErasedMarker); }
static BBProp PutIntBBProp(Int key, Term mod USES_REGS) /* get BBentry for at; */ { Prop p0; BBProp p; UInt hash_key; if (INT_BB_KEYS == NULL) { INT_BB_KEYS = (Prop *)Yap_AllocCodeSpace(sizeof(Prop)*INT_BB_KEYS_SIZE); if (INT_BB_KEYS != NULL) { UInt i = 0; Prop *pp = INT_BB_KEYS; for (i = 0; i < INT_BB_KEYS_SIZE; i++) { pp[0] = NIL; pp++; } } else { Yap_Error(OUT_OF_HEAP_ERROR,ARG1,"could not allocate space in bb_put/2"); return(NULL); } } hash_key = (CELL)key % INT_BB_KEYS_SIZE; p0 = INT_BB_KEYS[hash_key]; p = RepBBProp(p0); while (p0 != NIL && (!IsBBProperty(p->KindOfPE) || key != (Int)(p->KeyOfBB) || (p->ModuleOfBB != mod))) { p = RepBBProp(p0 = p->NextOfPE); } if (p0 == NIL) { YAPEnterCriticalSection(); p = (BBProp)Yap_AllocAtomSpace(sizeof(*p)); if (p == NULL) { YAPLeaveCriticalSection(); Yap_Error(OUT_OF_HEAP_ERROR,ARG1,"could not allocate space in bb_put/2"); return(NULL); } p->ModuleOfBB = mod; p->Element = 0L; p->KeyOfBB = (Atom)key; p->KindOfPE = BBProperty; p->NextOfPE = INT_BB_KEYS[hash_key]; INT_BB_KEYS[hash_key] = AbsBBProp(p); YAPLeaveCriticalSection(); } return (p); }
/* mask a hash table that allows for fast reverse translation from instruction address to corresponding opcode */ static void InitReverseLookupOpcode(void) { op_entry *opeptr; op_numbers i; /* 2 K should be OK */ int hash_size_mask = OP_HASH_SIZE-1; UInt sz = OP_HASH_SIZE*sizeof(struct opcode_tab_entry); while (OP_RTABLE == NULL) { if ((OP_RTABLE = (op_entry *)Yap_AllocCodeSpace(sz)) == NULL) { if (!Yap_growheap(FALSE, sz, NULL)) { Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "Couldn't obtain space for the reverse translation opcode table"); } } } memset(OP_RTABLE, 0, sz); opeptr = OP_RTABLE; /* clear up table */ { int j; for (j=0; j<OP_HASH_SIZE; j++) { opeptr[j].opc = 0; opeptr[j].opnum = _Ystop; } } opeptr = OP_RTABLE; opeptr[rtable_hash_op(Yap_opcode(_Ystop),hash_size_mask)].opc = Yap_opcode(_Ystop); /* now place entries */ for (i = _std_top; i > _Ystop; i--) { OPCODE opc = Yap_opcode(i); int j = rtable_hash_op(opc,hash_size_mask); while (opeptr[j].opc) { if (++j > hash_size_mask) j = 0; } /* clear entry, no conflict */ opeptr[j].opnum = i; opeptr[j].opc = opc; } }
Atom Yap_LookupMaybeWideAtom(wchar_t *atom) { /* lookup atom in atom table */ wchar_t *p = atom, c; size_t len = 0; char *ptr, *ptr0; Atom at; while ((c = *p++)) { if (c > 255) return LookupWideAtom(atom); len++; } /* not really a wide atom */ p = atom; ptr0 = ptr = Yap_AllocCodeSpace(len+1); if (!ptr) return NIL; while ((*ptr++ = *p++)); at = LookupAtom(ptr0); Yap_FreeCodeSpace(ptr0); return at; }
/* * New user indexed predicate: * the first argument is the term. */ static YAP_Int p_new_udi( USES_REGS1 ) { Term spec = Deref(ARG1); PredEntry *p; UdiInfo blk; int info; /* get the predicate from the spec, copied from cdmgr.c */ if (IsVarTerm(spec)) { Yap_Error(INSTANTIATION_ERROR,spec,"new user index/1"); return FALSE; } else if (!IsApplTerm(spec)) { Yap_Error(TYPE_ERROR_COMPOUND,spec,"new user index/1"); return FALSE; } else { Functor fun = FunctorOfTerm(spec); Term tmod = CurrentModule; while (fun == FunctorModule) { tmod = ArgOfTerm(1,spec); if (IsVarTerm(tmod) ) { Yap_Error(INSTANTIATION_ERROR, spec, "new user index/1"); return FALSE; } if (!IsAtomTerm(tmod) ) { Yap_Error(TYPE_ERROR_ATOM, spec, "new user index/1"); return FALSE; } spec = ArgOfTerm(2, spec); fun = FunctorOfTerm(spec); } p = RepPredProp(PredPropByFunc(fun, tmod)); } if (!p) return FALSE; /* boring, boring, boring! */ if ((p->PredFlags & (DynamicPredFlag|LogUpdatePredFlag|UserCPredFlag|CArgsPredFlag|NumberDBPredFlag|AtomDBPredFlag|TestPredFlag|AsmPredFlag|CPredFlag|BinaryPredFlag)) || (p->ModuleOfPred == PROLOG_MODULE)) { Yap_Error(PERMISSION_ERROR_MODIFY_STATIC_PROCEDURE, spec, "udi/2"); return FALSE; } if (p->PredFlags & (DynamicPredFlag|LogUpdatePredFlag|TabledPredFlag)) { Yap_Error(PERMISSION_ERROR_ACCESS_PRIVATE_PROCEDURE, spec, "udi/2"); return FALSE; } /* TODO: remove AtomRTree from atom list */ /* this is the real work */ blk = (UdiInfo) Yap_AllocCodeSpace(sizeof(struct udi_info)); memset((void *) blk,0, sizeof(struct udi_info)); if (!blk) { Yap_Error(OUT_OF_HEAP_ERROR, spec, "new user index/1"); return FALSE; } /*Init UdiInfo */ utarray_new(blk->args, &arg_icd); utarray_new(blk->clauselist, &cl_icd); blk->p = p; /*Now Init args list*/ info = p_udi_args_init(spec, p->ArityOfPE, blk); if (!info) { utarray_free(blk->args); utarray_free(blk->clauselist); Yap_FreeCodeSpace((char *) blk); return FALSE; } /*Push into the hash*/ HASH_ADD_UdiInfo(UdiControlBlocks, p, blk); p->PredFlags |= UDIPredFlag; return TRUE; }
/* * LoadForeign(ofiles,libs,proc_name,init_proc) dynamically loads foreign * code files and libraries and locates an initialization routine */ static Int LoadForeign(StringList ofiles, StringList libs, char *proc_name, YapInitProc *init_proc) { char command[2*MAXPATHLEN]; char o_files[1024]; /* list of objects we want to load */ char l_files[1024]; /* list of libraries we want to load */ char tmp_buff[32] = "/tmp/YAP_TMP_XXXXXX"; /* used for mktemp */ char *tfile; /* name of temporary file */ int fildes; /* temp file descriptor */ struct aouthdr sysHeader; struct filehdr fileHeader; struct scnhdr sectionHeader[MAXSECTIONS]; struct exec header; /* header for loaded file */ unsigned long loadImageSize, firstloadImSz; /* size of image we will load */ char *FCodeBase; /* where we load foreign code */ /* * put in a string the names of the files you want to load and of any * libraries you want to use */ /* files first */ *o_files = '\0'; { StringList tmp = ofiles; while(tmp != NULL) { strcat(o_files," "); strcat(o_files,tmp->s); tmp = tmp->next; } } /* same_trick for libraries */ *l_files = '\0'; { StringList tmp = libs; while(tmp != NULL) { strcat(l_files," "); strcat(l_files,tmp->s); tmp = tmp->next; } } /* next, create a temp file to serve as loader output */ tfile = mktemp(tmp_buff); /* prepare the magic */ if (strlen(o_files) + strlen(l_files) + strlen(proc_name) + strlen(YapExecutable) > 2*MAXPATHLEN) { strcpy(Yap_ErrorSay, " too many parameters in load_foreign/3 "); return LOAD_FAILLED; } sprintf(command, "/usr/bin/ld -N -A %s -o %s %s %s -lc", YapExecutable, tfile, o_files, l_files); /* now, do the magic */ if (system(command) != 0) { unlink(tfile); strcpy(Yap_ErrorSay," ld returned error status in load_foreign_files "); return LOAD_FAILLED; } /* now check the music has played */ if ((fildes = open(tfile, O_RDONLY)) < 0) { strcpy(Yap_ErrorSay," unable to open temp file in load_foreign_files "); return LOAD_FAILLED; } /* it did, get the mice */ /* first, get the header */ read(fildes, (char *) &fileHeader, sizeof(fileHeader)); read(fildes, (char *) &sysHeader, sizeof(sysHeader)); { int i; for (i = 0; i < fileHeader.f_nscns; i++) read(fildes, (char *) §ionHeader[i], sizeof(*sectionHeader)); } close(fildes); /* get the full size of what we need to load */ loadImageSize = sysHeader.tsize + sysHeader.dsize + sysHeader.bsize; #ifdef mips /* add an extra page in mips machines */ loadImageSize += 4095 + 16; #else /* add 16 just to play it safe */ loadImageSize += 16; #endif /* keep this copy */ firstloadImSz = loadImageSize; /* now fetch the space we need */ if (!(FCodeBase = Yap_AllocCodeSpace((int) loadImageSize)) #ifdef pyr || activate_code(ForeignCodeBase, u1) #endif /* pyr */ ) { strcpy(Yap_ErrorSay," unable to allocate space for external code "); return LOAD_FAILLED; } #ifdef mips FCodeBase = (char *) (Unsigned(FCodeBase + PAGESIZE - 1) & ~(PAGESIZE - 1)); #endif /* now, a new incantation to load the new foreign code */ #ifdef convex /* No -N flag in the Convex loader */ /* -T option does not want MallocBase bit set */ sprintf(command, "ld -x -A %s -T %lx -o %s -u %s %s %s -lc", ostabf, ((unsigned long) (((unsigned long) (ForeignCodeBase)) & ((unsigned long) (~Yap_HeapBase)) ) ), tfile, entry_point, o_files, l_files); #else #ifdef mips sprintf(command, "ld -systype bsd43 -N -A %s -T %lx -o %s -u %s %s %s -lc", ostabf, (unsigned long) ForeignCodeBase, tfile, entry_point, o_files, l_files); #else sprintf(command, "ld -N -A %s -T %lx -o %s -e %s -u _%s %s -lc", ostabf, (unsigned long) ForeignCodeBase, tfile, entry_point, o_files, l_files); #endif /* mips */ #endif /* convex */ /* and do it */ if (system(command) != 0) { unlink(tfile); strcpy(Yap_ErrorSay," ld returned error status in load_foreign_files "); return LOAD_FAILLED; } if ((fildes = open(tfile, O_RDONLY)) < 0) { strcpy(Yap_ErrorSay," unable to open temp file in load_foreign_files "); return LOAD_FAILLED; } read(fildes, (char *) &fileHeader, sizeof(fileHeader)); read(fildes, (char *) &sysHeader, sizeof(sysHeader)); { int i; for (i = 0; i < fileHeader.f_nscns; i++) read(fildes, (char *) §ionHeader[i], sizeof(*sectionHeader)); } loadImageSize = sysHeader.tsize + sysHeader.dsize + sysHeader.bsize; if (firstloadImSz < loadImageSize) { strcpy(Yap_ErrorSay," miscalculation in load_foreign/3 "); return LOAD_FAILLED; } /* now search for our init function */ { char entry_fun[256]; struct nlist func_info[2]; #if defined(mips) || defined(I386) char NAME1[128], NAME2[128]; func_info[0].n_name = NAME1; func_info[1].n_name = NAME2; #endif /* COFF */ sprintf(entry_fun, "_%s", proc_name); func_info[0].n_name = entry_fun; func_info[1].n_name = NULL; if (nlist(tfile, func_info) == -1) { strcpy(Yap_ErrorSay," in nlist(3) "); return LOAD_FAILLED; } if (func_info[0].n_type == 0) { strcpy(Yap_ErrorSay," in nlist(3) "); return LOAD_FAILLED; } *init_proc = (YapInitProc)(func_info[0].n_value); } /* ok, we got our init point */ /* now read our text */ lseek(fildes, (long)(N_TXTOFF(header)), 0); { unsigned int u1 = header.a_text + header.a_data; read(fildes, (char *) FCodeBase, u1); /* zero the BSS segment */ while (u1 < loadImageSize) FCodeBase[u1++] = 0; } close(fildes); unlink(tfile); return LOAD_SUCCEEDED; }
void Yap_InitCPredBack_(const char *Name, arity_t Arity, arity_t Extra, CPredicate Start, CPredicate Cont, CPredicate Cut, pred_flags_t flags) { CACHE_REGS PredEntry *pe = NULL; Atom atom = NIL; Functor f = NULL; while (atom == NIL) { atom = Yap_FullLookupAtom(Name); if (atom == NIL && !Yap_growheap(FALSE, 0L, NULL)) { Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "while initializing %s", Name); return; } } if (Arity) { while (!f) { f = Yap_MkFunctor(atom, Arity); if (!f && !Yap_growheap(FALSE, 0L, NULL)) { Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "while initializing %s", Name); return; } } } while (pe == NULL) { if (Arity) pe = RepPredProp(PredPropByFunc(f, CurrentModule)); else pe = RepPredProp(PredPropByAtom(atom, CurrentModule)); if (!pe && !Yap_growheap(FALSE, sizeof(PredEntry), NULL)) { Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "while initializing %s", Name); return; } } if (pe->cs.p_code.FirstClause != NIL) { flags = update_flags_from_prolog(flags, pe); CleanBack(pe, Start, Cont, Cut); } else { StaticClause *cl; yamop *code = ((StaticClause *)NULL)->ClCode; UInt sz = (CELL)NEXTOP(NEXTOP(NEXTOP(NEXTOP(code, OtapFs), OtapFs), OtapFs), l); if (flags & UserCPredFlag) pe->PredFlags = UserCPredFlag | BackCPredFlag | CompiledPredFlag | flags; else pe->PredFlags = CompiledPredFlag | StandardPredFlag | BackCPredFlag; #ifdef YAPOR pe->PredFlags |= SequentialPredFlag; #endif /* YAPOR */ cl = (StaticClause *)Yap_AllocCodeSpace(sz); if (cl == NULL) { Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "No Heap Space in InitCPredBack"); return; } cl->ClFlags = StaticMask; cl->ClNext = NULL; Yap_ClauseSpace += sz; cl->ClSize = (CELL)NEXTOP(NEXTOP(NEXTOP(NEXTOP(code, OtapFs), OtapFs), OtapFs), e); cl->usc.ClLine = Yap_source_line_no(); code = cl->ClCode; pe->cs.p_code.TrueCodeOfPred = pe->CodeOfPred = pe->cs.p_code.FirstClause = pe->cs.p_code.LastClause = code; if (flags & UserCPredFlag) pe->OpcodeOfPred = code->opc = Yap_opcode(_try_userc); else pe->OpcodeOfPred = code->opc = Yap_opcode(_try_c); code->y_u.OtapFs.f = Start; code->y_u.OtapFs.p = pe; code->y_u.OtapFs.s = Arity; code->y_u.OtapFs.extra = Extra; #ifdef YAPOR INIT_YAMOP_LTT(code, 2); PUT_YAMOP_SEQ(code); #endif /* YAPOR */ code = NEXTOP(code, OtapFs); if (flags & UserCPredFlag) code->opc = Yap_opcode(_retry_userc); else code->opc = Yap_opcode(_retry_c); code->y_u.OtapFs.f = Cont; code->y_u.OtapFs.p = pe; code->y_u.OtapFs.s = Arity; code->y_u.OtapFs.extra = Extra; #ifdef YAPOR INIT_YAMOP_LTT(code, 1); PUT_YAMOP_SEQ(code); #endif /* YAPOR */ code = NEXTOP(code, OtapFs); if (flags & UserCPredFlag) code->opc = Yap_opcode(_cut_userc); else code->opc = Yap_opcode(_cut_c); code->y_u.OtapFs.f = Cut; code->y_u.OtapFs.p = pe; code->y_u.OtapFs.s = Arity; code->y_u.OtapFs.extra = Extra; code = NEXTOP(code, OtapFs); code->opc = Yap_opcode(_Ystop); code->y_u.l.l = cl->ClCode; } }
void Yap_InitAsmPred(const char *Name, arity_t Arity, int code, CPredicate def, pred_flags_t flags) { CACHE_REGS Atom atom = NIL; PredEntry *pe = NULL; Functor f = NULL; while (atom == NIL) { atom = Yap_FullLookupAtom(Name); if (atom == NIL && !Yap_growheap(FALSE, 0L, NULL)) { Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "while initializing %s", Name); return; } } if (Arity) { while (!f) { f = Yap_MkFunctor(atom, Arity); if (!f && !Yap_growheap(FALSE, 0L, NULL)) { Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "while initializing %s", Name); return; } } } while (pe == NULL) { if (Arity) pe = RepPredProp(PredPropByFunc(f, CurrentModule)); else pe = RepPredProp(PredPropByAtom(atom, CurrentModule)); if (!pe && !Yap_growheap(FALSE, sizeof(PredEntry), NULL)) { Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "while initializing %s", Name); return; } } flags |= AsmPredFlag | StandardPredFlag | (code); if (pe->PredFlags & AsmPredFlag) { flags = update_flags_from_prolog(flags, pe); /* already exists */ } pe->PredFlags = flags; pe->cs.f_code = def; pe->ModuleOfPred = CurrentModule; if (def != NULL) { yamop *p_code = ((StaticClause *)NULL)->ClCode; StaticClause *cl; if (pe->CodeOfPred == (yamop *)(&(pe->OpcodeOfPred))) { if (flags & SafePredFlag) { cl = (StaticClause *)Yap_AllocCodeSpace( (CELL)NEXTOP(NEXTOP(NEXTOP(((yamop *)p_code), Osbpp), p), l)); } else { cl = (StaticClause *)Yap_AllocCodeSpace((CELL)NEXTOP( NEXTOP(NEXTOP(NEXTOP(NEXTOP(((yamop *)p_code), e), Osbpp), p), p), l)); } if (!cl) { Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "No Heap Space in InitAsmPred"); return; } Yap_ClauseSpace += (CELL)NEXTOP(NEXTOP(NEXTOP(((yamop *)p_code), Osbpp), p), l); } else { cl = ClauseCodeToStaticClause(pe->CodeOfPred); } cl->ClFlags = StaticMask; cl->ClNext = NULL; if (flags & SafePredFlag) { cl->ClSize = (CELL)NEXTOP(NEXTOP(NEXTOP(((yamop *)p_code), Osbpp), e), e); } else { cl->ClSize = (CELL)NEXTOP( NEXTOP(NEXTOP(NEXTOP(NEXTOP(((yamop *)p_code), e), Osbpp), p), e), e); } cl->usc.ClLine = Yap_source_line_no(); p_code = cl->ClCode; pe->CodeOfPred = p_code; if (!(flags & SafePredFlag)) { p_code->opc = Yap_opcode(_allocate); p_code = NEXTOP(p_code, e); } p_code->opc = Yap_opcode(_call_cpred); p_code->y_u.Osbpp.bmap = NULL; p_code->y_u.Osbpp.s = -Signed(RealEnvSize); p_code->y_u.Osbpp.p = p_code->y_u.Osbpp.p0 = pe; p_code = NEXTOP(p_code, Osbpp); if (!(flags & SafePredFlag)) { p_code->opc = Yap_opcode(_deallocate); p_code->y_u.p.p = pe; p_code = NEXTOP(p_code, p); } p_code->opc = Yap_opcode(_procceed); p_code->y_u.p.p = pe; p_code = NEXTOP(p_code, p); p_code->opc = Yap_opcode(_Ystop); p_code->y_u.l.l = cl->ClCode; pe->OpcodeOfPred = pe->CodeOfPred->opc; } else { pe->OpcodeOfPred = Yap_opcode(_undef_p); pe->CodeOfPred = (yamop *)(&(pe->OpcodeOfPred)); } }
void Yap_InitCmpPred(const char *Name, arity_t Arity, CmpPredicate cmp_code, pred_flags_t flags) { CACHE_REGS Atom atom = NIL; PredEntry *pe = NULL; yamop *p_code = NULL; StaticClause *cl = NULL; Functor f = NULL; while (atom == NIL) { atom = Yap_FullLookupAtom(Name); if (atom == NIL && !Yap_growheap(FALSE, 0L, NULL)) { Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "while initializing %s", Name); return; } } if (Arity) { while (!f) { f = Yap_MkFunctor(atom, Arity); if (!f && !Yap_growheap(FALSE, 0L, NULL)) { Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "while initializing %s", Name); return; } } } while (pe == NULL) { if (Arity) pe = RepPredProp(PredPropByFunc(f, CurrentModule)); else pe = RepPredProp(PredPropByAtom(atom, CurrentModule)); if (!pe && !Yap_growheap(FALSE, sizeof(PredEntry), NULL)) { Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "while initializing %s", Name); return; } } if (pe->PredFlags & BinaryPredFlag) { flags = update_flags_from_prolog(flags, pe); p_code = pe->CodeOfPred; /* already exists */ } else { while (!cl) { UInt sz = sizeof(StaticClause) + (CELL)NEXTOP(NEXTOP(NEXTOP(((yamop *)NULL), plxxs), p), l); cl = (StaticClause *)Yap_AllocCodeSpace(sz); if (!cl) { if (!Yap_growheap(FALSE, sz, NULL)) { Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "while initializing %s", Name); return; } } else { Yap_ClauseSpace += sz; cl->ClFlags = StaticMask | StandardPredFlag; cl->ClNext = NULL; cl->ClSize = sz; cl->usc.ClLine = Yap_source_line_no(); p_code = cl->ClCode; break; } } } // pe->PredFlags = flags | StandardPredFlag; pe->CodeOfPred = p_code; pe->cs.d_code = cmp_code; pe->ModuleOfPred = CurrentModule; p_code->opc = pe->OpcodeOfPred = Yap_opcode(_call_bfunc_xx); p_code->y_u.plxxs.p = pe; p_code->y_u.plxxs.f = FAILCODE; p_code->y_u.plxxs.x1 = Yap_emit_x(1); p_code->y_u.plxxs.x2 = Yap_emit_x(2); p_code->y_u.plxxs.flags = Yap_compile_cmp_flags(pe); p_code = NEXTOP(p_code, plxxs); p_code->opc = Yap_opcode(_procceed); p_code->y_u.p.p = pe; p_code = NEXTOP(p_code, p); p_code->opc = Yap_opcode(_Ystop); p_code->y_u.l.l = cl->ClCode; }
void Yap_InitCPred(const char *Name, arity_t Arity, CPredicate code, pred_flags_t flags) { CACHE_REGS Atom atom = NIL; PredEntry *pe = NULL; yamop *p_code; StaticClause *cl = NULL; Functor f = NULL; while (atom == NIL) { if (flags & UserCPredFlag) atom = Yap_LookupAtom(Name); else atom = Yap_FullLookupAtom(Name); if (atom == NIL && !Yap_growheap(FALSE, 0L, NULL)) { Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "while initializing %s", Name); return; } } if (Arity) { while (!f) { f = Yap_MkFunctor(atom, Arity); if (!f && !Yap_growheap(FALSE, 0L, NULL)) { Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "while initializing %s", Name); return; } } } while (pe == NULL) { if (Arity) pe = RepPredProp(PredPropByFunc(f, CurrentModule)); else pe = RepPredProp(PredPropByAtom(atom, CurrentModule)); if (!pe && !Yap_growheap(FALSE, sizeof(PredEntry), NULL)) { Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "while initializing %s", Name); return; } } if (pe->PredFlags & CPredFlag) { /* already exists */ flags = update_flags_from_prolog(flags, pe); cl = ClauseCodeToStaticClause(pe->CodeOfPred); if ((flags | StandardPredFlag | CPredFlag) != pe->PredFlags) { Yap_ClauseSpace -= cl->ClSize; Yap_FreeCodeSpace((ADDR)cl); cl = NULL; } } p_code = cl->ClCode; while (!cl) { UInt sz; if (flags & SafePredFlag) { sz = (CELL)NEXTOP(NEXTOP(NEXTOP(p_code, Osbpp), p), l); } else { sz = (CELL)NEXTOP(NEXTOP(NEXTOP(NEXTOP(NEXTOP(p_code, e), p), Osbpp), p), l); } cl = (StaticClause *)Yap_AllocCodeSpace(sz); if (!cl) { if (!Yap_growheap(FALSE, sz, NULL)) { Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "while initializing %s", Name); return; } } else { Yap_ClauseSpace += sz; cl->ClFlags = StaticMask; cl->ClNext = NULL; cl->ClSize = sz; cl->usc.ClLine = Yap_source_line_no(); p_code = cl->ClCode; } } pe->CodeOfPred = p_code; pe->PredFlags = flags | StandardPredFlag | CPredFlag; pe->src.OwnerFile = Yap_ConsultingFile(PASS_REGS1); pe->cs.f_code = code; if (!(flags & SafePredFlag)) { p_code->opc = Yap_opcode(_allocate); p_code = NEXTOP(p_code, e); } if (flags & UserCPredFlag) p_code->opc = Yap_opcode(_call_usercpred); else p_code->opc = Yap_opcode(_call_cpred); p_code->y_u.Osbpp.bmap = NULL; p_code->y_u.Osbpp.s = -Signed(RealEnvSize); p_code->y_u.Osbpp.p = p_code->y_u.Osbpp.p0 = pe; p_code = NEXTOP(p_code, Osbpp); if (!(flags & SafePredFlag)) { p_code->opc = Yap_opcode(_deallocate); p_code->y_u.p.p = pe; p_code = NEXTOP(p_code, p); } p_code->opc = Yap_opcode(_procceed); p_code->y_u.p.p = pe; p_code = NEXTOP(p_code, p); p_code->opc = Yap_opcode(_Ystop); p_code->y_u.l.l = cl->ClCode; pe->OpcodeOfPred = pe->CodeOfPred->opc; }
static Int LoadForeign( StringList ofiles, StringList libs, char *proc_name, YapInitProc *init_proc ) { /* *init_proc is initialized to NULL in load_foreign.c */ int init_missing = -1; int n, i; struct shl_symbol *p; while( ofiles ) { int valid_fname; /* shl_load wants to follow the LD_CONFIG_PATH */ const char *file = AtomName(ofiles->name); valid_fname = Yap_findFile(file, NULL, NULL, LOCAL_FileNameBuf, true, YAP_OBJ, true, true); if( !valid_fname ) { strcpy( LOCAL_ErrorSay, "%% Trying to open non-existing file in LoadForeign" ); return LOAD_FAILLED; } ofiles->handle = Yap_AllocCodeSpace( sizeof(shl_t) ); *(shl_t *)ofiles->handle = shl_load( LOCAL_FileNameBuf, BIND_DEFERRED, 0 ); if( *(shl_t *)ofiles->handle == NULL ) { strncpy( LOCAL_ErrorSay, strerror(errno), MAX_ERROR_MSG_SIZE ); return LOAD_FAILLED; } if( init_missing ) { init_missing = shl_findsym( ofiles->handle, proc_name, TYPE_PROCEDURE, init_proc ); } ofiles = ofiles->next; } if( init_missing ) { strcpy( LOCAL_ErrorSay, "Could not locate initialization routine" ); return LOAD_FAILLED; } while( libs ) { char *s = AtomName(lib->s); if( s[0] == '-' ) { strcpy( LOCAL_FileNameBuf, "lib" ); strcat( LOCAL_FileNameBuf, s+2 ); strcat( LOCAL_FileNameBuf, ".sl" ); } else { strcpy( LOCAL_FileNameBuf, s ); } *(shl_t *)libs->handle = shl_load( LOCAL_FileNameBuf, BIND_DEFERRED, 0 ); if( *(shl_t *)libs->handle == NULL ) { strncpy( LOCAL_ErrorSay, strerror(errno), MAX_ERROR_MSG_SIZE ); return LOAD_FAILLED; } libs = libs->next; } return LOAD_SUCCEEDED; }