ref: 0b985dfc7f234dd1b61b817e510ddaeac38e0de7
dir: /flisp.c/
/* femtoLisp by Jeff Bezanson (C) 2009 Distributed under the BSD License */ #include "llt.h" #include "flisp.h" #include "operators.h" #include "cvalues.h" #include "opcodes.h" #include "types.h" #include "print.h" #include "read.h" #include "timefuncs.h" #include "equal.h" #include "hashing.h" #include "table.h" #include "iostream.h" #include "fsixel.h" typedef struct { char *name; builtin_t fptr; }builtinspec_t; Fl fl; int isbuiltin(value_t x) { uint32_t i = uintval(x); return tag(x) == TAG_FUNCTION && i < nelem(builtins) && builtins[i].name != nil; } static value_t apply_cl(uint32_t nargs); // error utilities ------------------------------------------------------------ void free_readstate(fl_readstate_t *rs) { htable_free(&rs->backrefs); htable_free(&rs->gensyms); } _Noreturn void fl_exit(int status) { FL(exiting) = true; gc(0); exit(status); } #define FL_TRY \ fl_exception_context_t _ctx; int l__tr, l__ca; \ _ctx.sp = FL(sp); _ctx.frame = FL(curr_frame); _ctx.rdst = FL(readstate); _ctx.prev = FL(exctx); \ _ctx.ngchnd = FL(ngchandles); FL(exctx) = &_ctx; \ if(!setjmp(_ctx.buf)) \ for(l__tr = 1; l__tr; l__tr = 0, (void)(FL(exctx) = FL(exctx)->prev)) #define FL_CATCH_INC \ l__ca = 0, FL(lasterror) = FL(Nil), FL(throwing_frame) = 0, FL(sp) = _ctx.sp, FL(curr_frame) = _ctx.frame #define FL_CATCH \ else \ for(l__ca = 1; l__ca; FL_CATCH_INC) #define FL_CATCH_NO_INC \ else \ for(l__ca = 1; l__ca;) void fl_savestate(fl_exception_context_t *_ctx) { _ctx->sp = FL(sp); _ctx->frame = FL(curr_frame); _ctx->rdst = FL(readstate); _ctx->prev = FL(exctx); _ctx->ngchnd = FL(ngchandles); } void fl_restorestate(fl_exception_context_t *_ctx) { FL(lasterror) = FL(Nil); FL(throwing_frame) = 0; FL(sp) = _ctx->sp; FL(curr_frame) = _ctx->frame; } _Noreturn void fl_raise(value_t e) { FL(lasterror) = e; // unwind read state while(FL(readstate) != FL(exctx)->rdst){ free_readstate(FL(readstate)); FL(readstate) = FL(readstate)->prev; } if(FL(throwing_frame) == 0) FL(throwing_frame) = FL(curr_frame); FL(ngchandles) = FL(exctx)->ngchnd; fl_exception_context_t *thisctx = FL(exctx); if(FL(exctx)->prev) // don't throw past toplevel FL(exctx) = FL(exctx)->prev; longjmp(thisctx->buf, 1); } _Noreturn void lerrorf(value_t e, const char *format, ...) { char msgbuf[256]; va_list args; PUSH(e); va_start(args, format); vsnprintf(msgbuf, sizeof(msgbuf), format, args); value_t msg = string_from_cstr(msgbuf); va_end(args); e = POP(); fl_raise(fl_list2(e, msg)); } _Noreturn void type_error(const char *expected, value_t got) { fl_raise(fl_listn(3, FL(TypeError), symbol(expected), got)); } _Noreturn void bounds_error(value_t arr, value_t ind) { fl_raise(fl_listn(3, FL(BoundsError), arr, ind)); } _Noreturn void unbound_error(value_t sym) { fl_raise(fl_listn(2, FL(UnboundError), sym)); } // safe cast operators -------------------------------------------------------- #define isstring fl_isstring #define SAFECAST_OP(type, ctype, cnvt) \ ctype to##type(value_t v) \ { \ if(__likely(is##type(v))) \ return (ctype)cnvt(v); \ type_error(#type, v); \ } SAFECAST_OP(cons, cons_t*, ptr) SAFECAST_OP(symbol, symbol_t*, ptr) SAFECAST_OP(fixnum, fixnum_t, numval) //SAFECAST_OP(cvalue, cvalue_t*, ptr) SAFECAST_OP(string, char*, cvalue_data) #undef isstring // symbol table --------------------------------------------------------------- int fl_is_keyword_name(const char *str, size_t len) { return (str[0] == ':' || str[len-1] == ':') && str[1] != '\0'; } static symbol_t * mk_symbol(const char *str) { symbol_t *sym; size_t len = strlen(str); sym = calloc(1, sizeof(*sym)-sizeof(void*) + len + 1); assert(((uintptr_t)sym & 0x7) == 0); // make sure malloc aligns 8 sym->numtype = NONNUMERIC; if(fl_is_keyword_name(str, len)){ value_t s = tagptr(sym, TAG_SYM); setc(s, s); sym->flags |= FLAG_KEYWORD; }else{ sym->binding = UNBOUND; } sym->hash = memhash32(str, len)^0xAAAAAAAA; memcpy(sym->name, str, len+1); return sym; } static symbol_t ** symtab_lookup(symbol_t **ptree, const char *str) { int x; while(*ptree != nil && (x = strcmp(str, (*ptree)->name)) != 0) ptree = x < 0 ? &(*ptree)->left : &(*ptree)->right; return ptree; } value_t symbol(const char *str) { symbol_t **pnode; pnode = symtab_lookup(&FL(symtab), str); if(*pnode == nil) *pnode = mk_symbol(str); return tagptr(*pnode, TAG_SYM); } BUILTIN("gensym", gensym) { argcount(nargs, 0); USED(args); gensym_t *gs = alloc_words(sizeof(gensym_t)/sizeof(void*)); gs->id = FL(gensym_ctr)++; gs->binding = UNBOUND; gs->isconst = 0; gs->type = nil; return tagptr(gs, TAG_SYM); } value_t gensym(void) { return fn_builtin_gensym(nil, 0); } BUILTIN("gensym?", gensymp) { argcount(nargs, 1); return isgensym(args[0]) ? FL(t) : FL(f); } char * uint2str(char *dest, size_t len, uint64_t num, uint32_t base) { int i = len-1; uint64_t b = (uint64_t)base; char ch; dest[i--] = '\0'; while(i >= 0){ ch = (char)(num % b); if(ch < 10) ch += '0'; else ch = ch-10+'a'; dest[i--] = ch; num /= b; if(num == 0) break; } return &dest[i+1]; } const char * symbol_name(value_t v) { if(ismanaged(v)){ gensym_t *gs = (gensym_t*)ptr(v); FL(gsnameno) = 1-FL(gsnameno); char *n = uint2str(FL(gsname)[FL(gsnameno)]+1, sizeof(FL(gsname)[0])-1, gs->id, 10); *(--n) = 'g'; return n; } return ((symbol_t*)ptr(v))->name; } // conses --------------------------------------------------------------------- value_t mk_cons(void) { cons_t *c; if(__unlikely(FL(curheap) > FL(lim))) gc(0); c = (cons_t*)FL(curheap); FL(curheap) += sizeof(cons_t); return tagptr(c, TAG_CONS); } void * alloc_words(uint32_t n) { value_t *first; assert(n > 0); n = LLT_ALIGN(n, 2); // only allocate multiples of 2 words if(__unlikely((value_t*)FL(curheap) > (value_t*)FL(lim)+2-n)){ gc(0); while((value_t*)FL(curheap) > ((value_t*)FL(lim))+2-n) gc(1); } first = (value_t*)FL(curheap); FL(curheap) += (n*sizeof(value_t)); return first; } value_t alloc_vector(size_t n, int init) { if(n == 0) return FL(the_empty_vector); value_t *c = alloc_words(n+1); value_t v = tagptr(c, TAG_VECTOR); vector_setsize(v, n); if(init){ unsigned int i; for(i = 0; i < n; i++) vector_elt(v, i) = FL(unspecified); } return v; } // collector ------------------------------------------------------------------ void fl_gc_handle(value_t *pv) { if(__unlikely(FL(ngchandles) >= N_GC_HANDLES)) lerrorf(FL(MemoryError), "out of gc handles"); FL(gchandles)[FL(ngchandles)++] = pv; } void fl_free_gc_handles(uint32_t n) { assert(FL(ngchandles) >= n); FL(ngchandles) -= n; } value_t relocate(value_t v) { value_t a, d, nc, first, *pcdr; uintptr_t t = tag(v); if(t == TAG_CONS){ // iterative implementation allows arbitrarily long cons chains pcdr = &first; do{ if((a = car_(v)) == TAG_FWD){ *pcdr = cdr_(v); return first; } *pcdr = nc = tagptr((cons_t*)FL(curheap), TAG_CONS); FL(curheap) += sizeof(cons_t); d = cdr_(v); car_(v) = TAG_FWD; cdr_(v) = nc; car_(nc) = relocate(a); pcdr = &cdr_(nc); v = d; }while(iscons(v)); *pcdr = d == FL(Nil) ? FL(Nil) : relocate(d); return first; } if((t&3) == 0) return v; if(!ismanaged(v)) return v; if(isforwarded(v)) return forwardloc(v); if(t == TAG_VECTOR){ // N.B.: 0-length vectors secretly have space for a first element size_t i, sz = vector_size(v); if(vector_elt(v, -1) & 0x1){ // grown vector nc = relocate(vector_elt(v, 0)); forward(v, nc); }else{ nc = tagptr(alloc_words(sz+1), TAG_VECTOR); vector_setsize(nc, sz); a = vector_elt(v, 0); forward(v, nc); if(sz > 0){ vector_elt(nc, 0) = relocate(a); for(i = 1; i < sz; i++) vector_elt(nc, i) = relocate(vector_elt(v, i)); } } return nc; } if(t == TAG_CPRIM){ cprim_t *pcp = ptr(v); size_t nw = CPRIM_NWORDS-1+NWORDS(cp_class(pcp)->size); cprim_t *ncp = alloc_words(nw); while(nw--) ((value_t*)ncp)[nw] = ((value_t*)pcp)[nw]; nc = tagptr(ncp, TAG_CPRIM); forward(v, nc); return nc; } if(t == TAG_CVALUE) return cvalue_relocate(v); if(t == TAG_FUNCTION){ function_t *fn = ptr(v); function_t *nfn = alloc_words(4); nfn->bcode = fn->bcode; nfn->vals = fn->vals; nc = tagptr(nfn, TAG_FUNCTION); forward(v, nc); nfn->env = relocate(fn->env); nfn->vals = relocate(nfn->vals); nfn->bcode = relocate(nfn->bcode); assert(!ismanaged(fn->name)); nfn->name = fn->name; return nc; } if(t == TAG_SYM){ gensym_t *gs = ptr(v); gensym_t *ng = alloc_words(sizeof(gensym_t)/sizeof(void*)); ng->id = gs->id; ng->binding = gs->binding; ng->isconst = 0; nc = tagptr(ng, TAG_SYM); forward(v, nc); if(ng->binding != UNBOUND) ng->binding = relocate(ng->binding); return nc; } return v; } value_t relocate_lispvalue(value_t v) { return relocate(v); } static void trace_globals(symbol_t *root) { while(root != nil){ if(root->binding != UNBOUND) root->binding = relocate(root->binding); trace_globals(root->left); root = root->right; } } void gc(int mustgrow) { void *temp; uint32_t i, f, top; fl_readstate_t *rs; FL(gccalls)++; FL(curheap) = FL(tospace); if(FL(grew)) FL(lim) = FL(curheap)+FL(heapsize)*2-sizeof(cons_t); else FL(lim) = FL(curheap)+FL(heapsize)-sizeof(cons_t); if(FL(throwing_frame) > FL(curr_frame)){ top = FL(throwing_frame) - 4; f = FL(stack)[FL(throwing_frame)-4]; }else{ top = FL(sp); f = FL(curr_frame); } while(1){ for(i = f; i < top; i++) FL(stack)[i] = relocate(FL(stack)[i]); if(f == 0) break; top = f - 4; f = FL(stack)[f-4]; } for(i = 0; i < FL(ngchandles); i++) *FL(gchandles)[i] = relocate(*FL(gchandles)[i]); trace_globals(FL(symtab)); relocate_typetable(); rs = FL(readstate); while(rs){ value_t ent; for(i = 0; i < rs->backrefs.size; i++){ ent = (value_t)rs->backrefs.table[i]; if(ent != (value_t)HT_NOTFOUND) rs->backrefs.table[i] = (void*)relocate(ent); } for(i = 0; i < rs->gensyms.size; i++){ ent = (value_t)rs->gensyms.table[i]; if(ent != (value_t)HT_NOTFOUND) rs->gensyms.table[i] = (void*)relocate(ent); } rs->source = relocate(rs->source); rs = rs->prev; } FL(lasterror) = relocate(FL(lasterror)); FL(memory_exception_value) = relocate(FL(memory_exception_value)); FL(the_empty_vector) = relocate(FL(the_empty_vector)); sweep_finalizers(); #ifdef VERBOSEGC printf("GC: found %d/%d live conses\n", (FL(curheap)-FL(tospace))/sizeof(cons_t), FL(heapsize)/sizeof(cons_t)); #endif temp = FL(tospace); FL(tospace) = FL(fromspace); FL(fromspace) = temp; // if we're using > 80% of the space, resize tospace so we have // more space to fill next time. if we grew tospace last time, // grow the other half of the heap this time to catch up. if(FL(grew) || ((FL(lim)-FL(curheap)) < (int)(FL(heapsize)/5)) || mustgrow){ temp = LLT_REALLOC(FL(tospace), FL(heapsize)*2); if(__unlikely(temp == nil)) fl_raise(FL(memory_exception_value)); FL(tospace) = temp; if(FL(grew)){ FL(heapsize) *= 2; temp = bitvector_resize(FL(consflags), 0, FL(heapsize)/sizeof(cons_t), 1); if(__unlikely(temp == nil)) fl_raise(FL(memory_exception_value)); FL(consflags) = (uint32_t*)temp; } FL(grew) = !FL(grew); } if(__unlikely((value_t*)FL(curheap) > (value_t*)FL(lim)-2)){ // all data was live; gc again and grow heap. // but also always leave at least 4 words available, so a closure // can be allocated without an extra check. gc(0); } } static void grow_stack(void) { size_t newsz = FL(nstack) * 2; value_t *ns = LLT_REALLOC(FL(stack), newsz*sizeof(value_t)); if(__unlikely(ns == nil)) lerrorf(FL(MemoryError), "stack overflow"); FL(stack) = ns; FL(nstack) = newsz; } // utils ---------------------------------------------------------------------- // apply function with n args on the stack static value_t _applyn(uint32_t n) { value_t f = FL(stack)[FL(sp)-n-1]; uint32_t saveSP = FL(sp); value_t v; if(iscbuiltin(f)){ v = ((builtin_t*)ptr(f))[3](&FL(stack)[FL(sp)-n], n); }else if(isfunction(f)){ v = apply_cl(n); }else if(__likely(isbuiltin(f))){ value_t tab = symbol_value(FL(builtins_table_sym)); if(__unlikely(ptr(tab) == nil)) unbound_error(tab); FL(stack)[FL(sp)-n-1] = vector_elt(tab, uintval(f)); v = apply_cl(n); }else{ type_error("function", f); } FL(sp) = saveSP; return v; } value_t fl_apply(value_t f, value_t l) { value_t v = l; uint32_t n = FL(sp); PUSH(f); while(iscons(v)){ if(FL(sp) >= FL(nstack)) grow_stack(); PUSH(car_(v)); v = cdr_(v); } n = FL(sp) - n - 1; v = _applyn(n); POPN(n+1); return v; } value_t fl_applyn(uint32_t n, value_t f, ...) { va_list ap; va_start(ap, f); size_t i; PUSH(f); while(FL(sp)+n >= FL(nstack)) grow_stack(); for(i = 0; i < n; i++){ value_t a = va_arg(ap, value_t); PUSH(a); } value_t v = _applyn(n); POPN(n+1); va_end(ap); return v; } value_t fl_listn(size_t n, ...) { va_list ap; va_start(ap, n); uint32_t si = FL(sp); size_t i; while(FL(sp)+n >= FL(nstack)) grow_stack(); for(i = 0; i < n; i++){ value_t a = va_arg(ap, value_t); PUSH(a); } cons_t *c = alloc_words(n*2); cons_t *l = c; for(i = 0; i < n; i++){ c->car = FL(stack)[si++]; c->cdr = tagptr(c+1, TAG_CONS); c++; } c[-1].cdr = FL(Nil); POPN(n); va_end(ap); return tagptr(l, TAG_CONS); } value_t fl_list2(value_t a, value_t b) { PUSH(a); PUSH(b); cons_t *c = alloc_words(4); b = POP(); a = POP(); c[0].car = a; c[0].cdr = tagptr(c+1, TAG_CONS); c[1].car = b; c[1].cdr = FL(Nil); return tagptr(c, TAG_CONS); } value_t fl_cons(value_t a, value_t b) { PUSH(a); PUSH(b); value_t c = mk_cons(); cdr_(c) = POP(); car_(c) = POP(); return c; } int fl_isnumber(value_t v) { if(isfixnum(v)) return 1; if(iscprim(v)){ cprim_t *c = ptr(v); return c->type != FL(runetype); } if(iscvalue(v)){ cvalue_t *c = ptr(v); return valid_numtype(cv_class(c)->numtype); } return 0; } // eval ----------------------------------------------------------------------- static value_t list(value_t *args, uint32_t nargs, int star) { cons_t *c; uint32_t i; value_t v; v = cons_reserve(nargs); c = ptr(v); for(i = 0; i < nargs; i++){ c->car = args[i]; c->cdr = tagptr(c+1, TAG_CONS); c++; } if(star) c[-2].cdr = c[-1].car; else c[-1].cdr = FL(Nil); return v; } static value_t copy_list(value_t L) { if(!iscons(L)) return FL(Nil); PUSH(FL(Nil)); PUSH(L); value_t *plcons = &FL(stack)[FL(sp)-2]; value_t *pL = &FL(stack)[FL(sp)-1]; value_t c; c = mk_cons(); PUSH(c); // save first cons car_(c) = car_(*pL); cdr_(c) = FL(Nil); *plcons = c; *pL = cdr_(*pL); while(iscons(*pL)){ c = mk_cons(); car_(c) = car_(*pL); cdr_(c) = FL(Nil); cdr_(*plcons) = c; *plcons = c; *pL = cdr_(*pL); } c = POP(); // first cons POPN(2); return c; } static value_t do_trycatch(void) { uint32_t saveSP = FL(sp); value_t v = FL(Nil); value_t thunk = FL(stack)[FL(sp)-2]; FL(stack)[FL(sp)-2] = FL(stack)[FL(sp)-1]; FL(stack)[FL(sp)-1] = thunk; FL_TRY{ v = apply_cl(0); } FL_CATCH{ v = FL(stack)[saveSP-2]; PUSH(v); PUSH(FL(lasterror)); v = apply_cl(1); } FL(sp) = saveSP; return v; } /* argument layout on stack is |--required args--|--opt args--|--kw args--|--rest args... */ static uint32_t process_keys(value_t kwtable, uint32_t nreq, uint32_t nkw, uint32_t nopt, uint32_t bp, uint32_t nargs, int va) { uint32_t extr = nopt+nkw; uint32_t ntot = nreq+extr; value_t args[64], v = FL(Nil); uint32_t i, a = 0, nrestargs; value_t s1 = FL(stack)[FL(sp)-1]; value_t s2 = FL(stack)[FL(sp)-2]; value_t s4 = FL(stack)[FL(sp)-4]; value_t s5 = FL(stack)[FL(sp)-5]; if(__unlikely(nargs < nreq)) lerrorf(FL(ArgError), "too few arguments"); if(__unlikely(extr > nelem(args))) lerrorf(FL(ArgError), "too many arguments"); for(i = 0; i < extr; i++) args[i] = UNBOUND; for(i = nreq; i < nargs; i++){ v = FL(stack)[bp+i]; if(issymbol(v) && iskeyword((symbol_t*)ptr(v))) break; if(a >= nopt) goto no_kw; args[a++] = v; } if(i >= nargs) goto no_kw; // now process keywords uintptr_t n = vector_size(kwtable)/2; do{ i++; if(__unlikely(i >= nargs)) lerrorf(FL(ArgError), "keyword %s requires an argument", symbol_name(v)); value_t hv = fixnum(((symbol_t*)ptr(v))->hash); lltint_t lx = numval(hv); uintptr_t x = 2*((lx < 0 ? -lx : lx) % n); if(__likely(vector_elt(kwtable, x) == v)){ uintptr_t idx = numval(vector_elt(kwtable, x+1)); assert(idx < nkw); idx += nopt; if(args[idx] == UNBOUND){ // if duplicate key, keep first value args[idx] = FL(stack)[bp+i]; } }else{ lerrorf(FL(ArgError), "unsupported keyword %s", symbol_name(v)); } i++; if(i >= nargs) break; v = FL(stack)[bp+i]; }while(issymbol(v) && iskeyword((symbol_t*)ptr(v))); no_kw: nrestargs = nargs - i; if(__unlikely(!va && nrestargs > 0)) lerrorf(FL(ArgError), "too many arguments"); nargs = ntot + nrestargs; if(nrestargs) memmove(&FL(stack)[bp+ntot], &FL(stack)[bp+i], nrestargs*sizeof(value_t)); memmove(&FL(stack)[bp+nreq], args, extr*sizeof(value_t)); FL(sp) = bp + nargs; assert(FL(sp) < FL(nstack)-5); PUSH(s5); PUSH(s4); PUSH(nargs); PUSH(s2); PUSH(s1); FL(curr_frame) = FL(sp); return nargs; } #define GET_INT32(a) \ ((int32_t) \ ((((uint32_t)a[0])<<0) | \ (((uint32_t)a[1])<<8) | \ (((uint32_t)a[2])<<16) | \ (((uint32_t)a[3])<<24))) #define GET_INT16(a) \ ((int16_t) \ ((((int16_t)a[0])<<0) | \ (((int16_t)a[1])<<8))) #define PUT_INT32(a, i) \ do{ \ ((uint8_t*)(a))[0] = ((uint32_t)(i)>>0)&0xff; \ ((uint8_t*)(a))[1] = ((uint32_t)(i)>>8)&0xff; \ ((uint8_t*)(a))[2] = ((uint32_t)(i)>>16)&0xff; \ ((uint8_t*)(a))[3] = ((uint32_t)(i)>>24)&0xff; \ }while(0) /* stack on entry: <func> <nargs args...> caller's responsibility: - put the stack in this state - provide arg count - respect tail position - restore SP callee's responsibility: - check arg counts - allocate vararg array - push closed env, set up new environment */ static value_t apply_cl(uint32_t nargs) { uint32_t top_frame = FL(curr_frame); // frame variables uint32_t n, captured; uint32_t bp; const uint8_t *ip; fixnum_t s, hi; int tail, x; // temporary variables (not necessary to preserve across calls) uint32_t op, i, ipd; symbol_t *sym; cons_t *c; value_t *pv; value_t func, v, e; n = 0; v = 0; USED(n); USED(v); apply_cl_top: captured = 0; func = FL(stack)[FL(sp)-nargs-1]; ip = cv_data((cvalue_t*)ptr(fn_bcode(func))); assert(!ismanaged((uintptr_t)ip)); i = FL(sp)+GET_INT32(ip); while(i >= FL(nstack)) grow_stack(); ip += 4; bp = FL(sp)-nargs; PUSH(fn_env(func)); PUSH(FL(curr_frame)); PUSH(nargs); ipd = FL(sp); FL(sp)++; // ip PUSH(0); // captured? FL(curr_frame) = FL(sp); #ifdef COMPUTED_GOTO #pragma GCC diagnostic push #pragma GCC diagnostic ignored "-Wpedantic" #define OP(x) op_##x: #define NEXT_OP goto *((uint8_t*)&&op_OP_LOADA0 + ops[op = *ip++]) #define GOTO_OP_OFFSET(op) [op] = (int)((uint8_t*)&&op_##op - (uint8_t*)&&op_OP_LOADA0) static const int ops[] = { GOTO_OP_OFFSET(OP_LOADA0), GOTO_OP_OFFSET(OP_LOADA1), GOTO_OP_OFFSET(OP_LOADV), GOTO_OP_OFFSET(OP_BRF), GOTO_OP_OFFSET(OP_POP), GOTO_OP_OFFSET(OP_CALL), GOTO_OP_OFFSET(OP_TCALL), GOTO_OP_OFFSET(OP_LOADG), GOTO_OP_OFFSET(OP_LOADA), GOTO_OP_OFFSET(OP_LOADC), GOTO_OP_OFFSET(OP_RET), GOTO_OP_OFFSET(OP_DUP), GOTO_OP_OFFSET(OP_CAR), GOTO_OP_OFFSET(OP_CDR), GOTO_OP_OFFSET(OP_CLOSURE), GOTO_OP_OFFSET(OP_SETA), GOTO_OP_OFFSET(OP_JMP), GOTO_OP_OFFSET(OP_LOADC00), GOTO_OP_OFFSET(OP_PAIRP), GOTO_OP_OFFSET(OP_BRNE), GOTO_OP_OFFSET(OP_LOADT), GOTO_OP_OFFSET(OP_LOAD0), GOTO_OP_OFFSET(OP_LOADC01), GOTO_OP_OFFSET(OP_AREF), GOTO_OP_OFFSET(OP_ATOMP), GOTO_OP_OFFSET(OP_BRT), GOTO_OP_OFFSET(OP_BRNN), GOTO_OP_OFFSET(OP_LOAD1), GOTO_OP_OFFSET(OP_LT), GOTO_OP_OFFSET(OP_ADD2), GOTO_OP_OFFSET(OP_SETCDR), GOTO_OP_OFFSET(OP_LOADF), GOTO_OP_OFFSET(OP_CONS), GOTO_OP_OFFSET(OP_EQ), GOTO_OP_OFFSET(OP_SYMBOLP), GOTO_OP_OFFSET(OP_NOT), GOTO_OP_OFFSET(OP_CADR), GOTO_OP_OFFSET(OP_NEG), GOTO_OP_OFFSET(OP_NULLP), GOTO_OP_OFFSET(OP_BOOLEANP), GOTO_OP_OFFSET(OP_NUMBERP), GOTO_OP_OFFSET(OP_FIXNUMP), GOTO_OP_OFFSET(OP_BOUNDP), GOTO_OP_OFFSET(OP_BUILTINP), GOTO_OP_OFFSET(OP_FUNCTIONP), GOTO_OP_OFFSET(OP_VECTORP), GOTO_OP_OFFSET(OP_NOP), GOTO_OP_OFFSET(OP_SETCAR), GOTO_OP_OFFSET(OP_JMPL), GOTO_OP_OFFSET(OP_BRFL), GOTO_OP_OFFSET(OP_BRTL), GOTO_OP_OFFSET(OP_EQV), GOTO_OP_OFFSET(OP_EQUAL), GOTO_OP_OFFSET(OP_LIST), GOTO_OP_OFFSET(OP_APPLY), GOTO_OP_OFFSET(OP_ADD), GOTO_OP_OFFSET(OP_SUB), GOTO_OP_OFFSET(OP_MUL), GOTO_OP_OFFSET(OP_DIV), GOTO_OP_OFFSET(OP_IDIV), GOTO_OP_OFFSET(OP_NUMEQ), GOTO_OP_OFFSET(OP_COMPARE), GOTO_OP_OFFSET(OP_ARGC), GOTO_OP_OFFSET(OP_VECTOR), GOTO_OP_OFFSET(OP_ASET), GOTO_OP_OFFSET(OP_LOADNIL), GOTO_OP_OFFSET(OP_LOADI8), GOTO_OP_OFFSET(OP_LOADVL), GOTO_OP_OFFSET(OP_LOADGL), GOTO_OP_OFFSET(OP_LOADAL), GOTO_OP_OFFSET(OP_LOADCL), GOTO_OP_OFFSET(OP_SETG), GOTO_OP_OFFSET(OP_SETGL), GOTO_OP_OFFSET(OP_SETAL), GOTO_OP_OFFSET(OP_SETC), GOTO_OP_OFFSET(OP_SETCL), GOTO_OP_OFFSET(OP_VARGC), GOTO_OP_OFFSET(OP_TRYCATCH), GOTO_OP_OFFSET(OP_FOR), GOTO_OP_OFFSET(OP_TAPPLY), GOTO_OP_OFFSET(OP_SUB2), GOTO_OP_OFFSET(OP_LARGC), GOTO_OP_OFFSET(OP_LVARGC), GOTO_OP_OFFSET(OP_CALLL), GOTO_OP_OFFSET(OP_TCALLL), GOTO_OP_OFFSET(OP_BRNEL), GOTO_OP_OFFSET(OP_BRNNL), GOTO_OP_OFFSET(OP_BRN), GOTO_OP_OFFSET(OP_BRNL), GOTO_OP_OFFSET(OP_OPTARGS), GOTO_OP_OFFSET(OP_BRBOUND), GOTO_OP_OFFSET(OP_KEYARGS), }; NEXT_OP; #else #define OP(x) case x: #define NEXT_OP break op = *ip++; while(1){ switch(op){ #endif OP(OP_LOADA0) PUSH(captured ? vector_elt(FL(stack)[bp], 0) : FL(stack)[bp]); NEXT_OP; OP(OP_LOADA1) PUSH(captured ? vector_elt(FL(stack)[bp], 1) : FL(stack)[bp+1]); NEXT_OP; OP(OP_LOADV) v = fn_vals(FL(stack)[bp-1]); assert(*ip < vector_size(v)); PUSH(vector_elt(v, *ip++)); NEXT_OP; OP(OP_BRF) ip += POP() == FL(f) ? GET_INT16(ip) : 2; NEXT_OP; OP(OP_POP) POPN(1); NEXT_OP; OP(OP_TCALLL) tail = 1; if(0){ OP(OP_CALLL) tail = 0; } n = GET_INT32(ip); ip += 4; if(0){ OP(OP_TCALL) tail = 1; if(0){ OP(OP_CALL) tail = 0; } n = *ip++; // nargs } do_call: FL(stack)[ipd] = (uintptr_t)ip; func = FL(stack)[FL(sp)-n-1]; if(tag(func) == TAG_FUNCTION){ if(func > (N_BUILTINS<<3)){ if(tail){ FL(curr_frame) = FL(stack)[FL(curr_frame)-4]; for(s = -1; s < (fixnum_t)n; s++) FL(stack)[bp+s] = FL(stack)[FL(sp)-n+s]; FL(sp) = bp+n; } nargs = n; goto apply_cl_top; }else{ i = uintval(func); if(isbuiltin(func)){ s = builtins[i].nargs; if(s >= 0) argcount(n, s); else if(s != ANYARGS && (signed)n < -s) argcount(n, -s); // remove function arg for(s = FL(sp)-n-1; s < (int)FL(sp)-1; s++) FL(stack)[s] = FL(stack)[s+1]; FL(sp)--; switch(i){ case OP_LIST: goto apply_list; case OP_VECTOR: goto apply_vector; case OP_APPLY: goto apply_apply; case OP_ADD: goto apply_add; case OP_SUB: goto apply_sub; case OP_MUL: goto apply_mul; case OP_DIV: goto apply_div; default: op = i; #ifdef COMPUTED_GOTO goto *((uint8_t*)&&op_OP_LOADA0 + ops[i]); #else continue; #endif } } } }else if(__likely(iscbuiltin(func))){ s = FL(sp); v = (((builtin_t*)ptr(func))[3])(&FL(stack)[FL(sp)-n], n); FL(sp) = s-n; FL(stack)[FL(sp)-1] = v; NEXT_OP; } type_error("function", func); OP(OP_LOADGL) v = fn_vals(FL(stack)[bp-1]); v = vector_elt(v, GET_INT32(ip)); ip += 4; if(0){ OP(OP_LOADG) v = fn_vals(FL(stack)[bp-1]); assert(*ip < vector_size(v)); v = vector_elt(v, *ip); ip++; } assert(issymbol(v)); sym = (symbol_t*)ptr(v); if(__unlikely(sym->binding == UNBOUND)){ FL(stack)[ipd] = (uintptr_t)ip; unbound_error(v); } PUSH(sym->binding); NEXT_OP; OP(OP_LOADA) assert(nargs > 0); i = *ip++; if(captured){ e = FL(stack)[bp]; assert(isvector(e)); assert(i < vector_size(e)); v = vector_elt(e, i); }else{ v = FL(stack)[bp+i]; } PUSH(v); NEXT_OP; OP(OP_LOADC) s = *ip++; i = *ip++; v = FL(stack)[bp+nargs]; while(s--) v = vector_elt(v, vector_size(v)-1); assert(isvector(v)); assert(i < vector_size(v)); PUSH(vector_elt(v, i)); NEXT_OP; OP(OP_RET) v = POP(); FL(sp) = FL(curr_frame); FL(curr_frame) = FL(stack)[FL(sp)-4]; if(FL(curr_frame) == top_frame) return v; FL(sp) -= 5+nargs; captured = FL(stack)[FL(curr_frame)-1]; ipd = FL(curr_frame)-2; ip = (uint8_t*)FL(stack)[ipd]; nargs = FL(stack)[FL(curr_frame)-3]; bp = FL(curr_frame) - 5 - nargs; FL(stack)[FL(sp)-1] = v; NEXT_OP; OP(OP_DUP) FL(sp)++; FL(stack)[FL(sp)-1] = FL(stack)[FL(sp)-2]; NEXT_OP; OP(OP_CAR) v = FL(stack)[FL(sp)-1]; if(__unlikely(!iscons(v))){ FL(stack)[ipd] = (uintptr_t)ip; type_error("cons", v); } FL(stack)[FL(sp)-1] = car_(v); NEXT_OP; OP(OP_CDR) v = FL(stack)[FL(sp)-1]; if(__unlikely(!iscons(v))){ FL(stack)[ipd] = (uintptr_t)ip; type_error("cons", v); } FL(stack)[FL(sp)-1] = cdr_(v); NEXT_OP; OP(OP_CLOSURE) // build a closure (lambda args body . env) if(nargs > 0 && !captured){ // save temporary environment to the heap n = nargs; pv = alloc_words(n + 2); PUSH(tagptr(pv, TAG_VECTOR)); pv[0] = fixnum(n+1); pv++; do{ pv[n] = FL(stack)[bp+n]; }while(n--); // environment representation changed; install // the new representation so everybody can see it captured = 1; FL(stack)[FL(curr_frame)-1] = 1; FL(stack)[bp] = FL(stack)[FL(sp)-1]; }else{ PUSH(FL(stack)[bp]); // env has already been captured; share } if(__unlikely((value_t*)FL(curheap) > (value_t*)FL(lim)-2)) gc(0); pv = (value_t*)FL(curheap); FL(curheap) += 4*sizeof(value_t); e = FL(stack)[FL(sp)-2]; // closure to copy assert(isfunction(e)); pv[0] = ((value_t*)ptr(e))[0]; pv[1] = ((value_t*)ptr(e))[1]; pv[2] = FL(stack)[FL(sp)-1]; // env pv[3] = ((value_t*)ptr(e))[3]; POPN(1); FL(stack)[FL(sp)-1] = tagptr(pv, TAG_FUNCTION); NEXT_OP; OP(OP_SETA) assert(nargs > 0); v = FL(stack)[FL(sp)-1]; i = *ip++; if(captured){ e = FL(stack)[bp]; assert(isvector(e)); assert(i < vector_size(e)); vector_elt(e, i) = v; }else{ FL(stack)[bp+i] = v; } NEXT_OP; OP(OP_JMP) ip += GET_INT16(ip); NEXT_OP; OP(OP_LOADC00) PUSH(vector_elt(FL(stack)[bp+nargs], 0)); NEXT_OP; OP(OP_PAIRP) FL(stack)[FL(sp)-1] = iscons(FL(stack)[FL(sp)-1]) ? FL(t) : FL(f); NEXT_OP; OP(OP_BRNE) ip += FL(stack)[FL(sp)-2] != FL(stack)[FL(sp)-1] ? GET_INT16(ip) : 2; POPN(2); NEXT_OP; OP(OP_LOADT) PUSH(FL(t)); NEXT_OP; OP(OP_LOAD0) PUSH(fixnum(0)); NEXT_OP; OP(OP_LOADC01) PUSH(vector_elt(FL(stack)[bp+nargs], 1)); NEXT_OP; OP(OP_AREF) FL(stack)[ipd] = (uintptr_t)ip; v = FL(stack)[FL(sp)-2]; if(isvector(v)){ e = FL(stack)[FL(sp)-1]; i = isfixnum(e) ? numval(e) : (uint32_t)toulong(e); if(__unlikely(i >= vector_size(v))) bounds_error(v, e); v = vector_elt(v, i); }else if(__likely(isarray(v))){ v = cvalue_array_aref(&FL(stack)[FL(sp)-2]); }else{ type_error("sequence", v); } POPN(1); FL(stack)[FL(sp)-1] = v; NEXT_OP; OP(OP_ATOMP) FL(stack)[FL(sp)-1] = iscons(FL(stack)[FL(sp)-1]) ? FL(f) : FL(t); NEXT_OP; OP(OP_BRT) ip += POP() != FL(f) ? GET_INT16(ip) : 2; NEXT_OP; OP(OP_BRNN) ip += POP() != FL(Nil) ? GET_INT16(ip) : 2; NEXT_OP; OP(OP_LOAD1) PUSH(fixnum(1)); NEXT_OP; OP(OP_LT) x = numeric_compare(FL(stack)[FL(sp)-2], FL(stack)[FL(sp)-1], 0, 0, 0); if(x > 1) x = numval(fl_compare(FL(stack)[FL(sp)-2], FL(stack)[FL(sp)-1])); POPN(1); FL(stack)[FL(sp)-1] = x < 0 ? FL(t) : FL(f); NEXT_OP; OP(OP_ADD2) FL(stack)[ipd] = (uintptr_t)ip; if(bothfixnums(FL(stack)[FL(sp)-1], FL(stack)[FL(sp)-2])){ s = numval(FL(stack)[FL(sp)-1]) + numval(FL(stack)[FL(sp)-2]); v = fits_fixnum(s) ? fixnum(s) : mk_xlong(s); }else{ v = fl_add_any(&FL(stack)[FL(sp)-2], 2, 0); } POPN(1); FL(stack)[FL(sp)-1] = v; NEXT_OP; OP(OP_SETCDR) v = FL(stack)[FL(sp)-2]; if(__unlikely(!iscons(v))){ FL(stack)[ipd] = (uintptr_t)ip; type_error("cons", v); } cdr_(v) = FL(stack)[FL(sp)-1]; POPN(1); NEXT_OP; OP(OP_LOADF) PUSH(FL(f)); NEXT_OP; OP(OP_CONS) if(FL(curheap) > FL(lim)) gc(0); c = (cons_t*)FL(curheap); FL(curheap) += sizeof(cons_t); c->car = FL(stack)[FL(sp)-2]; c->cdr = FL(stack)[FL(sp)-1]; FL(stack)[FL(sp)-2] = tagptr(c, TAG_CONS); POPN(1); NEXT_OP; OP(OP_EQ) FL(stack)[FL(sp)-2] = FL(stack)[FL(sp)-2] == FL(stack)[FL(sp)-1] ? FL(t) : FL(f); POPN(1); NEXT_OP; OP(OP_SYMBOLP) FL(stack)[FL(sp)-1] = issymbol(FL(stack)[FL(sp)-1]) ? FL(t) : FL(f); NEXT_OP; OP(OP_NOT) FL(stack)[FL(sp)-1] = FL(stack)[FL(sp)-1] == FL(f) ? FL(t) : FL(f); NEXT_OP; OP(OP_CADR) v = FL(stack)[FL(sp)-1]; if(__unlikely(!iscons(v))){ FL(stack)[ipd] = (uintptr_t)ip; type_error("cons", v); } v = cdr_(v); if(__unlikely(!iscons(v))){ FL(stack)[ipd] = (uintptr_t)ip; type_error("cons", v); } FL(stack)[FL(sp)-1] = car_(v); NEXT_OP; OP(OP_NEG) do_neg: FL(stack)[ipd] = (uintptr_t)ip; FL(stack)[FL(sp)-1] = fl_neg(FL(stack)[FL(sp)-1]); NEXT_OP; OP(OP_NULLP) FL(stack)[FL(sp)-1] = FL(stack)[FL(sp)-1] == FL(Nil) ? FL(t) : FL(f); NEXT_OP; OP(OP_BOOLEANP) v = FL(stack)[FL(sp)-1]; FL(stack)[FL(sp)-1] = (v == FL(t) || v == FL(f)) ? FL(t) : FL(f); NEXT_OP; OP(OP_NUMBERP) v = FL(stack)[FL(sp)-1]; FL(stack)[FL(sp)-1] = fl_isnumber(v) ? FL(t) : FL(f); NEXT_OP; OP(OP_FIXNUMP) FL(stack)[FL(sp)-1] = isfixnum(FL(stack)[FL(sp)-1]) ? FL(t) : FL(f); NEXT_OP; OP(OP_BOUNDP) FL(stack)[ipd] = (uintptr_t)ip; sym = tosymbol(FL(stack)[FL(sp)-1]); FL(stack)[FL(sp)-1] = sym->binding == UNBOUND ? FL(f) : FL(t); NEXT_OP; OP(OP_BUILTINP) v = FL(stack)[FL(sp)-1]; FL(stack)[FL(sp)-1] = (isbuiltin(v) || iscbuiltin(v)) ? FL(t) : FL(f); NEXT_OP; OP(OP_FUNCTIONP) v = FL(stack)[FL(sp)-1]; FL(stack)[FL(sp)-1] = ((tag(v) == TAG_FUNCTION && (isbuiltin(v) || v>(N_BUILTINS<<3))) || iscbuiltin(v)) ? FL(t) : FL(f); NEXT_OP; OP(OP_VECTORP) FL(stack)[FL(sp)-1] = isvector(FL(stack)[FL(sp)-1]) ? FL(t) : FL(f); NEXT_OP; OP(OP_JMPL) ip += GET_INT32(ip); NEXT_OP; OP(OP_BRFL) ip += POP() == FL(f) ? GET_INT32(ip) : 4; NEXT_OP; OP(OP_BRTL) ip += POP() != FL(f) ? GET_INT32(ip) : 4; NEXT_OP; OP(OP_BRNEL) ip += FL(stack)[FL(sp)-2] != FL(stack)[FL(sp)-1] ? GET_INT32(ip) : 4; POPN(2); NEXT_OP; OP(OP_BRNNL) ip += POP() != FL(Nil) ? GET_INT32(ip) : 4; NEXT_OP; OP(OP_BRN) ip += POP() == FL(Nil) ? GET_INT16(ip) : 2; NEXT_OP; OP(OP_BRNL) ip += POP() == FL(Nil) ? GET_INT32(ip) : 4; NEXT_OP; OP(OP_EQV) if(FL(stack)[FL(sp)-2] == FL(stack)[FL(sp)-1]) v = FL(t); else if(!leafp(FL(stack)[FL(sp)-2]) || !leafp(FL(stack)[FL(sp)-1])) v = FL(f); else v = compare_(FL(stack)[FL(sp)-2], FL(stack)[FL(sp)-1], 1) == 0 ? FL(t) : FL(f); FL(stack)[FL(sp)-2] = v; POPN(1); NEXT_OP; OP(OP_EQUAL) if(FL(stack)[FL(sp)-2] == FL(stack)[FL(sp)-1]) v = FL(t); else v = compare_(FL(stack)[FL(sp)-2], FL(stack)[FL(sp)-1], 1) == 0 ? FL(t) : FL(f); FL(stack)[FL(sp)-2] = v; POPN(1); NEXT_OP; OP(OP_SETCAR) v = FL(stack)[FL(sp)-2]; if(__unlikely(!iscons(v))){ FL(stack)[ipd] = (uintptr_t)ip; type_error("cons", v); } car_(v) = FL(stack)[FL(sp)-1]; POPN(1); NEXT_OP; OP(OP_LIST) n = *ip++; apply_list: if(n > 0){ v = list(&FL(stack)[FL(sp)-n], n, 0); POPN(n); PUSH(v); }else{ PUSH(FL(Nil)); } NEXT_OP; OP(OP_TAPPLY) tail = 1; if(0){ OP(OP_APPLY) tail = 0; } n = *ip++; apply_apply: v = POP(); // arglist n = FL(sp)-(n-2); // n-2 == # leading arguments not in the list while(iscons(v)){ if(FL(sp) >= FL(nstack)) grow_stack(); PUSH(car_(v)); v = cdr_(v); } n = FL(sp)-n; goto do_call; OP(OP_ADD) n = *ip++; apply_add: s = 0; i = FL(sp)-n; for(; i < FL(sp); i++){ if(isfixnum(FL(stack)[i])){ s += numval(FL(stack)[i]); if(__unlikely(!fits_fixnum(s))){ i++; goto add_ovf; } }else{ add_ovf: FL(stack)[ipd] = (uintptr_t)ip; v = fl_add_any(&FL(stack)[i], FL(sp)-i, s); break; } } if(i == FL(sp)) v = fixnum(s); POPN(n); PUSH(v); NEXT_OP; OP(OP_SUB) n = *ip++; apply_sub: if(n == 2) goto do_sub2; if(n == 1) goto do_neg; FL(stack)[ipd] = (uintptr_t)ip; i = FL(sp)-n; // we need to pass the full arglist on to fl_add_any // so it can handle rest args properly PUSH(FL(stack)[i]); FL(stack)[i] = fixnum(0); FL(stack)[i+1] = fl_neg(fl_add_any(&FL(stack)[i], n, 0)); FL(stack)[i] = POP(); v = fl_add_any(&FL(stack)[i], 2, 0); POPN(n); PUSH(v); NEXT_OP; OP(OP_SUB2) do_sub2: if(bothfixnums(FL(stack)[FL(sp)-2], FL(stack)[FL(sp)-1])){ s = numval(FL(stack)[FL(sp)-2]) - numval(FL(stack)[FL(sp)-1]); v = fits_fixnum(s) ? fixnum(s) : mk_xlong(s); }else{ FL(stack)[ipd] = (uintptr_t)ip; FL(stack)[FL(sp)-1] = fl_neg(FL(stack)[FL(sp)-1]); v = fl_add_any(&FL(stack)[FL(sp)-2], 2, 0); } POPN(1); FL(stack)[FL(sp)-1] = v; NEXT_OP; OP(OP_MUL) n = *ip++; apply_mul: FL(stack)[ipd] = (uintptr_t)ip; v = fl_mul_any(&FL(stack)[FL(sp)-n], n); POPN(n); PUSH(v); NEXT_OP; OP(OP_DIV) n = *ip++; apply_div: FL(stack)[ipd] = (uintptr_t)ip; i = FL(sp)-n; if(n == 1){ FL(stack)[FL(sp)-1] = fl_div2(fixnum(1), FL(stack)[i]); }else{ if(n > 2){ PUSH(FL(stack)[i]); FL(stack)[i] = fixnum(1); FL(stack)[i+1] = fl_mul_any(&FL(stack)[i], n); FL(stack)[i] = POP(); } v = fl_div2(FL(stack)[i], FL(stack)[i+1]); POPN(n); PUSH(v); } NEXT_OP; OP(OP_IDIV) FL(stack)[ipd] = (uintptr_t)ip; v = FL(stack)[FL(sp)-2]; e = FL(stack)[FL(sp)-1]; if(bothfixnums(v, e)){ if(e == 0) DivideByZeroError(); v = fixnum(numval(v) / numval(e)); }else{ v = fl_idiv2(v, e); } POPN(1); FL(stack)[FL(sp)-1] = v; NEXT_OP; OP(OP_NUMEQ) v = FL(stack)[FL(sp)-2]; e = FL(stack)[FL(sp)-1]; if(bothfixnums(v, e)) v = v == e ? FL(t) : FL(f); else{ FL(stack)[ipd] = (uintptr_t)ip; v = numeric_compare(v, e, 1, 0, 1) == 0 ? FL(t) : FL(f); } POPN(1); FL(stack)[FL(sp)-1] = v; NEXT_OP; OP(OP_COMPARE) FL(stack)[FL(sp)-2] = compare_(FL(stack)[FL(sp)-2], FL(stack)[FL(sp)-1], 0); POPN(1); NEXT_OP; OP(OP_ARGC) n = *ip++; if(0){ OP(OP_LARGC) n = GET_INT32(ip); ip += 4; } FL(stack)[ipd] = (uintptr_t)ip; argcount(nargs, n); NEXT_OP; OP(OP_VECTOR) n = *ip++; apply_vector: v = alloc_vector(n, 0); if(n){ memcpy(&vector_elt(v, 0), &FL(stack)[FL(sp)-n], n*sizeof(value_t)); POPN(n); } PUSH(v); NEXT_OP; OP(OP_ASET) e = FL(stack)[FL(sp)-3]; FL(stack)[ipd] = (uintptr_t)ip; if(isvector(e)){ i = tofixnum(FL(stack)[FL(sp)-2]); if(__unlikely(i >= vector_size(e))) bounds_error(v, FL(stack)[FL(sp)-1]); vector_elt(e, i) = (v = FL(stack)[FL(sp)-1]); }else if(__likely(isarray(e))){ v = cvalue_array_aset(&FL(stack)[FL(sp)-3]); }else{ type_error("sequence", e); } POPN(2); FL(stack)[FL(sp)-1] = v; NEXT_OP; OP(OP_FOR) FL(stack)[ipd] = (uintptr_t)ip; s = tofixnum(FL(stack)[FL(sp)-3]); hi = tofixnum(FL(stack)[FL(sp)-2]); v = FL(unspecified); FL(sp) += 2; n = FL(sp); for(; s <= hi; s++){ FL(stack)[FL(sp)-2] = FL(stack)[FL(sp)-3]; FL(stack)[FL(sp)-1] = fixnum(s); v = apply_cl(1); FL(sp) = n; } POPN(4); FL(stack)[FL(sp)-1] = v; NEXT_OP; OP(OP_LOADNIL) PUSH(FL(Nil)); NEXT_OP; OP(OP_LOADI8) s = (int8_t)*ip++; PUSH(fixnum(s)); NEXT_OP; OP(OP_LOADVL) v = fn_vals(FL(stack)[bp-1]); v = vector_elt(v, GET_INT32(ip)); ip += 4; PUSH(v); NEXT_OP; OP(OP_SETGL) v = fn_vals(FL(stack)[bp-1]); v = vector_elt(v, GET_INT32(ip)); ip += 4; if(0){ OP(OP_SETG) v = fn_vals(FL(stack)[bp-1]); assert(*ip < vector_size(v)); v = vector_elt(v, *ip); ip++; } assert(issymbol(v)); sym = (symbol_t*)ptr(v); v = FL(stack)[FL(sp)-1]; if(!isconstant(sym)) sym->binding = v; NEXT_OP; OP(OP_LOADAL) assert(nargs > 0); i = GET_INT32(ip); ip += 4; v = captured ? vector_elt(FL(stack)[bp], i) : FL(stack)[bp+i]; PUSH(v); NEXT_OP; OP(OP_SETAL) assert(nargs > 0); v = FL(stack)[FL(sp)-1]; i = GET_INT32(ip); ip += 4; if(captured) vector_elt(FL(stack)[bp], i) = v; else FL(stack)[bp+i] = v; NEXT_OP; OP(OP_SETC) s = *ip++; i = *ip++; v = FL(stack)[bp+nargs]; while(s--) v = vector_elt(v, vector_size(v)-1); assert(isvector(v)); assert(i < vector_size(v)); vector_elt(v, i) = FL(stack)[FL(sp)-1]; NEXT_OP; OP(OP_LOADCL) s = GET_INT32(ip); ip += 4; i = GET_INT32(ip); ip += 4; v = FL(stack)[bp+nargs]; while(s--) v = vector_elt(v, vector_size(v)-1); PUSH(vector_elt(v, i)); NEXT_OP; OP(OP_SETCL) s = GET_INT32(ip); ip += 4; i = GET_INT32(ip); ip += 4; v = FL(stack)[bp+nargs]; while(s--) v = vector_elt(v, vector_size(v)-1); assert(i < vector_size(v)); vector_elt(v, i) = FL(stack)[FL(sp)-1]; NEXT_OP; OP(OP_VARGC) i = *ip++; if(0){ OP(OP_LVARGC) i = GET_INT32(ip); ip += 4; } s = (fixnum_t)nargs - (fixnum_t)i; if(s > 0){ v = list(&FL(stack)[bp+i], s, 0); FL(stack)[bp+i] = v; if(s > 1){ FL(stack)[bp+i+1] = FL(stack)[bp+nargs+0]; FL(stack)[bp+i+2] = FL(stack)[bp+nargs+1]; FL(stack)[bp+i+3] = i+1; //FL(stack)[bp+i+4] = 0; FL(stack)[bp+i+5] = 0; FL(sp) = bp+i+6; FL(curr_frame) = FL(sp); } }else if(__unlikely(s < 0)){ FL(stack)[ipd] = (uintptr_t)ip; lerrorf(FL(ArgError), "too few arguments"); }else{ PUSH(0); FL(stack)[FL(sp)-3] = i+1; FL(stack)[FL(sp)-4] = FL(stack)[FL(sp)-5]; FL(stack)[FL(sp)-5] = FL(stack)[FL(sp)-6]; FL(stack)[FL(sp)-6] = FL(Nil); FL(curr_frame) = FL(sp); } ipd = FL(sp)-2; nargs = i+1; NEXT_OP; OP(OP_TRYCATCH) FL(stack)[ipd] = (uintptr_t)ip; v = do_trycatch(); POPN(1); FL(stack)[FL(sp)-1] = v; NEXT_OP; OP(OP_OPTARGS) i = GET_INT32(ip); ip += 4; n = GET_INT32(ip); ip += 4; if(__unlikely(nargs < i)){ FL(stack)[ipd] = (uintptr_t)ip; lerrorf(FL(ArgError), "too few arguments"); } if((int32_t)n > 0){ if(__unlikely(nargs > n)){ FL(stack)[ipd] = (uintptr_t)ip; lerrorf(FL(ArgError), "too many arguments"); } }else n = -n; if(__likely(n > nargs)){ n -= nargs; FL(sp) += n; FL(stack)[FL(sp)-1] = FL(stack)[FL(sp)-n-1]; FL(stack)[FL(sp)-2] = FL(stack)[FL(sp)-n-2]; FL(stack)[FL(sp)-3] = nargs+n; FL(stack)[FL(sp)-4] = FL(stack)[FL(sp)-n-4]; FL(stack)[FL(sp)-5] = FL(stack)[FL(sp)-n-5]; FL(curr_frame) = FL(sp); ipd = FL(sp)-2; for(i = 0; i < n; i++) FL(stack)[bp+nargs+i] = UNBOUND; nargs += n; } NEXT_OP; OP(OP_BRBOUND) i = GET_INT32(ip); ip += 4; v = captured ? vector_elt(FL(stack)[bp], i) : FL(stack)[bp+i]; PUSH(v != UNBOUND ? FL(t) : FL(f)); NEXT_OP; OP(OP_KEYARGS) v = fn_vals(FL(stack)[bp-1]); v = vector_elt(v, 0); i = GET_INT32(ip); ip += 4; n = GET_INT32(ip); ip += 4; s = GET_INT32(ip); ip += 4; FL(stack)[ipd] = (uintptr_t)ip; nargs = process_keys(v, i, n, labs(s)-(i+n), bp, nargs, s<0); NEXT_OP; OP(OP_NOP) NEXT_OP; #ifdef COMPUTED_GOTO #pragma GCC diagnostic pop #else } op = *ip++; } #endif } #define SWAP_INT32(a) #define SWAP_INT16(a) #include "maxstack.inc" #if BYTE_ORDER == BIG_ENDIAN #undef SWAP_INT32 #undef SWAP_INT16 #define SWAP_INT32(a) \ do{ \ uint8_t *x = (void*)a, y; \ y = x[0]; x[0] = x[3]; x[3] = y; \ y = x[1]; x[1] = x[2]; x[2] = y; \ }while(0) #define SWAP_INT16(a) \ do{ \ uint8_t *x = (void*)a, y; \ y = x[0]; x[0] = x[1]; x[1] = y; \ }while(0) #define compute_maxstack compute_maxstack_swap #include "maxstack.inc" #undef compute_maxstack #else #endif // top = top frame pointer to start at static value_t _stacktrace(uint32_t top) { value_t lst = FL(Nil); fl_gc_handle(&lst); while(top > 0){ const uint8_t *ip1 = (void*)FL(stack)[top-2]; uint32_t sz = FL(stack)[top-3]+1; uint32_t bp = top-5-sz; value_t func = FL(stack)[bp]; const uint8_t *ip0 = cv_data((cvalue_t*)ptr(fn_bcode(func))); intptr_t ip = ip1 - ip0 - 1; /* -1: ip1 is *after* the one that was being executed */ value_t v = alloc_vector(sz+1, 0); vector_elt(v, 0) = fixnum(ip); vector_elt(v, 1) = func; if(FL(stack)[top-1] /*captured*/){ memmove(&vector_elt(v, 2), &vector_elt(FL(stack)[bp+1], 0), (sz-1)*sizeof(value_t)); }else{ for(uint32_t i = 1; i < sz; i++){ value_t si = FL(stack)[bp+i]; // if there's an error evaluating argument defaults some slots // might be left set to UNBOUND (issue #22) vector_elt(v, i+1) = si == UNBOUND ? FL(unspecified) : si; } } lst = fl_cons(v, lst); top = FL(stack)[top-4]; } fl_free_gc_handles(1); return lst; } // builtins ------------------------------------------------------------------- BUILTIN("gc", gc) { USED(args); argcount(nargs, 0); gc(0); return FL(t); } BUILTIN("function", function) { if(nargs == 1 && issymbol(args[0])) return fn_builtin_builtin(args, nargs); if(nargs < 2 || nargs > 4) argcount(nargs, 2); if(__unlikely(!fl_isstring(args[0]))) type_error("string", args[0]); if(__unlikely(!isvector(args[1]))) type_error("vector", args[1]); cvalue_t *arr = (cvalue_t*)ptr(args[0]); cv_pin(arr); char *data = cv_data(arr); uint32_t ms; if((uint8_t)data[4] >= N_OPCODES){ // read syntax, shifted 48 for compact text representation size_t i, sz = cv_len(arr); for(i = 0; i < sz; i++) data[i] -= 48; #if BYTE_ORDER == BIG_ENDIAN ms = compute_maxstack((uint8_t*)data, cv_len(arr)); }else{ ms = compute_maxstack_swap((uint8_t*)data, cv_len(arr)); } #else } ms = compute_maxstack((uint8_t*)data, cv_len(arr)); #endif PUT_INT32(data, ms); function_t *fn = alloc_words(4); value_t fv = tagptr(fn, TAG_FUNCTION); fn->bcode = args[0]; fn->vals = args[1]; fn->env = FL(Nil); fn->name = FL(lambda); if(nargs > 2){ if(issymbol(args[2])){ fn->name = args[2]; if(nargs > 3) fn->env = args[3]; }else{ fn->env = args[2]; if(nargs > 3){ if(__unlikely(!issymbol(args[3]))) type_error("symbol", args[3]); fn->name = args[3]; } } if(__unlikely(isgensym(fn->name))) lerrorf(FL(ArgError), "name should not be a gensym"); } return fv; } BUILTIN("function:code", function_code) { argcount(nargs, 1); value_t v = args[0]; if(__unlikely(!isclosure(v))) type_error("function", v); return fn_bcode(v); } BUILTIN("function:vals", function_vals) { argcount(nargs, 1); value_t v = args[0]; if(__unlikely(!isclosure(v))) type_error("function", v); return fn_vals(v); } BUILTIN("function:env", function_env) { argcount(nargs, 1); value_t v = args[0]; if(__unlikely(!isclosure(v))) type_error("function", v); return fn_env(v); } BUILTIN("function:name", function_name) { argcount(nargs, 1); value_t v = args[0]; if(__unlikely(!isclosure(v))) type_error("function", v); return fn_name(v); } BUILTIN("copy-list", copy_list) { argcount(nargs, 1); return copy_list(args[0]); } BUILTIN("append", append) { value_t first = FL(Nil), lst, lastcons = FL(Nil); uint32_t i; if(nargs == 0) return FL(Nil); fl_gc_handle(&first); fl_gc_handle(&lastcons); for(i = 0; i < nargs; i++){ lst = args[i]; if(iscons(lst)){ lst = copy_list(lst); if(first == FL(Nil)) first = lst; else cdr_(lastcons) = lst; lastcons = tagptr((((cons_t*)FL(curheap))-1), TAG_CONS); }else if(lst != FL(Nil)){ type_error("cons", lst); } } fl_free_gc_handles(2); return first; } BUILTIN("list*", liststar) { if(nargs == 1) return args[0]; if(nargs == 0) argcount(nargs, 1); return list(args, nargs, 1); } BUILTIN("stacktrace", stacktrace) { USED(args); argcount(nargs, 0); return _stacktrace(FL(throwing_frame) ? FL(throwing_frame) : FL(curr_frame)); } BUILTIN("map", map) { if(__unlikely(nargs < 2)) lerrorf(FL(ArgError), "too few arguments"); if(!iscons(args[1])) return FL(Nil); value_t v; intptr_t first, last, argSP = args-FL(stack); assert(argSP >= 0 && argSP < FL(nstack)); if(nargs == 2){ if(FL(sp)+4 > FL(nstack)) grow_stack(); PUSH(FL(stack)[argSP]); PUSH(car_(FL(stack)[argSP+1])); v = _applyn(1); POPN(2); PUSH(v); v = mk_cons(); car_(v) = POP(); cdr_(v) = FL(Nil); PUSH(v); PUSH(v); first = FL(sp)-2; last = FL(sp)-1; FL(stack)[argSP+1] = cdr_(FL(stack)[argSP+1]); while(iscons(FL(stack)[argSP+1])){ PUSH(FL(stack)[argSP]); PUSH(car_(FL(stack)[argSP+1])); v = _applyn(1); POPN(2); PUSH(v); v = mk_cons(); car_(v) = POP(); cdr_(v) = FL(Nil); cdr_(FL(stack)[last]) = v; FL(stack)[last] = v; FL(stack)[argSP+1] = cdr_(FL(stack)[argSP+1]); } POPN(2); }else{ size_t i; while(FL(sp)+nargs+1 > FL(nstack)) grow_stack(); PUSH(FL(stack)[argSP]); for(i = 1; i < nargs; i++){ PUSH(car(FL(stack)[argSP+i])); FL(stack)[argSP+i] = cdr_(FL(stack)[argSP+i]); } v = _applyn(nargs-1); POPN(nargs); PUSH(v); v = mk_cons(); car_(v) = POP(); cdr_(v) = FL(Nil); PUSH(v); PUSH(v); first = FL(sp)-2; last = FL(sp)-1; while(iscons(FL(stack)[argSP+1])){ PUSH(FL(stack)[argSP]); for(i = 1; i < nargs; i++){ PUSH(car(FL(stack)[argSP+i])); FL(stack)[argSP+i] = cdr_(FL(stack)[argSP+i]); } v = _applyn(nargs-1); POPN(nargs); PUSH(v); v = mk_cons(); car_(v) = POP(); cdr_(v) = FL(Nil); cdr_(FL(stack)[last]) = v; FL(stack)[last] = v; } POPN(2); } return FL(stack)[first]; } BUILTIN("sleep", fl_sleep) { if(nargs > 1) argcount(nargs, 1); double s = nargs > 0 ? todouble(args[0]) : 0; sleep_ms(s * 1000.0); return FL(t); } BUILTIN("*vm-stats*", vm_stats) { USED(args); argcount(nargs, 0); ios_printf(ios_stderr, "nstack %"PRIu32"\n", FL(nstack)); ios_printf(ios_stderr, "heapsize %"PRIu32"\n", FL(heapsize)); ios_printf(ios_stderr, "maxfinalizers %"PRIu64"\n", (uint64_t)FL(maxfinalizers)); ios_printf(ios_stderr, "gc calls %"PRIu64"\n", (uint64_t)FL(gccalls)); return FL(t); } static const builtinspec_t builtin_fns[] = { #define BUILTIN_FN(l, c){l, fn_builtin_##c}, #include "builtin_fns.h" #undef BUILTIN_FN }; // initialization ------------------------------------------------------------- void fl_init(size_t initial_heapsize) { int i; memset(&fl, 0, sizeof(fl)); FL(scr_width) = 80; FL(heapsize) = initial_heapsize; FL(fromspace) = LLT_ALLOC(FL(heapsize)); FL(tospace) = LLT_ALLOC(FL(heapsize)); FL(curheap) = FL(fromspace); FL(lim) = FL(curheap)+FL(heapsize)-sizeof(cons_t); FL(consflags) = bitvector_new(FL(heapsize)/sizeof(cons_t), 1); htable_new(&FL(printconses), 32); comparehash_init(); FL(nstack) = 262144; FL(stack) = LLT_ALLOC(FL(nstack)*sizeof(value_t)); FL(Nil) = builtin(OP_THE_EMPTY_LIST); FL(t) = builtin(OP_BOOL_CONST_T); FL(f) = builtin(OP_BOOL_CONST_F); FL(eof) = builtin(OP_EOF_OBJECT); FL(lambda) = symbol("λ"); FL(function) = symbol("function"); FL(quote) = symbol("quote"); FL(trycatch) = symbol("trycatch"); FL(backquote) = symbol("quasiquote"); FL(comma) = symbol("unquote"); FL(commaat) = symbol("unquote-splicing"); FL(commadot) = symbol("unquote-nsplicing"); FL(IOError) = symbol("io-error"); FL(ParseError) = symbol("parse-error"); FL(TypeError) = symbol("type-error"); FL(ArgError) = symbol("arg-error"); FL(UnboundError) = symbol("unbound-error"); FL(KeyError) = symbol("key-error"); FL(MemoryError) = symbol("memory-error"); FL(BoundsError) = symbol("bounds-error"); FL(DivideError) = symbol("divide-error"); FL(EnumerationError) = symbol("enumeration-error"); FL(Error) = symbol("error"); FL(pairsym) = symbol("pair"); FL(symbolsym) = symbol("symbol"); FL(fixnumsym) = symbol("fixnum"); FL(vectorsym) = symbol("vector"); FL(builtinsym) = symbol("builtin"); FL(booleansym) = symbol("boolean"); FL(nullsym) = symbol("null"); FL(definesym) = symbol("define"); FL(defmacrosym) = symbol("define-macro"); FL(forsym) = symbol("for"); FL(setqsym) = symbol("set!"); FL(evalsym) = symbol("eval"); FL(vu8sym) = symbol("vu8"); FL(fnsym) = symbol("fn"); FL(nulsym) = symbol("nul"); FL(alarmsym) = symbol("alarm"); FL(backspacesym) = symbol("backspace"); FL(tabsym) = symbol("tab"); FL(linefeedsym) = symbol("linefeed"); FL(vtabsym) = symbol("vtab"); FL(pagesym) = symbol("page"); FL(returnsym) = symbol("return"); FL(escsym) = symbol("esc"); FL(spacesym) = symbol("space"); FL(deletesym) = symbol("delete"); FL(newlinesym) = symbol("newline"); FL(tsym) = symbol("t"); FL(Tsym) = symbol("T"); FL(fsym) = symbol("f"); FL(Fsym) = symbol("F"); FL(builtins_table_sym) = symbol("*builtins*"); set(FL(printprettysym) = symbol("*print-pretty*"), FL(t)); set(FL(printreadablysym) = symbol("*print-readably*"), FL(t)); set(FL(printwidthsym) = symbol("*print-width*"), fixnum(FL(scr_width))); set(FL(printlengthsym) = symbol("*print-length*"), FL(f)); set(FL(printlevelsym) = symbol("*print-level*"), FL(f)); FL(lasterror) = FL(Nil); for(i = 0; i < nelem(builtins); i++){ if(builtins[i].name) setc(symbol(builtins[i].name), builtin(i)); } setc(symbol("eq"), builtin(OP_EQ)); setc(symbol("procedure?"), builtin(OP_FUNCTIONP)); setc(symbol("top-level-bound?"), builtin(OP_BOUNDP)); #if defined(__linux__) set(symbol("*os-name*"), symbol("linux")); #elif defined(__OpenBSD__) set(symbol("*os-name*"), symbol("openbsd")); #elif defined(__FreeBSD__) set(symbol("*os-name*"), symbol("freebsd")); #elif defined(__NetBSD__) set(symbol("*os-name*"), symbol("netbsd")); #elif defined(__DragonFly__) set(symbol("*os-name*"), symbol("dragonflybsd")); #elif defined(__plan9__) set(symbol("*os-name*"), symbol("plan9")); #else set(symbol("*os-name*"), symbol("unknown")); #endif FL(the_empty_vector) = tagptr(alloc_words(1), TAG_VECTOR); vector_setsize(FL(the_empty_vector), 0); cvalues_init(); FL(memory_exception_value) = fl_list2(FL(MemoryError), cvalue_static_cstring("out of memory")); const builtinspec_t *b; for(i = 0, b = builtin_fns; i < nelem(builtin_fns); i++, b++) setc(symbol(b->name), cbuiltin(b->name, b->fptr)); table_init(); iostream_init(); fsixel_init(); } // top level ------------------------------------------------------------------ value_t fl_toplevel_eval(value_t expr) { return fl_applyn(1, symbol_value(FL(evalsym)), expr); } int fl_load_system_image(value_t sys_image_iostream) { value_t e; uint32_t saveSP; symbol_t *sym; PUSH(sys_image_iostream); saveSP = FL(sp); FL_TRY{ while(1){ e = fl_read_sexpr(FL(stack)[FL(sp)-1]); if(ios_eof(value2c(ios_t*, FL(stack)[FL(sp)-1]))) break; if(isfunction(e)){ // stage 0 format: series of thunks PUSH(e); (void)_applyn(0); FL(sp) = saveSP; }else{ // stage 1 format: list alternating symbol/value while(iscons(e)){ sym = tosymbol(car_(e)); e = cdr_(e); (void)tocons(e); sym->binding = car_(e); e = cdr_(e); } break; } } } FL_CATCH_NO_INC{ ios_puts("fatal error during bootstrap:\n", ios_stderr); fl_print(ios_stderr, FL(lasterror)); ios_putc('\n', ios_stderr); return 1; } ios_close(value2c(ios_t*, FL(stack)[FL(sp)-1])); POPN(1); return 0; }