static void
registerWakeup(Word name, Word value ARG_LD)
{ Word wake;
Word tail = valTermRef(LD->attvar.tail);
assert(gTop+6 <= gMax && tTop+4 <= tMax);
wake = gTop;
gTop += 4;
wake[0] = FUNCTOR_wakeup3;
wake[1] = needsRef(*name) ? makeRef(name) : *name;
wake[2] = needsRef(*value) ? makeRef(value) : *value;
wake[3] = ATOM_nil;
if ( *tail )
{ Word t; /* Non-empty list */
deRef2(tail, t);
TrailAssignment(t);
*t = consPtr(wake, TAG_COMPOUND|STG_GLOBAL);
TrailAssignment(tail); /* on local stack! */
*tail = makeRef(wake+3);
DEBUG(1, Sdprintf("appended to wakeup\n"));
} else /* empty list */
{ Word head = valTermRef(LD->attvar.head);
assert(isVar(*head));
TrailAssignment(head); /* See (*) */
*head = consPtr(wake, TAG_COMPOUND|STG_GLOBAL);
TrailAssignment(tail);
*tail = makeRef(wake+3);
LD->alerted |= ALERT_WAKEUP;
DEBUG(1, Sdprintf("new wakeup\n"));
}
}
static void
put_new_attvar(Word p, atom_t name, Word value ARG_LD)
{ Word gp, at;
assert(gTop+6 <= gMax && tTop+1 <= tMax);
gp = gTop;
if ( p >= (Word)lBase )
{ gTop += 6;
at = &gp[1];
setVar(*at);
gp[0] = consPtr(&gp[1], TAG_ATTVAR|STG_GLOBAL);
*p = makeRefG(&gp[0]);
LTrail(p);
} else
{ gTop += 5;
at = &gp[0];
setVar(*at);
*p = consPtr(&gp[0], TAG_ATTVAR|STG_GLOBAL);
GTrail(p);
}
at[1] = FUNCTOR_att3;
at[2] = name;
at[3] = linkVal(value);
at[4] = ATOM_nil;
at[0] = consPtr(&at[1], TAG_COMPOUND|STG_GLOBAL);
}
int
put_int64(Word at, int64_t l, int flags ARG_LD)
{ Word p;
word r, m;
int req;
r = consInt(l);
if ( valInt(r) == l )
{ *at = r;
return TRUE;
}
#if SIZEOF_VOIDP == 8
req = 3;
#elif SIZEOF_VOIDP == 4
req = 4;
#else
#error "FIXME: Unsupported sizeof word"
#endif
if ( !hasGlobalSpace(req) )
{ int rc = ensureGlobalSpace(req, flags);
if ( rc != TRUE )
return rc;
}
p = gTop;
gTop += req;
#if SIZEOF_VOIDP == 8
r = consPtr(p, TAG_INTEGER|STG_GLOBAL);
m = mkIndHdr(1, TAG_INTEGER);
*p++ = m;
*p++ = l;
*p = m;
#else
#if SIZEOF_VOIDP == 4
r = consPtr(p, TAG_INTEGER|STG_GLOBAL);
m = mkIndHdr(2, TAG_INTEGER);
*p++ = m;
#ifdef WORDS_BIGENDIAN
*p++ = (word)(l>>32);
*p++ = (word)l;
#else
*p++ = (word)l;
*p++ = (word)(l>>32);
#endif
*p = m;
#else
#error "FIXME: Unsupported sizeof intptr_t."
#endif
#endif
*at = r;
return TRUE;
}
static inline void
exitCyclicCopy(int flags ARG_LD)
{ Word p;
while(popSegStack(&LD->cycle.lstack, &p, Word))
{ if ( isRef(*p) )
{ Word p2 = unRef(*p);
if ( *p2 == VAR_MARK ) /* sharing variables */
{ setVar(*p2);
setVar(*p);
} else
{ *p = *p2 | MARK_MASK; /* cyclic terms */
}
} else
{ Word old;
popSegStack(&LD->cycle.lstack, &old, Word);
if ( !(flags©_ATTRS) )
{ Word p2 = valPAttVar(*p & ~BOTH_MASK);
assert(*p2 == VAR_MARK);
setVar(*p2);
}
*p = consPtr(old, STG_GLOBAL|TAG_ATTVAR);
}
}
}
static int
globalMPZ(Word at, mpz_t mpz, int flags ARG_LD)
{ DEBUG(CHK_SECURE, assert(!onStackArea(global, at) && !onStackArea(local, at)));
if ( mpz->_mp_alloc )
{ Word p;
size_t size;
size_t wsz = mpz_wsize(mpz, &size);
word m = mkIndHdr(wsz+1, TAG_INTEGER);
if ( wsizeofInd(m) != wsz+1 )
{ PL_error(NULL, 0, NULL, ERR_REPRESENTATION, ATOM_integer);
return 0;
}
if ( !hasGlobalSpace(wsz+3) )
{ int rc = ensureGlobalSpace(wsz+3, flags);
if ( rc != TRUE )
return rc;
}
p = gTop;
gTop += wsz+3;
*at = consPtr(p, TAG_INTEGER|STG_GLOBAL);
*p++ = m;
p[wsz] = 0L; /* pad out */
p[wsz+1] = m;
*p++ = (word)mpz->_mp_size;
memcpy(p, mpz->_mp_d, size);
} else /* already on the stack */
{ Word p = (Word)mpz->_mp_d - 2;
#ifndef NDEBUG
size_t size;
size_t wsz = mpz_wsize(mpz, &size);
assert(p[0] == mkIndHdr(wsz+1, TAG_INTEGER));
#endif
*at = consPtr(p, TAG_INTEGER|STG_GLOBAL);
}
return TRUE;
}
static void
make_new_attvar(Word p ARG_LD)
{ Word gp;
assert(gTop+2 <= gMax && tTop+1 <= tMax);
if ( p >= (Word)lBase )
{ gp = gTop;
gp[1] = ATOM_nil;
gp[0] = consPtr(&gp[1], TAG_ATTVAR|STG_GLOBAL);
*p = makeRefG(gp);
gTop += 2;
LTrail(p);
} else
{ gp = gTop;
gp[0] = ATOM_nil;
*p = consPtr(&gp[0], TAG_ATTVAR|STG_GLOBAL);
gTop += 1;
GTrail(p);
}
}
static void
put_new_attvar(Word p, atom_t name, Word value ARG_LD)
{ Word gp, at;
assert(gTop+7 <= gMax && tTop+1 <= tMax);
gp = link_attvar(PASS_LD1);
gTop += 6;
at = &gp[1];
setVar(*at);
gp[0] = consPtr(&gp[1], TAG_ATTVAR|STG_GLOBAL);
at[1] = FUNCTOR_att3;
at[2] = name;
at[3] = linkVal(value);
at[4] = ATOM_nil;
at[0] = consPtr(&at[1], TAG_COMPOUND|STG_GLOBAL);
trail_new_attvar(gp PASS_LD);
Trail(p, makeRefG(gp));
}
Word
alloc_attvar(ARG1_LD)
{ Word gp = allocGlobalNoShift(3);
if ( gp )
{ register_attvar(&gp[0] PASS_LD);
gp[1] = consPtr(&gp[2], TAG_ATTVAR|STG_GLOBAL);
gp[2] = ATOM_nil;
return &gp[1];
}
return NULL;
}
static void
make_new_attvar(Word p ARG_LD)
{ Word gp;
assert(gTop+3 <= gMax && tTop+1 <= tMax);
gp = link_attvar(PASS_LD1);
gp[1] = ATOM_nil;
gp[0] = consPtr(&gp[1], TAG_ATTVAR|STG_GLOBAL);
gTop += 2;
trail_new_attvar(gp PASS_LD);
Trail(p, makeRefG(gp));
}
word
globalString(size_t len, const char *s)
{ GET_LD
Word p = allocString(len+1 PASS_LD);
if ( p )
{ char *q = (char *)&p[1];
*q++ = 'B';
memcpy(q, s, len);
return consPtr(p, TAG_STRING|STG_GLOBAL);
}
return 0;
}
char *
loadMPZFromCharp(const char *data, Word r, Word *store)
{ GET_LD
int size = 0;
size_t limpsize;
size_t wsize;
int neg;
mpz_t mpz;
Word p;
word m;
size |= (data[0]&0xff)<<24;
size |= (data[1]&0xff)<<16;
size |= (data[2]&0xff)<<8;
size |= (data[3]&0xff);
size = (size << SHIFTSIGN32)>>SHIFTSIGN32; /* sign extend */
data += 4;
DEBUG(1, Sdprintf("loadMPZFromCharp(): size = %d bytes\n", size));
if ( size < 0 )
{ neg = TRUE;
size = -size;
} else
neg = FALSE;
limpsize = (size+sizeof(mp_limb_t)-1)/sizeof(mp_limb_t);
wsize = (limpsize*sizeof(mp_limb_t)+sizeof(word)-1)/sizeof(word);
p = *store;
*store += (wsize+3);
*r = consPtr(p, TAG_INTEGER|STG_GLOBAL);
m = mkIndHdr(wsize+1, TAG_INTEGER);
*p++ = m;
p[wsize] = 0L; /* pad out */
p[wsize+1] = m;
*p++ = (neg ? -limpsize : limpsize);
mpz->_mp_size = limpsize;
mpz->_mp_alloc = limpsize;
mpz->_mp_d = (mp_limb_t*)p;
mpz_import(mpz, size, 1, 1, 1, 0, data);
assert((Word)mpz->_mp_d == p); /* check no (re-)allocation is done */
return (char *)data+size;
}
word
globalWString(size_t len, const pl_wchar_t *s)
{ GET_LD
const pl_wchar_t *e = &s[len];
const pl_wchar_t *p;
Word g;
for(p=s; p<e; p++)
{ if ( *p > 0xff )
break;
}
if ( p == e ) /* 8-bit string */
{ unsigned char *t;
if ( !(g = allocString(len+1 PASS_LD)) )
return 0;
t = (unsigned char *)&g[1];
*t++ = 'B';
for(p=s; p<e; )
*t++ = *p++ & 0xff;
} else /* wide string */
{ char *t;
pl_wchar_t *w;
if ( !(g = allocString((len+1)*sizeof(pl_wchar_t) PASS_LD)) )
return 0;
t = (char *)&g[1];
w = (pl_wchar_t*)t;
w[0] = 0;
*t = 'W';
memcpy(&w[1], s, len*sizeof(pl_wchar_t));
}
return consPtr(g, TAG_STRING|STG_GLOBAL);
}
static int
copy_term(Word from, Word to, int flags ARG_LD)
{ term_agendaLR agenda;
int rc = TRUE;
initTermAgendaLR(&agenda, 1, from, to);
while( nextTermAgendaLR(&agenda, &from, &to) )
{
again:
switch(tag(*from))
{ case TAG_REFERENCE:
{ Word p2 = unRef(*from);
if ( *p2 == VAR_MARK ) /* reference to a copied variable */
{ *to = makeRef(p2);
} else
{ from = p2; /* normal reference */
goto again;
}
continue;
}
case TAG_VAR:
{ if ( shared(*from) )
{ *to = VAR_MARK;
*from = makeRef(to);
TrailCyclic(from PASS_LD);
} else
{ setVar(*to);
}
continue;
}
case TAG_ATTVAR:
if ( flags©_ATTRS )
{ Word p = valPAttVar(*from);
if ( isAttVar(*p) ) /* already copied */
{ *to = makeRefG(p);
} else
{ Word attr;
if ( !(attr = alloc_attvar(PASS_LD1)) )
{ rc = GLOBAL_OVERFLOW;
goto out;
}
TrailCyclic(p PASS_LD);
TrailCyclic(from PASS_LD);
*from = consPtr(attr, STG_GLOBAL|TAG_ATTVAR);
*to = makeRefG(attr);
from = p;
to = &attr[1];
goto again;
}
} else
{ if ( shared(*from) )
{ Word p = valPAttVar(*from & ~BOTH_MASK);
if ( *p == VAR_MARK )
{ *to = makeRef(p);
} else
{ *to = VAR_MARK;
*from = consPtr(to, STG_GLOBAL|TAG_ATTVAR)|BOTH_MASK;
TrailCyclic(p PASS_LD);
TrailCyclic(from PASS_LD);
}
} else
{ setVar(*to);
}
}
continue;
case TAG_COMPOUND:
{ Functor ff = valueTerm(*from);
if ( isRef(ff->definition) )
{ *to = consPtr(unRef(ff->definition), TAG_COMPOUND|STG_GLOBAL);
continue;
}
if ( ground(ff->definition) )
{ *to = *from;
continue;
}
if ( shared(ff->definition) )
{ int arity = arityFunctor(ff->definition);
Functor ft;
if ( !(ft = (Functor)allocGlobalNoShift(arity+1)) )
{ rc = GLOBAL_OVERFLOW;
goto out;
}
ft->definition = ff->definition & ~BOTH_MASK;
ff->definition = makeRefG((Word)ft);
TrailCyclic(&ff->definition PASS_LD);
*to = consPtr(ft, TAG_COMPOUND|STG_GLOBAL);
if ( pushWorkAgendaLR(&agenda, arity, ff->arguments, ft->arguments) )
continue;
rc = MEMORY_OVERFLOW;
goto out;
} else /* unshared term */
{ int arity = arityFunctor(ff->definition);
Functor ft;
if ( !(ft = (Functor)allocGlobalNoShift(arity+1)) )
{ rc = GLOBAL_OVERFLOW;
goto out;
}
ft->definition = ff->definition & ~BOTH_MASK;
*to = consPtr(ft, TAG_COMPOUND|STG_GLOBAL);
if ( pushWorkAgendaLR(&agenda, arity, ff->arguments, ft->arguments) )
continue;
rc = MEMORY_OVERFLOW;
goto out;
}
}
default:
*to = *from;
continue;
}
}
out:
clearTermAgendaLR(&agenda);
return rc;
}
int
outOfStack(void *stack, stack_overflow_action how)
{ GET_LD
Stack s = stack;
const char *msg = "out-of-stack";
if ( LD->outofstack )
{ Sdprintf("[Thread %d]: failed to recover from %s-overflow\n",
PL_thread_self(), s->name);
print_backtrace_named(msg);
save_backtrace("crash");
print_backtrace_named("crash");
fatalError("Sorry, cannot continue");
return FALSE; /* NOTREACHED */
}
save_backtrace(msg);
if ( s->spare != s->def_spare )
{ Sdprintf("[Thread %d]: %s-overflow: spare=%ld\n"
"Last resource exception:\n",
PL_thread_self(), s->name, (long)s->spare);
print_backtrace_named("exception");
}
LD->trim_stack_requested = TRUE;
LD->exception.processing = TRUE;
LD->outofstack = stack;
switch(how)
{ case STACK_OVERFLOW_THROW:
case STACK_OVERFLOW_RAISE:
{ if ( gTop+5 < gMax )
{ Word p = gTop;
p[0] = FUNCTOR_error2; /* see (*) above */
p[1] = consPtr(&p[3], TAG_COMPOUND|STG_GLOBAL);
p[2] = PL_new_atom(s->name);
p[3] = FUNCTOR_resource_error1;
p[4] = ATOM_stack;
gTop += 5;
PL_unregister_atom(p[2]);
*valTermRef(LD->exception.bin) = consPtr(p, TAG_COMPOUND|STG_GLOBAL);
freezeGlobal(PASS_LD1);
} else
{ Sdprintf("Out of %s-stack. No room for exception term. Aborting.\n", s->name);
*valTermRef(LD->exception.bin) = ATOM_aborted;
}
exception_term = exception_bin;
if ( how == STACK_OVERFLOW_THROW &&
LD->exception.throw_environment )
{ /* see PL_throw() */
longjmp(LD->exception.throw_environment->exception_jmp_env, 1);
}
return FALSE;
}
default:
assert(0);
fail;
}
}