From fb091ab82684bbac4cdabfcbcccac868ce86b573 Mon Sep 17 00:00:00 2001 From: Richard Brooksby Date: Fri, 9 Feb 1996 10:16:53 +0000 Subject: [PATCH] New unit New Dylan object format code, outside MPS interface. Copied from Perforce Change: 15217 ServerID: perforce.ravenbrook.com --- mps/src/fmtdy.c | 569 ++++++++++++++++++++++++++++++++++++++++++++++++ mps/src/fmtdy.h | 19 ++ 2 files changed, 588 insertions(+) create mode 100644 mps/src/fmtdy.c create mode 100644 mps/src/fmtdy.h diff --git a/mps/src/fmtdy.c b/mps/src/fmtdy.c new file mode 100644 index 00000000000..8cd352f1af8 --- /dev/null +++ b/mps/src/fmtdy.c @@ -0,0 +1,569 @@ +/* impl.c.formdy: DYLAN OBJECT FORMAT IMPLEMENTATION + * + * $HopeName$ + * Copyright (C) 1996 Harlequin Group, all rights reserved. + * + * All objects, B: + * + * B W pointer to wrapper + * B+1 object body + * + * Forwarded (or padding) one-word objects, B: + * + * B N | 0b01 new address | 1 + * + * Forwarded (or padding) multi-word objects, B: + * + * B N | 0b10 new address | 2 + * B+1 L limit of object (addr of end + 1) + * + * Wrappers, W: + * + * W WW pointer to wrapper wrapper + * W+1 class DylanWorks class pointer (traceable) + * W+2 (FL << 2) | FF fixed part length and format + * W+3 (VS << 3) | VF variable part format and element size + * W+4 (WT << 2) | 1 tagged pattern vector length + * W+5 pattern 0 patterns for fixed part fields + * W+5+WT-1 pattern WT-1 + * + * The wrapper wrapper, WW: + * + * WW WW WW is it's own wrapper + * WW+1 class DylanWorks class of wrappers + * WW+2 (3 << 2) | 2 wrappers have three patterned fields + * WW+3 (0 << 3) | 0 wrappers have a non-traceable vector + * WW+4 (1 << 2) | 1 one pattern word follows + * WW+5 0b001 only field 0 is traceable + */ + +#include "fmtdy.h" +#include "mps.h" +#include +#include +#include + +#define notreached() do assert(0); while(0) + +static int dylan_wrapper_check(mps_word_t *w) +{ + mps_word_t *ww; + mps_word_t class; + mps_word_t fh, fl, ff; + mps_word_t vh, vs, vf; + mps_word_t vt, t; + + assert(w != NULL); + assert(((mps_word_t)w & 3) == 0); + + /* The first word of the wrapper is a pointer to a wrapper wrapper, */ + /* which always has the same contents. Check it. */ + + /* @@@@ When this becomes part of the Dylan run-time, it would be */ + /* possible to know the address of a unique wrapper wrapper and check */ + /* that instead. */ + + assert(w[0] != 0); + assert((w[0] & 3) == 0); /* wrapper wrapper is aligned */ + ww = (mps_word_t *)w[0]; + assert(ww[0] == w[0]); /* wrapper wrapper is own wrapper */ + assert(ww[1] != 0); /* wrapper class exists */ + assert((ww[1] & 3) == 0); /* wrapper class is aligned */ + assert(ww[2] == ((3 << 2) | 2)); /* three fields with patterns */ + assert(ww[3] == ((0 << 3) | 0)); /* non-traceable vector of pats */ + assert(ww[4] == ((1 << 2) | 1)); /* one pattern word in wrapper */ + assert(ww[5] == 1); /* first field traceable */ + + /* Unpack the wrapper. */ + + class = w[1]; /* class */ + fh = w[2]; /* fixed part header word */ + fl = fh >> 2; /* fixed part length */ + ff = fh & 3; /* fixed part format code */ + vh = w[3]; /* variable part header */ + vs = vh >> 3; /* variable part length */ + vf = vh & 7; /* variable part format code */ + vt = w[4]; /* vector total word (Dylan-tagged) */ + t = vt >> 2; /* vector total length */ + + /* The second word is the class of the wrapped object. */ + /* It would be good to check which pool this is in. */ + + assert(class != 0); /* class exists */ + assert((class & 3) == 0); /* class is aligned */ + + /* The third word contains the fixed part format and length. */ + /* The only illegal format is 3. Anything else is possible, although */ + /* we could do some bound checking on the length if we knew more about */ + /* the surroundings of the object. */ + + /* Fixed part format 3 is reserved. */ + assert(ff != 3); + + /* Zero length fixed part is only legal in format 0. */ + assert(ff == 0 || fl != 0); + + /* The fourth word contains the variable part format and element */ + /* size. This assumes that DylanWorks is only going to use byte */ + /* vectors in the non-word case. */ + + /* Variable part format 6 is reserved. */ + assert(vh != 6); + + /* There should be no shift in word vector formats. */ + assert((vf & 6) == 4 || vs == 0); + + /* @@@@ Dylan only uses byte vectors, so the shift should be 3. */ + /* Note that the code supports other sizes -- this check is only */ + /* for Dylan consistency. */ + assert((vf & 6) != 4 || vs == 3); + + /* The fifth word is the number of patterns in the pattern */ + /* vector. This can be calculated from the fixed part length. */ + /* The word is also tagged like a DylanWorks integer. */ + + assert((vt & 3) == 1); + + /* The pattern vector in the wrapper should be of non-zero length only */ + /* if there is a patterned fixed part. */ + assert(ff == 2 || t == 0); + + /* The number of patterns is (fixed fields+31)/32. */ + assert(ff != 2 || t == ((fl + MPS_WORD_WIDTH - 1) >> MPS_WORD_SHIFT)); + + /* The patterns are random bits, so we can't check them. However, */ + /* the left-over bits in the last pattern should be zero. */ + + assert(ff != 2 || (w[4+t] >> ((fh>>2) & (MPS_WORD_WIDTH-1))) == 0); + + return 1; +} + +/* Scan a contiguous array of references in [base, limit). */ +/* This code has been hand-optimised and examined using Metrowerks */ +/* Codewarrior on a 68K and also Microsoft Visual C on a 486. The */ +/* variables in the loop allocate nicely into registers. Alter with */ +/* care. */ + +static mps_res_t dylan_scan_contig(mps_ss_t mps_ss, + mps_addr_t *base, mps_addr_t *limit) +{ + mps_res_t res; + mps_addr_t *p; /* reference cursor */ + mps_addr_t r; /* reference to be fixed */ + + MPS_SCAN_BEGIN(mps_ss) { + p = base; + loop: if(p >= limit) goto out; + r = *p++; + if(!MPS_FIX1(mps_ss, r)) goto loop; + res = MPS_FIX2(mps_ss, p-1); + if(res == MPS_RES_OK) goto loop; + return res; + out: assert(p == limit); + } MPS_SCAN_END(mps_ss); + + return MPS_RES_OK; +} + +/* Scan an array of words in [base, limit) using the patterns at pats */ +/* to determine which words can be fixed. */ +/* This code has been hand-optimised and examined using Metrowerks */ +/* Codewarrior on a 68K and also Microsoft Visual C on a 486. The */ +/* variables in the loop allocate nicely into registers. Alter with */ +/* care. */ + +static mps_res_t dylan_scan_pat(mps_ss_t mps_ss, + mps_addr_t *base, mps_addr_t *limit, + mps_word_t *pats, mps_word_t nr_pats) +{ + mps_res_t res; + mps_word_t *pc = pats;/* pattern cursor */ + mps_word_t pat; /* pattern register */ + mps_addr_t *p; /* reference cursor */ + mps_addr_t *pp; /* inner loop cursor */ + int b; /* bit */ + mps_addr_t r; /* reference to be fixed */ + + MPS_SCAN_BEGIN(mps_ss) { + p = base; + goto in; + pat: p += MPS_WORD_WIDTH; + if(p >= limit) goto out; + in: pp = p; + pat = *pc++; + loop: if(pat == 0) goto pat; + ++pp; + b = pat & 1; + pat >>= 1; + if(b == 0) goto loop; + r = *(pp-1); + if(!MPS_FIX1(mps_ss, r)) goto loop; + res = MPS_FIX2(mps_ss, pp-1); + if(res == MPS_RES_OK) goto loop; + return res; + out: assert(p < limit + MPS_WORD_WIDTH); + assert(pc == pats + nr_pats); + } MPS_SCAN_END(mps_ss); + + return MPS_RES_OK; +} + +#define NONWORD_LENGTH(_vt, _vs) \ + ((_vs) < MPS_WORD_SHIFT ? \ + ((_vt) + (1 << (MPS_WORD_SHIFT - (_vs))) - 1) >> \ + (MPS_WORD_SHIFT - (_vs)) : \ + (_vt) << ((_vs) - MPS_WORD_SHIFT)) + +static mps_res_t dylan_scan1(mps_ss_t mps_ss, mps_addr_t *object_io) +{ + mps_addr_t *p; /* cursor in object */ + mps_addr_t *q; /* cursor limit for loops */ + mps_word_t h; /* header word */ + mps_word_t *w; /* pointer to wrapper */ + mps_word_t fh; /* fixed part header word */ + mps_word_t fl; /* fixed part length, in words */ + mps_word_t vh; /* variable part header */ + mps_word_t vf; /* variable part format */ + mps_word_t vl; /* variable part actual length */ + unsigned vs; /* variable part element size (log2 of bits) */ + mps_word_t vt; /* total vector length */ + mps_res_t res; + + assert(object_io != NULL); + + p = (mps_addr_t *)*object_io; + assert(p != NULL); + + h = (mps_word_t)p[0]; /* load the header word */ + + /* If the object is forwarded, simply skip it. */ + if(h & 3) { + mps_addr_t l; + + if((h & 3) == 1) /* single-word */ + l = (mps_addr_t)(p + 1); + else { /* multi-word */ + assert((h & 3) == 2); + l = (mps_addr_t)p[1]; + } + + *object_io = l; + return MPS_RES_OK; + } + + w = (mps_word_t *)h; /* wrapper is header word */ + assert(dylan_wrapper_check(w)); + + ++p; /* skip header */ + + /* Fixed Part */ + + fh = w[2]; + fl = fh >> 2; /* get the fixed part length */ + + /* It might be worth inlining common cases here, for example, */ + /* pairs. This can be done by examining fh as a whole. */ + + if(fl > 0) { + q = p + fl; /* set q to end of fixed part */ + switch(fh & 3) { /* switch on the fixed format */ + case 0: /* all non-traceable fields */ + p = q; + break; + + case 1: /* all traceable fields */ + res = dylan_scan_contig(mps_ss, p, q); + if(res) return res; + break; + + case 2: /* patterns */ + res = dylan_scan_pat(mps_ss, p, q, &w[5], w[4]>>2); + if(res) return res; + break; + + default: + notreached(); + break; + } + p = q; + } + + /* Variable Part */ + vh = w[3]; + vf = vh & 7; /* get variable part format */ + if(vf != 7) + { + vt = *(mps_word_t *)p; /* total vector length */ + assert((vt & 3) == 1); /* check Dylan integer tag */ + vt >>= 2; /* untag it */ + ++p; + + switch(vf) + { + case 0: /* non-stretchy non-traceable */ + p += vt; + break; + + case 1: /* stretchy non-traceable */ + notreached(); /* Not used by DylanWorks yet */ + p += vt + 1; + break; + + case 2: /* non-stretchy traceable */ + q = p + vt; + res = dylan_scan_contig(mps_ss, p, q); + if(res) return res; + p = q; + break; + + case 3: /* stretchy traceable */ + notreached(); /* DW doesn't create them yet */ + vl = *(mps_word_t *)p; /* vector length */ + assert((vl & 3) == 1); /* check Dylan integer tag */ + vl >>= 2; /* untag it */ + ++p; + res = dylan_scan_contig(mps_ss, p, p + vl); + if(res) return res; + p += vt; /* skip to end of whole vector */ + break; + + case 4: /* non-word */ + vs = vh >> 3; + p += NONWORD_LENGTH(vt, vs); + break; + + case 5: /* stretchy non-word */ + notreached(); /* DW doesn't create them yet */ + vs = vh >> 3; + p += NONWORD_LENGTH(vt, vs) + 1; + break; + + default: + notreached(); + break; + } + } + + *object_io = (mps_addr_t)p; + return MPS_RES_OK; +} + +static mps_res_t dylan_scan(mps_ss_t mps_ss, + mps_addr_t base, mps_addr_t limit) +{ + mps_res_t res; + + while(base < limit) { + res = dylan_scan1(mps_ss, &base); + if(res) return res; + } + + assert(base == limit); + + return MPS_RES_OK; +} + +static mps_addr_t dylan_skip(mps_addr_t object) +{ + mps_addr_t *p; /* cursor in object */ + mps_word_t *w; /* wrapper cursor */ + mps_word_t h; /* header word */ + mps_word_t vh; /* variable part header */ + mps_word_t vf; /* variable part format */ + mps_word_t vt; /* total vector length */ + unsigned vs; /* variable part element size (log2 of bits) */ + + p = (mps_addr_t *)object; + assert(p != NULL); + + h = (mps_word_t)p[0]; /* load the header word */ + + /* If the object is forwarded, simply skip it. */ + if(h & 3) { + mps_addr_t l; + + if((h & 3) == 1) /* single-word */ + l = (mps_addr_t)(p + 1); + else { /* multi-word */ + assert((h & 3) == 2); + l = (mps_addr_t)p[1]; + } + + return l; + } + + w = (mps_word_t *)h; /* load the fixed wrapper */ + assert(dylan_wrapper_check(w)); + ++p; + + p += w[2] >> 2; /* skip fixed part fields */ + + vf = w[3] & 7; /* get variable part format */ + if(vf != 7) + { + vh = *(mps_word_t *)p; + assert((vh & 3) == 1); /* check Dylan integer tag */ + vt = vh >> 2; /* total length */ + ++p; + + p += vf & 1; /* stretchy vectors have an extra word */ + + if((vf & 6) == 4) /* non-word */ + { + vs = w[3] >> 3; + p += NONWORD_LENGTH(vt, vs); + } + else + p += vt; + } + + return (mps_addr_t)p; +} + +static void dylan_copy(mps_addr_t old, mps_addr_t new) +{ + size_t length = (char *)dylan_skip(old) - (char *)old; + assert(dylan_wrapper_check(*(mps_word_t **)old)); + memcpy(old, new, length); +} + +static mps_addr_t dylan_isfwd(mps_addr_t object) +{ + mps_word_t h, tag; + + h = *(mps_word_t *)object; + tag = h & 3; + if(tag != 0) + return (mps_addr_t)(h - tag); + else + return NULL; +} + +static void dylan_fwd(mps_addr_t old, mps_addr_t new) +{ + mps_word_t *p; + mps_addr_t limit; + + assert(dylan_isfwd(old) == NULL); + assert(((mps_word_t)new & 3) == 0); + + p = (mps_word_t *)old; + limit = dylan_skip(old); + if(limit == &p[1]) /* single-word object? */ + p[0] = (mps_word_t)new | 1; + else { + p[0] = (mps_word_t)new | 2; + p[1] = (mps_word_t)limit; + } +} + +static void dylan_pad(mps_addr_t base, size_t size) +{ + mps_word_t *p; + + p = (mps_word_t *)base; + if(size == sizeof(mps_word_t)) /* single-word object? */ + p[0] = 1; + else { + p[0] = 2; + p[1] = (mps_word_t)((char *)base + size); + } +} + +static struct mps_form_A_s dylan_form_A_s = +{ + sizeof(mps_word_t), + dylan_scan, + dylan_skip, + dylan_copy, + dylan_fwd, + dylan_isfwd, + dylan_pad +}; + +mps_form_A_s *dylan_form_A(void) +{ + return &dylan_form_A_s; +} + +/* Format Test Code */ + +static mps_word_t *ww = NULL; +static mps_word_t *tvw; + +mps_res_t dylan_init(mps_addr_t base, size_t size, + mps_addr_t *refs, size_t nr_refs) +{ + + /* Make sure the size is aligned. */ + assert((size & (sizeof(mps_word_t)-1)) == 0); + + if(ww == NULL) { + ww = malloc(sizeof(mps_word_t) * 6); + if(ww == NULL) return MPS_RES_MEMORY; + tvw = malloc(sizeof(mps_word_t) * 5); + if(tvw == NULL) { + free(ww); + return MPS_RES_MEMORY; + } + + /* Build a wrapper wrapper. */ + ww[0] = (mps_word_t)ww; + ww[1] = (mps_word_t)ww; /* dummy class */ + ww[2] = (3 << 2) | 2; + ww[3] = (0 << 3) | 0; + ww[4] = (1 << 2) | 1; + ww[5] = 1; + + /* Build a wrapper for traceable vectors. */ + tvw[0] = (mps_word_t)ww; + tvw[1] = (mps_word_t)ww; /* dummy class */ + tvw[2] = 0; /* no fixed part */ + tvw[3] = 2; /* traceable variable part */ + tvw[4] = 1; /* no patterns */ + } + + /* If there is enough room, make a vector, otherwise just */ + /* make a padding object. */ + + if(size >= sizeof(mps_word_t) * 2) { + mps_word_t *p = (mps_word_t *)base; + mps_word_t i, t = (size / sizeof(mps_word_t)) - 2; + p[0] = (mps_word_t)tvw; /* install vector wrapper */ + p[1] = (t << 2) | 1; /* tag the vector length */ + for(i = 0; i < t; ++i) + p[2+i] = (mps_word_t)refs[rand() % nr_refs]; + } else + dylan_pad(base, size); + + return MPS_RES_OK; +} + +void dylan_write(mps_addr_t base, + mps_addr_t *refs, size_t nr_refs) +{ + mps_word_t *p = (mps_word_t *)base; + + /* If the object is a vector, update a random entry. */ + if(p[0] == (mps_word_t)tvw) { + mps_word_t t = p[1] >> 2; + if(t > 0) + p[2 + (rand() % t)] = + (mps_word_t)refs[rand() % nr_refs]; + } +} + +mps_addr_t dylan_read(mps_addr_t base) +{ + mps_word_t *p = (mps_word_t *)base; + + /* If the object is a vector, return a random entry. */ + if(p[0] == (mps_word_t)tvw) { + mps_word_t t = p[1] >> 2; + if(t > 0) + return (mps_addr_t)p[2 + (rand() % t)]; + } + + return base; +} diff --git a/mps/src/fmtdy.h b/mps/src/fmtdy.h new file mode 100644 index 00000000000..064073a16e9 --- /dev/null +++ b/mps/src/fmtdy.h @@ -0,0 +1,19 @@ +/* impl.h.formdyl: DYLAN OBJECT FORMAT + * + * $HopeName$ + * Copyright (C) 1996 Harlequin Group, all rights reserved + */ + +#ifndef formdyl_h +#define formdyl_h + +#include "mps.h" + +extern mps_form_A_s *dylan_form_A(void); +extern mps_res_t dylan_init(mps_addr_t base, size_t size, + mps_addr_t *refs, size_t nr_refs); +extern void dylan_write(mps_addr_t base, + mps_addr_t *refs, size_t nr_refs); +extern mps_addr_t dylan_read(mps_addr_t base); + +#endif /* formdyl_h */