diff --git a/mps/src/fmthe.c b/mps/src/fmthe.c new file mode 100644 index 00000000000..833207ce2b2 --- /dev/null +++ b/mps/src/fmthe.c @@ -0,0 +1,614 @@ +/* impl.c.fmthe: DYLAN-LIKE OBJECT FORMAT WITH HEADERS + * + * $HopeName$ + * Copyright (C) 2000 Harlequin Limited. All rights reserved. + * + * .source: This was derived from impl.c.fmtdy -- it's probably a good idea to + * keep them in sync and share improvements. + * + * .layouts: + * + * 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 subtype_mask DylanWorks subtype_mask (untraceable) + * W+3 (FL << 2) | FF fixed part length and format + * W+4 (VS << 3) | VF variable part format and element size + * W+5 (WT << 2) | 1 tagged pattern vector length + * W+6 pattern 0 patterns for fixed part fields + * W+6+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 subtype_mask DylanWorks subtype_mask for WW + * WW+3 (4 << 2) | 2 wrappers have four patterned fields + * WW+4 (0 << 3) | 0 wrappers have a non-traceable vector + * WW+5 (1 << 2) | 1 one pattern word follows + * WW+6 0b001 only field 0 is traceable + * + * + * TRANSGRESSIONS + * + * .assert: Test code really shouldn't use assert. + */ + + +#include "fmthe.h" +#include "mps.h" + +#include +#include +#include + +#include "mpstd.h" +#ifdef MPS_PF_SUS8LC +/* .hack.stderr: builder.lc (LCC) uses Sun's header files. Sun's + * assert.h is broken, as it assumes it can use stderr. We have to + * fix it by supplying stderr. + */ +#include +/* Better include ossu.h as well, in case we use other stuff from stdio.h. */ +#include "ossu.h" +#endif + +#include "testlib.h" + + +#define notreached() assert(0) +#define unused(param) ((void)(param)) + + +#ifdef FMTDY_COUNTING +#define FMTDY_COUNT(x) x +#define FMTDY_FL_LIMIT 16 +static unsigned long dylan_vff_counts[4*8]; +static unsigned long dylan_fl_counts[FMTDY_FL_LIMIT]; +static unsigned long dylan_fl_oversize_count; +static unsigned long dylan_fw_counts[2]; +#else +#define FMTDY_COUNT(x) +#endif /* FMTDY_COUNTING */ + + +static int dylan_wrapper_check(mps_word_t *w) +{ + mps_word_t *ww; + mps_word_t vh; + mps_word_t version; + mps_word_t reserved; + mps_word_t class; + mps_word_t fh, fl, ff; + mps_word_t vb, es, 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. */ + + /* .improve.unique.wrapper: 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[WW] != 0); + assert((w[WW] & 3) == 0); /* wrapper wrapper is aligned */ + ww = (mps_word_t *)w[WW]; + assert(ww[WW] == w[WW]); /* wrapper wrapper is own wrapper */ + assert(ww[WC] != 0); /* wrapper class exists */ + assert((ww[WC] & 3) == 0); /* wrapper class is aligned */ + assert(ww[WF] == (((WS - 1) << 2) | 2)); /* fields with patterns */ + assert((ww[WV] & 0x00ffffff) == 0);/* non-traceable vector */ + /* Code in this file only works for version 2 */ + assert(((ww[WV] >> (MPS_WORD_WIDTH - 8)) & 0xff) == 2); + assert(ww[WS] == ((1 << 2) | 1)); /* one pattern word in wrapper wrapper */ + /* The first field is traceable, the second field can be traced, */ + /* but doesn't need to be. */ + assert((ww[WP] == 1) || (ww[WP] == 3)); + + /* Unpack the wrapper. */ + + class = w[WC]; /* class */ + fh = w[WF]; /* fixed part header word */ + fl = fh >> 2; /* fixed part length */ + ff = fh & 3; /* fixed part format code */ + vh = w[WV]; /* variable part header */ + version = (vh >> (MPS_WORD_WIDTH - 8)) & 0xff; + assert(version == 2); /* Code in this file only works for version 2 */ + reserved = (vh >> 8) & 0xff; + assert(reserved == 0); + vb = (vh >> 16) & 0xff; + es = (vh & 0xff) >> 3;/* element size */ + vf = vh & 7; /* variable part format code */ + vt = w[WS]; /* 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. */ + /* Current Dylan run-time does not honour this so I remove it for now */ + /* We probably want this check as then we can scan without having to */ + /* check for 0 fixed length fields as a special case */ + /* 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(vf != 6); + + /* There should be no shift in word vector formats. */ + assert((vf & 6) == 4 || es == 0); + + /* 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[WS+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_word_t)r&3) != 0) /* pointers tagged with 0 */ + goto loop; /* not a pointer */ + 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; +} + + +/* dylan_scan_pat -- scan according to pattern + * + * Scan an array of words in [base, limit) using the patterns at pats + * to determine which words can be fixed. + */ + +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 */ + + unused(nr_pats); + + 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 = (int)(pat & 1); + pat >>= 1; + if(b == 0) goto loop; + r = *(pp-1); + if(((mps_word_t)r&3) != 0) /* pointers tagged with 0 */ + goto loop; /* not a pointer */ + 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 AddHeader(p) ((mps_addr_t)((char*)(p) + headerSIZE)) + + +#define NONWORD_LENGTH(_vt, _es) \ + ((_es) < MPS_WORD_SHIFT ? \ + ((_vt) + (1 << (MPS_WORD_SHIFT - (_es))) - 1) >> \ + (MPS_WORD_SHIFT - (_es)) : \ + (_vt) << ((_es) - 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 vb; /* vector bias */ + unsigned es; /* variable part element size (log2 of bits) */ + mps_word_t vt; /* total vector length */ + mps_res_t res; + int* header; + + assert(object_io != NULL); + + p = (mps_addr_t *)*object_io; + assert(p != NULL); + + header = (int*)((char*)p - headerSIZE); + if (*header != realTYPE) { + switch (*header) { + case pad1TYPE: *object_io = (mps_addr_t)((char*)p + 4); break; + case pad2TYPE: *object_io = (mps_addr_t)((char*)p + 8); break; + default: notreached(); break; + } + return MPS_RES_OK; + } + + 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 = AddHeader(p + 1); + FMTDY_COUNT(++dylan_fw_counts[0]); + } else { /* multi-word */ + assert((h & 3) == 2); + l = (mps_addr_t)p[1]; + FMTDY_COUNT(++dylan_fw_counts[1]); + } + + *object_io = l; + return MPS_RES_OK; + } + + mps_fix(mps_ss, p); /* fix the wrapper */ + w = (mps_word_t *)p[0]; /* wrapper is header word */ + assert(dylan_wrapper_check(w)); + + ++p; /* skip header */ + + /* Fixed Part */ + + fh = w[WF]; + 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. */ + + FMTDY_COUNT(fl < FMTDY_FL_LIMIT ? ++dylan_fl_counts[fl] : + ++dylan_fl_oversize_count); + 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[WP], w[WS]>>2); + if(res) return res; + break; + + default: + notreached(); + break; + } + p = q; + } + + /* Variable Part */ + vh = w[WV]; + vf = vh & 7; /* get variable part format */ + FMTDY_COUNT(++dylan_vff_counts[(vf << 2)|(fh&3)]); + 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 */ + es = (vh & 0xff) >> 3; + vb = (vh >> 16) & 0xff; + vt += vb; + p += NONWORD_LENGTH(vt, es); + break; + + case 5: /* stretchy non-word */ + notreached(); /* DW doesn't create them yet */ + es = (vh & 0xff) >> 3; + vb = (vh >> 16) & 0xff; + vt += vb; + p += NONWORD_LENGTH(vt, es) + 1; + break; + + default: + notreached(); + break; + } + } + + *object_io = AddHeader(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; + mps_addr_t p = base; + + while(p < limit) { + res = dylan_scan1(mps_ss, &p); + if(res) return res; + } + + assert(p <= AddHeader(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 vb; /* vector bias */ + unsigned es; /* variable part element size (log2 of bits) */ + int* header; + + p = (mps_addr_t *)object; + assert(p != NULL); + + header = (int*)((char*)object - headerSIZE); + if (*header != realTYPE) { + switch (*header) { + case pad1TYPE: return (mps_addr_t)((char*)object + 4); break; + case pad2TYPE: return (mps_addr_t)((char*)object + 8); break; + default: assert(0 == 1); break; + } + } + + h = (mps_word_t)p[0]; /* load the header word */ + + /* If the object is forwarded, simply skip it. */ + if(h & 3) { + if((h & 3) == 1) /* single-word */ + return AddHeader(p + 1); + else { /* multi-word */ + assert((h & 3) == 2); + return (mps_addr_t)p[1]; + } + } + + w = (mps_word_t *)h; /* load the fixed wrapper */ + assert(dylan_wrapper_check(w)); + ++p; + + p += w[WF] >> 2; /* skip fixed part fields */ + + vh = w[WV]; + vf = vh & 7; /* get variable part format */ + if(vf != 7) + { + vt = *(mps_word_t *)p; + assert((vt & 3) == 1); /* check Dylan integer tag */ + vt = vt >> 2; /* total length */ + ++p; + + p += vf & 1; /* stretchy vectors have an extra word */ + + if((vf & 6) == 4) /* non-word */ + { + es = (vh & 0xff) >> 3; + vb = (vh >> 16) & 0xff; + vt += vb; + p += NONWORD_LENGTH(vt, es); + } + else + p += vt; + } + + return AddHeader(p); +} + + +static mps_addr_t dylan_isfwd(mps_addr_t object) +{ + mps_word_t h, tag; + int *header; + + header = (int*)((char*)object - headerSIZE); + if (*header != realTYPE) { + return NULL; + } + + 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 addr, size_t fullSize) +{ + mps_word_t *p; + size_t size; + + p = (mps_word_t *)AddHeader(addr); + size = fullSize - headerSIZE; + if (fullSize <= headerSIZE) { + *(int*)addr = (fullSize == 4) ? pad1TYPE : pad2TYPE; + } else { + *(int*)addr = realTYPE; + if(size == sizeof(mps_word_t)) /* single-word object? */ + p[0] = 1; + else { + p[0] = 2; + p[1] = (mps_word_t)AddHeader((char *)addr + fullSize); + } + } +} + + +/* HeaderFormat -- format descriptor for this format */ + +static struct mps_fmt_auto_header_s HeaderFormat = +{ + ALIGN, + dylan_scan, + dylan_skip, + dylan_fwd, + dylan_isfwd, + dylan_pad, + (size_t)headerSIZE +}; + + +/* EnsureHeaderFormat -- create a format object for this format */ + +mps_res_t EnsureHeaderFormat(mps_fmt_t *mps_fmt_o, mps_arena_t arena) +{ + return mps_fmt_create_auto_header(mps_fmt_o, arena, &HeaderFormat); +} + + +/* HeaderFormatCheck -- check an object in this format */ + +mps_res_t HeaderFormatCheck(mps_addr_t addr) +{ + if (addr != 0 && ((mps_word_t)addr & (ALIGN-1)) == 0 + && dylan_wrapper_check((mps_word_t *)((mps_word_t *)addr)[0])) + return MPS_RES_OK; + else + return MPS_RES_FAIL; +}