/* build-literals.c
*
* COPYRIGHT (c) 1997 Bell Labs, Lucent Technologies.
*/
#include "ml-base.h"
#include "ml-objects.h"
#include "heap.h"
#include <string.h>
/* Codes for literal machine instructions (version 1):
* INT(i) 0x01 <i>
* RAW32[i] 0x02 <i>
* RAW32[i1,..,in] 0x03 <n> <i1> ... <in>
* RAW64[r] 0x04 <r>
* RAW64[r1,..,rn] 0x05 <n> <r1> ... <rn>
* STR[c1,..,cn] 0x06 <n> <c1> ... <cn>
* LIT(k) 0x07 <k>
* VECTOR(n) 0x08 <n>
* RECORD(n) 0x09 <n>
* RETURN 0xff
*/
#define V1_MAGIC 0x19981022
#define I_INT 0x01
#define I_RAW32 0x2
#define I_RAW32L 0x3
#define I_RAW64 0x4
#define I_RAW64L 0x5
#define I_STR 0x6
#define I_LIT 0x7
#define I_VECTOR 0x8
#define I_RECORD 0x9
#define I_RETURN 0xff
#define _B0(p) ((p)[pc])
#define _B1(p) ((p)[pc+1])
#define _B2(p) ((p)[pc+2])
#define _B3(p) ((p)[pc+3])
#define GET32(p) \
((_B0(p) << 24) | (_B1(p) << 16) | (_B2(p) << 8) | _B3(p))
/* the size of a list cons cell in bytes */
#define CONS_SZB (WORD_SZB*3)
/* GetDouble:
*/
PVT double GetDouble (Byte_t *p)
{
int i;
union {
double d;
Byte_t b[sizeof(double)];
} u;
#ifdef BYTE_ORDER_LITTLE
for (i = sizeof(double)-1; i >= 0; i--) {
u.b[i] = *p++;
}
#else
for (i = 0; i < sizeof(double); i++) {
u.b[i] = p[i];
}
#endif
return u.d;
} /* end of GetDouble */
/* BuildLiterals:
*
* NOTE: we allocate all of the objects in the first generation, and allocate
* the vector of literals in the allocation space.
*/
ml_val_t BuildLiterals (ml_state_t *msp, Byte_t *lits, int len)
{
int pc = 0;
Word_t magic, maxDepth;
ml_val_t stk;
ml_val_t res;
Int32_t i, j, n;
double d;
int availSpace, spaceReq;
/* A check that the available space is sufficient for the literal object that
* we are about to allocate. Note that the cons cell has already been accounted
* for in availSpace (but not in spaceReq).
*/
#define GC_CHECK \
do { \
if ((spaceReq > availSpace) && NeedGC(msp, spaceReq+CONS_SZB)) { \
InvokeGCWithRoots (msp, 0, (ml_val_t *)&lits, &stk, NIL(ml_val_t *)); \
availSpace = 0; \
} \
else \
availSpace -= spaceReq; \
} while (0)
#ifdef DEBUG_LITERALS
SayDebug("BuildLiterals: lits = %#x, len = %d\n", lits, len);
#endif
if (len <= 8) return ML_nil;
magic = GET32(lits); pc += 4;
maxDepth = GET32(lits); pc += 4;
if (magic != V1_MAGIC) {
Die("bogus literal magic number %#x", magic);
}
stk = ML_nil;
availSpace = 0;
while (TRUE) {
ASSERT(pc < len);
ASSERT(availSpace <= ((int)msp->ml_limitPtr - (int)msp->ml_allocPtr));
availSpace -= CONS_SZB; /* space for stack cons cell */
if (availSpace < ONE_K) {
if (NeedGC(msp, 64*ONE_K))
InvokeGCWithRoots (msp, 0, (ml_val_t *)&lits, &stk, NIL(ml_val_t *));
availSpace = 64*ONE_K;
}
switch (lits[pc++]) {
case I_INT:
i = GET32(lits); pc += 4;
#ifdef DEBUG_LITERALS
SayDebug("[%2d]: INT(%d)\n", pc-5, i);
#endif
LIST_cons(msp, stk, INT_CtoML(i), stk);
break;
case I_RAW32:
i = GET32(lits); pc += 4;
#ifdef DEBUG_LITERALS
SayDebug("[%2d]: RAW32[%d]\n", pc-5, i);
#endif
INT32_ALLOC(msp, res, i);
LIST_cons(msp, stk, res, stk);
availSpace -= 2*WORD_SZB;
break;
case I_RAW32L:
n = GET32(lits); pc += 4;
#ifdef DEBUG_LITERALS
SayDebug("[%2d]: RAW32L(%d) [...]\n", pc-5, n);
#endif
ASSERT(n > 0);
spaceReq = 4*(n+1);
GC_CHECK;
ML_AllocWrite (msp, 0, MAKE_DESC(n, DTAG_raw32));
for (j = 1; j <= n; j++) {
i = GET32(lits); pc += 4;
ML_AllocWrite (msp, j, (ml_val_t)i);
}
res = ML_Alloc (msp, n);
LIST_cons(msp, stk, res, stk);
break;
case I_RAW64:
d = GetDouble(&(lits[pc])); pc += 8;
REAL64_ALLOC(msp, res, d);
#ifdef DEBUG_LITERALS
SayDebug("[%2d]: RAW64[%f] @ %#x\n", pc-5, d, res);
#endif
LIST_cons(msp, stk, res, stk);
availSpace -= 4*WORD_SZB; /* extra 4 bytes for alignment padding */
break;
case I_RAW64L:
n = GET32(lits); pc += 4;
#ifdef DEBUG_LITERALS
SayDebug("[%2d]: RAW64L(%d) [...]\n", pc-5, n);
#endif
ASSERT(n > 0);
spaceReq = 8*(n+1);
GC_CHECK;
#ifdef ALIGN_REALDS
/* Force REALD_SZB alignment (descriptor is off by one word) */
msp->ml_allocPtr = (ml_val_t *)((Addr_t)(msp->ml_allocPtr) | WORD_SZB);
#endif
j = 2*n; /* number of words */
ML_AllocWrite (msp, 0, MAKE_DESC(j, DTAG_raw64));
res = ML_Alloc (msp, j);
for (j = 0; j < n; j++) {
PTR_MLtoC(double, res)[j] = GetDouble(&(lits[pc])); pc += 8;
}
LIST_cons(msp, stk, res, stk);
break;
case I_STR:
n = GET32(lits); pc += 4;
#ifdef DEBUG_LITERALS
SayDebug("[%2d]: STR(%d) [...]", pc-5, n);
#endif
if (n == 0) {
#ifdef DEBUG_LITERALS
SayDebug("\n");
#endif
LIST_cons(msp, stk, ML_string0, stk);
break;
}
j = BYTES_TO_WORDS(n+1); /* include space for '\0' */
/* the space request includes space for the data-object header word and
* the sequence header object.
*/
spaceReq = WORD_SZB*(j+1+3);
GC_CHECK;
/* allocate the data object */
ML_AllocWrite(msp, 0, MAKE_DESC(j, DTAG_raw32));
ML_AllocWrite (msp, j, 0); /* so word-by-word string equality works */
res = ML_Alloc (msp, j);
#ifdef DEBUG_LITERALS
SayDebug(" @ %#x (%d words)\n", res, j);
#endif
memcpy (PTR_MLtoC(void, res), &lits[pc], n); pc += n;
/* allocate the header object */
SEQHDR_ALLOC(msp, res, DESC_string, res, n);
/* push on stack */
LIST_cons(msp, stk, res, stk);
break;
case I_LIT:
n = GET32(lits); pc += 4;
for (j = 0, res = stk; j < n; j++) {
res = LIST_tl(res);
}
#ifdef DEBUG_LITERALS
SayDebug("[%2d]: LIT(%d) = %#x\n", pc-5, n, LIST_hd(res));
#endif
LIST_cons(msp, stk, LIST_hd(res), stk);
break;
case I_VECTOR:
n = GET32(lits); pc += 4;
#ifdef DEBUG_LITERALS
SayDebug("[%2d]: VECTOR(%d) [", pc-5, n);
#endif
if (n == 0) {
#ifdef DEBUG_LITERALS
SayDebug("]\n");
#endif
LIST_cons(msp, stk, ML_vector0, stk);
break;
}
/* the space request includes space for the data-object header word and
* the sequence header object.
*/
spaceReq = WORD_SZB*(n+1+3);
GC_CHECK;
/* allocate the data object */
ML_AllocWrite(msp, 0, MAKE_DESC(n, DTAG_vec_data));
/* top of stack is last element in vector */
for (j = n; j > 0; j--) {
ML_AllocWrite(msp, j, LIST_hd(stk));
stk = LIST_tl(stk);
}
res = ML_Alloc(msp, n);
/* allocate the header object */
SEQHDR_ALLOC(msp, res, DESC_polyvec, res, n);
#ifdef DEBUG_LITERALS
SayDebug("...] @ %#x\n", res);
#endif
LIST_cons(msp, stk, res, stk);
break;
case I_RECORD:
n = GET32(lits); pc += 4;
#ifdef DEBUG_LITERALS
SayDebug("[%2d]: RECORD(%d) [", pc-5, n);
#endif
if (n == 0) {
#ifdef DEBUG_LITERALS
SayDebug("]\n");
#endif
LIST_cons(msp, stk, ML_unit, stk);
break;
}
else {
spaceReq = 4*(n+1);
GC_CHECK;
ML_AllocWrite(msp, 0, MAKE_DESC(n, DTAG_record));
}
/* top of stack is last element in record */
for (j = n; j > 0; j--) {
ML_AllocWrite(msp, j, LIST_hd(stk));
stk = LIST_tl(stk);
}
res = ML_Alloc(msp, n);
#ifdef DEBUG_LITERALS
SayDebug("...] @ %#x\n", res);
#endif
LIST_cons(msp, stk, res, stk);
break;
case I_RETURN:
ASSERT(pc == len);
#ifdef DEBUG_LITERALS
SayDebug("[%2d]: RETURN(%#x)\n", pc-5, LIST_hd(stk));
#endif
return (LIST_hd(stk));
break;
default:
Die ("bogus literal opcode #%x @ %d", lits[pc-1], pc-1);
} /* switch */
} /* while */
} /* end of BuildLiterals */
syntax highlighted by Code2HTML, v. 0.9.1