/************************************************************************* * * * YAP Prolog * * * * Yap Prolog was developed at NCCUP - Universidade do Porto * * * * Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 * * * ************************************************************************** * * * File: arrays.c * * Last rev: * * mods: * * comments: Array Manipulation Routines * * * *************************************************************************/ #include "Yap.h" #include "clause.h" #include "eval.h" #include "heapgc.h" #if HAVE_ERRNO_H #include #else extern int errno; #endif #if HAVE_STRING_H #include #endif #if __simplescalar__ #ifdef HAVE_MMAP #undef HAVE_MMAP #endif #endif STATIC_PROTO(Int p_compile_array_refs, (void)); STATIC_PROTO(Int p_array_refs_compiled, (void)); STATIC_PROTO(Int p_sync_mmapped_arrays, (void)); /* * * This file works together with pl/arrays.yap and arrays.h. * * YAP now supports a very simple notion of arrays. Arrays may be * allocated dynamically or statically: * * o anonymous arrays are created during execution and allocated * in the heap. They have the lifetime of any other other heap * object. Any term can be an argument to a dynamic array. * * Dynamic arrays are named as a free variable and are * initialised with free variables. * * o named arrays are created during execution but allocated * in the code space. They have the lifetime of an heap * object. Any term can be an argument to a dynamic array. * * Named arrays are named with atoms and are initialised with * free variables. * * o static arrays are allocated in the heap. Their space is * never recovered unless explictly said so by the * program. Arguments to these arrays must have fixed size, * and can only be atomic (at least for now). * * Static arrays can be named through an atom. They are * initialised with []. * * Users create arrays by a declaration X array Arity. If X is an atom * A, then this it is a static array and A's the array name, otherwise * X refers to a dynamic array. * * As in C, arrays start counting from 0. * * Users access arrays by a token X[I] or a[I], this token can appear * anywhere within the computation, so a[2] = X[3*4] means that the * second element of global array a should unify with the 12th element * of array X. The mechanism used to implement this is the same * mechanism used to implement suspension variables. * * Representation: * * Dynamic Arrays are represented as a compound term of arity N, where * N is the size of the array. Even so, I will not include array bound * checking for now. * * |--------------------------------------------------------------| * | $ARRAY/N|.... * |______________________________________________________________ * * * Unbound Var is used as a place to point to. * * Static Arrays are represented as a special property for an atom, * with field size and * * A term of the form X[I] is represented as a Reference pointing to * the compound term: * * '$array_arg'(X,I) * * Dereferecing will automatically find X[I]. * * The only exception is the compiler, which uses a different * dereferencing routine. The clause cl(a[2], Y[X], Y) will be * compiled as: * * cl(A, B, Y) :- '$access_array'(a, A, 2), '$access_array'(Y, B, X). * * There are three operations to access arrays: * * X[I] = A, This is normal unification. * * X[I] := A, This is multiassignment, and therefore * backtrackable. * * X[I] ::= A, This is non-backtrackable multiassignment, ans most * useful for static arrays. * * The LHS of := and of ::= must be an array element! * */ STATIC_PROTO(Term AccessNamedArray, (Atom, Int)); STATIC_PROTO(void InitNamedArray, (ArrayEntry *, Int)); STATIC_PROTO(void CreateNamedArray, (PropEntry *, Int, AtomEntry *)); STATIC_PROTO(void ResizeStaticArray, (StaticArrayEntry *, Int)); #if HAVE_MMAP STATIC_PROTO(Int CloseMmappedArray, (StaticArrayEntry *, void *)); STATIC_PROTO(void ResizeMmappedArray, (StaticArrayEntry *, Int, void *)); #endif STATIC_PROTO(Int p_create_array, (void)); STATIC_PROTO(Int p_create_mmapped_array, (void)); STATIC_PROTO(void replace_array_references_complex, (CELL *, CELL *, CELL *, Term)); STATIC_PROTO(Term replace_array_references, (Term)); STATIC_PROTO(Int p_array_references, (void)); STATIC_PROTO(Int p_create_static_array, (void)); STATIC_PROTO(Int p_resize_static_array, (void)); STATIC_PROTO(Int p_close_static_array, (void)); STATIC_PROTO(Int p_access_array, (void)); STATIC_PROTO(Int p_assign_static, (void)); STATIC_PROTO(Int p_assign_dynamic, (void)); static Term GetTermFromArray(DBTerm *ref) { if (ref != NULL) { Term TRef; while ((TRef = Yap_FetchTermFromDB(ref)) == 0L) { if (Yap_Error_TYPE == OUT_OF_ATTVARS_ERROR) { Yap_Error_TYPE = YAP_NO_ERROR; if (!Yap_growglobal(NULL)) { Yap_Error(OUT_OF_ATTVARS_ERROR, TermNil, Yap_ErrorMessage); return TermNil; } } else { Yap_Error_TYPE = YAP_NO_ERROR; if (!Yap_gc(3, ENV, P)) { Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage); return TermNil; } } } return TRef; } else { P = (yamop *)FAILCODE; return TermNil; } } static Term GetNBTerm(live_term *ar, Int indx) { /* The object is now in use */ Term livet = ar[indx].tlive; if (!IsVarTerm(livet)) { if (!IsApplTerm(livet)) { return livet; } else if (FunctorOfTerm(livet) == FunctorAtFoundOne) { return Yap_ReadTimedVar(livet); } else { return livet; } } else { Term termt = ar[indx].tstore; if (!IsUnboundVar(&(ar[indx].tlive))) { return livet; } if (IsVarTerm(termt)) { livet = MkVarTerm(); } else if (IsAtomicTerm(termt)) { livet = termt; } else { DBTerm *ref = (DBTerm *)RepAppl(termt); if ((livet = GetTermFromArray(ref)) == TermNil) { return TermNil; } } Bind(&(ar[indx].tlive), livet); return livet; } } static Term AccessNamedArray(Atom a, Int indx) { AtomEntry *ae = RepAtom(a); ArrayEntry *pp; READ_LOCK(ae->ARWLock); pp = RepArrayProp(ae->PropsOfAE); while (!EndOfPAEntr(pp) && pp->KindOfPE != ArrayProperty #if THREADS && pp->owner_id != worker_id #endif ) pp = RepArrayProp(pp->NextOfPE); READ_UNLOCK(ae->ARWLock); if (!EndOfPAEntr(pp)) { if (ArrayIsDynamic(pp)) { Term out; READ_LOCK(pp->ArRWLock); if (IsVarTerm(pp->ValueOfVE) || pp->ArrayEArity <= indx || indx < 0) { READ_UNLOCK(pp->ArRWLock); P = (yamop *)FAILCODE; return(MkAtomTerm(AtomFoundVar)); } out = RepAppl(pp->ValueOfVE)[indx+1]; READ_UNLOCK(pp->ArRWLock); return(out); } else { StaticArrayEntry *ptr = (StaticArrayEntry *)pp; READ_LOCK(ptr->ArRWLock); if (-(pp->ArrayEArity) <= indx || indx < 0) { /* Yap_Error(DOMAIN_ERROR_ARRAY_OVERFLOW, MkIntegerTerm(indx), "access_array");*/ READ_UNLOCK(ptr->ArRWLock); P = (yamop *)FAILCODE; return(MkAtomTerm(AtomFoundVar)); } switch (ptr->ArrayType) { case array_of_ints: { Term out; out = MkIntegerTerm(ptr->ValueOfVE.ints[indx]); READ_UNLOCK(ptr->ArRWLock); return out; } case array_of_doubles: { Term out; out = MkEvalFl(ptr->ValueOfVE.floats[indx]); READ_UNLOCK(ptr->ArRWLock); return out; } case array_of_ptrs: { Term out; out = MkIntegerTerm((Int)(ptr->ValueOfVE.ptrs[indx])); READ_UNLOCK(ptr->ArRWLock); return out; } case array_of_atoms: { Term out; out = ptr->ValueOfVE.atoms[indx]; READ_UNLOCK(ptr->ArRWLock); if (out == 0L) return TermNil; else return out; } /* just return the atom */ case array_of_chars: { Term out; out = MkIntegerTerm((Int)(ptr->ValueOfVE.chars[indx])); READ_UNLOCK(ptr->ArRWLock); return out; } case array_of_uchars: { Term out; out = MkIntegerTerm((Int)(ptr->ValueOfVE.uchars[indx])); READ_UNLOCK(ptr->ArRWLock); return out; } case array_of_dbrefs: { /* The object is now in use */ Term TRef = ptr->ValueOfVE.dbrefs[indx]; READ_UNLOCK(ptr->ArRWLock); if (TRef != 0L) { DBRef ref = DBRefOfTerm(TRef); #if defined(YAPOR) || defined(THREADS) LOCK(ref->lock); INC_DBREF_COUNT(ref); TRAIL_REF(ref); /* So that fail will erase it */ UNLOCK(ref->lock); #else if (ref->Flags & LogUpdMask) { LogUpdClause *cl = (LogUpdClause *)ref; if (!(cl->ClFlags & InUseMask)) { cl->ClFlags |= InUseMask; TRAIL_CLREF(cl); } } else { if (!(ref->Flags & InUseMask)) { ref->Flags |= InUseMask; TRAIL_REF(ref); /* So that fail will erase it */ } } #endif } else { P = (yamop *)FAILCODE; TRef = TermNil; } return TRef; } case array_of_nb_terms: { /* The object is now in use */ Term out = GetNBTerm(ptr->ValueOfVE.lterms, indx); READ_UNLOCK(ptr->ArRWLock); return out; } case array_of_terms: { /* The object is now in use */ DBTerm *ref = ptr->ValueOfVE.terms[indx]; READ_UNLOCK(ptr->ArRWLock); return GetTermFromArray(ref); } default: READ_UNLOCK(ptr->ArRWLock); return TermNil; } } } else { Yap_Error(EXISTENCE_ERROR_ARRAY,MkAtomTerm(a),"named array"); return (TermNil); } } static Int p_access_array(void) { Term t = Deref(ARG1); Term ti = Deref(ARG2); Term tf; Int indx; if (IsNonVarTerm(ti)) { union arith_ret v; if (IsIntTerm(ti)) indx = IntOfTerm(ti); else if (Yap_Eval(ti, &v) == long_int_e) indx = v.Int; else { Yap_Error(TYPE_ERROR_INTEGER,ti,"access_array"); return (FALSE); } } else { Yap_Error(INSTANTIATION_ERROR,ti,"access_array"); return (TermNil); } if (IsNonVarTerm(t)) { if (IsApplTerm(t)) { if (indx >= ArityOfFunctor(FunctorOfTerm(t)) || indx < 0) { /* Yap_Error(DOMAIN_ERROR_ARRAY_OVERFLOW, MkIntegerTerm(indx), "access_array");*/ P = (yamop *)FAILCODE; return(FALSE); } tf = (RepAppl(t))[indx + 1]; } else if (IsAtomTerm(t)) { tf = AccessNamedArray(AtomOfTerm(t), indx); if (tf == MkAtomTerm(AtomFoundVar)) { return(FALSE); } } else { Yap_Error(TYPE_ERROR_ARRAY,t,"access_array"); return(FALSE); } } else { Yap_Error(INSTANTIATION_ERROR,t,"access_array"); return(FALSE); } return Yap_unify(tf, ARG3); } static Int p_array_arg(void) { register Term ti = Deref(ARG3), t; register Int indx; if (IsNonVarTerm(ti)) { union arith_ret v; if (IsIntTerm(ti)) indx = IntOfTerm(ti); else if (Yap_Eval(ti, &v) == long_int_e) indx = v.Int; else { Yap_Error(TYPE_ERROR_INTEGER,ti,"array_arg"); return (FALSE); } } else { Yap_Error(INSTANTIATION_ERROR,ti,"array_arg"); return (FALSE); } t = Deref(ARG2); if (IsNonVarTerm(t)) { if (IsApplTerm(t)) { return (Yap_unify(((RepAppl(t))[indx + 1]), ARG1)); } else if (IsAtomTerm(t)) { Term tf = AccessNamedArray(AtomOfTerm(t), indx); if (tf == MkAtomTerm(AtomFoundVar)) { return(FALSE); } return (Yap_unify(tf, ARG1)); } else Yap_Error(TYPE_ERROR_ARRAY,t,"array_arg"); } else Yap_Error(INSTANTIATION_ERROR,t,"array_arg"); return (FALSE); } static void InitNamedArray(ArrayEntry * p, Int dim) { Term *tp; WRITE_LOCK(p->ArRWLock); /* Leave a pointer so that we can reclaim array space when * we backtrack or when we abort */ /* place terms in reverse order */ Bind_Global(&(p->ValueOfVE),AbsAppl(H)); tp = H; tp[0] = (CELL)Yap_MkFunctor(AtomArray, dim); tp++; p->ArrayEArity = dim; /* Initialise the array as a set of variables */ H = tp+dim; for (; tp < H; tp++) { RESET_VARIABLE(tp); } WRITE_UNLOCK(p->ArRWLock); } /* we assume the atom ae is already locked */ static void CreateNamedArray(PropEntry * pp, Int dim, AtomEntry *ae) { ArrayEntry *p; p = (ArrayEntry *) Yap_AllocAtomSpace(sizeof(*p)); p->KindOfPE = ArrayProperty; p->NextOfPE = ae->PropsOfAE; INIT_RWLOCK(p->ArRWLock); ae->PropsOfAE = AbsArrayProp(p); #if THREADS p->owner_id = worker_id; #endif p->NextAE = DynamicArrays; DynamicArrays = p; InitNamedArray(p, dim); } static void AllocateStaticArraySpace(StaticArrayEntry *p, static_array_types atype, Int array_size) { Int asize = 0; switch (atype) { case array_of_doubles: asize = array_size*sizeof(Float); break; case array_of_ints: asize = array_size*sizeof(Int); break; case array_of_chars: asize = array_size*sizeof(char); break; case array_of_uchars: asize = array_size*sizeof(unsigned char); break; case array_of_ptrs: asize = array_size*sizeof(AtomEntry *); break; case array_of_atoms: case array_of_terms: case array_of_nb_terms: asize = array_size*sizeof(live_term); break; case array_of_dbrefs: asize = array_size*sizeof(DBRef); break; } while ((p->ValueOfVE.floats = (Float *) Yap_AllocAtomSpace(asize) ) == NULL) { YAPLeaveCriticalSection(); if (!Yap_growheap(FALSE, asize, NULL)) { Yap_Error(OUT_OF_HEAP_ERROR, TermNil, Yap_ErrorMessage); return; } YAPEnterCriticalSection(); } } /* ae and p are assumed to be locked, if they exist */ static StaticArrayEntry * CreateStaticArray(AtomEntry *ae, Int dim, static_array_types type, CODEADDR start_addr, StaticArrayEntry *p) { if (EndOfPAEntr(p)) { while ((p = (StaticArrayEntry *) Yap_AllocAtomSpace(sizeof(*p))) == NULL) { if (!Yap_growheap(FALSE, sizeof(*p), NULL)) { Yap_Error(OUT_OF_HEAP_ERROR, TermNil, Yap_ErrorMessage); return NULL; } } p->KindOfPE = ArrayProperty; p->NextOfPE = ae->PropsOfAE; INIT_RWLOCK(p->ArRWLock); } WRITE_LOCK(p->ArRWLock); p->ArrayEArity = -dim; p->ArrayType = type; ae->PropsOfAE = AbsArrayProp((ArrayEntry *)p); p->NextAE = StaticArrays; StaticArrays = p; if (start_addr == NULL) { int i; AllocateStaticArraySpace(p, type, dim); if (p->ValueOfVE.ints == NULL) { WRITE_UNLOCK(p->ArRWLock); return p; } switch(type) { case array_of_ints: for (i = 0; i < dim; i++) p->ValueOfVE.ints[i] = 0; break; case array_of_chars: for (i = 0; i < dim; i++) p->ValueOfVE.chars[i] = '\0'; break; case array_of_uchars: for (i = 0; i < dim; i++) p->ValueOfVE.uchars[i] = '\0'; break; case array_of_doubles: for (i = 0; i < dim; i++) p->ValueOfVE.floats[i] = 0.0; break; case array_of_ptrs: for (i = 0; i < dim; i++) p->ValueOfVE.ptrs[i] = NULL; break; case array_of_atoms: case array_of_dbrefs: for (i = 0; i < dim; i++) p->ValueOfVE.atoms[i] = 0L; break; case array_of_terms: for (i = 0; i < dim; i++) p->ValueOfVE.terms[i] = NULL; break; case array_of_nb_terms: for (i = 0; i < dim; i++) { RESET_VARIABLE(&(p->ValueOfVE.lterms[i].tlive)); p->ValueOfVE.lterms[i].tstore = TermNil; } break; } } else { /* external array */ p->ValueOfVE.chars = (char *)start_addr; } WRITE_UNLOCK(p->ArRWLock); return p; } static void ResizeStaticArray(StaticArrayEntry *pp, Int dim) { statarray_elements old_v = pp->ValueOfVE; static_array_types type = pp->ArrayType; Int old_dim = - pp->ArrayEArity; Int mindim = (dim < old_dim ? dim : old_dim), i; /* change official size */ if (pp->ArrayEArity >= 0){ return; } WRITE_LOCK(pp->ArRWLock); pp->ArrayEArity = -dim; #if HAVE_MMAP if (pp->ValueOfVE.chars < (char *)Yap_HeapBase || pp->ValueOfVE.chars > (char *)HeapTop) { ResizeMmappedArray(pp, dim, (void *)(pp->ValueOfVE.chars)); WRITE_UNLOCK(pp->ArRWLock); return; } #endif AllocateStaticArraySpace(pp, type, dim); switch(type) { case array_of_ints: for (i = 0; i ValueOfVE.ints[i] = old_v.ints[i]; for (i = mindim; iValueOfVE.ints[i] = 0; break; case array_of_chars: for (i = 0; i ValueOfVE.chars[i] = old_v.chars[i]; for (i = mindim; iValueOfVE.chars[i] = '\0'; break; case array_of_uchars: for (i = 0; i ValueOfVE.uchars[i] = old_v.uchars[i]; for (i = mindim; iValueOfVE.uchars[i] = '\0'; break; case array_of_doubles: for (i = 0; i ValueOfVE.floats[i] = old_v.floats[i]; for (i = mindim; iValueOfVE.floats[i] = 0.0; break; case array_of_ptrs: for (i = 0; i ValueOfVE.ptrs[i] = old_v.ptrs[i]; for (i = mindim; iValueOfVE.ptrs[i] = NULL; break; case array_of_atoms: for (i = 0; i ValueOfVE.atoms[i] = old_v.atoms[i]; for (i = mindim; iValueOfVE.atoms[i] = TermNil; break; case array_of_dbrefs: for (i = 0; i ValueOfVE.dbrefs[i] = old_v.dbrefs[i]; for (i = mindim; iValueOfVE.dbrefs[i] = 0L; break; case array_of_terms: for (i = 0; i ValueOfVE.terms[i] = old_v.terms[i]; for (i = mindim; iValueOfVE.terms[i] = NULL; break; case array_of_nb_terms: for (i = 0; i ValueOfVE.lterms[i].tlive; if (IsVarTerm(tlive) && IsUnboundVar(&(pp->ValueOfVE.lterms[i].tlive))) { RESET_VARIABLE(&(pp->ValueOfVE.lterms[i].tlive)); } else { pp->ValueOfVE.lterms[i].tlive = tlive; } pp->ValueOfVE.lterms[i].tstore = old_v.lterms[i].tstore; } break; } WRITE_UNLOCK(pp->ArRWLock); } /* create an array (?Name, + Size) */ static Int p_create_array(void) { Term ti; Term t; Int size; restart: ti = Deref(ARG2); t = Deref(ARG1); { union arith_ret v; if (IsIntTerm(ti)) size = IntOfTerm(ti); else if (Yap_Eval(ti, &v) == long_int_e) size = v.Int; else { Yap_Error(TYPE_ERROR_INTEGER,ti,"create_array"); return (FALSE); } } if (IsVarTerm(t)) { /* Create an anonymous array */ Functor farray; farray = Yap_MkFunctor(AtomArray, size); if (H+1+size > ASP-1024) { if (!Yap_gc(2, ENV, P)) { Yap_Error(OUT_OF_STACK_ERROR,TermNil,Yap_ErrorMessage); return(FALSE); } else { if (H+1+size > ASP-1024) { if (!Yap_growstack( sizeof(CELL) * (size+1-(H-ASP-1024)))) { Yap_Error(OUT_OF_HEAP_ERROR, TermNil, Yap_ErrorMessage); return FALSE; } } } goto restart; } t = AbsAppl(H); *H++ = (CELL) farray; for (; size >= 0; size--) { RESET_VARIABLE(H); H++; } return (Yap_unify(t, ARG1)); } else if (IsAtomTerm(t)) { /* Create a named array */ AtomEntry *ae = RepAtom(AtomOfTerm(t)); PropEntry *pp; WRITE_LOCK(ae->ARWLock); pp = RepProp(ae->PropsOfAE); while (!EndOfPAEntr(pp) && pp->KindOfPE != ArrayProperty #if THREADS && ((ArrayEntry *)pp)->owner_id != worker_id #endif ) pp = RepProp(pp->NextOfPE); if (EndOfPAEntr(pp)) { if (H+1+size > ASP-1024) { WRITE_UNLOCK(ae->ARWLock); if (!Yap_gc(2, ENV, P)) { Yap_Error(OUT_OF_STACK_ERROR,TermNil,Yap_ErrorMessage); return(FALSE); } else goto restart; } CreateNamedArray(pp, size, ae); WRITE_UNLOCK(ae->ARWLock); return (TRUE); } else { ArrayEntry *app = (ArrayEntry *) pp; WRITE_UNLOCK(ae->ARWLock); if (!IsVarTerm(app->ValueOfVE) || !IsUnboundVar(&app->ValueOfVE)) { if (size == app->ArrayEArity || size == -app->ArrayEArity) return TRUE; Yap_Error(PERMISSION_ERROR_CREATE_ARRAY,t,"create_array", ae->StrOfAE); } else { if (H+1+size > ASP-1024) { if (!Yap_gc(2, ENV, P)) { Yap_Error(OUT_OF_STACK_ERROR,TermNil,Yap_ErrorMessage); return(FALSE); } else goto restart; } InitNamedArray(app, size); return (TRUE); } } } return (FALSE); } /* create an array (+Name, + Size, +Props) */ static Int p_create_static_array(void) { Term ti = Deref(ARG2); Term t = Deref(ARG1); Term tprops = Deref(ARG3); Int size; static_array_types props; if (IsVarTerm(ti)) { Yap_Error(INSTANTIATION_ERROR,ti,"create static array"); return (FALSE); } else if (IsIntTerm(ti)) size = IntOfTerm(ti); else { union arith_ret v; if (Yap_Eval(ti, &v) == long_int_e) { size = v.Int; } else { Yap_Error(TYPE_ERROR_INTEGER,ti,"create static array"); return (FALSE); } } if (IsVarTerm(tprops)) { Yap_Error(INSTANTIATION_ERROR,tprops,"create static array"); return (FALSE); } else if (IsAtomTerm(tprops)) { char *atname = RepAtom(AtomOfTerm(tprops))->StrOfAE; if (!strcmp(atname, "int")) props = array_of_ints; else if (!strcmp(atname, "dbref")) props = array_of_dbrefs; else if (!strcmp(atname, "float")) props = array_of_doubles; else if (!strcmp(atname, "ptr")) props = array_of_ptrs; else if (!strcmp(atname, "atom")) props = array_of_atoms; else if (!strcmp(atname, "char")) props = array_of_chars; else if (!strcmp(atname, "unsigned_char")) props = array_of_uchars; else if (!strcmp(atname, "term")) props = array_of_terms; else if (!strcmp(atname, "nb_term")) props = array_of_nb_terms; else { Yap_Error(DOMAIN_ERROR_ARRAY_TYPE,tprops,"create static array"); return(FALSE); } } else { Yap_Error(TYPE_ERROR_ATOM,tprops,"create static array"); return (FALSE); } if (IsVarTerm(t)) { Yap_Error(INSTANTIATION_ERROR,t,"create static array"); return (FALSE); } else if (IsAtomTerm(t)) { /* Create a named array */ AtomEntry *ae = RepAtom(AtomOfTerm(t)); StaticArrayEntry *pp; ArrayEntry *app; WRITE_LOCK(ae->ARWLock); pp = RepStaticArrayProp(ae->PropsOfAE); while (!EndOfPAEntr(pp) && pp->KindOfPE != ArrayProperty) pp = RepStaticArrayProp(pp->NextOfPE); app = (ArrayEntry *) pp; if (EndOfPAEntr(pp) || pp->ValueOfVE.ints == NULL) { pp = CreateStaticArray(ae, size, props, NULL, pp); if (pp == NULL || pp->ValueOfVE.ints == NULL) { WRITE_UNLOCK(ae->ARWLock); return FALSE; } WRITE_UNLOCK(ae->ARWLock); return TRUE; } else if (ArrayIsDynamic(app)) { if (IsVarTerm(app->ValueOfVE) && IsUnboundVar(&app->ValueOfVE)) { pp = CreateStaticArray(ae, size, props, NULL, pp); WRITE_UNLOCK(ae->ARWLock); if (pp == NULL) { return FALSE; } return TRUE; } else { WRITE_UNLOCK(ae->ARWLock); Yap_Error(PERMISSION_ERROR_CREATE_ARRAY,t,"cannot create static array over dynamic array"); return FALSE; } } else { if (pp->ArrayEArity == -size && pp->ArrayType == props) { WRITE_UNLOCK(ae->ARWLock); return TRUE; } WRITE_UNLOCK(ae->ARWLock); Yap_Error(PERMISSION_ERROR_CREATE_ARRAY,t,"cannot create static array over static array"); return FALSE; } } Yap_Error(TYPE_ERROR_ATOM,t,"create static array"); return FALSE; } /* has a static array associated (+Name) */ static Int p_static_array_properties(void) { Term t = Deref(ARG1); if (IsVarTerm(t)) { return (FALSE); } else if (IsAtomTerm(t)) { /* Create a named array */ AtomEntry *ae = RepAtom(AtomOfTerm(t)); StaticArrayEntry *pp; READ_LOCK(ae->ARWLock); pp = RepStaticArrayProp(ae->PropsOfAE); while (!EndOfPAEntr(pp) && pp->KindOfPE != ArrayProperty) pp = RepStaticArrayProp(pp->NextOfPE); if (EndOfPAEntr(pp) || pp->ValueOfVE.ints == NULL) { READ_UNLOCK(ae->ARWLock); return (FALSE); } else { static_array_types tp = pp->ArrayType; Int dim = -pp->ArrayEArity; READ_UNLOCK(ae->ARWLock); if (dim <= 0 || !Yap_unify(ARG2,MkIntegerTerm(dim))) return(FALSE); switch(tp) { case array_of_ints: return(Yap_unify(ARG3,MkAtomTerm(Yap_LookupAtom("int")))); case array_of_dbrefs: return(Yap_unify(ARG3,MkAtomTerm(Yap_LookupAtom("dbref")))); case array_of_doubles: return(Yap_unify(ARG3,MkAtomTerm(Yap_LookupAtom("float")))); case array_of_ptrs: return(Yap_unify(ARG3,MkAtomTerm(Yap_LookupAtom("ptr")))); case array_of_chars: return(Yap_unify(ARG3,MkAtomTerm(Yap_LookupAtom("char")))); case array_of_uchars: return(Yap_unify(ARG3,MkAtomTerm(Yap_LookupAtom("unsigned char")))); case array_of_terms: return(Yap_unify(ARG3,MkAtomTerm(Yap_LookupAtom("term")))); case array_of_nb_terms: return(Yap_unify(ARG3,MkAtomTerm(Yap_LookupAtom("nb_term")))); case array_of_atoms: return(Yap_unify(ARG3,MkAtomTerm(Yap_LookupAtom("atom")))); } } } return (FALSE); } /* resize a static array (+Name, + Size, +Props) */ /* does not work for mmap arrays yet */ static Int p_resize_static_array(void) { Term ti = Deref(ARG3); Term t = Deref(ARG1); Int size; if (IsVarTerm(ti)) { Yap_Error(INSTANTIATION_ERROR,ti,"resize a static array"); return (FALSE); } else if (IsIntTerm(ti)) size = IntOfTerm(ti); else { union arith_ret v; if (Yap_Eval(ti, &v) == long_int_e) { size = v.Int; } else { Yap_Error(TYPE_ERROR_INTEGER,ti,"resize a static array"); return (FALSE); } } if (IsVarTerm(t)) { Yap_Error(INSTANTIATION_ERROR,t,"resize a static array"); return (FALSE); } else if (IsAtomTerm(t)) { /* resize a named array */ Atom a = AtomOfTerm(t); StaticArrayEntry *pp = RepStaticArrayProp(RepAtom(a)->PropsOfAE); while (!EndOfPAEntr(pp) && pp->KindOfPE != ArrayProperty) pp = RepStaticArrayProp(pp->NextOfPE); if (EndOfPAEntr(pp) || pp->ValueOfVE.ints == NULL) { Yap_Error(PERMISSION_ERROR_RESIZE_ARRAY,t,"resize a static array"); return(FALSE); } else { Int osize = - pp->ArrayEArity; ResizeStaticArray(pp, size); return(Yap_unify(ARG2,MkIntegerTerm(osize))); } } else { Yap_Error(TYPE_ERROR_ATOM,t,"resize a static array"); return (FALSE); } } /* Close a named array (+Name) */ static Int p_close_static_array(void) { /* does not work for mmap arrays yet */ Term t = Deref(ARG1); if (IsVarTerm(t)) { Yap_Error(INSTANTIATION_ERROR,t,"close static array"); return (FALSE); } else if (IsAtomTerm(t)) { /* Create a named array */ AtomEntry *ae = RepAtom(AtomOfTerm(t)); PropEntry *pp; READ_LOCK(ae->ARWLock); pp = RepProp(ae->PropsOfAE); while (!EndOfPAEntr(pp) && pp->KindOfPE != ArrayProperty) pp = RepProp(pp->NextOfPE); READ_UNLOCK(ae->ARWLock); if (EndOfPAEntr(pp)) { return (FALSE); } else { StaticArrayEntry *ptr = (StaticArrayEntry *)pp; if (ptr->ValueOfVE.ints != NULL) { #if HAVE_MMAP if (ptr->ValueOfVE.chars < (char *)Yap_HeapBase || ptr->ValueOfVE.chars > (char *)HeapTop) { return(CloseMmappedArray(ptr, (void *)ptr->ValueOfVE.chars)); } #endif Yap_FreeAtomSpace((char *)(ptr->ValueOfVE.ints)); ptr->ValueOfVE.ints = NULL; ptr->ArrayEArity = 0; return(TRUE); } else { return(FALSE); } } } else { Yap_Error(TYPE_ERROR_ATOM,t,"close static array"); return (FALSE); } } #if HAVE_MMAP #if HAVE_UNISTD_H #include #endif #if HAVE_SYS_MMAN_H #include #endif #if HAVE_SYS_STAT_H #include #endif #if HAVE_FCNTL_H #include #endif STATIC_PROTO(void ResizeMmappedArray, (StaticArrayEntry *,Int ,void *)); /* keep a list of mmaped blocks to synch on exit */ typedef struct MMAP_ARRAY_BLOCK { Atom name; void *start; size_t size; Int items; int fd; struct MMAP_ARRAY_BLOCK *next; } mmap_array_block; static mmap_array_block *mmap_arrays = NULL; static Int CloseMmappedArray(StaticArrayEntry *pp, void *area) { mmap_array_block *ptr = mmap_arrays, *optr = mmap_arrays; while (ptr != NULL && ptr->start != area) { ptr = ptr->next; optr = ptr; } if (ptr == NULL) { Yap_Error(SYSTEM_ERROR,ARG1,"close_mmapped_array (array chain incoherent)", strerror(errno)); return(FALSE); } if (munmap(ptr->start, ptr->size) == -1) { Yap_Error(SYSTEM_ERROR,ARG1,"close_mmapped_array (munmap: %s)", strerror(errno)); return(FALSE); } optr->next = ptr->next; pp->ValueOfVE.ints = NULL; pp->ArrayEArity = 0; if (close(ptr->fd) < 0) { Yap_Error(SYSTEM_ERROR,ARG1,"close_mmapped_array (close: %s)", strerror(errno)); return(FALSE); } Yap_FreeAtomSpace((char *)ptr); return(TRUE); } static void ResizeMmappedArray(StaticArrayEntry *pp, Int dim, void *area) { mmap_array_block *ptr = mmap_arrays; size_t total_size; while (ptr != NULL && ptr->start != area) { ptr = ptr->next; } if (ptr == NULL) return; /* This is a very stupid algorithm to change size for an array. First, we unmap it, then we actually change the size for the file, and last we initialise again */ if (munmap(ptr->start, ptr->size) == -1) { Yap_Error(SYSTEM_ERROR,ARG1,"resize_mmapped_array (munmap: %s)", strerror(errno)); return; } total_size = (ptr->size / ptr->items)*dim; if (ftruncate(ptr->fd, total_size) < 0) { Yap_Error(SYSTEM_ERROR,ARG1,"resize_mmapped_array (ftruncate: %s)", strerror(errno)); return; } if (lseek(ptr->fd, total_size-1, SEEK_SET) < 0) { Yap_Error(SYSTEM_ERROR,ARG1,"resize_mmapped_array (lseek: %s)", strerror(errno)); return; } if (write(ptr->fd, "", 1) < 0) { Yap_Error(SYSTEM_ERROR,ARG1,"resize_mmapped_array (write: %s)", strerror(errno)); return; } if ((ptr->start = (void *)mmap(0, (size_t) total_size, PROT_READ | PROT_WRITE, MAP_SHARED, ptr->fd, 0)) == (void *) - 1) { Yap_Error(SYSTEM_ERROR,ARG1,"resize_mmapped_array (mmap: %s)", strerror(errno)); return; } ptr->size = total_size; ptr->items = dim; pp->ValueOfVE.chars = ptr->start; } #endif /* create an array (+Name, + Size, +Props) */ static Int p_create_mmapped_array(void) { #ifdef HAVE_MMAP Term ti = Deref(ARG2); Term t = Deref(ARG1); Term tprops = Deref(ARG3); Term tfile = Deref(ARG4); Int size; static_array_types props; size_t total_size; CODEADDR array_addr; int fd; if (IsVarTerm(ti)) { Yap_Error(INSTANTIATION_ERROR,ti,"create_mmapped_array"); return (FALSE); } else if (IsIntTerm(ti)) size = IntOfTerm(ti); else { union arith_ret v; if (Yap_Eval(ti, &v) == long_int_e) { size = v.Int; } else { Yap_Error(TYPE_ERROR_INTEGER,ti,"create_mmapped_array"); return (FALSE); } } if (IsVarTerm(tprops)) { Yap_Error(INSTANTIATION_ERROR,tprops,"create_mmapped_array"); return (FALSE); } else if (IsAtomTerm(tprops)) { char *atname = RepAtom(AtomOfTerm(tprops))->StrOfAE; if (!strcmp(atname, "int")) { props = array_of_ints; total_size = size*sizeof(Int); } else if (!strcmp(atname, "dbref")) { props = array_of_dbrefs; total_size = size*sizeof(Int); } else if (!strcmp(atname, "float")) { props = array_of_doubles; total_size = size*sizeof(Float); } else if (!strcmp(atname, "ptr")) { props = array_of_ptrs; total_size = size*sizeof(AtomEntry *); } else if (!strcmp(atname, "atom")) { props = array_of_atoms; total_size = size*sizeof(Term); } else if (!strcmp(atname, "char")) { props = array_of_chars; total_size = size*sizeof(char); } else if (!strcmp(atname, "unsigned_char")) { props = array_of_uchars; total_size = size*sizeof(unsigned char); } else { Yap_Error(DOMAIN_ERROR_ARRAY_TYPE,tprops,"create_mmapped_array"); return(FALSE); } } else { Yap_Error(TYPE_ERROR_ATOM,tprops,"create_mmapped_array"); return (FALSE); } if (IsVarTerm(tfile)) { Yap_Error(INSTANTIATION_ERROR,tfile,"create_mmapped_array"); return (FALSE); } else if (IsAtomTerm(tfile)) { char *filename = RepAtom(AtomOfTerm(tfile))->StrOfAE; fd = open(filename, O_RDWR|O_CREAT, S_IRUSR|S_IWUSR); if (fd == -1) { Yap_Error(SYSTEM_ERROR,ARG1,"create_mmapped_array (open: %s)", strerror(errno)); return(FALSE); } if (lseek(fd, total_size-1, SEEK_SET) < 0) Yap_Error(SYSTEM_ERROR,tfile,"create_mmapped_array (lseek: %s)", strerror(errno)); if (write(fd, "", 1) < 0) Yap_Error(SYSTEM_ERROR,tfile,"create_mmapped_array (write: %s)", strerror(errno)); /* if (ftruncate(fd, total_size) < 0) Yap_Error(SYSTEM_ERROR,tfile,"create_mmapped_array"); */ if ((array_addr = (CODEADDR)mmap(0, (size_t) total_size, PROT_READ | PROT_WRITE, MAP_SHARED, fd, 0)) == (CODEADDR) - 1) Yap_Error(SYSTEM_ERROR,tfile,"create_mmapped_array (mmap: %s)", strerror(errno)); } else { Yap_Error(TYPE_ERROR_ATOM,tfile,"create_mmapped_array"); return (FALSE); } if (IsVarTerm(t)) { Yap_Error(INSTANTIATION_ERROR,t,"create_mmapped_array"); return (FALSE); } else if (IsAtomTerm(t)) { /* Create a named array */ AtomEntry *ae = RepAtom(AtomOfTerm(t)); StaticArrayEntry *pp; WRITE_LOCK(ae->ARWLock); pp = RepStaticArrayProp(ae->PropsOfAE); while (!EndOfPAEntr(pp) && pp->KindOfPE != ArrayProperty) pp = RepStaticArrayProp(pp->NextOfPE); if (EndOfPAEntr(pp) || pp->ValueOfVE.ints == NULL) { mmap_array_block *ptr; if (EndOfPAEntr(pp)) { WRITE_UNLOCK(ae->ARWLock); return FALSE; } else { WRITE_LOCK(pp->ArRWLock); } CreateStaticArray(ae, size, props, array_addr, pp); ptr = (mmap_array_block *)Yap_AllocAtomSpace(sizeof(mmap_array_block)); ptr->name = AbsAtom(ae); ptr->size = total_size; ptr->items = size; ptr->start = (void *)array_addr; ptr->fd = fd; ptr->next = mmap_arrays; mmap_arrays = ptr; WRITE_UNLOCK(pp->ArRWLock); WRITE_UNLOCK(ae->ARWLock); return TRUE; } else { WRITE_UNLOCK(ae->ARWLock); Yap_Error(DOMAIN_ERROR_ARRAY_TYPE,t,"create_mmapped_array", ae->StrOfAE); return(FALSE); } } else { Yap_Error(TYPE_ERROR_ATOM,t,"create_mmapped_array"); return FALSE; } #else Yap_Error(SYSTEM_ERROR,ARG1,"create_mmapped_array (mmap)"); return (FALSE); #endif } /* This routine removes array references from complex terms? */ static void replace_array_references_complex(register CELL *pt0, register CELL *pt0_end, register CELL *ptn, Term Var) { register CELL **to_visit = (CELL **) Yap_PreAllocCodeSpace(); CELL **to_visit_base = to_visit; loop: while (pt0 < pt0_end) { register CELL d0; ++pt0; d0 = Derefa(pt0); if (IsVarTerm(d0)) { *ptn++ = d0; } else if (IsPairTerm(d0)) { /* store the terms to visit */ *ptn++ = AbsPair(H); #ifdef RATIONAL_TREES to_visit[0] = pt0; to_visit[1] = pt0_end; to_visit[2] = ptn; to_visit[3] = (CELL *)*pt0; to_visit += 4; *pt0 = TermNil; #else if (pt0 < pt0_end) { to_visit[0] = pt0; to_visit[1] = pt0_end; to_visit[2] = ptn; to_visit += 3; } #endif pt0 = RepPair(d0) - 1; pt0_end = RepPair(d0) + 1; /* write the head and tail of the list */ ptn = H; H += 2; } else if (IsApplTerm(d0)) { register Functor f; f = FunctorOfTerm(d0); /* store the terms to visit */ if (IsExtensionFunctor(f)) { { *ptn++ = d0; continue; } } *ptn++ = AbsAppl(H); /* store the terms to visit */ #ifdef RATIONAL_TREES to_visit[0] = pt0; to_visit[1] = pt0_end; to_visit[2] = ptn; to_visit[3] = (CELL *)*pt0; to_visit += 4; *pt0 = TermNil; #else if (pt0 < pt0_end) { to_visit[0] = pt0; to_visit[1] = pt0_end; to_visit[2] = ptn; to_visit += 3; } #endif pt0 = RepAppl(d0); d0 = ArityOfFunctor(f); pt0_end = pt0 + d0; /* start writing the compound term */ ptn = H; *ptn++ = (CELL) f; H += d0 + 1; } else { /* AtomOrInt */ *ptn++ = d0; } /* just continue the loop */ } /* Do we still have compound terms to visit */ if (to_visit > (CELL **) to_visit_base) { #ifdef RATIONAL_TREES to_visit -= 4; pt0 = to_visit[0]; pt0_end = to_visit[1]; ptn = to_visit[2]; *pt0 = (CELL)to_visit[3]; #else to_visit -= 3; pt0 = to_visit[0]; pt0_end = to_visit[1]; ptn = to_visit[2]; #endif goto loop; } Bind_Global(PtrOfTerm(Var), TermNil); Yap_ReleasePreAllocCodeSpace((ADDR)to_visit); } /* * * Given a term t0, build a new term tf of the form ta+tb, where ta is * obtained by replacing the array references in t0 by empty * variables, and tb is a list of array references and corresponding * variables. */ static Term replace_array_references(Term t0) { Term t; t = Deref(t0); if (IsVarTerm(t)) { /* we found a variable */ return (MkPairTerm(t, TermNil)); } else if (IsAtomOrIntTerm(t)) { return (MkPairTerm(t, TermNil)); } else if (IsPairTerm(t)) { Term VList = MkVarTerm(); CELL *h0 = H; H += 2; replace_array_references_complex(RepPair(t) - 1, RepPair(t) + 1, h0, VList); return (MkPairTerm(AbsPair(h0), VList)); } else { Term VList = MkVarTerm(); CELL *h0 = H; Functor f = FunctorOfTerm(t); *H++ = (CELL) (f); H += ArityOfFunctor(f); replace_array_references_complex(RepAppl(t), RepAppl(t) + ArityOfFunctor(FunctorOfTerm(t)), h0 + 1, VList); return (MkPairTerm(AbsAppl(h0), VList)); } } static Int p_array_references(void) { Term t = replace_array_references(ARG1); Term t1 = HeadOfTerm(t); Term t2 = TailOfTerm(t); return (Yap_unify(t1, ARG2) && Yap_unify(t2, ARG3)); } static Int p_assign_static(void) { Term t1, t2, t3; StaticArrayEntry *ptr; Int indx; t2 = Deref(ARG2); if (IsNonVarTerm(t2)) { if (IsIntTerm(t2)) indx = IntOfTerm(t2); else { union arith_ret v; if (Yap_Eval(t2, &v) == long_int_e) { indx = v.Int; } else { Yap_Error(TYPE_ERROR_INTEGER,t2,"update_array"); return (FALSE); } } } else { Yap_Error(INSTANTIATION_ERROR,t2,"update_array"); return (FALSE); } t3 = Deref(ARG3); t1 = Deref(ARG1); if (IsVarTerm(t1)) { Yap_Error(INSTANTIATION_ERROR,t1,"update_array"); return(FALSE); } if (!IsAtomTerm(t1)) { if (IsApplTerm(t1)) { CELL *ptr; Functor f = FunctorOfTerm(t1); /* store the terms to visit */ if (IsExtensionFunctor(f)) { Yap_Error(TYPE_ERROR_ARRAY,t1,"update_array"); return(FALSE); } if (indx > 0 && indx > ArityOfFunctor(f)) { Yap_Error(DOMAIN_ERROR_ARRAY_OVERFLOW,t2,"update_array"); return(FALSE); } ptr = RepAppl(t1)+indx+1; #ifdef MULTI_ASSIGNMENT_VARIABLES MaBind(ptr, t3); return(TRUE); #else Yap_Error(SYSTEM_ERROR,t2,"update_array"); return(FALSE); #endif } else { Yap_Error(TYPE_ERROR_ATOM,t1,"update_array"); return(FALSE); } } { AtomEntry *ae = RepAtom(AtomOfTerm(t1)); READ_LOCK(ae->ARWLock); ptr = RepStaticArrayProp(ae->PropsOfAE); while (!EndOfPAEntr(ptr) && ptr->KindOfPE != ArrayProperty) ptr = RepStaticArrayProp(ptr->NextOfPE); if (EndOfPAEntr(ptr)) { READ_UNLOCK(ae->ARWLock); Yap_Error(EXISTENCE_ERROR_ARRAY,t1,"assign_static %s", RepAtom(AtomOfTerm(t1))->StrOfAE); return FALSE; } if (ArrayIsDynamic((ArrayEntry *)ptr)) { ArrayEntry *pp = (ArrayEntry *)ptr; CELL *pt; WRITE_LOCK(pp->ArRWLock); READ_UNLOCK(ae->ARWLock); if (indx < 0 || indx >= pp->ArrayEArity) { Yap_Error(DOMAIN_ERROR_ARRAY_OVERFLOW,t2,"assign_static"); WRITE_UNLOCK(pp->ArRWLock); return FALSE; } pt = RepAppl(pp->ValueOfVE) + indx + 1; WRITE_UNLOCK(pp->ArRWLock); #ifdef MULTI_ASSIGNMENT_VARIABLES /* the evil deed is to be done now */ MaBind(pt, t3); return TRUE; #else Yap_Error(SYSTEM_ERROR,t2,"update_array"); return FALSE; #endif } WRITE_LOCK(ptr->ArRWLock); READ_UNLOCK(ae->ARWLock); /* a static array */ if (indx < 0 || indx >= - ptr->ArrayEArity) { WRITE_UNLOCK(ptr->ArRWLock); Yap_Error(DOMAIN_ERROR_ARRAY_OVERFLOW,t2,"assign_static"); return FALSE; } switch (ptr->ArrayType) { case array_of_ints: { Int i; union arith_ret v; if (IsVarTerm(t3)) { WRITE_UNLOCK(ptr->ArRWLock); Yap_Error(INSTANTIATION_ERROR,t3,"assign_static"); return FALSE; } if (IsIntTerm(t3)) i = IntOfTerm(t3); else if (Yap_Eval(t3, &v) == long_int_e) i = v.Int; else { WRITE_UNLOCK(ptr->ArRWLock); Yap_Error(TYPE_ERROR_INTEGER,t3,"assign_static"); return (FALSE); } ptr->ValueOfVE.ints[indx]= i; } break; case array_of_chars: { Int i; union arith_ret v; if (IsVarTerm(t3)) { WRITE_UNLOCK(ptr->ArRWLock); Yap_Error(INSTANTIATION_ERROR,t3,"assign_static"); return FALSE; } if (IsIntTerm(t3)) i = IntOfTerm(t3); else if (Yap_Eval(t3, &v) == long_int_e) i = v.Int; else { Yap_Error(TYPE_ERROR_INTEGER,t3,"assign_static"); return (FALSE); } if (i > 127 || i < -128) { WRITE_UNLOCK(ptr->ArRWLock); Yap_Error(TYPE_ERROR_CHAR,t3,"assign_static"); return FALSE; } ptr->ValueOfVE.chars[indx]= i; } break; case array_of_uchars: { Int i; union arith_ret v; if (IsVarTerm(t3)) { WRITE_UNLOCK(ptr->ArRWLock); Yap_Error(INSTANTIATION_ERROR,t3,"assign_static"); return FALSE; } if (IsIntTerm(t3)) i = IntOfTerm(t3); else if (Yap_Eval(t3, &v) == long_int_e) i = v.Int; else { WRITE_UNLOCK(ptr->ArRWLock); Yap_Error(TYPE_ERROR_INTEGER,t3,"assign_static"); return FALSE; } if (i > 255 || i < 0) { WRITE_UNLOCK(ptr->ArRWLock); Yap_Error(TYPE_ERROR_UCHAR,t3,"assign_static"); return FALSE; } ptr->ValueOfVE.chars[indx]= i; } break; case array_of_doubles: { Float f; union arith_ret v; if (IsVarTerm(t3)) { WRITE_UNLOCK(ptr->ArRWLock); Yap_Error(INSTANTIATION_ERROR,t3,"assign_static"); return FALSE; } if (IsFloatTerm(t3)) f = FloatOfTerm(t3); else if (Yap_Eval(t3, &v) == double_e) f = v.dbl; else { WRITE_UNLOCK(ptr->ArRWLock); Yap_Error(TYPE_ERROR_FLOAT,t3,"assign_static"); return FALSE; } ptr->ValueOfVE.floats[indx]= f; } break; case array_of_ptrs: { Int r; if (IsVarTerm(t3)) { WRITE_UNLOCK(ptr->ArRWLock); Yap_Error(INSTANTIATION_ERROR,t3,"assign_static"); return FALSE; } if (IsIntegerTerm(t3)) r = IntegerOfTerm(t3); else { WRITE_UNLOCK(ptr->ArRWLock); Yap_Error(TYPE_ERROR_PTR,t3,"assign_static"); return FALSE; } ptr->ValueOfVE.ptrs[indx]= (AtomEntry *)r; } break; case array_of_atoms: { if (IsVarTerm(t3)) { WRITE_UNLOCK(ptr->ArRWLock); Yap_Error(INSTANTIATION_ERROR,t3,"assign_static"); return FALSE; } if (!IsAtomTerm(t3)) { WRITE_UNLOCK(ptr->ArRWLock); Yap_Error(TYPE_ERROR_ATOM,t3,"assign_static"); return FALSE; } ptr->ValueOfVE.atoms[indx]= t3; } break; case array_of_dbrefs: { Term t0 = ptr->ValueOfVE.dbrefs[indx]; DBRef p = DBRefOfTerm(t3); if (IsVarTerm(t3)) { WRITE_UNLOCK(ptr->ArRWLock); Yap_Error(INSTANTIATION_ERROR,t3,"assign_static"); return FALSE; } if (!IsDBRefTerm(t3)) { WRITE_UNLOCK(ptr->ArRWLock); Yap_Error(TYPE_ERROR_DBREF,t3,"assign_static"); return FALSE; } ptr->ValueOfVE.dbrefs[indx]= t3; if (t0 != 0L) { DBRef ptr = DBRefOfTerm(t0); if (ptr->Flags & LogUpdMask) { LogUpdClause *lup = (LogUpdClause *)ptr; LOCK(lup->ClLock); lup->ClRefCount--; if (lup->ClRefCount == 0 && (lup->ClFlags & ErasedMask) && !(lup->ClFlags & InUseMask)) { UNLOCK(lup->ClLock); Yap_ErLogUpdCl(lup); } else { UNLOCK(lup->ClLock); } } else { ptr->NOfRefsTo--; if (ptr->NOfRefsTo == 0 && (ptr->Flags & ErasedMask) && !(ptr->Flags & InUseMask)) { Yap_ErDBE(ptr); } } } if (p->Flags & LogUpdMask) { LogUpdClause *lup = (LogUpdClause *)p; LOCK(lup->ClLock); lup->ClRefCount++; UNLOCK(lup->ClLock); } else { p->NOfRefsTo++; } } break; case array_of_nb_terms: { Term told = ptr->ValueOfVE.lterms[indx].tstore; CELL *livep = &(ptr->ValueOfVE.lterms[indx].tlive); RESET_VARIABLE(livep); /* recover space */ if (IsApplTerm(told)) { Yap_ReleaseTermFromDB((DBTerm *)RepAppl(told)); } if (IsVarTerm(t3)) { RESET_VARIABLE(&(ptr->ValueOfVE.lterms[indx].tstore)); } else if (IsAtomicTerm(t3)) { ptr->ValueOfVE.lterms[indx].tstore = t3; } else { DBTerm *new = Yap_StoreTermInDB(t3,3); if (!new) { WRITE_UNLOCK(ptr->ArRWLock); return FALSE; } ptr->ValueOfVE.lterms[indx].tstore = AbsAppl((CELL *)new); } } break; case array_of_terms: { DBTerm *ref = ptr->ValueOfVE.terms[indx]; if (ref != NULL) { Yap_ReleaseTermFromDB(ref); } ptr->ValueOfVE.terms[indx] = Yap_StoreTermInDB(t3,3); if (ptr->ValueOfVE.terms[indx] == NULL){ WRITE_UNLOCK(ptr->ArRWLock); return FALSE; } } break; } WRITE_UNLOCK(ptr->ArRWLock); return TRUE; } } static Int p_assign_dynamic(void) { Term t1, t2, t3; StaticArrayEntry *ptr; Int indx; t2 = Deref(ARG2); if (IsNonVarTerm(t2)) { if (IsIntTerm(t2)) indx = IntOfTerm(t2); else { union arith_ret v; if (Yap_Eval(t2, &v) == long_int_e) { indx = v.Int; } else { Yap_Error(TYPE_ERROR_INTEGER,t2,"update_array"); return (FALSE); } } } else { Yap_Error(INSTANTIATION_ERROR,t2,"update_array"); return (FALSE); } t3 = Deref(ARG3); t1 = Deref(ARG1); if (IsVarTerm(t1)) { Yap_Error(INSTANTIATION_ERROR,t1,"update_array"); return(FALSE); } if (!IsAtomTerm(t1)) { if (IsApplTerm(t1)) { CELL *ptr; Functor f = FunctorOfTerm(t1); /* store the terms to visit */ if (IsExtensionFunctor(f)) { Yap_Error(TYPE_ERROR_ARRAY,t1,"update_array"); return(FALSE); } if (indx > 0 && indx > ArityOfFunctor(f)) { Yap_Error(DOMAIN_ERROR_ARRAY_OVERFLOW,t2,"update_array"); return(FALSE); } ptr = RepAppl(t1)+indx+1; #ifdef MULTI_ASSIGNMENT_VARIABLES MaBind(ptr, t3); return(TRUE); #else Yap_Error(SYSTEM_ERROR,t2,"update_array"); return(FALSE); #endif } else { Yap_Error(TYPE_ERROR_ATOM,t1,"update_array"); return(FALSE); } } { AtomEntry *ae = RepAtom(AtomOfTerm(t1)); READ_LOCK(ae->ARWLock); ptr = RepStaticArrayProp(ae->PropsOfAE); while (!EndOfPAEntr(ptr) && ptr->KindOfPE != ArrayProperty) ptr = RepStaticArrayProp(ptr->NextOfPE); READ_UNLOCK(ae->ARWLock); } if (EndOfPAEntr(ptr)) { Yap_Error(EXISTENCE_ERROR_ARRAY,t1,"assign_static %s", RepAtom(AtomOfTerm(t1))->StrOfAE); return(FALSE); } if (ArrayIsDynamic((ArrayEntry *)ptr)) { ArrayEntry *pp = (ArrayEntry *)ptr; CELL *pt; WRITE_LOCK(pp->ArRWLock); if (indx < 0 || indx >= pp->ArrayEArity) { Yap_Error(DOMAIN_ERROR_ARRAY_OVERFLOW,t2,"assign_static"); WRITE_UNLOCK(pp->ArRWLock); return(FALSE); } pt = RepAppl(pp->ValueOfVE) + indx + 1; WRITE_UNLOCK(pp->ArRWLock); #ifdef MULTI_ASSIGNMENT_VARIABLES /* the evil deed is to be done now */ MaBind(pt, t3); return TRUE; #else Yap_Error(SYSTEM_ERROR,t2,"update_array"); return FALSE; #endif } WRITE_LOCK(ptr->ArRWLock); /* a static array */ if (indx < 0 || indx >= - ptr->ArrayEArity) { WRITE_UNLOCK(ptr->ArRWLock); Yap_Error(DOMAIN_ERROR_ARRAY_OVERFLOW,t2,"assign_static"); return FALSE; } switch (ptr->ArrayType) { case array_of_ints: case array_of_chars: case array_of_uchars: case array_of_doubles: case array_of_ptrs: case array_of_atoms: case array_of_dbrefs: case array_of_terms: WRITE_UNLOCK(ptr->ArRWLock); Yap_Error(DOMAIN_ERROR_ARRAY_TYPE, t3, "assign_static"); return FALSE; case array_of_nb_terms: #ifdef MULTI_ASSIGNMENT_VARIABLES { Term t = ptr->ValueOfVE.lterms[indx].tlive; Functor f; /* we have a mutable term there */ if (IsVarTerm(t) || !IsApplTerm(t) || (f = FunctorOfTerm(t)) != FunctorAtFoundOne) { Term tn = Yap_NewTimedVar(t3); CELL *sp = RepAppl(tn); *sp = (CELL)FunctorAtFoundOne; Bind(&(ptr->ValueOfVE.lterms[indx].tlive),tn); } else { Yap_UpdateTimedVar(t, t3); } } WRITE_UNLOCK(ptr->ArRWLock); return TRUE; #else WRITE_UNLOCK(ptr->ArRWLock); Yap_Error(SYSTEM_ERROR,t2,"update_array"); return FALSE; #endif } WRITE_UNLOCK(ptr->ArRWLock); return TRUE; } static Int p_add_to_array_element(void) { Term t1, t2, t3; StaticArrayEntry *ptr; Int indx; t2 = Deref(ARG2); if (IsNonVarTerm(t2)) { if (IsIntTerm(t2)) indx = IntOfTerm(t2); else { union arith_ret v; if (Yap_Eval(t2, &v) == long_int_e) { indx = v.Int; } else { Yap_Error(TYPE_ERROR_INTEGER,t2,"add_to_array_element"); return (FALSE); } } } else { Yap_Error(INSTANTIATION_ERROR,t2,"add_to_array_element"); return (FALSE); } t1 = Deref(ARG1); if (IsVarTerm(t1)) { Yap_Error(INSTANTIATION_ERROR,t1,"add_to_array_element"); return(FALSE); } t3 = Deref(ARG3); if (IsVarTerm(t3)) { Yap_Error(INSTANTIATION_ERROR,t3,"add_to_array_element"); return(FALSE); } if (!IsAtomTerm(t1)) { if (IsApplTerm(t1)) { CELL *ptr; Functor f = FunctorOfTerm(t1); Term ta; /* store the terms to visit */ if (IsExtensionFunctor(f)) { Yap_Error(TYPE_ERROR_ARRAY,t1,"add_to_array_element"); return(FALSE); } if (indx > 0 && indx > ArityOfFunctor(f)) { Yap_Error(DOMAIN_ERROR_ARRAY_OVERFLOW,t2,"add_to_array_element"); return(FALSE); } ptr = RepAppl(t1)+indx+1; ta = RepAppl(t1)[indx+1]; if (IsIntegerTerm(ta)) { if (IsIntegerTerm(t3)) { ta = MkIntegerTerm(IntegerOfTerm(ta)+IntegerOfTerm(t3)); } else if (IsFloatTerm(t3)) { ta = MkFloatTerm(IntegerOfTerm(ta)+FloatOfTerm(t3)); } else { Yap_Error(TYPE_ERROR_NUMBER,t3,"add_to_array_element"); return(FALSE); } } else if (IsFloatTerm(ta)) { if (IsFloatTerm(t3)) { ta = MkFloatTerm(FloatOfTerm(ta)+IntegerOfTerm(t3)); } else if (IsFloatTerm(t3)) { ta = MkFloatTerm(FloatOfTerm(ta)+FloatOfTerm(t3)); } else { Yap_Error(TYPE_ERROR_NUMBER,t3,"add_to_array_element"); return(FALSE); } } else { Yap_Error(TYPE_ERROR_NUMBER,ta,"add_to_array_element"); return(FALSE); } #ifdef MULTI_ASSIGNMENT_VARIABLES t3 = MkIntegerTerm(IntegerOfTerm(t3)+1); MaBind(ptr, t3); return(Yap_unify(ARG4,t3)); #else Yap_Error(SYSTEM_ERROR,t2,"add_to_array_element"); return(FALSE); #endif } else { Yap_Error(TYPE_ERROR_ATOM,t1,"add_to_array_element"); return(FALSE); } } { AtomEntry *ae = RepAtom(AtomOfTerm(t1)); READ_LOCK(ae->ARWLock); ptr = RepStaticArrayProp(ae->PropsOfAE); while (!EndOfPAEntr(ptr) && ptr->KindOfPE != ArrayProperty) ptr = RepStaticArrayProp(ptr->NextOfPE); READ_UNLOCK(ae->ARWLock); } if (EndOfPAEntr(ptr)) { Yap_Error(EXISTENCE_ERROR_ARRAY,t1,"add_to_array_element %s", RepAtom(AtomOfTerm(t1))->StrOfAE); return(FALSE); } if (ArrayIsDynamic((ArrayEntry *)ptr)) { ArrayEntry *pp = (ArrayEntry *)ptr; CELL *pt; Term ta; WRITE_LOCK(pp->ArRWLock); if (indx < 0 || indx >= pp->ArrayEArity) { Yap_Error(DOMAIN_ERROR_ARRAY_OVERFLOW,t2,"add_to_array_element"); READ_UNLOCK(pp->ArRWLock); return FALSE; } pt = RepAppl(pp->ValueOfVE) + indx + 1; ta = RepAppl(pp->ValueOfVE)[indx+1]; if (IsIntegerTerm(ta)) { if (IsIntegerTerm(t3)) { ta = MkIntegerTerm(IntegerOfTerm(ta)+IntegerOfTerm(t3)); } else if (IsFloatTerm(t3)) { ta = MkFloatTerm(IntegerOfTerm(ta)+FloatOfTerm(t3)); } else { WRITE_UNLOCK(pp->ArRWLock); Yap_Error(TYPE_ERROR_NUMBER,t3,"add_to_array_element"); return FALSE; } } else if (IsFloatTerm(ta)) { if (IsFloatTerm(t3)) { ta = MkFloatTerm(FloatOfTerm(ta)+IntegerOfTerm(t3)); } else if (IsFloatTerm(t3)) { ta = MkFloatTerm(FloatOfTerm(ta)+FloatOfTerm(t3)); } else { WRITE_UNLOCK(pp->ArRWLock); Yap_Error(TYPE_ERROR_NUMBER,t3,"add_to_array_element"); return FALSE; } } else { WRITE_UNLOCK(pp->ArRWLock); Yap_Error(TYPE_ERROR_NUMBER,ta,"add_to_array_element"); return FALSE; } #ifdef MULTI_ASSIGNMENT_VARIABLES /* the evil deed is to be done now */ t3 = MkIntegerTerm(IntegerOfTerm(t3)+1); MaBind(pt, t3); WRITE_UNLOCK(pp->ArRWLock); return Yap_unify(ARG4,t3); #else Yap_Error(SYSTEM_ERROR,t2,"add_to_array_element"); WRITE_UNLOCK(pp->ArRWLock); return FALSE; #endif } WRITE_LOCK(ptr->ArRWLock); /* a static array */ if (indx < 0 || indx >= - ptr->ArrayEArity) { WRITE_UNLOCK(ptr->ArRWLock); Yap_Error(DOMAIN_ERROR_ARRAY_OVERFLOW,t2,"add_to_array_element"); return FALSE; } switch (ptr->ArrayType) { case array_of_ints: { Int i = ptr->ValueOfVE.ints[indx]; if (!IsIntegerTerm(t3)) { WRITE_UNLOCK(ptr->ArRWLock); Yap_Error(TYPE_ERROR_INTEGER,t3,"add_to_array_element"); return FALSE; } i += IntegerOfTerm(t3); ptr->ValueOfVE.ints[indx] = i; WRITE_UNLOCK(ptr->ArRWLock); return Yap_unify(ARG4,MkIntegerTerm(i)); } break; case array_of_doubles: { Float fl = ptr->ValueOfVE.floats[indx]; if (IsFloatTerm(t3)) { fl += FloatOfTerm(t3); } else if (IsIntegerTerm(t3)) { fl += IntegerOfTerm(t3); } else { WRITE_UNLOCK(ptr->ArRWLock); Yap_Error(TYPE_ERROR_NUMBER,t3,"add_to_array_element"); return FALSE; } ptr->ValueOfVE.floats[indx] = fl; WRITE_UNLOCK(ptr->ArRWLock); return Yap_unify(ARG4,MkFloatTerm(fl)); } break; default: WRITE_UNLOCK(ptr->ArRWLock); Yap_Error(TYPE_ERROR_INTEGER,t2,"add_to_array_element"); return FALSE; } } static Int p_compile_array_refs(void) { compile_arrays = TRUE; return (TRUE); } static Int p_array_refs_compiled(void) { return (compile_arrays); } static Int p_sync_mmapped_arrays(void) { #ifdef HAVE_MMAP mmap_array_block *ptr = mmap_arrays; while (ptr != NULL) { msync(ptr->start, ptr->size, MS_SYNC); ptr = ptr->next; } #endif return(TRUE); } static Int p_static_array_to_term(void) { Term t = Deref(ARG1); if (IsVarTerm(t)) { return FALSE; } else if (IsAtomTerm(t)) { /* Create a named array */ AtomEntry *ae = RepAtom(AtomOfTerm(t)); StaticArrayEntry *pp; READ_LOCK(ae->ARWLock); pp = RepStaticArrayProp(ae->PropsOfAE); while (!EndOfPAEntr(pp) && pp->KindOfPE != ArrayProperty) pp = RepStaticArrayProp(pp->NextOfPE); if (EndOfPAEntr(pp) || pp->ValueOfVE.ints == NULL) { READ_UNLOCK(ae->ARWLock); return (FALSE); } else { static_array_types tp = pp->ArrayType; Int dim = -pp->ArrayEArity, indx; CELL *base; while (H+1+dim > ASP-1024) { if (!Yap_gc(2, ENV, P)) { Yap_Error(OUT_OF_STACK_ERROR,TermNil,Yap_ErrorMessage); return(FALSE); } else { if (H+1+dim > ASP-1024) { if (!Yap_growstack( sizeof(CELL) * (dim+1-(H-ASP-1024)))) { Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage); return FALSE; } } } } READ_LOCK(pp->ArRWLock); READ_UNLOCK(ae->ARWLock); base = H; *H++ = (CELL)Yap_MkFunctor(AbsAtom(ae),dim); switch(tp) { case array_of_ints: { CELL *sptr = H; H += dim; for (indx=0; indx < dim; indx++) { *sptr++ = MkIntegerTerm(pp->ValueOfVE.ints[indx]); } } break; case array_of_dbrefs: for (indx=0; indx < dim; indx++) { /* The object is now in use */ Term TRef = pp->ValueOfVE.dbrefs[indx]; if (TRef != 0L) { DBRef ref = DBRefOfTerm(TRef); #if defined(YAPOR) || defined(THREADS) LOCK(ref->lock); INC_DBREF_COUNT(ref); TRAIL_REF(ref); /* So that fail will erase it */ UNLOCK(ref->lock); #else if (!(ref->Flags & InUseMask)) { ref->Flags |= InUseMask; TRAIL_REF(ref); /* So that fail will erase it */ } #endif } else { TRef = TermNil; } *H++ = TRef; } break; case array_of_doubles: { CELL *sptr = H; H += dim; for (indx=0; indx < dim; indx++) { *sptr++ = MkEvalFl(pp->ValueOfVE.floats[indx]); } } break; case array_of_ptrs: { CELL *sptr = H; H += dim; for (indx=0; indx < dim; indx++) { *sptr++ = MkIntegerTerm((Int)(pp->ValueOfVE.ptrs[indx])); } } break; case array_of_chars: { CELL *sptr = H; H += dim; for (indx=0; indx < dim; indx++) { *sptr++ = MkIntegerTerm((Int)(pp->ValueOfVE.chars[indx])); } } break; case array_of_uchars: { CELL *sptr = H; H += dim; for (indx=0; indx < dim; indx++) { *sptr++ = MkIntegerTerm((Int)(pp->ValueOfVE.uchars[indx])); } } break; case array_of_terms: { CELL *sptr = H; H += dim; for (indx=0; indx < dim; indx++) { /* The object is now in use */ DBTerm *ref = pp->ValueOfVE.terms[indx]; Term TRef = GetTermFromArray(ref); if (P == FAILCODE) { return FALSE; } *sptr++ = TRef; } } break; case array_of_nb_terms: { CELL *sptr = H; H += dim; for (indx=0; indx < dim; indx++) { /* The object is now in use */ Term To = GetNBTerm(pp->ValueOfVE.lterms, indx); if (P == FAILCODE) { return FALSE; } *sptr++ = To; } } break; case array_of_atoms: for (indx=0; indx < dim; indx++) { Term out; out = pp->ValueOfVE.atoms[indx]; if (out == 0L) out = TermNil; *H++ = out; } break; } READ_UNLOCK(pp->ArRWLock); return Yap_unify(AbsAppl(base),ARG2); } } Yap_Error(TYPE_ERROR_ATOM,t,"add_to_array_element"); return FALSE; } static Int p_static_array_location(void) { Term t = Deref(ARG1); Int *ptr; if (IsVarTerm(t)) { return FALSE; } else if (IsAtomTerm(t)) { /* Create a named array */ AtomEntry *ae = RepAtom(AtomOfTerm(t)); StaticArrayEntry *pp; READ_LOCK(ae->ARWLock); pp = RepStaticArrayProp(ae->PropsOfAE); while (!EndOfPAEntr(pp) && pp->KindOfPE != ArrayProperty) pp = RepStaticArrayProp(pp->NextOfPE); if (EndOfPAEntr(pp) || pp->ValueOfVE.ints == NULL) { READ_UNLOCK(ae->ARWLock); return FALSE; } else { ptr = pp->ValueOfVE.ints; READ_UNLOCK(ae->ARWLock); } return Yap_unify(ARG2,MkIntegerTerm((Int)ptr)); } return FALSE; } void Yap_InitArrayPreds(void) { Yap_InitCPred("$create_array", 2, p_create_array, SyncPredFlag|HiddenPredFlag); Yap_InitCPred("$array_references", 3, p_array_references, SafePredFlag|HiddenPredFlag); Yap_InitCPred("$array_arg", 3, p_array_arg, SafePredFlag|HiddenPredFlag); Yap_InitCPred("static_array", 3, p_create_static_array, SafePredFlag|SyncPredFlag); Yap_InitCPred("resize_static_array", 3, p_resize_static_array, SafePredFlag|SyncPredFlag); Yap_InitCPred("mmapped_array", 4, p_create_mmapped_array, SafePredFlag|SyncPredFlag); Yap_InitCPred("update_array", 3, p_assign_static, SafePredFlag); Yap_InitCPred("dynamic_update_array", 3, p_assign_dynamic, SafePredFlag); Yap_InitCPred("add_to_array_element", 4, p_add_to_array_element, SafePredFlag); Yap_InitCPred("array_element", 3, p_access_array, 0); Yap_InitCPred("close_static_array", 1, p_close_static_array, SafePredFlag); Yap_InitCPred("$sync_mmapped_arrays", 0, p_sync_mmapped_arrays, SafePredFlag|HiddenPredFlag); Yap_InitCPred("$compile_array_refs", 0, p_compile_array_refs, SafePredFlag|HiddenPredFlag); Yap_InitCPred("$array_refs_compiled", 0, p_array_refs_compiled, SafePredFlag|HiddenPredFlag); Yap_InitCPred("$static_array_properties", 3, p_static_array_properties, SafePredFlag|HiddenPredFlag); Yap_InitCPred("static_array_to_term", 2, p_static_array_to_term, 0L); Yap_InitCPred("static_array_location", 2, p_static_array_location, 0L); }