#include "pez.h" #include #include #include #include #include #include #include #include #include #include #ifdef __GNUC__ #define FORCEINLINE __attribute__((always_inline)) #define NODISCARD __attribute__((nodiscard)) #else #define FORCEINLINE #define NODISCARD #endif /*********/ /* Types */ /*********/ typedef unsigned uint; typedef int32_t fixnum; typedef struct Val { uint64_t r; } Val; #define vec_of(T) struct { \ T *at; \ uint len, cap; \ } typedef struct Obj Obj; #define OBJHEADER Obj *next; uint8_t t : 4, gc : 1; struct Obj { OBJHEADER; }; typedef struct Str { OBJHEADER; uint n; char dat[]; } Str; typedef struct Tuple { uint8_t len; Val dat[]; } Tuple; typedef struct Array { OBJHEADER; vec_of(Val); } Array; struct KV { Val k, v; }; typedef struct Record { OBJHEADER; uint8_t exp; uint count; struct KV dat[]; } Record; typedef struct Proto { OBJHEADER; uint8_t variadic : 1, named : 1; short nvars, nparams; short ncon, nupval; uint ncode; int linebegin, lineend; const char *file; const uint8_t *code; const Val *con; struct cmupval *upval; char name[]; } Proto; typedef struct Upval Upval; struct Upval { OBJHEADER; Val *ptr; union { Upval *nextup; Val slot; }; }; typedef struct Fn { OBJHEADER; short nupval; Proto *proto; Upval *upval[]; } Fn; typedef struct Local Local; enum { NAMEMAX = 80 }; struct cmupval { uint8_t idx; bool arg : 1, local : 1; }; typedef struct Comp { PezContext *cx; int (*readcb)(void *); void *readud; uint line, col; int peekchr; bool have_peekchr; char stash_ident[NAMEMAX]; Local *stash_local; char stash_binopk; char stash_binopchr; int stash_binopop; Proto *proto; vec_of(uint8_t) code; vec_of(Val) con; Val k; /* for constant folding */ bool has_k; int lastop, lastop2; /* last and 2nd-to-last opcode idxs */ bool lvalue : 1, lvalue_const : 1; const char *lvalue_name; vec_of(char) spool; // for var names vec_of(Val) kpool; // for consts struct fenv { const char *name; struct fenv *prev; vec_of(Local) locals; // also params uint16_t scope; uint16_t nvars; // num of locals in scope not counting konsts uint16_t nupval; struct cmupval upvals[256]; } fenv; } Comp; struct Local { uint16_t scope; uint16_t sref; // name uint16_t kref; // when has_k uint16_t index : 10; uint16_t isparam : 1, has_k : 1, mutable : 1, captured : 1; }; static struct Str strpool_deleted; typedef struct StrPool { uint count, deleted, N; struct Str **dat; } StrPool; typedef struct Globals { uint count, N; struct KV *dat; } Globals; enum dbgopts { DBGbytecode = 1, DBGstressgc = 2, DBGgcinfo = 4, }; struct PezContext { PezAllocFn *alloc; void *ud; int dbg; PezError err; char errstr[140]; Val *stack, *stktop, *stkend; Obj *heap; Upval *openup; uint nalloc, gcthresh, gccanrun : 1; StrPool strpool; Globals globals; }; /******************/ /* Value innards */ /******************/ enum { TAGObj = 0, // xx00 TAGNum = 1, // 0001 TAGBool = 5, // 0101 TAGSStr = 9, // 1001 (length is in high nybble) TAGCFn = 2, // xx10 (fn pointer is left shifted by 2) TAGDeleted = 15, // 1111 // for KV }; #define VOID ((Val){0}) #define _EMPTY ((Val){TAGEmpty}) #define _DELETED ((Val){TAGDeleted}) #define isvoid(v) ((v).r == 0) #define _isdeleted(v) (((v).r & 0xFF) == TAGDeleted) #define isobj(v) (!isvoid(v) && ((v).r & 3) == TAGObj) #define isnum(v) (((v).r & 0xFF) == TAGNum) #define isbool(v) (((v).r & 0xFF) == TAGBool) #define issstr(v) (((v).r & 0x0F) == TAGSStr) #define sstr_len(v) (((v).r & 0xFF) >> 4) #define iscfn(v) (((v).r & 3) == TAGCFn) #define unbox_num(v) ((fixnum)((v).r >> 32)) #define unbox_obj(v) ((void *)(intptr_t)(v).r) #define unbox_bool(v) ((bool)((v).r >> 32)) #define unbox_cfn(v) ((PezCFn *)((intptr_t)(v).r >> 2)) #define objtag(v) (((Obj *)unbox_obj(v))->t) #define isobj_of(v, tag) (isobj(v) && objtag(v) == (tag)) #define box_obj(x) ((Val){(intptr_t)(x)}) #define box_num(x) ((Val){(uint64_t)(x) << 32 | TAGNum}) #define box_bool(x) ((Val){((uint64_t)(bool)(x) << 32) | TAGBool}) #define box_cfn(x) ((Val){(uint64_t)(intptr_t)(x) << 2 | TAGCFn}) #define truthy(x) (!isvoid(x) && ((x).r == TAGBool ? unbox_bool(x) : 1)) static Val length_sstr; static const char * typestr(Val v) { if (isvoid(v)) return "void"; if (isobj(v)) { switch (objtag(v)) { case PEZ_TString: return "string"; case PEZ_TTuple: return "tuple"; case PEZ_TRecord: return "record"; case PEZ_TArray: return "array"; case PEZ_TFn: return "function"; case PEZ_TFnProto: return "(function prototype)"; } } if (isnum(v)) return "number"; if (isbool(v)) return "bool"; if (issstr(v)) return "string"; if (iscfn(v)) return "function"; return NULL; } static int unbox_sstr(Val v, char buf[8]) { int n = sstr_len(v); assert(issstr(v)); assert(n >= 0 && n < 8); buf[n] = 0; for (int i = 0; i < n; ++i) { uint8_t c = (v.r >> (56 - (i * 8))) & 0xFF; buf[i] = c; } return n; } /***********/ /* Utility */ /***********/ #define MAX(a, b) ((a) > (b) ? (a) : (b)) #define TRY(x) do { if (!(x)) return 0; } while (0) #define ETRY(x) do { if (!(x)) goto Err; } while (0) static void gc(PezContext *cx); static void * cxrealloc(PezContext *cx, void *p, size_t osz, size_t sz) { void *a = cx->alloc(cx->ud, p, osz, sz); cx->nalloc += sz - osz; // fprintf(stderr, ">> %+ld\n", sz - osz); if (a || !p || (p && !sz)) { assert(cx->nalloc >= 0); if (sz > osz && cx->gccanrun) { if (cx->dbg & DBGstressgc) { gc(cx); } else if (cx->nalloc >= cx->gcthresh) { gc(cx); cx->gcthresh = cx->nalloc * 2; } }; } else if (p && !a && sz > osz) { cx->err = PEZ_ENoMem; } return a; } static inline void * cxalloc(PezContext *cx, size_t sz) { return cxrealloc(cx, NULL, 0, sz); } static inline void cxfree(PezContext *cx, void *p, size_t sz) { cxrealloc(cx, p, sz, 0); } #define delvec(cx, v) \ (void)((v)->at ? cxfree(cx, (v)->at, (v)->cap * sizeof *(v)->at) : (void)0, \ (v)->at = 0, (v)->cap = (v)->len = 0) #define vecempty(v) ((v)->len == 0) #define vecpush(cx, v, src, n) \ _vecpush(cx, (void **)&(v)->at, sizeof *(v)->at, \ &(v)->len, &(v)->cap, (src), (n)) #define veclast(v) (&(v)->at[(v)->len - 1]) #define vecpop(cx, v) \ _vecpop(cx,(void **)&(v)->at, sizeof *(v)->at, &(v)->len, &(v)->cap) static bool _vecpush(PezContext *cx, void **at, size_t sz, uint *len, uint *cap, const void *src, size_t n) { if (cx->gccanrun && (cx->dbg & DBGstressgc)) { gc(cx); } if (*len + n - 1 >= *cap) { uint newcap = (*len + n - 1) * 2; uint8_t *new; newcap = newcap < 4 ? 4 : newcap; new = cxrealloc(cx, *at, *cap * sz, newcap * sz); if (!new) { if (*at) { cxfree(cx, *at, *cap * sz); } *at = NULL; *len = *cap = 0; return 0; } *at = new; *cap = newcap; } memcpy((char *)*at + *len * sz, src, n * sz); *len += n; return 1; } /* static void _vecpop(PezContext *cx, void **at, size_t sz, uint *len, uint *cap) { uint newcap; assert(*len > 0); --*len; if (*len < *cap / 4) { uint newcap = *cap / 2; uint8_t *new; new = cxrealloc(cx, *at, *cap * sz, newcap * sz); if (new) { *at = new; *cap = newcap; } } } */ static void * newobj(PezContext *cx, int type, size_t sz) { Obj *o = cxalloc(cx, sz); assert(sz >= sizeof *o); if (!o) { return NULL; } memset(o, 0, sz); o->next = cx->heap; cx->heap = o; o->t = type; return o; } static inline bool FORCEINLINE push(PezContext *cx, Val v) { if (cx->stktop >= cx->stkend) { cx->err = PEZ_EStack; return 0; } *cx->stktop++ = v; return 1; } static inline Val FORCEINLINE pop(PezContext *cx) { assert(cx->stktop > cx->stack); return *--cx->stktop; } static inline Val * FORCEINLINE peek(PezContext *cx) { assert(cx->stktop > cx->stack); return &cx->stktop[-1]; } #define FNV1A_INI 0x811c9dc5u static inline uint32_t fnv1a(uint32_t h, const void *src, size_t n) { for (const uint8_t *d = src; n--; ++d) { h ^= *d; h *= 0x01000193; } return h; } static inline uint64_t splittable64(uint64_t x) { x ^= x >> 30; x *= 0xbf58476d1ce4e5b9U; x ^= x >> 27; x *= 0x94d049bb133111ebU; x ^= x >> 31; return x; } /***********/ /* Objects */ /***********/ static Proto * newproto(PezContext *cx, const char *file, const char *name, int line) { Proto *pr = newobj(cx, PEZ_TFnProto, sizeof *pr + (name ? strlen(name) + 1 : 0)); if (pr) { pr->file = file; pr->linebegin = line; if (name) { pr->named = 1; strcpy(pr->name, name); } } return pr; } static inline size_t sizeofproto(Proto *pr) { return sizeof *pr + (pr->named ? strlen(pr->name) + 1 : 0); } static void delproto(PezContext *cx, Proto *pr) { cxfree(cx, (void *)pr->code, pr->ncode); cxfree(cx, (void *)pr->con, pr->ncon * sizeof(Val)); cxfree(cx, (void *)pr->upval, pr->nupval * sizeof(struct cmupval)); } static void closeups(PezContext *cx, Val *vals) { for (Upval *up = cx->openup, *next; up; up = next) { next = up->nextup; if (up->ptr >= vals) { cx->openup = next; up->slot = *up->ptr; up->ptr = &up->slot; } } } static inline size_t sizeoffn(Fn *fn) { return sizeof(*fn) + fn->nupval * sizeof(struct Upval *); } static Fn * newfn(PezContext *cx, Proto *pr, Val *args, Val *locals, Fn *parent) { Fn *fn = newobj(cx, PEZ_TFn, sizeof *fn + pr->nupval * sizeof(struct Upval *)); if (fn) { TRY(push(cx, box_obj(fn))); // gc keep fn->proto = pr; fn->nupval = pr->nupval; for (int i = 0; i < pr->nupval; ++i) { struct cmupval *upinfo = &pr->upval[i]; if (upinfo->local || upinfo->arg) { Upval *up; Val *vals = upinfo->local ? locals : args; for (up = cx->openup; up; up = up->nextup) { if (up->ptr == &vals[upinfo->idx]) { break; } } if (!up) { up = newobj(cx, PEZ_TUpval, sizeof *up); if (!up) { cxfree(cx, fn, sizeoffn(fn)); pop(cx); return NULL; } up->ptr = &vals[upinfo->idx]; up->nextup = cx->openup; cx->openup = up; } fn->upval[i] = up; } else { assert(fn && upinfo->idx < parent->nupval); fn->upval[i] = parent->upval[upinfo->idx]; } } pop(cx); } return fn; } static void delfn(PezContext *cx, Fn *fn) { } static Val * globals_lookup(PezContext *cx, Val key, bool put) { uint32_t h, idx; Globals *pool = &cx->globals; if (!pool->dat) { pool->dat = cxalloc(cx, sizeof(struct KV) * (pool->N = 8)); if (!pool->dat) { return NULL; } memset(pool->dat, 0, sizeof(struct KV) * pool->N); } if (put && pool->count == pool->N / 2) { //resize struct KV *new = cxalloc(cx, sizeof(struct KV) * (pool->N *= 2)); if (!new) { return NULL; } memset(new, 0, sizeof(struct KV) * pool->N); for (uint i = 0; i < pool->N / 2; ++i) { struct KV kv = pool->dat[i]; if (isvoid(kv.k)) { continue; } h = splittable64(kv.k.r); for (idx = h & (pool->N - 1);; idx = (idx + 1) & (pool->N - 1)) { if (isvoid(new[idx].k)) { new[idx] = kv; break; } } } cxfree(cx, pool->dat, sizeof(struct KV) * (pool->N / 2)); pool->dat = new; } h = splittable64(key.r); for (idx = h & (pool->N - 1);; idx = (idx + 1) & (pool->N - 1)) { struct KV *kv = &pool->dat[idx]; if (kv->k.r == key.r) { return &kv->v; } else if (isvoid(kv->k)) { if (put) { kv->k = key; ++pool->count; return &kv->v; } return NULL; } } } static Val * getglobal(PezContext *cx, Val key) { return globals_lookup(cx, key, 0); } static bool putglobal(PezContext *cx, Val key, Val val) { Val *dst = globals_lookup(cx, key, 1); if (!dst) { return 0; } *dst = val; return 1; } static Str ** strpool_lookup(PezContext *cx, const char *str, int len) { StrPool *pool = &cx->strpool; uint32_t h, idx; if (!pool->dat) { pool->dat = cxalloc(cx, sizeof(Str *) * (pool->N = 8)); if (!pool->dat) { return NULL; } memset(pool->dat, 0, sizeof(Str *) * pool->N); } if (pool->count + pool->deleted == pool->N / 2) { // resize Str **new = cxalloc(cx, sizeof(Str *) * (pool->N *= 2)); if (!new) { return NULL; } memset(new, 0, sizeof(Str *) * pool->N); for (uint i = 0; i < pool->N / 2; ++i) { Str *s0 = pool->dat[i]; if (!s0 || s0 == &strpool_deleted) { continue; } h = fnv1a(FNV1A_INI, s0->dat, s0->n); for (idx = h & (pool->N - 1);; idx = (idx + 1) & (pool->N - 1)) { if (!new[idx]) { new[idx] = s0; break; } } } cxfree(cx, pool->dat, sizeof(Str *) * (pool->N / 2)); pool->dat = new; pool->deleted = 0; } h = fnv1a(FNV1A_INI, str, len); for (idx = h & (pool->N - 1);; idx = (idx + 1) & (pool->N - 1)) { Str *s = pool->dat[idx]; if (!s || (s != &strpool_deleted && s->n == len && !memcmp(s->dat, str, len))) { return &pool->dat[idx]; } } } static bool box_str(PezContext *cx, Val *pv, const char *s, int len) { Str **slot; if (len < 8) { uint64_t r = TAGSStr + (len << 4); for (int i = 0; i < len; ++i) { r |= (uint64_t)(uint8_t)s[i] << (56 - (i * 8)); } pv->r = r; return 1; } TRY(slot = strpool_lookup(cx, s, len)); if (!*slot) { Str *o = newobj(cx, PEZ_TString, sizeof(Str) + len + 1); if (!o) { return 0; } o->n = len; memcpy(o->dat, s, len + 1); *slot = o; ++cx->strpool.count; } *pv = box_obj(*slot); return 1; } static inline size_t sizeofstr(Str *str) { return sizeof(*str) + str->n + 1; } static Array * newarr(PezContext *cx, uint cap) { Array *arr = newobj(cx, PEZ_TArray, sizeof *arr); if (!arr) { return NULL; } if (cap) { if (!push(cx, box_obj(arr))) { // gc keep cxfree(cx, arr, sizeof *arr); return NULL; } arr->at = cxalloc(cx, cap * sizeof(Val)); arr->cap = cap; pop(cx); } return arr; } static bool arrpushn(PezContext *cx, Array *arr, Val *src, uint n) { return n == 0 ? 1 : vecpush(cx, arr, src, n); } static void delarray(PezContext *cx, Array *arr) { delvec(cx, arr); } static void delstring(PezContext *cx, Str *str) { Str **slot = strpool_lookup(cx, str->dat, str->n); assert(slot && *slot == str); *slot = NULL; ++cx->strpool.deleted; --cx->strpool.count; } /******/ /* GC */ /******/ static void delobj(PezContext *cx, Obj *o) { size_t sz = 0; switch (o->t) { case PEZ_TFn: sz = sizeoffn((Fn *)o); delfn(cx, (Fn *)o); break; case PEZ_TFnProto: sz = sizeofproto((Proto *)o); delproto(cx, (Proto *)o); break; case PEZ_TArray: sz = sizeof(Array); delarray(cx, (Array *)o); break; case PEZ_TString: sz = sizeofstr((Str *)o); delstring(cx, (Str *)o); break; case PEZ_TUpval: sz = sizeof(Upval); break; } assert(sz); cxfree(cx, o, sz); } static void gcmark(PezContext *cx, Obj *o); static void markproto(PezContext *cx, Proto *pr) { for (uint i = 0; i < pr->ncon; ++i) { if (isobj(pr->con[i])) { gcmark(cx, unbox_obj(pr->con[i])); } } } static void markfn(PezContext *cx, Fn *fn) { gcmark(cx, (Obj *)fn->proto); for (int i = 0; i < fn->nupval; ++i) { if (fn->upval[i]) { gcmark(cx, (Obj *)fn->upval[i]); } } } static void markarray(PezContext *cx, Array *arr) { for (uint i = 0; i < arr->len; ++i) { if (isobj(arr->at[i])) { gcmark(cx, unbox_obj(arr->at[i])); } } } static void gcmark(PezContext *cx, Obj *o) { assert(cx->gccanrun); if (o->gc) { return; } // fprintf(stderr, "visit! %p %s\n", o, typestr(box_obj(o))); o->gc = 1; assert(o->next != o); switch (o->t) { case PEZ_TFnProto: markproto(cx, (Proto *)o); break; case PEZ_TFn: markfn(cx, (Fn *)o); break; case PEZ_TArray: markarray(cx, (Array *)o); break; } } static void gc(PezContext *cx) { uint nalloc = cx->nalloc; if (cx->dbg & DBGgcinfo) { fprintf(stderr, "--- GC running with %d bytes allocated\n", nalloc); } for (Val *stk = cx->stack; stk != cx->stktop; ++stk) { if (isobj(*stk)) { gcmark(cx, unbox_obj(*stk)); } } if (cx->globals.dat) { for (uint i = 0; i < cx->globals.N; ++i) { struct KV *kv = &cx->globals.dat[i]; if (!isvoid(kv->k)) { if (isobj(kv->k)) { gcmark(cx, unbox_obj(kv->k)); } if (isobj(kv->v)) { gcmark(cx, unbox_obj(kv->v)); } } } } for (Obj *o = cx->heap, *next, *prev = NULL; o; o = next) { next = o->next; if (o->gc) { if (cx->dbg & DBGgcinfo) fprintf(stderr, "live %p %s\n", o, typestr(box_obj(o))); prev = o; o->gc = 0; } else { if (cx->dbg & DBGgcinfo) fprintf(stderr, "dead %p %s\n", o, typestr(box_obj(o))); if (o == cx->heap) { cx->heap = next; } if (prev) { prev->next = next; } delobj(cx, o); } } if (cx->dbg & DBGgcinfo) { fprintf(stderr, "--- GC released %d bytes (now %d allocated)\n", nalloc - cx->nalloc, cx->nalloc); } } /********************/ /* Fixed point math */ /********************/ #define FX(n) ((fixnum)(n * 4096)) static inline fixnum ftofix(double f) { return FX(f); } static inline double fixtof(fixnum f) { return f / 4096.0; } static inline int32_t fixtoint(fixnum f) { return f >> 12; } static inline fixnum inttofix(int32_t n) { return (uint32_t)n << 12; } static inline fixnum fixtrunc(fixnum f) { return f & ~(uint32_t)0xFFF; } /******/ /* VM */ /******/ #define OPCODES(_) \ /* name,stack effect */ \ _(nop, 0) \ /* stack manip */ \ _(pop, -1) \ _(dup, 1) \ _(dupn, 000) \ _(dupbck, 1) \ /* constants */ \ _(void, 1) \ _(zero, 1) \ _(one, 1) \ _(byte, 1) \ _(short, 1) \ _(number, 1) \ _(true, 1) \ _(false, 1) \ _(sstr0, 1) \ _(sstr1, 1) \ _(sstr2, 1) \ _(sstr3, 1) \ _(sstr4, 1) \ _(sstr5, 1) \ _(sstr6, 1) \ _(sstr7, 1) \ _(string, 1) \ _(lambda, 1) \ /* unary ops */ \ _(neg, 0) \ _(not, 0) \ /* binary ops */ \ _(add, -1) \ _(sub, -1) \ _(mul, -1) \ _(div, -1) \ _(mod, -1) \ _(band, -1) \ _(bior, -1) \ _(bxor, -1) \ _(shl, -1) \ _(shra, -1) \ _(shrl, -1) \ _(eq, -1) \ _(ne, -1) \ _(lt, -1) \ _(le, -1) \ _(gt, -1) \ _(ge, -1) \ /* ops with immediates */ \ _(iadd, 0) \ _(imul, 0) \ _(idiv, 0) \ _(imod, 0) \ _(iband, 0) \ _(ibior, 0) \ _(ibxor, 0) \ _(ishl, 0) \ _(ishra, 0) \ _(ishrl, 0) \ _(ieq, 0) \ _(ine, 0) \ _(ilt, 0) \ _(ile, 0) \ _(igt, 0) \ _(ige, 0) \ /* variables */ \ _(arg, 1) \ _(setarg, 0) \ _(local, 1) \ _(setloc,-1) \ _(upval, 1) \ _(setupv,-1) \ _(close, 0) \ _(global, 0) \ _(setglo,-2) \ _(putglo,-2) \ /* applications */ \ _(apply, 000) \ _(setapp, 000) \ _(length, 0) \ /* constructors */ \ _(newarr, 000) \ _(arradd, 000) \ /* control flow */ \ _(ret, 0) \ _(b, 0) \ _(bt, -1) \ _(bf, -1) \ enum op { #define X(o,_) O##o, OPCODES(X) #undef X OPCODE_COUNT, }; static const char *opnames[] = { #define X(o,_) #o, OPCODES(X) #undef X }; static const int8_t opeffects[] = { #define X(_,effect) effect, OPCODES(X) #undef X }; static void vrunerr(PezContext *cx, void *fn, int ip, const char *fmt, va_list ap) { char buf[80] = {0}; cx->err = PEZ_ERuntime; vsnprintf(buf, sizeof buf, fmt, ap); if (ip >= 0) { // from bytecode execution Proto *pr = ((Fn *)fn)->proto; assert(pr); snprintf(cx->errstr, sizeof cx->errstr, "%s:%s:%d-%d: %s", pr->file ? pr->file : "?", pr->named ? pr->name : "?", pr->linebegin, pr->lineend, buf); } else { // from C code const char *name = fn; snprintf(cx->errstr, sizeof cx->errstr, "[C]:%s: %s", name ? name : "?", buf); } cx->errstr[sizeof cx->errstr - 1] = 0; } static void runerr(PezContext *cx, Fn *fn, int ip, const char *fmt, ...) { va_list ap; va_start(ap, fmt); vrunerr(cx, fn, ip, fmt, ap); va_end(ap); } static void inspectstr(const char *s, size_t len) { fputc('"', stderr); for (size_t i = 0; i < len; ++i) { unsigned char c = s[i]; extern int isprint(int); switch (c) { case '\n': fprintf(stderr, "\\n"); break; case '\t': fprintf(stderr, "\\t"); break; case '\\': fprintf(stderr, "\\\\"); break; case '\"': fprintf(stderr, "\\\""); break; default: if (isprint(c)) { fputc(c, stderr); } else { fprintf(stderr, "\\x%.2X", c); } } } fputc('"', stderr); } static void inspectproto(Proto *pr) { int n; for (uint i = 0; i < pr->ncon; ++i) { Val k = pr->con[i]; if (isobj_of(k, PEZ_TFnProto)) { inspectproto(unbox_obj(k)); } } n = fprintf(stderr, "fn %s[%d%s]:\n", pr->named ? pr->name : "", pr->nparams, pr->variadic ? ",*" : ""); for (uint ip = 0; ip < pr->ncode;) { uint8_t o = pr->code[ip++]; const uint8_t *argp = &pr->code[ip]; int16_t i16; uint dst; fixnum num; Val v; Proto *opr; fprintf(stderr, "%.4X:\t%s \t", ip-1, opnames[o]); switch (o) { case Odupn: ++ip; fprintf(stderr, "%d", 1 + *argp); break; case Obyte: case Oiadd: case Oimul: case Oidiv: case Oimod: case Oiband: case Oibior: case Oibxor: case Oishl: case Oishrl: case Oishra: case Oilt: case Oile: case Oigt: case Oige: case Oeq: case One: ++ip; fprintf(stderr, "%d", (int8_t)*argp); break; case Oshort: memcpy(&i16, argp, 2); ip += 2; fprintf(stderr, "%d", i16); break; case Onumber: memcpy(&num, argp, 4); ip += 4; fprintf(stderr, "%f", fixtof(num)); break; case Olocal: case Osetloc: case Oarg: case Osetarg: case Oupval: case Osetupv: case Oclose: ++ip; fprintf(stderr, "#%d", *argp); break; case Ostring: ++ip; assert(*argp < pr->ncon); v = pr->con[*argp]; assert(isobj_of(v, PEZ_TString)); inspectstr(((Str *)unbox_obj(v))->dat, ((Str *)unbox_obj(v))->n); break; case Olambda: ++ip; assert(*argp < pr->ncon); v = pr->con[*argp]; assert(isobj_of(v, PEZ_TFnProto)); opr = unbox_obj(v); if (opr->named) { fprintf(stderr, "<'%s %p>", opr->name, opr); } else { fprintf(stderr, "<%p>", opr); } break; case Oapply: case Osetapp: case Onewarr: case Oarradd: ++ip; fprintf(stderr, "%d", *argp); break; case Ob: case Obt: case Obf: memcpy(&i16, argp, 2); ip += 2; dst = ip + i16; assert(dst < pr->ncode); fprintf(stderr, "%.4X", dst); break; } if (o >= Osstr0 && o <= Osstr7) { int n = o - Osstr0; char buf[8] = {0}; memcpy(buf, argp, n); inspectstr(buf, n); ip += n; } fprintf(stderr, "\n"); } while (n-->1) fputc('-', stderr); fprintf(stderr, "\n"); } #define UDO_Oadd(a,b) ( box_num((uint32_t)unbox_num(a) + unbox_num(b)) ) #define UDO_Osub(a,b) ( box_num((uint32_t)unbox_num(a) - unbox_num(b)) ) #define UDO_Omul(a,b) ( box_num(pez_fixmul(unbox_num(a), unbox_num(b))) ) #define UDO_Odiv(a,b) ( box_num(pez_fixdiv(unbox_num(a), unbox_num(b))) ) #define UDO_Omod(a,b) ( box_num(pez_fixmod(unbox_num(a), unbox_num(b))) ) #define UDO_Oband(a,b) ( box_num(unbox_num(a) & unbox_num(b)) ) #define UDO_Obior(a,b) ( box_num(unbox_num(a) | unbox_num(b)) ) #define UDO_Obxor(a,b) ( box_num(unbox_num(a) ^ unbox_num(b)) ) #define UDO_Oshl(a,b) ( box_num((uint32_t)unbox_num(a) << (unbox_num(b) >> 12 & 0x1F)) ) #define UDO_Oshra(a,b) ( box_num(unbox_num(a) >> (unbox_num(b) >> 12 & 0x1F)) ) #define UDO_Oshrl(a,b) ( box_num((uint32_t)unbox_num(a) >> (unbox_num(b) >> 12 & 0x1F)) ) #define UDO_Oeq(a,b) ( box_bool((a).r == (b).r) ) #define UDO_One(a,b) ( box_bool((a).r != (b).r) ) #define UDO_Olt(a,b) ( box_bool(unbox_num(a) < unbox_num(b)) ) #define UDO_Ole(a,b) ( box_bool(unbox_num(a) <= unbox_num(b)) ) #define UDO_Ogt(a,b) ( box_bool(unbox_num(a) > unbox_num(b)) ) #define UDO_Oge(a,b) ( box_bool(unbox_num(a) >= unbox_num(b)) ) static Val uncheckedop(int op, Val a, Val b) { switch (op) { case Oadd: return UDO_Oadd(a,b); case Osub: return UDO_Osub(a,b); case Omul: return UDO_Omul(a,b); case Odiv: return UDO_Odiv(a,b); case Omod: return UDO_Omod(a,b); case Oband: return UDO_Oband(a,b); case Obior: return UDO_Obior(a,b); case Obxor: return UDO_Obxor(a,b); case Oshl: return UDO_Oshl(a,b); case Oshra: return UDO_Oshra(a,b); case Oshrl: return UDO_Oshrl(a,b); case Oeq: return UDO_Oeq(a,b); case One: return UDO_One(a,b); case Olt: return UDO_Olt(a,b); case Ole: return UDO_Ole(a,b); case Ogt: return UDO_Ogt(a,b); case Oge: return UDO_Oge(a,b); } assert(0 && "bad op"); } static bool exefn(PezContext *cx, Fn *fn, uint nargs); static inline bool checkindex(PezContext *cx, int *idx, Fn *srcfn, int srcpc, const char *what, int len, Val arg) { fixnum num; if (!isnum(arg)) { runerr(cx, srcfn, srcpc, "attempt to index %s with %s value", what, typestr(arg)); return 0; } num = unbox_num(arg); if (fixtrunc(num) != num) { runerr(cx, srcfn, srcpc, "non-integer %s index", what); return 0; } *idx = fixtoint(num); *idx = *idx < 0 ? len + *idx : *idx; if (*idx >= len) { runerr(cx, srcfn, srcpc, "%s index out of range", what); return 0; } return 1; } static inline bool apply(PezContext *cx, Val *ret, void *srcfn, int srcpc, Val recv, uint n) { int idx; Val *args = cx->stktop - n, arg; if (isobj_of(recv, PEZ_TFn)) { Fn *f = unbox_obj(recv); if (f->proto->variadic ? n < f->proto->nparams : n != f->proto->nparams) { runerr(cx, srcfn, srcpc, "function takes %d arg(s), %d %s given", f->proto->nparams, n, n == 1 ? "was" : "were"); return 0; } TRY(exefn(cx, f, n)); *ret = pop(cx); } else if (iscfn(recv)) { Val *stktop = cx->stktop; PezCFn *f = unbox_cfn(recv); assert(f); TRY(f(cx, n)); assert(cx->stktop > cx->stack); *ret = *peek(cx); cx->stktop = stktop; } else if (isobj_of(recv, PEZ_TArray)) { Array *arr = unbox_obj(recv); if (n != 1) { runerr(cx, srcfn, srcpc, "array indexing takes one argument (got %d)", n); return 0; } arg = args[0]; if (arg.r == length_sstr.r) { *ret = box_num(inttofix(arr->len)); return 1; } TRY(checkindex(cx, &idx, srcfn, srcpc, "array", arr->len, arg)); *ret = arr->at[idx]; } else if (issstr(recv) || isobj_of(recv, PEZ_TString)) { char buf[8]; const char *str; int len; if (issstr(recv)) { len = unbox_sstr(recv, buf); str = buf; } else { len = ((Str *)unbox_obj(recv))->n; str = ((Str *)unbox_obj(recv))->dat; } if (n != 1) { runerr(cx, srcfn, srcpc, "string indexing takes one argument (got %d)", n); return 0; } arg = args[0]; if (arg.r == length_sstr.r) { *ret = box_num(inttofix(len)); return 1; } TRY(checkindex(cx, &idx, srcfn, srcpc, "string", len, arg)); *ret = (Val){(uint64_t)str[idx] << 56 | TAGSStr | 1 << 4}; } else { runerr(cx, srcfn, srcpc, "%s value is not applicable", typestr(recv)); return 0; } return 1; } static inline bool setapply(PezContext *cx, Val *ret, void *srcfn, int srcpc, Val recv, uint n, Val rval) { int idx; Val *args = cx->stktop - n, arg; if (isobj_of(recv, PEZ_TFn) || iscfn(recv)) { runerr(cx, srcfn, srcpc, "procedure has no setter"); return 0; } else if (isobj_of(recv, PEZ_TArray)) { Array *arr = unbox_obj(recv); if (n != 1) { runerr(cx, srcfn, srcpc, "array indexing takes one argument"); return 0; } arg = args[0]; if (arg.r == length_sstr.r) { runerr(cx, srcfn, srcpc, "cannot mutate array length"); return 0; } TRY(checkindex(cx, &idx, srcfn, srcpc, "array", arr->len, arg)); *ret = arr->at[idx] = rval; } else if (issstr(recv) || isobj_of(recv, PEZ_TString)) { runerr(cx, srcfn, srcpc, "cannot mutate string"); return 0; } else { runerr(cx, srcfn, srcpc, "%s value is not applicable", typestr(recv)); return 0; } return 1; } static bool exefn(PezContext *cx, Fn *fn, uint nargs) { Proto *pr = fn->proto; const uint8_t *code = pr->code; Val *args = cx->stktop - nargs, *locals = cx->stktop; uint ip = 0; for (int i = 0; i < pr->nvars; ++i) { TRY(push(cx, VOID)); } #ifdef __GNUC__ // use computed goto #define X(o,_) &&DoO##o, static const void *jumptable[] = { OPCODES(X) &&Bad }; #undef X #define VMBEGIN { #define VMEND } #define CASE(o) goto *jumptable[code[ip++]]; Do##o: #define BADOP goto *jumptable[code[ip++]]; Bad: #else #define VMBEGIN Next: switch (code[ip++]) { #define VMEND } goto Next; #define CASE(o) break; case o: #define BADOP break; default: #endif VMBEGIN CASE(Onop) {} CASE(Oret) { Val ret = pop(cx); cx->stktop -= pr->nvars; assert(cx->stktop >= cx->stack); push(cx, ret); closeups(cx, args); return 1; } CASE(Opop) { pop(cx); } CASE(Odup) { TRY(push(cx, *peek(cx))); } CASE(Odupn) { int n = code[ip++] + 1; Val *it = cx->stktop - n; assert(cx->stktop > cx->stack + n); for (int i = 0; i < n; ++i ) { TRY(push(cx, it[i])); } } CASE(Odupbck) { Val v; assert(cx->stktop > cx->stack + 1); v = *peek(cx); TRY(push(cx, VOID)); cx->stktop[-1] = cx->stktop[-2]; cx->stktop[-2] = cx->stktop[-3]; cx->stktop[-3] = v; } CASE(Ovoid) { TRY(push(cx, VOID)); } CASE(Ozero) { TRY(push(cx, box_num(FX(0)))); } CASE(Oone) { TRY(push(cx, box_num(FX(1)))); } CASE(Obyte) { TRY(push(cx, box_num(inttofix((int8_t)code[ip++])))); } CASE(Oshort) { int16_t i16; memcpy(&i16, &code[ip], 2), ip += 2; TRY(push(cx, box_num(inttofix(i16)))); } CASE(Onumber) { fixnum num; memcpy(&num, &code[ip], 4), ip += 4; TRY(push(cx, box_num(num))); } CASE(Ofalse) { TRY(push(cx, box_bool(0))); } CASE(Otrue) { TRY(push(cx, box_bool(1))); } #define SSTR(n) \ CASE(Osstr##n) { \ char buf[8]; \ Val v; \ bool ok; \ memcpy(buf, code + ip, n); \ ip += n; \ ok = box_str(cx, &v, buf, n); \ assert(ok); \ TRY(push(cx, v)); \ } SSTR(0) SSTR(1) SSTR(2) SSTR(3) SSTR(4) SSTR(5) SSTR(6) SSTR(7) #undef SSTR CASE(Ostring) { uint8_t idx = code[ip++]; Val v; assert(idx < pr->ncon); v = pr->con[idx]; assert(isobj_of(v, PEZ_TString)); TRY(push(cx, v)); } CASE(Olambda) { uint8_t idx = code[ip++]; Val k; Fn *ofn; assert(idx < pr->ncon); k = pr->con[idx]; assert(isobj_of(k, PEZ_TFnProto)); TRY(ofn = newfn(cx, unbox_obj(k), args, locals, fn)); TRY(push(cx, box_obj(ofn))); } CASE(Onot) { Val *p = peek(cx); *p = box_bool(!truthy(*p)); } CASE(Oneg) { Val *p = peek(cx); if (!isnum(*p)) { runerr(cx, fn, ip, "attempt to negate %s value", typestr(*p)); return 0; } *p = box_num(-(uint32_t)unbox_num(*p)); } #define ARITH(o, oname) \ CASE(O##o) { \ Val b = pop(cx), a = pop(cx); \ if (!isnum(a) || !isnum(b)) { \ runerr(cx, fn, ip, "cannot %s %s and %s values", \ oname, typestr(a), typestr(b)); \ return 0; \ } \ push(cx, UDO_O##o(a, b)); \ } ARITH(add, "add") ARITH(sub, "subtract") ARITH(mul, "multiply") ARITH(div, "divide") ARITH(mod, "divide") ARITH(band, "perform bitwise-and on") ARITH(bior, "perform bitwise-or on") ARITH(bxor, "perform bitwise-xor on") ARITH(shl, "bitshift") ARITH(shra, "bitshift") ARITH(shrl, "bitshift") ARITH(lt, "compare") ARITH(le, "compare") ARITH(gt, "compare") ARITH(ge, "compare") #undef ARITH #define IARITH(o, oname, expr) \ CASE(O##i##o) { \ Val *p = peek(cx), a = *p; \ int32_t iimm =(int8_t)code[ip++]; \ fixnum nimm = (uint32_t)iimm << 12; (void)nimm; \ fixnum x = unbox_num(a); \ if (!isnum(a)) { \ runerr(cx, fn, ip, "cannot %s %s and number values", \ oname, typestr(a)); \ return 0; \ } \ *p = expr; \ } IARITH(add, "add", box_num((uint32_t)x + nimm)) IARITH(mul, "multiply", box_num((uint32_t)x * iimm)) IARITH(div, "divide", box_num(/*iimm!=0*/ x / iimm)) IARITH(mod, "divide", box_num(/*nimm!=0*/ nimm < 0 ? -x % -nimm : x % nimm)) IARITH(band, "perform bitwise-and on", box_num(x & nimm)) IARITH(bior, "perform bitwise-or on", box_num(x | nimm)) IARITH(bxor, "perform bitwise-xor on", box_num(x ^ nimm)) IARITH(shl, "bitshift", box_num((uint32_t)x << (iimm & 0x1F))) IARITH(shra, "bitshift", box_num( x >> (iimm & 0x1F))) IARITH(shrl, "bitshift", box_num((uint32_t)x >> (iimm & 0x1F))) IARITH(lt, "compare", box_bool(x < nimm)) IARITH(le, "compare", box_bool(x <= nimm)) IARITH(gt, "compare", box_bool(x > nimm)) IARITH(ge, "compare", box_bool(x >= nimm)) #undef IARITH CASE(Oeq) { Val a = pop(cx), b = pop(cx); push(cx, box_bool(a.r == b.r)); } CASE(One) { Val a = pop(cx), b = pop(cx); push(cx, box_bool(a.r != b.r)); } CASE(Oieq) { *peek(cx) = box_bool(peek(cx)->r == box_num((int8_t)code[ip++] << 12).r); } CASE(Oine) { *peek(cx) = box_bool(peek(cx)->r != box_num((int8_t)code[ip++] << 12).r); } CASE(Oarg) { uint8_t idx = code[ip++]; TRY(push(cx, args[idx])); } CASE(Osetarg) { uint8_t idx = code[ip++]; args[idx] = pop(cx); } CASE(Olocal) { uint8_t idx = code[ip++]; TRY(push(cx, locals[idx])); } CASE(Osetloc) { uint8_t idx = code[ip++]; locals[idx] = pop(cx); } CASE(Oupval) { uint8_t idx = code[ip++]; assert(idx < fn->nupval); TRY(push(cx, *fn->upval[idx]->ptr)); } CASE(Osetupv) { uint8_t idx = code[ip++]; assert(idx < fn->nupval); *fn->upval[idx]->ptr = pop(cx); } CASE(Oclose) { uint8_t idx = code[ip++]; closeups(cx, &locals[idx]); } CASE(Oglobal) { Val k = pop(cx), *v; if ((v = getglobal(cx, k))) { push(cx, *v); } else { char buf[8]; const char *name; if (issstr(k)) { unbox_sstr(k, buf); name = buf; } else if (isobj_of(k, PEZ_TString)) { Str *s = unbox_obj(k); name = s->dat; } else { assert(0); } runerr(cx, fn, ip, "no such global \"%s\"", name); return 0; } } CASE(Osetglo) { Val k, v, *g; v = pop(cx); k = pop(cx); if ((g = getglobal(cx, k))) { *g = v; } else { char buf[8]; const char *name; if (issstr(k)) { unbox_sstr(k, buf); name = buf; } else if (isobj_of(k, PEZ_TString)) { Str *s = unbox_obj(k); name = s->dat; } else { assert(0); } runerr(cx, fn, ip, "no such global \"%s\"", name); return 0; } } CASE(Oputglo) { Val k, v; v = pop(cx); k = pop(cx); TRY(putglobal(cx, k, v)); } CASE(Oapply) { uint8_t n = code[ip++]; Val lhs, ret; assert(cx->stktop - n - 1 >= cx->stack); lhs = cx->stktop[-n - 1]; memmove(cx->stktop - n - 1, cx->stktop - n, n * sizeof(Val)); --cx->stktop; if (isobj_of(lhs, PEZ_TFn)) { Fn *f = unbox_obj(lhs); Proto *pr = f->proto; if (pr->variadic ? n < pr->nparams : n != pr->nparams) { runerr(cx, fn, ip, "function takes %d arg(s), %d %s given", pr->nparams, n, n == 1 ? "was" : "were"); return 0; } TRY(exefn(cx, f, n)); ret = pop(cx); cx->stktop -= n-1; *peek(cx) = ret; } else { TRY(apply(cx, &ret, fn, ip, lhs, n)); cx->stktop -= n-1; *peek(cx) = ret; } } CASE(Osetapp) { uint8_t n = code[ip++]; Val rval = pop(cx), a = cx->stktop[-1 - n], ret; TRY(setapply(cx, &ret, fn, ip, a, n, rval)); cx->stktop -= n; cx->stktop[-1] = ret; } CASE(Olength) { Val a = *peek(cx); if (isobj_of(a, PEZ_TArray)) { *peek(cx) = box_num(inttofix(((Array *)unbox_obj(a))->len)); } else { Val arg, ret; bool ok = box_str(cx, &arg, "length", 6); assert(ok); TRY(push(cx, arg)); TRY(apply(cx, &ret, fn, ip, a, 1)); --cx->stktop; *peek(cx) = ret; } } CASE(Onewarr) { uint8_t n = code[ip++]; Array *arr = newarr(cx, n); TRY(arr != NULL); TRY(push(cx, box_obj(arr))); // gc keep TRY(arrpushn(cx, arr, cx->stktop - n - 1, n)); pop(cx); cx->stktop -= n; push(cx, box_obj(arr)); } CASE(Oarradd) { uint8_t n = code[ip++]; Val r = cx->stktop[-n - 1]; Array *arr = unbox_obj(r); assert(isobj(r) && arr->t == PEZ_TArray); TRY(arrpushn(cx, arr, cx->stktop - n, n)); cx->stktop -= n; } CASE(Ob) { int16_t off; uint dst; memcpy(&off, &code[ip], 2), ip += 2; dst = ip + off; assert(dst < pr->ncode); ip = dst; } CASE(Obt) { int16_t off; uint dst; Val v = pop(cx); memcpy(&off, &code[ip], 2), ip += 2; dst = ip + off; assert(dst < pr->ncode); if (truthy(v)) { ip = dst; } } CASE(Obf) { int16_t off; uint dst; Val v = pop(cx); memcpy(&off, &code[ip], 2), ip += 2; dst = ip + off; assert(dst < pr->ncode); if (!truthy(v)) { ip = dst; } } BADOP { runerr(cx, fn, ip, "bad opcode %#x", code[ip-1]); return 0; } VMEND #undef BADOP #undef CASE #undef VMEND #undef VMBEGIN } /******************/ /* Core functions */ /******************/ struct vals { vec_of(Val); }; static bool xprint1(PezContext *cx, struct vals *seen, bool (*cb)(PezContext *, void *, const char *, uint), void *u, Val v) { for (uint i = 0; i < seen->len; ++i) { if (seen->at[i].r == v.r) { char buf[20]; int n = sprintf(buf, "#%d", i); return cb(cx, u, buf, n); } } if (isvoid(v)) { cb(cx, u, "()", 2); } else if (isbool(v)) { cb(cx, u, unbox_bool(v) ? "#t" : "#f", 2); } else if (isnum(v)) { fixnum num = unbox_num(v); double d = fixtof(num); char buf[NAMEMAX]; int n = sprintf(buf, num == fixtrunc(num) ? "%g" : "%f", d); TRY(cb(cx, u, buf, n)); } else if (issstr(v) || isobj_of(v, PEZ_TString)) { char buf[8]; const char *str; int len; bool ok = 1; if (issstr(v)) { len = unbox_sstr(v, buf); str = buf; } else { len = ((Str *)unbox_obj(v))->n; str = ((Str *)unbox_obj(v))->dat; } ok &= cb(cx, u, "\"", 1); for (uint i = 0; i < len; ++i) { extern int isprint(int); if (str[i] == '\\') { ok &= cb(cx, u, "\\\\", 2); } else if (str[i] == '\n') { ok &= cb(cx, u, "\\n", 2); } else if (str[i] == '\t') { ok &= cb(cx, u, "\\t", 2); } else if (str[i] == '"') { ok &= cb(cx, u, "\\\"", 2); } else if (isprint(str[i])) { ok &= cb(cx, u, &str[i], 1); } else { char tmp[5]; sprintf(tmp, "\\x%.2X", (unsigned char)str[i]); ok &= cb(cx, u, tmp, 4); } } ok &= cb(cx, u, "\"", 1); TRY(ok); } else if (iscfn(v) || isobj_of(v, PEZ_TFn)) { const char *name = isobj_of(v, PEZ_TFn) && ((Fn *)unbox_obj(v))->proto->named ? ((Fn *)unbox_obj(v))->proto->name : NULL; if (name) { TRY(cb(cx, u, "#", 1)); } else { TRY(cb(cx, u, "#", 11)); } } else if (isobj_of(v, PEZ_TArray)) { Array *arr = unbox_obj(v); bool ok = 1; TRY(vecpush(cx, seen, &v, 1)); ok &= cb(cx, u, "#[", 2); for (uint i = 0; i < arr->len; ++i) { ok &= xprint1(cx, seen, cb, u, arr->at[i]); if (i != arr->len - 1) { ok &= cb(cx, u, ", ", 2); } } ok &= cb(cx, u, "]", 1); TRY(ok); } else { TRY(cb(cx, u, "#", 6)); } return 1; } static bool f_xprintf1(PezContext *cx, const char *fn, bool (*cb)(PezContext *, void *, const char *, uint), void *u, int argc) { int args = pez_top(cx) - argc, arg = 1; char sbuf[8]; const char *fmt; int fmtlen; bool ok = 1; if (argc < 1) { pez_error(cx, fn, "missing format string"); return 0; } if (!pez_isstring(cx, args + 0)) { pez_error(cx, fn, "expected format string (got %s)", pez_typename(cx, args + 0)); return 0; } fmtlen = pez_length(cx, args + 0); fmt = pez_getstring(cx, sbuf, args + 0); for (uint i = 0; i < fmtlen; ++i) { char c = fmt[i]; if (c == '%' && i < fmtlen - 1) { if ((c = fmt[++i]) != '%') { Val v; char sbuf[8]; const char *str; int len; struct vals seen = {0}; if (arg == argc) { pez_error(cx, fn, "not enough arguments for format string"); return 0; } v = cx->stack[args + arg]; switch (c) { case 'a': ok &= xprint1(cx, &seen, cb, u, v); delvec(cx, &seen); break; case 's': if (!pez_isstring(cx, args + arg)) { pez_error(cx, fn, "%%s format specifier expects a string (got %s)", pez_typename(cx, args + arg)); return 0; } len = pez_length(cx, args + arg); str = pez_getstring(cx, sbuf, args + arg); ok &= cb(cx, u, str, len); break; default: pez_error(cx, fn, "bad format specifier '%%%c'", c); return 0; } ++arg; continue; } } ok &= cb(cx, u, &c, 1); } TRY(ok); TRY(pez_pushvoid(cx)); return 1; } static bool printtofile(PezContext *cx, void *fp, const char *d, uint n) { fwrite(d, 1, n, fp); return 1; } static bool f_printf(PezContext *cx, int argc) { return f_xprintf1(cx, "printf", printtofile, stdout, argc); } static bool printtostr(PezContext *cx, void *V, const char *d, uint n) { vec_of(char) *v = V; return vecpush(cx, v, d, n); } static bool f_sprintf(PezContext *cx, int argc) { vec_of(char) s = {0}; ETRY(f_xprintf1(cx, "sprintf", printtostr, &s, argc)); ETRY(pez_pushstring(cx, s.at, s.len)); delvec(cx, &s); return 1; Err: delvec(cx, &s); return 0; } static const struct coredef { const char *n; PezCFn *f; } core[] = { { "printf", f_printf }, { "sprintf", f_sprintf } }; static bool initcore(PezContext *cx) { for (size_t i = 0; i < sizeof core / sizeof *core; ++i) { const struct coredef *def = &core[i]; Val s, f; TRY(box_str(cx, &s, def->n, strlen(def->n))); f = box_cfn(def->f); TRY(putglobal(cx, s, f)); } return 1; } /*******************/ /* Parser/compiler */ /*******************/ static void initcomp(Comp *cm, PezContext *cx, Proto *pr, int (*cb)(void *), void *ud) { memset(cm, 0, sizeof *cm); cm->cx = cx; cm->readcb = cb; cm->readud = ud; cm->line = 1; cm->col = 0; cm->lastop = cm->lastop2 = -1; cm->proto = pr; } static void delfenv(PezContext *cx, struct fenv *fenv) { delvec(cx, &fenv->locals); } static void deinitcomp(Comp *cm) { delfenv(cm->cx, &cm->fenv); delvec(cm->cx, &cm->spool); delvec(cm->cx, &cm->kpool); } static bool fincompfn(Comp *cm) { Proto *pr = cm->proto; const uint8_t *code = cxrealloc(cm->cx, cm->code.at, cm->code.cap, cm->code.len); const Val *con = cxrealloc(cm->cx, cm->con.at, cm->con.cap * sizeof(Val), cm->con.len * sizeof(Val)); assert(code != NULL && (cm->con.len == 0 || con != NULL) && "can't shrink?"); pr->lineend = cm->line; pr->code = code; pr->ncode = cm->code.len; pr->con = con; pr->ncon = cm->con.len; pr->upval = cxalloc(cm->cx, cm->fenv.nupval * sizeof *pr->upval); pr->nupval = cm->fenv.nupval; // fprintf(stderr, "fini %s %d\n", pr->name, pr->nupval); if (pr->upval) { memcpy(pr->upval, cm->fenv.upvals, pr->nupval * sizeof(struct cmupval)); } return 1; } static void comperr(Comp *cm, int ch, const char *fmt, ...) { va_list ap; char buf[80] = {0}; char buf2[10]; cm->cx->err = PEZ_ESyntax; va_start(ap, fmt); vsnprintf(buf, sizeof buf, fmt, ap); va_end(ap); sprintf(buf2, "'%c'", ch); snprintf(cm->cx->errstr, sizeof cm->cx->errstr, "%s:%d:%d: %s (near %s)", cm->proto->file, cm->line, cm->col, buf, ch == EOF ? "" : buf2); cm->cx->errstr[sizeof cm->cx->errstr - 1] = 0; } static bool compbytes(Comp *cm, void *d, size_t n) { return vecpush(cm->cx, &cm->code, d, n); } static bool compbyte(Comp *cm, uint8_t x) { return compbytes(cm, &x, 1); } static bool compop(Comp *cm, enum op x); static int peekchr(Comp *cm); static bool compconst(Comp *cm, Val v) { int t; if (isvoid(v)) { TRY(compop(cm, Ovoid)); return 1; } if (isnum(v)) { fixnum num = unbox_num(v); if (num == 0) { TRY(compop(cm, Ozero)); } else if (num == FX(1)) { TRY(compop(cm, Oone)); } else if (num == fixtrunc(num) && num >= FX(-128) && num < FX(127)) { int8_t n = fixtoint(num); TRY(compop(cm, Obyte)); TRY(compop(cm, n)); } else if (num == fixtrunc(num) && num >= FX(-32768) && num < FX(32768)) { int16_t n = fixtoint(num); TRY(compop(cm, Oshort)); TRY(compbytes(cm, &n, 2)); } else { TRY(compop(cm, Onumber)); TRY(compbytes(cm, &num, 4)); } return 1; } if (isbool(v)) { TRY(compop(cm, unbox_bool(v) ? Otrue : Ofalse)); return 1; } if (issstr(v)) { char s[8]; int n = unbox_sstr(v, s); assert(n >= 0 && n < 8); TRY(compop(cm, Osstr0 + n)); TRY(compbytes(cm, s, n)); return 1; } if (isobj(v) && (t = objtag(v)) == PEZ_TString) { uint8_t idx = cm->con.len; for (uint i = 0; i < cm->con.len; ++i) { if (cm->con.at[i].r == v.r) { idx = i; goto K; } } if (cm->con.len == UINT8_MAX) { comperr(cm, peekchr(cm), "too many consts"); return 0; } K: vecpush(cm->cx, &cm->con, &v, 1); TRY(compop(cm, Ostring)); TRY(compbyte(cm, idx)); return 1; } assert(0 && "const?"); return 0; } static bool compop(Comp *cm, enum op x) { if (cm->has_k) { cm->has_k = 0; TRY(compconst(cm, cm->k)); } cm->lastop2 = cm->lastop; cm->lastop = cm->code.len; return compbyte(cm, x); } /* must be called after emitting any branches to avoid * confusing discard() peephole optimizer */ static void resetlastops(Comp *cm) { cm->lastop = cm->lastop2 = -1; } static bool addparam(Comp *cm, const char *name) { struct fenv *fenv = &cm->fenv; Local l = { .sref = cm->spool.len, .scope = fenv->scope, .isparam = 1, .mutable = 1 }; assert(l.scope == 0); assert(l.sref == cm->spool.len); TRY(vecpush(cm->cx, &cm->spool, name, strlen(name) + 1)); l.index = cm->proto->nparams++; TRY(vecpush(cm->cx, &fenv->locals, &l, 1)); return 1; } static void beginscope(Comp *cm) { ++cm->fenv.scope; } static Local * addlocal(Comp *cm, uint *idx, const char *name, bool mutable, bool has_k, Val k) { struct fenv *fenv = &cm->fenv; Local l = { .sref = cm->spool.len, .scope = fenv->scope, .kref = cm->kpool.len, .has_k = has_k, .mutable = mutable, }; assert(l.scope > 0); assert(l.sref == cm->spool.len); assert(l.kref == cm->kpool.len); TRY(vecpush(cm->cx, &cm->spool, name, strlen(name) + 1)); if (mutable) { assert(!has_k); } if (!has_k) { // this renders into a stack slot *idx = l.index = fenv->nvars++; cm->proto->nvars = MAX(cm->proto->nvars, fenv->nvars); } else { // to propagate constant folding through const locals TRY(vecpush(cm->cx, &cm->kpool, &k, 1)); } TRY(vecpush(cm->cx, &fenv->locals, &l, 1)); return veclast(&fenv->locals); } static Local * findlocal(Comp *cm, const char *name) { for (int i = cm->fenv.locals.len - 1; i >= 0; --i) { Local *l = &cm->fenv.locals.at[i]; if (!strcmp(&cm->spool.at[l->sref], name)) { return l; } } // search for foldablable consts in enclosing functions for (struct fenv *fenv = cm->fenv.prev; fenv; fenv = fenv->prev) { for (int i = fenv->locals.len - 1; i >= 0; --i) { Local *l = &fenv->locals.at[i]; if (l->has_k && !strcmp(&cm->spool.at[l->sref], name)) { return l; } } } return NULL; } static int addupval(Comp *cm, struct fenv *fenv, uint8_t idx, bool arg, bool local) { struct cmupval up = { idx, arg, local }; for (int i = 0; i < fenv->nupval; ++i) { struct cmupval *up = &fenv->upvals[i]; if (up->idx == idx && up->local == local) { return up->idx; } } assert(fenv->nupval < 256 && "upval limit"); fenv->upvals[fenv->nupval] = up; return fenv->nupval++; } static int findupval(Comp *cm, Local **pl, struct fenv *fenv, const char *name) { int idx; if (!fenv->prev) { return -1; } for (int i = fenv->prev->locals.len - 1; i >= 0; --i) { Local *l = &fenv->prev->locals.at[i]; if (!strcmp(&cm->spool.at[l->sref], name)) { assert(!l->has_k); // would've been found by findlocal earlier l->captured = 1; *pl = l; return addupval(cm, fenv, l->index, l->isparam, !l->isparam); } } if ((idx = findupval(cm, pl, fenv->prev, name)) != -1) { return addupval(cm, fenv, idx, 0, 0); } return -1; } static bool endscope(Comp *cm) { while (!vecempty(&cm->fenv.locals)) { Local *l = veclast(&cm->fenv.locals); if (l->scope < cm->fenv.scope) { break; } else { if (!l->has_k) { --cm->fenv.nvars; if (l->mutable && l->scope > 0 && l->captured) { TRY(compop(cm, Oclose) && compbyte(cm, l->index)); } } --cm->fenv.locals.len; } } --cm->fenv.scope; return 1; } static int nextchr(Comp *cm) { int c; if (cm->have_peekchr) { cm->have_peekchr = 0; return cm->peekchr; } c = cm->readcb(cm->readud); if (c == '\n') { ++cm->line; cm->col = 0; } else { ++cm->col; } return c; } static int peekchr(Comp *cm) { if (cm->have_peekchr) { return cm->peekchr; } cm->peekchr = nextchr(cm); cm->have_peekchr = 1; return cm->peekchr; } static bool aisspace(int c) { switch (c) case ' ': case '\t': case '\n': case '\r': case '\v': case '\f': return 1; return 0; } static inline void eatspaces(Comp *cm) { for (;; nextchr(cm)) { int c = peekchr(cm); if (c == ';') { // ; comment for (; (c = peekchr(cm)) != '\n' && c != EOF; nextchr(cm)) ; continue; } if (!aisspace(peekchr(cm))) { break; } } } static bool matchchr(Comp *cm, int chr) { if (peekchr(cm) == chr) { nextchr(cm); return 1; } return 0; } static bool matchspchr(Comp *cm, int chr) { eatspaces(cm); return matchchr(cm, chr); } static bool expectchr(Comp *cm, int chr) { if (!matchchr(cm, chr)) { comperr(cm, peekchr(cm), "expected '%c'", chr); return 0; } return 1; } static bool expectspchr(Comp *cm, int chr) { eatspaces(cm); return expectchr(cm, chr); } static bool aisdigit(int c) { return c >= '0' && c <= '9'; } static bool aisalpha(int c) { return (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'); } static bool aissep(int c) { if (aisspace(c)) return 1; switch (c) case '(': case ')': case '[': case ']': case '{': case '}': case '.': case ',': case ';': case '?': case '+': case '-': case '*': case '/': case '&': case '|': case '^': case '~': case '=': case '\'': case '"': case '<': case '>': case ':': case '@': case '%': case '\\': case '`': case EOF: return 1; return 0; } /* Used by 'string-constants */ static bool aissep2(int c) { if (aisspace(c)) return 1; switch (c) case '(': case ')': case '[': case ']': case '{': case '}': case ',': case ';': case '\'': case '"': case EOF: return 1; return 0; } static bool readident(Comp *cm, char *dst, size_t size) { size_t i = 0; while (!aissep(peekchr(cm))) { if (i == size - 2) { comperr(cm, peekchr(cm), "identifier too long"); return 0; } dst[i++] = nextchr(cm); } dst[i] = 0; return 1; } static bool block(Comp *cm, int endchr); static bool expr(Comp *cm); static bool compclosure(Comp *cm, Proto *pr) { Val k = box_obj(pr); if (cm->con.len == UINT8_MAX) { comperr(cm, peekchr(cm), "too many consts"); return 0; } TRY(vecpush(cm->cx, &cm->con, &k, 1)); TRY(compop(cm, Olambda)); TRY(compbyte(cm, cm->con.len - 1)); return 1; } static bool lambdaexpr(Comp *cm, const char *name) { Proto *proto = newproto(cm->cx, cm->proto->file, name, cm->line); Proto *prevfn = cm->proto; vec_of(uint8_t) prevcode; vec_of(Val) prevcon; struct fenv prevfenv = cm->fenv;; struct fenv fenv = { .prev = &prevfenv, .name = name }; bool ret = 1; memcpy(&prevcode, &cm->code, sizeof prevcode); memset(&cm->code, 0, sizeof cm->code); memcpy(&prevcon, &cm->con, sizeof prevcon); memset(&cm->con, 0, sizeof cm->con); cm->proto = proto; cm->fenv = fenv; if (matchspchr(cm, '[')) { while (!matchspchr(cm, ']')) { char name[NAMEMAX]; int c; eatspaces(cm); if ((c = peekchr(cm)) != '_' && !aisalpha(c)) { comperr(cm, c, "expected identifier"); return 0; } ETRY(readident(cm, name, sizeof name)); ETRY(addparam(cm, name)); if (!matchspchr(cm, ',')) { ETRY(expectspchr(cm, ']')); break; } } } ETRY(block(cm, '}')); ETRY(compop(cm, Oret)); ETRY(fincompfn(cm)); Cleanup: cm->proto = prevfn; memcpy(&cm->code, &prevcode, sizeof prevcode); memcpy(&cm->con, &prevcon, sizeof prevcon); delfenv(cm->cx, &cm->fenv); cm->fenv = prevfenv; return ret && compclosure(cm, proto); Err: ret = 0; goto Cleanup; } static bool flushconst(Comp *cm) { if (cm->has_k) { cm->has_k = 0; return compconst(cm, cm->k); } return 1; } static bool primaryexpr(Comp *cm) { char buf[NAMEMAX]; Local *local; int c; if (*cm->stash_ident) { strcpy(buf, cm->stash_ident); *cm->stash_ident = 0; goto Ident; } if (cm->stash_local) { local = cm->stash_local; cm->stash_local = NULL; goto Local; } eatspaces(cm); c = nextchr(cm); cm->lvalue = 0; if (aisdigit(c)) { // number int i = 0; double dbl; fixnum num; char *eptr; goto begin; do { c = nextchr(cm); begin: if (i == sizeof buf - 1) { comperr(cm, c, "number literal too long"); return 0; } buf[i++] = c; } while ((c = peekchr(cm)) == '.' || !aissep(c)); buf[i++] = 0; dbl = strtod(buf, &eptr); if (eptr != buf + i - 1) { comperr(cm, c, "bad number literal '%s'", buf); return 0; } if (dbl > 0x80000) { comperr(cm, c, "number literal overflow '%s'", buf); return 0; } num = ftofix(dbl); cm->has_k = 1; cm->k = box_num(num); return 1; } if (c == '_' || aisalpha(c)) { int idx; // identifier *buf = c; TRY(readident(cm, buf + 1, sizeof buf - 1)); Ident: local = findlocal(cm, buf); if (local) { Local: if (local->isparam) { assert(local->index < 256); TRY(compop(cm, Oarg) && compbyte(cm, local->index)); } else if (local->has_k) { cm->has_k = 1; cm->k = cm->kpool.at[local->kref]; } else { assert(local->index < 256); TRY(compop(cm, Olocal) && compbyte(cm, local->index)); } cm->lvalue = 1; cm->lvalue_const = !local->mutable; cm->lvalue_name = &cm->spool.at[local->sref]; } else if ((idx = findupval(cm, &local, &cm->fenv, buf)) != -1) { assert(idx >= 0 && idx < 256); TRY(compop(cm, Oupval) && compbyte(cm, idx)); cm->lvalue = 1; cm->lvalue_const = !local->mutable; cm->lvalue_name = &cm->spool.at[local->sref]; } else { Val nam; TRY(box_str(cm->cx, &nam, buf, strlen(buf))); TRY(compconst(cm, nam)); TRY(compop(cm, Oglobal)); cm->lvalue = 1; cm->lvalue_const = 0; cm->lvalue_name = NULL; } return 1; } if (c == '\'') { // enum-like string int i = 0; while (!aissep2((c = peekchr(cm)))) { assert(i < sizeof buf - 2); buf[i++] = c; nextchr(cm); } switch (c) { case EOF: case '(': case ')': case ',': case '[': case ']': case '{': case '}': break; default: if (!aisspace(c)) { goto BadE; } } if (i == 0) { BadE: comperr(cm, c, "expected enum-like string constant"); return 0; } buf[i] = 0; TRY(box_str(cm->cx, &cm->k, buf, i)); cm->has_k = 1; return 1; } if (c == '"') { // string int i = 0; while ((c = nextchr(cm)) != '"') { assert(i < sizeof buf - 2); if (c == EOF) { Eof: comperr(cm, c, "unterminated string constant"); return 0; } if (c == '\\') { switch ((c = nextchr(cm))) { case 'n': c = '\n'; break; case 't': c = '\t'; break; case '"': c = '"'; break; case '\\': c = '\\'; break; case 'x': case 'X': { const char *b16 = "0123456789abcdef", *p; extern int tolower(int); uint8_t b = 0; for (int i = 0; i < 2; ++i) { b <<= 4; if ((c = nextchr(cm)) == EOF) { goto Eof; } if (!(p = strchr(b16, tolower(c))) || !*p) { goto Bad; } b |= p - b16; } c = b; break; } case EOF: goto Eof; default: Bad: comperr(cm, c, "bad escape sequence"); return 0; } } buf[i++] = c; } buf[i] = 0; TRY(box_str(cm->cx, &cm->k, buf, i)); cm->has_k = 1; return 1; } switch (c) { case '(': if (peekchr(cm) == ')') { nextchr(cm); cm->k = VOID; cm->has_k = 1; } else { return block(cm, ')'); } return 1; case '{': return lambdaexpr(cm, NULL); case '#': // other literals if (aisalpha((c = peekchr(cm)))) { // #t or #f char buf[10]; int i = 0; do { buf[i++] = c; if (i == sizeof buf - 1) { comperr(cm, c, "bad literal '#%.*s'", i, buf); return 0; } c = nextchr(cm); } while (!aissep(peekchr(cm))); buf[i++] = 0; if (!strcmp(buf, "t") || !strcmp(buf, "f")) { cm->k = box_bool(*buf == 't'); cm->has_k = 1; return 1; } comperr(cm, c, "bad literal '#%.*s'", i, buf); return 0; } else if (c == '[') { // array int n = 0; bool big = 0; nextchr(cm); cm->lvalue = 0; while (!matchspchr(cm, ']')) { TRY(expr(cm)); TRY(flushconst(cm)); if (++n == 255) { TRY(compop(cm, big ? Oarradd : Onewarr)); TRY(compbyte(cm, n)); big = 1; n = 0; } if (!matchspchr(cm, ',')) { TRY(expectspchr(cm, ']')); break; } } TRY(compop(cm, big ? Oarradd : Onewarr)); TRY(compbyte(cm, n)); return 1; } else if (c == EOF || aisspace(c)) { comperr(cm, c, "stray '#'"); return 0; } comperr(cm, c, "bad literal '#%c'", c); return 0; } comperr(cm, c, "expected expression"); return 0; } static bool postfixexpr(Comp *cm) { TRY(primaryexpr(cm)); for (;;) { if (matchspchr(cm, '[')) { int n = 0; TRY(flushconst(cm)); cm->lvalue = 0; while (!matchspchr(cm, ']')) { TRY(expr(cm)); TRY(flushconst(cm)); ++n; if (!matchspchr(cm, ',')) { TRY(expectspchr(cm, ']')); break; } } assert(n < 256); cm->lvalue = 1; cm->lvalue_const = 0; cm->lvalue_name = NULL; TRY(compop(cm, Oapply)); TRY(compbyte(cm, n)); } else if (matchspchr(cm, '.')) { int c; char name[NAMEMAX]; Val s; eatspaces(cm); if ((c = peekchr(cm)) != '_' && !aisalpha(c)) { comperr(cm, c, "expected identifier"); return 0; } TRY(readident(cm, name, sizeof name)); if (!strcmp(name, "length")) { TRY(compop(cm, Olength)); } else { TRY(box_str(cm->cx, &s, name, strlen(name))); TRY(compconst(cm, s)); TRY(compop(cm, Oapply)); TRY(compbyte(cm, 1)); } cm->lvalue = 1; cm->lvalue_const = 0; cm->lvalue_name = NULL; } else { break; } } return 1; } static bool prefixexpr(Comp *cm) { if (*cm->stash_ident || cm->stash_local) { return postfixexpr(cm); } else if (matchspchr(cm, '-')) { TRY(prefixexpr(cm)); cm->lvalue = 0; if (cm->has_k && isnum(cm->k)) { cm->k = box_num(-(uint32_t)unbox_num(cm->k)); return 1; } return compop(cm, Oneg); } else if (matchspchr(cm, '!')) { TRY(prefixexpr(cm)); cm->lvalue = 0; if (cm->has_k) { cm->k = box_bool(!truthy(cm->k)); return 1; } return compop(cm, Onot); } else { return postfixexpr(cm); } } /* * kinds: * 0 - not binop * 'A' - arith * 'C' - cmp * 'L' - logic * 'S' - setters */ enum { Oset = 0x100, Ologand, Ologor }; // pseudo ops static int getbinop(char *kind, char *chr, Comp *cm) { int c; if (cm->stash_binopop) { int op = cm->stash_binopop; *kind = cm->stash_binopk; *chr = cm->stash_binopchr; cm->stash_binopop = 0; return op; } eatspaces(cm); c = peekchr(cm); *chr = 0; switch (c) { case '+': *chr = nextchr(cm); *kind = matchchr(cm, '=') ? 'S' : 'A'; return Oadd; case '-': *chr = nextchr(cm); *kind = matchchr(cm, '=') ? 'S' : 'A'; return Osub; case '*': *chr = nextchr(cm); *kind = matchchr(cm, '=') ? 'S' : 'A'; return Omul; case '/': *chr = nextchr(cm); *kind = matchchr(cm, '=') ? 'S' : 'A'; return Odiv; case '%': *chr = nextchr(cm); *kind = matchchr(cm, '=') ? 'S' : 'A'; return Omod; case '&': *chr = nextchr(cm); if (matchchr(cm, '&')) { *kind = 'L'; return Ologand; } *kind = matchchr(cm, '=') ? 'S' : 'A'; return Oband; case '|': *chr = nextchr(cm); if (matchchr(cm, '|')) { *kind = 'L'; return Ologor; } *kind = matchchr(cm, '=') ? 'S' : 'A'; return Obior; case '^': *chr = nextchr(cm); *kind = matchchr(cm, '=') ? 'S' : 'A'; return Obxor; case '<': *chr = nextchr(cm); if (matchchr(cm, '<')) { *kind = matchchr(cm, '=') ? 'S' : 'A'; return Oshl; } *kind = 'C'; if (matchchr(cm, '=')) { return Ole; } return Olt; case '>': *chr = nextchr(cm); if (matchchr(cm, '>')) { int o = matchchr(cm, '>') ? Oshrl : Oshra; *kind = matchchr(cm, '=') ? 'S' : 'A'; return o; } *kind = 'C'; if (matchchr(cm, '=')) { return Oge; } return Ogt; case '=': *chr = nextchr(cm); if (matchchr(cm, '=')) { *kind = 'C'; return Oeq; } *kind = 'S'; return Oset; case '!': *chr = nextchr(cm); if (matchchr(cm, '=')) { *kind = 'C'; return One; } *kind = 0; return -1; } *kind = 0; return 0; } static void stashbinop(Comp *cm, int op, char kind, char chr) { cm->stash_binopop = op; cm->stash_binopk = kind; cm->stash_binopchr = chr; } static inline bool isimm(int *imm, Val v) { fixnum num = unbox_num(v); *imm = fixtoint(num); return isnum(v) && num == fixtrunc(num) && *imm >= -128 && *imm < 128; } // returns true if op is commutative or can be made to be, // (mutates op such that a b lt => b a gt, etc) static inline bool commutate(enum op *op) { switch (*op) { case Oadd: case Omul: case Oband: case Obior: case Obxor: case Oeq: case One: return 1; case Olt: *op = Ogt; return 1; case Ole: *op = Oge; return 1; case Ogt: *op = Olt; return 1; case Oge: *op = Ole; return 1; default: return 0; } } static bool discard(Comp *cm); static bool binexprimm(Comp *cm, enum op op, int8_t imm) { enum op iop = 0; if (op == Osub) { // X - k turns into X + -k, but if k == -128 we cannot encode 128 if (imm == -128) { goto Bail; } imm = -imm; goto Oadd; } else if (op == Odiv && imm == 0) { // the idiv fastpath assumes dividend is nonzero goto Bail; } else if (op == Omod && imm == 0) { // the imod fastpath assumes dividend is nonzero // always x % 0 = 0 cm->has_k = 0; TRY(discard(cm) && compop(cm, Ozero)); return 1; } else if (op == Omul) { // try turn mul by powers of 2 into shifts for (int exp = 0; exp < 8; ++exp) { if (imm == 1 << exp) { iop = Oishl; imm = exp; goto CompIop; } } } switch (op) { Oadd: case Oadd: iop = Oiadd; break; case Omul: iop = Oimul; break; case Odiv: iop = Oidiv; break; case Omod: iop = Oimod; break; case Oband: iop = Oiband; break; case Obior: iop = Oibior; break; case Obxor: iop = Oibxor; break; case Oshl: iop = Oishl; break; case Oshra: iop = Oishra; break; case Oshrl: iop = Oishrl; break; case Olt: iop = Oilt; break; case Ole: iop = Oile; break; case Ogt: iop = Oigt; break; case Oge: iop = Oige; break; case Oeq: iop = Oieq; break; case One: iop = Oine; break; default: break; } CompIop: assert(iop); cm->has_k = 0; TRY(compop(cm, iop) && compbyte(cm, imm)); return 1; Bail: TRY(compop(cm, op)); return 1; } static bool binexpr(Comp *cm, char okind, bool (*prev)(Comp *)) { uint save = cm->code.len, save2, save3; char kind, chr; enum op op, op2; TRY(prev(cm)); op = getbinop(&kind, &chr, cm), op2 = op; if (kind != okind) { stashbinop(cm, op, kind, chr); return 1; } do { Val lk = cm->k; bool has_lk = cm->has_k; int imm; enum op opx = op; TRY(flushconst(cm)); save2 = cm->code.len; TRY(prev(cm)); save3 = cm->code.len; cm->lvalue = 0; if (has_lk && cm->has_k) { // lhs and rhs constant? // only fold when types check if (op == Oeq || op == One || (isnum(lk) && isnum(cm->k))) { // constant fold: undo previous exprs and binop and save constant result cm->code.len = save; cm->has_k = 1; cm->k = uncheckedop(op, lk, cm->k); continue; } } else if (has_lk && isimm(&imm, lk) && commutate(&opx)) { // when lhs is a constant and the operation can be // commutative try use immediate op // eliminate code generated for lhs for (uint i = 0; i < save3 - save2; ++i) { memmove(cm->code.at + save + i, cm->code.at + save2 + i, save2 - save); } cm->code.len -= (save2 - save); cm->has_k = 1; cm->k = lk; goto TryImm; } else if (cm->has_k && isimm(&imm, cm->k)) { // try immediate variants of ops TryImm: TRY(binexprimm(cm, opx, imm)); continue; } TRY(compop(cm, op)); } while (okind != 'C' && (op2 = getbinop(&kind, &chr, cm)) == op); if (op2 != op && kind != 0) { stashbinop(cm, op2, kind, chr); } return 1; } static bool arithexpr(Comp *cm) { return binexpr(cm, 'A', prefixexpr); } static bool cmpexpr(Comp *cm) { return binexpr(cm, 'C', arithexpr); } static bool logicexpr(Comp *cm) { uint *ip = &cm->code.len, save; char kind, chr; int op, op2; TRY(cmpexpr(cm)); op = getbinop(&kind, &chr, cm), op2 = op; if (kind != 'L') { stashbinop(cm, op, kind, chr); return 1; } do { int br_arg, br_jumpfrom, diff; int16_t off; if (cm->has_k) { if (op == Ologand ? truthy(cm->k) : !truthy(cm->k)) { // discard lhs cm->has_k = 0; TRY(cmpexpr(cm)); } else { // discard rhs Val k = cm->k; save = *ip; TRY(cmpexpr(cm)); *ip = save; cm->has_k = 1; cm->k = k; } continue; } TRY(compop(cm, Odup)); TRY(compop(cm, op == Ologand ? Obf : Obt)); br_arg = *ip; TRY(compbytes(cm, "X", 2)); br_jumpfrom = *ip; TRY(compop(cm, Opop)); TRY(cmpexpr(cm)); TRY(flushconst(cm)); off = diff = *ip - br_jumpfrom; assert(off == diff); memcpy(cm->code.at + br_arg, &off, 2); resetlastops(cm); } while ((op2 = getbinop(&kind, &chr, cm)) == op); if (op2 != op && kind != 0) { stashbinop(cm, op2, kind, chr); } return 1; } static bool condexpr(Comp *cm) { TRY(logicexpr(cm)); if (matchspchr(cm, '?')) { uint *ip = &cm->code.len, save; if (cm->has_k && truthy(cm->k)) { bool has_k; Val k; TRY(condexpr(cm)); has_k = cm->has_k; k = cm->k; cm->has_k = 0; TRY(expectspchr(cm, ':')); save = *ip; TRY(condexpr(cm)); *ip = save; cm->has_k = has_k; cm->k = k; } else if (cm->has_k && !truthy(cm->k)) { save = *ip; TRY(condexpr(cm)); *ip = save; cm->has_k = 0; TRY(expectspchr(cm, ':')); TRY(condexpr(cm)); } else { int bf_arg, bf_jumpfrom, b_arg, b_jumpfrom, diff; int16_t off; /* * bf F * * b OK * F: * OK: ... */ TRY(compop(cm, Obf)); bf_arg = *ip; TRY(compbytes(cm, "X", 2)); bf_jumpfrom = *ip; TRY(condexpr(cm) && flushconst(cm)); TRY(compop(cm, Ob)); b_arg = *ip; TRY(compbytes(cm, "X", 2)); b_jumpfrom = *ip; TRY(expectspchr(cm, ':')); off = diff = *ip - bf_jumpfrom; assert(off == diff); memcpy(&cm->code.at[bf_arg], &off, 2); TRY(condexpr(cm) && flushconst(cm)); off = diff = *ip - b_jumpfrom; assert(off == diff); memcpy(&cm->code.at[b_arg], &off, 2); resetlastops(cm); } cm->lvalue = 0; } return 1; } static bool setexpr(Comp *cm) { char kind, chr; int binop; TRY(condexpr(cm)); if ((binop = getbinop(&kind, &chr, cm)) && kind == 'S') { int idx = -1, argc = -1, opcode; vec_of(uint8_t) *code = (void *)&cm->code.at; if (!cm->lvalue) { comperr(cm, chr, "not an lvalue"); return 0; } if (cm->lvalue_const) { assert(cm->lvalue_name); comperr(cm, chr, "local '%s' is not mutable", cm->lvalue_name); return 0; } /* * with Oset, * ... * local #x * is turned into * ... * * (dup) * setloc #x * * with compound operators, such as Oadd, * ... * local #x * is turned into * ... * local #x * * add * (dup) * setloc #x * and so on */ assert(cm->lastop >= 0 && cm->lastop < code->len); switch ((opcode = code->at[cm->lastop])) { case Olocal: case Oarg: case Oupval: idx = code->at[cm->lastop + 1]; if (binop == Oset) { code->len -= 2; } break; case Oglobal: --code->len; if (binop != Oset) { TRY(compop(cm, Odup)); TRY(compop(cm, Oglobal)); } break; case Oapply: argc = code->at[cm->lastop + 1]; code->len -= 2; Oapply: if (binop != Oset) { TRY(compop(cm, Odupn)); TRY(compbyte(cm, argc)); TRY(compop(cm, Oapply)); TRY(compbyte(cm, argc)); } break; case Olength: --code->len; TRY(compconst(cm, length_sstr)); argc = 1; opcode = Oapply; goto Oapply; default: assert(0 && "bad lvalue?"); } TRY(condexpr(cm)); if (binop != Oset) { int imm; if (cm->has_k && isimm(&imm, cm->k)) { TRY(binexprimm(cm, binop, imm)); } else { TRY(compop(cm, binop)); } } if (opcode == Oglobal) { TRY(compop(cm, Odupbck)); } else if (opcode != Oapply) { TRY(compop(cm, Odup)); } switch (opcode) { case Olocal: case Oarg: case Oupval: TRY(compop(cm, opcode == Olocal ? Osetloc : opcode == Oarg ? Osetarg : Osetupv)); TRY(compbyte(cm, idx)); break; case Oglobal: TRY(compop(cm, Osetglo)); break; case Oapply: TRY(compop(cm, Osetapp)); TRY(compbyte(cm, argc)); break; } } else if (binop) { stashbinop(cm, binop, kind, chr); } return 1; } static bool expr(Comp *cm) { cm->lvalue = 0; TRY(setexpr(cm)); if (cm->stash_binopop) { comperr(cm, cm->stash_binopchr, "unexpected operator"); return 0; } return 1; } static bool stmt(Comp *cm); static bool discard(Comp *cm) { /* * Optimization to remove sequences like { void; pop } * and turn things like { dup; setloc #n; pop } into { setloc #n } */ uint8_t *code = cm->code.at; if (cm->lastop != -1 && cm->code.at[cm->lastop] == Ovoid) { --cm->code.len; resetlastops(cm); return 1; } else if (cm->lastop != -1 && cm->lastop2 != -1 && (code[cm->lastop2] == Odup || code[cm->lastop2] == Odupbck)) { switch (code[cm->lastop]) { case Osetloc: case Osetarg: memmove(code + cm->lastop2, code + cm->lastop, 2); --cm->code.len; resetlastops(cm); return 1; case Osetglo: case Oputglo: memmove(code + cm->lastop2, code + cm->lastop, 1); --cm->code.len; resetlastops(cm); return 1; } } return compop(cm, Opop); } // @local declarations static bool decl(Comp *cm, Local **pl, bool nofold) { int c; char name[NAMEMAX]; bool mutable; uint idx = -1u; Local *l; eatspaces(cm); if ((c = peekchr(cm)) != '_' && !aisalpha(c)) { comperr(cm, c, "expected identifier"); return 0; } TRY(readident(cm, name, sizeof name)); eatspaces(cm); switch ((c = nextchr(cm))) { case ':': // constant mutable = 0; break; case '=': // variable mutable = 1; break; default: comperr(cm, c, "expected ':' or '='"); return 0; } if (matchspchr(cm, '{')) { // named fn, possibly recursive TRY(l = addlocal(cm, &idx, name, mutable, cm->has_k && !mutable, cm->k)); TRY(lambdaexpr(cm, name)); } else { TRY(expr(cm)); // initializer if (cm->has_k && nofold) { TRY(flushconst(cm)); } TRY(l = addlocal(cm, &idx, name, mutable, cm->has_k && !mutable, cm->k)); } if (pl) { *pl = l; } if (!cm->has_k || mutable) { if (idx > 255) { comperr(cm, c, "too many locals"); return 0; } TRY(compop(cm, Odup)); TRY(compop(cm, Osetloc) && compbyte(cm, idx)); } return 1; } static bool forstmt(Comp *cm) { int b_jumpto, bf_jumpfrom, bf_arg, diff; uint *ip = &cm->code.len; int16_t off; TRY(expectspchr(cm, '[')); if (!matchchr(cm, '@')) { // FOR [cond] body /* * L0: * bf L1 * * b L0 * L1: ... */ b_jumpto = *ip; TRY(expr(cm)); TRY(expectspchr(cm, ']')); TRY(compop(cm, Obf)); bf_arg = *ip; TRY(compbytes(cm, "X", 2)); bf_jumpfrom = *ip; TRY(stmt(cm) && discard(cm)); TRY(compop(cm, Ob)); off = diff = b_jumpto - (*ip + 2); assert(off == diff); TRY(compbytes(cm, &off, 2)); off = diff = *ip - bf_jumpfrom; assert(off == diff); memcpy(cm->code.at + bf_arg, &off, 2); } else { // FOR [@x: ini][cond][cont] body /* * * setloc #x * L0: * bf L1 * * * setloc #x * b L0 * L1: ... * * we copy the generated code to a temp buffer * to move it to be after */ Local *local; uint8_t tmp[256]; int ilocal, cont, ncont; // ini beginscope(cm); TRY(decl(cm, &local, /* nofold */ 1) && discard(cm)); assert(local); ilocal = local - cm->fenv.locals.at; TRY(expectspchr(cm, ']')); // cond TRY(expectspchr(cm, '[')); b_jumpto = *ip; if (matchspchr(cm, ']')) { comperr(cm, ']', "expected operator"); return 0; } cm->stash_local = &cm->fenv.locals.at[ilocal]; TRY(expr(cm)); TRY(expectspchr(cm, ']')); TRY(compop(cm, Obf)); bf_arg = *ip; TRY(compbytes(cm, "X", 2)); bf_jumpfrom = *ip; // cont TRY(expectspchr(cm, '[')); cont = *ip; if (matchspchr(cm, ']')) { comperr(cm, ']', "expected operator"); return 0; } cm->stash_local = &cm->fenv.locals.at[ilocal]; TRY(expr(cm)); TRY(expectspchr(cm, ']')); assert(!cm->has_k); ncont = *ip - cont; assert(ncont > 0 && "?"); assert(ncont < 256 && "cont too big"); memcpy(tmp, cm->code.at + cont, ncont); *ip -= ncont; resetlastops(cm); // body TRY(stmt(cm) && discard(cm)); // cont (2) TRY(vecpush(cm->cx, &cm->code, tmp, ncont)); resetlastops(cm); local = &cm->fenv.locals.at[ilocal]; TRY(compop(cm, local->isparam ? Osetarg : Osetloc)); assert(local->index < 256); TRY(compbyte(cm, local->index)); TRY(compop(cm, Ob)); off = diff = b_jumpto - (*ip + 2); assert(off == diff); TRY(compbytes(cm, &off, 2)); off = diff = *ip - bf_jumpfrom; assert(off == diff); memcpy(cm->code.at + bf_arg, &off, 2); endscope(cm); } resetlastops(cm); return compop(cm, Ovoid); } static bool stmt(Comp *cm) { int c; if (matchspchr(cm, '@')) { // local declaration TRY(decl(cm, NULL, /* nofold */ 0)); } else if (matchspchr(cm, '~')) { // global define char name[NAMEMAX]; Val key; eatspaces(cm); if ((c = peekchr(cm)) != '_' && !aisalpha(c)) { comperr(cm, c, "expected identifier"); return 0; } TRY(readident(cm, name, sizeof name)); TRY(expectspchr(cm, '=')); TRY(box_str(cm->cx, &key, name, strlen(name))); TRY(compconst(cm, key)); TRY(expr(cm)); // initializer TRY(compop(cm, Odupbck)); TRY(compop(cm, Oputglo)); } else if ((c = peekchr(cm)) == 'F' || c == 'R' || c == 'B') { char buf[NAMEMAX]; TRY(readident(cm, buf, sizeof buf)); if (!strcmp(buf, "FOR")) { return forstmt(cm); } else { strcpy(cm->stash_ident, buf); return expr(cm); } } else { return expr(cm); } return 1; } static bool block(Comp *cm, int endchr) { bool first = 1, eof = 0; beginscope(cm); eatspaces(cm); while (peekchr(cm) != endchr && !(eof = peekchr(cm) == EOF)) { if (!first) { if (cm->has_k) { // just don't emit anything in this case cm->has_k = 0; } else { // discard previous statement value TRY(discard(cm)); } } first = 0; TRY(stmt(cm)); cm->lvalue = 0; eatspaces(cm); } if (first) { TRY(compop(cm, Ovoid)); } if (eof) { comperr(cm, EOF, "unexpected end of input"); return 0; } nextchr(cm); endscope(cm); return 1; } /**************/ /* Public API */ /**************/ bool pez_eval_cb(PezContext *cx, const char *fname, int (*cb)(void *), void *ud) { Val *stktop = cx->stktop; Proto *pr; Fn *fn; Comp cm; int gccanrun = cx->gccanrun; cx->gccanrun = 0; if (!(pr = newproto(cx, fname, "", /* line */ 1))) { return 0; } if (!(fn = newfn(cx, pr, NULL, NULL, NULL))) { delproto(cx, pr); return 0; } initcomp(&cm, cx, pr, cb, ud); ETRY(block(&cm, EOF)); ETRY(compop(&cm, Oret)); ETRY(fincompfn(&cm)); if (cx->dbg & DBGbytecode) { inspectproto(pr); } ETRY(push(cx, box_obj(fn))); // gc keep cx->gccanrun = 1; ETRY(exefn(cx, fn, 0)); cx->stktop[-2] = cx->stktop[-1]; --cx->stktop; // gc unkeep if (cx->dbg & DBGstressgc) { gc(cx); } deinitcomp(&cm); cx->gccanrun = gccanrun; return 1; Err: cx->stktop = stktop; deinitcomp(&cm); delfenv(cx, &cm.fenv); cx->gccanrun = gccanrun; return 0; } static int str_read_cb(void *ud) { char **s = ud; char c = **s; if (c == 0) { return EOF; } ++*s; return c; } bool pez_eval_str(PezContext *cx, const char *fname, const char *str) { assert(str); return pez_eval_cb(cx, fname, str_read_cb, &str); } bool pez_eval_file(PezContext *cx, const char *fname, FILE *fp) { assert(fp); return pez_eval_cb(cx, fname, (int(*)(void *))fgetc, fp); } static void * mallocator(void *_ud, void *ptr, size_t _oldsize, size_t newsize) { if (ptr && newsize == 0) { free(ptr); } else if (ptr && newsize > 0) { return realloc(ptr, newsize); } else if (!ptr && newsize > 0) { return malloc(newsize); } return NULL; } // #define STACK_SIZE 4096 PezContext * pez_new(PezAllocFn *alloc, void *userdata, size_t stacksize) { PezContext *cx; stacksize /= sizeof(Val); alloc = alloc ? alloc : mallocator; cx = alloc(userdata, NULL, 0, sizeof *cx); if (!cx) goto Err; memset(cx, 0, sizeof *cx); cx->alloc = alloc; cx->ud = userdata; cx->stack = cxalloc(cx, stacksize * sizeof(Val)); if (!cx->stack) goto Err; cx->stktop = cx->stack; cx->stkend = cx->stack + stacksize; if (!box_str(cx, &length_sstr, "length", 6)) assert(0); if (!initcore(cx)) goto Err; cx->gcthresh = stacksize * sizeof(Val)*5/2 + 128; return cx; Err: cx->err = PEZ_ENoMem; if (cx && cx->stack) { cxfree(cx, cx->stack, sizeof(Val) * stacksize); } if (cx) { cxfree(cx, cx, sizeof *cx); } return NULL; } void pez_del(PezContext *cx) { assert(cx); for (Obj *o = cx->heap, *next; o; o = next) { next = o->next; delobj(cx, o); } cxfree(cx, cx->stack, (cx->stkend - cx->stack) * sizeof(Val)); if (cx->strpool.dat) { cxfree(cx, cx->strpool.dat, cx->strpool.N * sizeof(Str *)); } if (cx->globals.dat) { cxfree(cx, cx->globals.dat, cx->globals.N * sizeof(struct KV)); } if (cx->nalloc != 0) { fprintf(stderr, "ERR nalloc %d\n", cx->nalloc); assert(cx->nalloc == 0); } cx->alloc(cx->ud, cx, sizeof *cx, 0); } void pez_debug(PezContext *cx, const char *opts) { if (!opts) { cx->dbg = 0; return; } if (strchr(opts, 'b')) cx->dbg |= DBGbytecode; if (strchr(opts, 'G')) cx->dbg |= DBGstressgc; if (strchr(opts, 'g')) cx->dbg |= DBGgcinfo; } int pez_geterrno(PezContext *cx) { return cx->err; } const char * pez_geterr(PezContext *cx) { switch (cx->err) { case PEZ_EStack: return "stack overflow"; case PEZ_ENoMem: return "out of memory"; case PEZ_ESyntax: return cx->errstr; case PEZ_ERuntime: return cx->errstr; } return NULL; } int pez_top(PezContext *cx) { assert(cx); return cx->stktop - cx->stack; } void pez_pop(PezContext *cx) { pop(cx); } static inline Val * iget(PezContext *cx, int idx) { if (idx < 0) { idx += pez_top(cx); } assert(idx >= 0 && idx < pez_top(cx)); return &cx->stack[idx]; } bool pez_push(PezContext *cx, int idx) { Val v = *iget(cx, idx); return push(cx, v); } bool pez_pushvoid(PezContext *cx) { return push(cx, VOID); } bool pez_pushnumber(PezContext *cx, PezNumber n) { return push(cx, box_num(n)); } bool pez_pushint(PezContext *cx, int idx) { return push(cx, box_num(inttofix(idx))); } bool pez_pushstring(PezContext *cx, const char *str, int len) { Val s; TRY(box_str(cx, &s, str, len == -1 ? strlen(str) : len)); return push(cx, s); } bool pez_pushglobal(PezContext *cx, const char *name) { Val k, *g; TRY(box_str(cx, &k, name, strlen(name))); TRY(g = getglobal(cx, k)); return push(cx, *g); } bool pez_isvoid(PezContext *cx, int idx) { return isvoid(*iget(cx, idx)); } bool pez_isnumber(PezContext *cx, int idx) { return isnum(*iget(cx, idx)); } bool pez_isbool(PezContext *cx, int idx) { return isbool(*iget(cx, idx)); } static bool isobj_of1(PezContext *cx, int idx, int type) { Val v = *iget(cx, idx); return isobj_of(v, type); } bool pez_isstring(PezContext *cx, int idx) { return isobj_of1(cx, idx, PEZ_TString) || issstr(*iget(cx, idx)); } bool pez_isfunction(PezContext *cx, int idx) { return isobj_of1(cx, idx, PEZ_TFn) || iscfn(*iget(cx, idx)); } bool pez_isarray(PezContext *cx, int idx) { return isobj_of1(cx, idx, PEZ_TArray); } const char * pez_typename(PezContext *cx, int idx) { return typestr(*iget(cx, idx)); } bool pez_getnumber(PezContext *cx, PezNumber *out, int idx) { Val v = *iget(cx, idx); *out = unbox_num(v); return isnum(v); } bool pez_getbool(PezContext *cx, bool *out, int idx) { Val v = *iget(cx, idx); *out = unbox_bool(v); return isbool(v); } const char * pez_getstring(PezContext *cx, char buf[8], int idx) { Val v = *iget(cx, idx); if (issstr(v)) { unbox_sstr(v, buf); return buf; } if (isobj_of(v, PEZ_TString)) { Str *s = unbox_obj(v); return s->dat; } return NULL; } const char * pez_fnname(PezContext *cx, int idx) { Val v = *iget(cx, idx); if (isobj_of(v, PEZ_TFn)) { Fn *fn = unbox_obj(v); if (fn->proto->named) { return fn->proto->name; } } return NULL; } int pez_length(PezContext *cx, int idx) { Val v = *iget(cx, idx); if (isobj_of(v, PEZ_TArray)) { return ((Array *)unbox_obj(v))->len; } if (issstr(v)) { return sstr_len(v); } if (isobj_of(v, PEZ_TString)) { return ((Str *)unbox_obj(v))->n; } return -1; } void pez_error(PezContext *cx, const char *fn, const char *fmt, ...) { va_list ap; va_start(ap, fmt); vrunerr(cx, (void *)fn, -1, fmt, ap); va_end(ap); } bool pez_apply(PezContext *cx, int argc) { Val a = *iget(cx, -argc - 1), ret; assert(pez_top(cx) >= argc + 1); TRY(apply(cx, &ret, NULL, -1, a, argc)); cx->stktop -= argc + 1; return push(cx, ret); } bool pez_setapply(PezContext *cx, int argc) { Val a = *iget(cx, -argc - 2), rval = pop(cx), ret; assert(pez_top(cx) >= argc + 2); TRY(setapply(cx, &ret, NULL, -1, a, argc, rval)); cx->stktop -= argc + 1; return push(cx, ret); } bool pez_iget(PezContext *cx, int idx, int arg) { TRY(pez_push(cx, idx)); TRY(pez_pushint(cx, arg)); return pez_apply(cx, 1); }