ref: bbfee60f6716dce8cf7a802c044cf7d0fe8bb6f2
dir: /src/sl.c/
#include "sl.h"
#include "operators.h"
#include "cvalues.h"
#include "types.h"
#include "print.h"
#include "read.h"
#include "timefuncs.h"
#include "equal.h"
#include "hashing.h"
#include "table.h"
#include "io.h"
#include "compress.h"
sl_v sl_builtinssym, sl_quote, sl_lambda, sl_comma, sl_commaat;
sl_v sl_commadot, sl_trycatch, sl_backquote;
sl_v sl_conssym, sl_symsym, sl_fixnumsym, sl_vecsym, sl_builtinsym, sl_vu8sym;
sl_v sl_defsym, sl_defmacrosym, sl_forsym, sl_setqsym;
sl_v sl_booleansym, sl_nullsym, sl_evalsym, sl_fnsym, sl_trimsym;
sl_v sl_nulsym, sl_alarmsym, sl_backspacesym, sl_tabsym, sl_linefeedsym, sl_newlinesym;
sl_v sl_vtabsym, sl_pagesym, sl_returnsym, sl_escsym, sl_spacesym, sl_deletesym;
sl_v sl_errio, sl_errparse, sl_errtype, sl_errarg, sl_errmem, sl_errconst;
sl_v sl_errdiv0, sl_errbounds, sl_err, sl_errkey, sl_errunbound, sl_erroom;
sl_v sl_emptyvec, sl_emptystr;
sl_v sl_printwidthsym, sl_printreadablysym, sl_printprettysym, sl_printlengthsym;
sl_v sl_printlevelsym;
sl_v sl_tablesym, sl_arrsym;
sl_v sl_iosym, sl_rdsym, sl_wrsym, sl_apsym, sl_crsym, sl_truncsym;
sl_v sl_s8sym, sl_u8sym, sl_s16sym, sl_u16sym, sl_s32sym, sl_u32sym;
sl_v sl_s64sym, sl_u64sym, sl_bignumsym;
sl_v sl_bytesym, sl_runesym, sl_floatsym, sl_doublesym;
sl_v sl_strtypesym;
sl_type *sl_mptype, *sl_builtintype;
sl_type *sl_s8type, *sl_u8type;
sl_type *sl_s16type, *sl_u16type;
sl_type *sl_s32type, *sl_u32type;
sl_type *sl_s64type, *sl_u64type;
sl_type *sl_floattype, *sl_doubletype;
sl_type *sl_bytetype, *sl_runetype;
sl_type *sl_strtype;
sl_thread(Sl *slp);
Slg slg = {0};
typedef struct {
const char *name;
builtin_t fptr;
}sl_builtinspec;
bool
isbuiltin(sl_v x)
{
int i;
return tag(x) == TAG_FN && (i = uintval(x)) < nelem(builtins) && builtins[i].name != nil;
}
static sl_v apply_cl(int nargs) sl_hotfn;
// error utilities ------------------------------------------------------------
void
free_readstate(sl_readstate *rs)
{
htable_free(&rs->backrefs);
htable_free(&rs->gensyms);
}
_Noreturn void
sl_exit(const char *status)
{
if(!slg.exiting){
slg.exiting = true;
sl_applyn(
1,
sym_value(mk_sym("__finish", false)),
status == nil ? sl_nil : cvalue_static_cstr(status)
);
sl_gc(false);
}
exits(status);
}
#define SL_TRY \
sl_exctx _ctx; int l__tr, l__ca; \
_ctx.sp = sl.sp; _ctx.frame = sl.curr_frame; _ctx.rdst = sl.readstate; _ctx.prev = sl.exctx; \
_ctx.ngchnd = slg.ngchandles; sl.exctx = &_ctx; \
if(!sl_setjmp(_ctx.buf)) \
for(l__tr = 1; l__tr; l__tr = 0, (void)(sl.exctx = sl.exctx->prev))
#define SL_CATCH_INC \
l__ca = 0, sl.lasterror = sl_nil, sl.throwing_frame = 0, sl.sp = _ctx.sp, sl.curr_frame = _ctx.frame
#define SL_CATCH \
else \
for(l__ca = 1; l__ca; SL_CATCH_INC)
#define SL_CATCH_NO_INC \
else \
for(l__ca = 1; l__ca;)
void
sl_savestate(sl_exctx *_ctx)
{
_ctx->sp = sl.sp;
_ctx->frame = sl.curr_frame;
_ctx->rdst = sl.readstate;
_ctx->prev = sl.exctx;
_ctx->ngchnd = slg.ngchandles;
}
void
sl_restorestate(sl_exctx *_ctx)
{
sl.lasterror = sl_nil;
sl.throwing_frame = 0;
sl.sp = _ctx->sp;
sl.curr_frame = _ctx->frame;
}
_Noreturn void
sl_raise(sl_v e)
{
ios_flush(ios_stdout);
ios_flush(ios_stderr);
sl.lasterror = e;
// unwind read state
while(sl.readstate != sl.exctx->rdst){
free_readstate(sl.readstate);
sl.readstate = sl.readstate->prev;
}
if(sl.throwing_frame == 0)
sl.throwing_frame = sl.curr_frame;
slg.ngchandles = sl.exctx->ngchnd;
sl_exctx *thisctx = sl.exctx;
if(sl.exctx->prev) // don't throw past toplevel
sl.exctx = sl.exctx->prev;
sl_longjmp(thisctx->buf, 1);
}
_Noreturn void
lerrorf(sl_v e, const char *format, ...)
{
char msgbuf[256];
va_list args;
PUSH(e);
va_start(args, format);
vsnprintf(msgbuf, sizeof(msgbuf), format, args);
sl_v msg = str_from_cstr(msgbuf);
va_end(args);
e = POP();
sl_raise(mk_list2(e, msg));
}
_Noreturn void
type_error(const char *expected, sl_v got)
{
sl_raise(mk_listn(3, sl_errtype, mk_sym(expected, false), got));
}
_Noreturn void
bounds_error(sl_v arr, sl_v ind)
{
sl_raise(mk_listn(3, sl_errbounds, arr, ind));
}
_Noreturn void
const_error(const sl_sym *sym)
{
lerrorf(
sl_errconst,
"modifying a %s is not permitted: %s",
iskeyword(sym) ? "keyword" : "constant",
sym->name
);
}
_Noreturn void
unbound_error(sl_v sym)
{
sl_raise(mk_listn(2, sl_errunbound, sym));
}
_Noreturn void
arity_error(int nargs, int c)
{
lerrorf(sl_errarg, "arity mismatch: wanted %d, got %d", c, nargs);
}
// safe cast operators --------------------------------------------------------
#define isstr sl_isstr
#define SAFECAST_OP(type, ctype, cnvt) \
ctype to##type(sl_v v) \
{ \
if(sl_likely(is##type(v))) \
return (ctype)cnvt(v); \
type_error(#type, v); \
}
SAFECAST_OP(cons, sl_cons*, ptr)
SAFECAST_OP(sym, sl_sym*, ptr)
SAFECAST_OP(fixnum, sl_fx, numval)
//SAFECAST_OP(cvalue, sl_cv*, ptr)
SAFECAST_OP(str, char*, cvalue_data)
#undef isstr
// symbol table ---------------------------------------------------------------
static sl_sym *
alloc_sym(const char *str, int len, bool copy)
{
sl_sym *sym = MEM_ALLOC(sizeof(*sym) + (copy ? len+1 : 0));
sym->numtype = NONNUMERIC;
if(str[0] == ':' && str[1] != 0){
sl_v s = tagptr(sym, TAG_SYM);
sym->flags = FLAG_KEYWORD;
setc(s, s);
}else{
sym->binding = UNBOUND;
sym->flags = 0;
}
sym->type = nil;
sym->hash = memhash(str, len)^0xAAAAAAAAAAAAAAAAULL;
if(copy){
memcpy((char*)(sym+1), str, len+1);
sym->name = (const char*)(sym+1);
}else{
sym->name = str;
}
sym->size = 0;
return sym;
}
sl_v
mk_sym(const char *str, bool copy)
{
int len = strlen(str);
sl_sym *v;
const char *k;
if(!Tgetkv(slg.symbols, str, len, &k, (void**)&v)){
v = alloc_sym(str, len, copy);
slg.symbols = Tsetl(slg.symbols, v->name, len, v);
}
return tagptr(v, TAG_SYM);
}
sl_v
mk_csym_(const char *str, int len)
{
sl_sym *v = alloc_sym(str, len, false);
slg.symbols = Tsetl(slg.symbols, str, len, v);
return tagptr(v, TAG_SYM);
}
BUILTIN("gensym", gensym)
{
argcount(nargs, 0);
USED(args);
sl_gensym *gs = alloc_words(sizeof(sl_gensym)/sizeof(sl_v));
gs->id = slg.gensym_ctr++;
gs->binding = UNBOUND;
gs->type = nil;
return tagptr(gs, TAG_SYM);
}
sl_v
mk_gensym(void)
{
return fn_builtin_gensym(nil, 0);
}
sl_purefn
BUILTIN("gensym?", gensymp)
{
argcount(nargs, 1);
return isgensym(args[0]) ? sl_t : sl_nil;
}
char *
uint2str(char *dest, usize len, u64int num, int base)
{
int i = len-1;
u64int b = (u64int)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 *
sym_name(sl_v v)
{
if(ismanaged(v)){
sl_gensym *gs = ptr(v);
slg.gsnameno = 1-slg.gsnameno;
char *n = uint2str(slg.gsname[slg.gsnameno]+1, sizeof(slg.gsname[0])-1, gs->id, 10);
*(--n) = 'g';
return n;
}
return ((sl_sym*)ptr(v))->name;
}
// conses ---------------------------------------------------------------------
sl_v
alloc_cons(void)
{
sl_cons *c;
if(sl_unlikely(slg.curheap > slg.lim))
sl_gc(false);
c = (sl_cons*)slg.curheap;
slg.curheap += sizeof(sl_cons);
return tagptr(c, TAG_CONS);
}
void *
alloc_words(int n)
{
sl_v *first;
#if !defined(BITS64)
// force 8-byte alignment
if(n & 1)
n++;
#endif
if(sl_unlikely((sl_v*)slg.curheap > (sl_v*)slg.lim+2-n)){
sl_gc(false);
while(sl_unlikely((sl_v*)slg.curheap > ((sl_v*)slg.lim)+2-n))
sl_gc(true);
}
first = (sl_v*)slg.curheap;
slg.curheap += n*sizeof(sl_v);
return first;
}
sl_v
alloc_vec(usize n, bool init)
{
if(n == 0)
return sl_emptyvec;
sl_v *c = alloc_words(n+1);
sl_v v = tagptr(c, TAG_VEC);
vec_setsize(v, n);
if(init){
for(usize i = 0; i < n; i++)
vec_elt(v, i) = sl_void;
}
return v;
}
// collector ------------------------------------------------------------------
void
sl_gc_handle(sl_v *pv)
{
if(sl_unlikely(slg.ngchandles >= N_GC_HANDLES))
lerrorf(sl_errmem, "out of gc handles");
slg.gchandles[slg.ngchandles++] = pv;
}
void
sl_free_gc_handles(int n)
{
assert(slg.ngchandles >= n);
slg.ngchandles -= n;
}
sl_v
sl_relocate(sl_v v)
{
sl_v a, d, nc, first, *pcdr;
if(isfixnum(v))
return v;
uintptr t = tag(v);
if(t == TAG_CONS){
// iterative implementation allows arbitrarily long cons chains
pcdr = &first;
do{
a = car_(v);
if(isforwarded(v)){
*pcdr = forwardloc(v);
return first;
}
d = cdr_(v);
*pcdr = nc = tagptr((sl_cons*)slg.curheap, TAG_CONS);
slg.curheap += sizeof(sl_cons);
forward(v, nc);
car_(nc) = ismanaged(a) ? sl_relocate(a) : a;
pcdr = &cdr_(nc);
v = d;
}while(iscons(v));
*pcdr = d == sl_nil ? sl_nil : sl_relocate(d);
return first;
}
if(!ismanaged(v))
return v;
if(isforwarded(v))
return forwardloc(v);
if(t == TAG_CVALUE)
return cvalue_relocate(v);
if(t == TAG_VEC){
// N.B.: 0-length vectors secretly have space for a first element
usize i, sz = vec_size(v);
if(vec_elt(v, -1) & 0x1){
// grown vector
nc = sl_relocate(vec_elt(v, 0));
forward(v, nc);
}else{
nc = tagptr(alloc_words(sz+1), TAG_VEC);
vec_setsize(nc, sz);
a = vec_elt(v, 0);
forward(v, nc);
if(sz > 0){
vec_elt(nc, 0) = sl_relocate(a);
for(i = 1; i < sz; i++)
vec_elt(nc, i) = sl_relocate(vec_elt(v, i));
}
}
return nc;
}
if(t == TAG_FN){
sl_fn *fn = ptr(v);
sl_fn *nfn = alloc_words(sizeof(sl_fn)/sizeof(sl_v));
nfn->vals = fn->vals;
nfn->bcode = fn->bcode;
nc = tagptr(nfn, TAG_FN);
forward(v, nc);
nfn->vals = sl_relocate(nfn->vals);
nfn->bcode = sl_relocate(nfn->bcode);
nfn->env = sl_relocate(fn->env);
assert(!ismanaged(fn->name));
nfn->name = fn->name;
return nc;
}
if(t == TAG_SYM){
sl_gensym *gs = ptr(v);
sl_gensym *ng = alloc_words(sizeof(sl_gensym)/sizeof(sl_v));
ng->id = gs->id;
ng->binding = gs->binding;
ng->type = gs->type;
nc = tagptr(ng, TAG_SYM);
forward(v, nc);
if(sl_likely(ng->binding != UNBOUND))
ng->binding = sl_relocate(ng->binding);
return nc;
}
if(t == TAG_CPRIM){
sl_cprim *pcp = ptr(v);
usize nw = CPRIM_NWORDS+NWORDS(cp_class(pcp)->size);
sl_cprim *ncp = alloc_words(nw);
while(nw--)
((sl_v*)ncp)[nw] = ((sl_v*)pcp)[nw];
nc = tagptr(ncp, TAG_CPRIM);
forward(v, nc);
return nc;
}
return v;
}
static void
trace_globals(void)
{
const char *k = nil;
sl_sym *v;
while(Tnext(slg.symbols, &k, (void**)&v)){
if(v->binding != UNBOUND)
v->binding = sl_relocate(v->binding);
}
}
void
sl_gc(bool mustgrow)
{
slg.gccalls++;
slg.lim = slg.curheap = slg.tospace;
slg.lim += slg.heapsize * (slg.grew ? 2 : 1) - sizeof(sl_cons);
sl_v *top, *f;
if(sl.throwing_frame > sl.curr_frame){
top = sl.throwing_frame - 3;
f = (sl_v*)*top;
}else{
top = sl.sp;
f = sl.curr_frame;
}
for(;;){
for(sl_v *p = f; p < top; p++)
*p = sl_relocate(*p);
if(f == sl.stack)
break;
top = f - 3;
f = (sl_v*)*top;
}
for(int i = 0; i < slg.ngchandles; i++)
*slg.gchandles[i] = sl_relocate(*slg.gchandles[i]);
trace_globals();
relocate_typetable();
sl_readstate *rs = sl.readstate;
while(rs){
sl_v ent;
for(int i = 0; i < rs->backrefs.size; i++){
ent = (sl_v)rs->backrefs.table[i];
if(ent != (sl_v)HT_NOTFOUND)
rs->backrefs.table[i] = (void*)sl_relocate(ent);
}
for(int i = 0; i < rs->gensyms.size; i++){
ent = (sl_v)rs->gensyms.table[i];
if(ent != (sl_v)HT_NOTFOUND)
rs->gensyms.table[i] = (void*)sl_relocate(ent);
}
rs->source = sl_relocate(rs->source);
rs = rs->prev;
}
sl.lasterror = sl_relocate(sl.lasterror);
sl_erroom = sl_relocate(sl_erroom);
sl_emptyvec = sl_relocate(sl_emptyvec);
sl_emptystr = sl_relocate(sl_emptystr);
sweep_finalizers();
void *temp = slg.tospace;
slg.tospace = slg.fromspace;
slg.fromspace = temp;
// FIXME(sigrid): add some extra to the "used"?
sl_segused(slg.fromspace, slg.heapsize, slg.curheap-slg.fromspace);
// 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(slg.grew || ((intptr)(slg.lim-slg.curheap) < (intptr)slg.heapsize/5) || mustgrow){
sl_segfree(slg.tospace, slg.heapsize);
slg.tospace = sl_segalloc(slg.heapsize*2);
if(sl_unlikely(slg.tospace == nil)){
slg.tospace = sl_segalloc(slg.heapsize);
if(slg.tospace == nil){
// FIXME(sigrid): lost it entirely. give up?
// alternatively, wait and try indefinitely?
sysfatal("lost tospace");
}
sl_raise(sl_erroom);
}
if(slg.grew){
slg.heapsize *= 2;
temp = bitvector_resize(sl.consflags, 0, slg.heapsize/sizeof(sl_cons), 1);
if(sl_unlikely(temp == nil))
sl_raise(sl_erroom);
sl.consflags = (u32int*)temp;
}
slg.grew = !slg.grew;
}
if(sl_unlikely((sl_v*)slg.curheap > (sl_v*)slg.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.
sl_gc(false);
}
}
// utils ----------------------------------------------------------------------
// apply function with n args on the stack
sl_hotfn
static sl_v
_applyn(int n)
{
sl_v *saveSP = sl.sp;
sl_v f = saveSP[-n-1];
sl_v v;
if(iscbuiltin(f))
v = ((sl_cv*)ptr(f))->cbuiltin(saveSP-n, n);
else if(isfn(f))
v = apply_cl(n);
else if(sl_likely(isbuiltin(f))){
sl_v tab = sym_value(sl_builtinssym);
if(sl_unlikely(ptr(tab) == nil))
unbound_error(tab);
saveSP[-n-1] = vec_elt(tab, uintval(f));
v = apply_cl(n);
}else{
type_error("fn", f);
}
sl.sp = saveSP;
return v;
}
sl_v
sl_apply(sl_v f, sl_v v)
{
sl_v *saveSP = sl.sp;
PUSH(f);
int n;
for(n = 0; iscons(v); n++){
PUSH(car_(v));
v = cdr_(v);
}
if(v != sl_nil)
lerrorf(sl_errarg, "apply: last argument: not a list");
v = _applyn(n);
sl.sp = saveSP;
return v;
}
sl_v
sl_applyn(int n, sl_v f, ...)
{
va_list ap;
va_start(ap, f);
PUSH(f);
for(int i = 0; i < n; i++){
sl_v a = va_arg(ap, sl_v);
PUSH(a);
}
sl_v v = _applyn(n);
POPN(n+1);
va_end(ap);
return v;
}
sl_v
mk_listn(int n, ...)
{
va_list ap;
va_start(ap, n);
sl_v *si = sl.sp;
for(int i = 0; i < n; i++){
sl_v a = va_arg(ap, sl_v);
PUSH(a);
}
sl_cons *c = alloc_words(n*2);
sl_cons *l = c;
for(int i = 0; i < n; i++){
c->car = *si++;
c->cdr = tagptr(c+1, TAG_CONS);
c++;
}
c[-1].cdr = sl_nil;
POPN(n);
va_end(ap);
return tagptr(l, TAG_CONS);
}
sl_v
mk_list2(sl_v a, sl_v b)
{
PUSH(a);
PUSH(b);
sl_cons *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 = sl_nil;
return tagptr(c, TAG_CONS);
}
sl_v
mk_cons(sl_v a, sl_v b)
{
PUSH(a);
PUSH(b);
sl_v c = alloc_cons();
cdr_(c) = POP();
car_(c) = POP();
return c;
}
bool
sl_isnum(sl_v v)
{
if(isfixnum(v) || ismp(v))
return true;
if(iscprim(v)){
sl_cprim *c = ptr(v);
return c->type != sl_runetype && valid_numtype(c->type->numtype);
}
return false;
}
// eval -----------------------------------------------------------------------
sl_hotfn
static sl_v
list(sl_v *args, int nargs, bool star)
{
if(sl_unlikely(nargs == 0))
return sl_nil;
sl_v v = cons_reserve(nargs);
sl_cons *c = ptr(v);
for(int 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 = sl_nil;
return v;
}
static sl_v
copy_list(sl_v L)
{
if(!iscons(L))
return sl_nil;
sl_v *plcons = sl.sp;
sl_v *pL = plcons+1;
PUSH(sl_nil);
PUSH(L);
sl_v c;
c = alloc_cons(); PUSH(c); // save first cons
car_(c) = car_(*pL);
cdr_(c) = sl_nil;
*plcons = c;
*pL = cdr_(*pL);
while(iscons(*pL)){
c = alloc_cons();
car_(c) = car_(*pL);
cdr_(c) = sl_nil;
cdr_(*plcons) = c;
*plcons = c;
*pL = cdr_(*pL);
}
c = POP(); // first cons
POPN(2);
return c;
}
static sl_v
do_trycatch(void)
{
sl_v *saveSP = sl.sp;
sl_v v = sl_nil;
sl_v thunk = saveSP[-2];
sl.sp[-2] = saveSP[-1];
sl.sp[-1] = thunk;
SL_TRY{
v = apply_cl(0);
}
SL_CATCH{
v = saveSP[-2];
PUSH(v);
PUSH(sl.lasterror);
v = apply_cl(1);
}
sl.sp = saveSP;
return v;
}
/*
argument layout on stack is
|--required args--|--opt args--|--kw args--|--rest args...
*/
static int
process_keys(sl_v kwtable, int nreq, int nkw, int nopt, sl_v *bp, int nargs, int va)
{
int extr = nopt+nkw;
int ntot = nreq+extr;
sl_v args[64], v = sl_nil;
int i, a = 0, nrestargs;
sl_v s1 = sl.sp[-1];
sl_v s3 = sl.sp[-3];
sl_v s4 = sl.sp[-4];
if(sl_unlikely(nargs < nreq))
lerrorf(sl_errarg, "too few arguments");
if(sl_unlikely(extr > nelem(args)))
lerrorf(sl_errarg, "too many arguments");
for(i = 0; i < extr; i++)
args[i] = UNBOUND;
for(i = nreq; i < nargs; i++){
v = bp[i];
if(issym(v) && iskeyword((sl_sym*)ptr(v)))
break;
if(a >= nopt)
goto no_kw;
args[a++] = v;
}
if(i >= nargs)
goto no_kw;
// now process keywords
uintptr n = vec_size(kwtable)/2;
do{
i++;
if(sl_unlikely(i >= nargs))
lerrorf(sl_errarg, "keyword %s requires an argument", sym_name(v));
sl_v hv = fixnum(((sl_sym*)ptr(v))->hash);
sl_fx lx = numval(hv);
uintptr x = 2*((lx < 0 ? -lx : lx) % n);
if(sl_likely(vec_elt(kwtable, x) == v)){
intptr idx = numval(vec_elt(kwtable, x+1));
assert(idx < nkw);
idx += nopt;
if(args[idx] == UNBOUND){
// if duplicate key, keep first value
args[idx] = bp[i];
}
}else{
lerrorf(sl_errarg, "unsupported keyword %s", sym_name(v));
}
i++;
if(i >= nargs)
break;
v = bp[i];
}while(issym(v) && iskeyword((sl_sym*)ptr(v)));
no_kw:
nrestargs = nargs - i;
if(sl_unlikely(!va && nrestargs > 0))
lerrorf(sl_errarg, "too many arguments");
nargs = ntot + nrestargs;
if(nrestargs)
memmove(bp+ntot, bp+i, nrestargs*sizeof(sl_v));
memmove(bp+nreq, args, extr*sizeof(sl_v));
sl.sp = bp + nargs;
assert((intptr)(sl.sp-sl.stack) < (intptr)sl.nstack-4);
PUSH(s4);
PUSH(s3);
PUSH(nargs);
PUSH(s1);
sl.curr_frame = sl.sp;
return nargs;
}
#if BYTE_ORDER == LITTLE_ENDIAN && defined(MEM_UNALIGNED_ACCESS)
#define GET_S32(a) *(const s32int*)(a)
#define GET_S16(a) *(const s16int*)(a)
#else
#define GET_S32(a) (s32int)((a)[0]<<0 | (a)[1]<<8 | (a)[2]<<16 | (u32int)(a)[3]<<24)
#define GET_S16(a) (s16int)((a)[0]<<0 | (a)[1]<<8)
#endif
/*
stack on entry: <fn> <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 sl_v
apply_cl(int nargs)
{
sl_v *top_frame = sl.curr_frame, *bp, *ipd;
register sl_v *sp = sl.sp;
const u8int *ip;
bool tail;
int n;
goto apply_func;
#if defined(COMPUTED_GOTO)
#pragma GCC diagnostic push
#pragma GCC diagnostic ignored "-Wpedantic"
static const void * const ops[] = {
#define GOTO_OP_OFFSET(op) [op] = &&op_##op
#include "vm_goto.h"
#undef GOTO_OP_OFFSET
};
#define NEXT_OP goto *ops[*ip++]
#define LABEL(x) x
#define OP(x) op_##x:
#include "vm.h"
#undef OP
#undef LABEL
#undef NEXT_OP
#pragma GCC diagnostic pop
#else /* just a usual (portable) switch/case */
u8int op;
while(1){
switch(op){
#define NEXT_OP break
#define LABEL(x) x
#define OP(x) case x:
#include "vm.h"
#undef OP
#undef LABEL
#undef NEXT_OP
}
op = *ip++;
}
#endif
}
// top = top frame pointer to start at
static sl_v
_stacktrace(sl_v *top)
{
sl_v lst = sl_nil;
sl_v *stack = sl.stack;
sl_gc_handle(&lst);
while(top > stack){
const u8int *ip1 = (void*)top[-1];
int sz = top[-2]+1;
sl_v *bp = top-4-sz;
sl_v fn = bp[0];
const u8int *ip0 = cvalue_data(fn_bcode(fn));
intptr ip = ip1 - ip0 - 1; /* -1: ip1 is *after* the one that was being executed */
sl_v v = alloc_vec(sz+1, 0);
vec_elt(v, 0) = fixnum(ip);
vec_elt(v, 1) = fn;
for(int i = 1; i < sz; i++){
sl_v si = bp[i];
// if there's an error evaluating argument defaults some slots
// might be left set to UNBOUND
vec_elt(v, i+1) = si == UNBOUND ? sl_void : si;
}
lst = mk_cons(v, lst);
top = (sl_v*)top[-3];
}
sl_free_gc_handles(1);
return lst;
}
// builtins -------------------------------------------------------------------
BUILTIN("gc", gc)
{
USED(args);
argcount(nargs, 0);
sl_gc(false);
return sl_void;
}
BUILTIN("fn", fn)
{
if(nargs == 1 && issym(args[0]))
return fn_builtin_builtin(args, nargs);
if(nargs < 1 || nargs > 4)
argcount(nargs, 1);
if(sl_unlikely(!sl_isstr(args[0])))
type_error("str", args[0]);
sl_v vals = sl_emptyvec;
if(nargs > 1){
vals = args[1];
if(sl_unlikely(!isvec(vals)))
type_error("vec", vals);
}
sl_cv *arr = ptr(args[0]);
cv_pin(arr);
u8int *data = cv_data(arr);
if(slg.loading){
// read syntax, shifted 48 for compact text representation
usize i, sz = cv_len(arr);
for(i = 0; i < sz; i++)
data[i] -= 48;
}
sl_fn *fn = alloc_words(sizeof(sl_fn)/sizeof(sl_v));
sl_v fv = tagptr(fn, TAG_FN);
fn->bcode = args[0];
fn->vals = vals;
fn->env = sl_nil;
fn->name = sl_lambda;
if(nargs > 2){
if(issym(args[2])){
fn->name = args[2];
if(nargs > 3)
fn->env = args[3];
}else{
fn->env = args[2];
if(nargs > 3){
if(sl_unlikely(!issym(args[3])))
type_error("sym", args[3]);
fn->name = args[3];
}
}
if(sl_unlikely(isgensym(fn->name)))
lerrorf(sl_errarg, "name should not be a gensym");
}
return fv;
}
sl_purefn
BUILTIN("fn-code", fn_code)
{
argcount(nargs, 1);
sl_v v = args[0];
if(sl_unlikely(!isfn(v)))
type_error("fn", v);
return fn_bcode(v);
}
sl_purefn
BUILTIN("fn-vals", fn_vals)
{
argcount(nargs, 1);
sl_v v = args[0];
if(sl_unlikely(!isfn(v)))
type_error("fn", v);
return fn_vals(v);
}
sl_purefn
BUILTIN("fn-env", fn_env)
{
argcount(nargs, 1);
sl_v v = args[0];
if(sl_unlikely(!isfn(v)))
type_error("fn", v);
return fn_env(v);
}
BUILTIN("fn-name", fn_name)
{
argcount(nargs, 1);
sl_v v = args[0];
if(isfn(v))
return fn_name(v);
if(isbuiltin(v))
return mk_sym(builtins[uintval(v)].name, false);
if(iscbuiltin(v)){
v = (sl_v)ptrhash_get(&slg.reverse_dlsym_lookup, ptr(v));
if(v == (sl_v)HT_NOTFOUND)
return sl_nil;
return v;
}
type_error("fn", v);
}
BUILTIN("copy-list", copy_list)
{
argcount(nargs, 1);
return copy_list(args[0]);
}
BUILTIN("append", append)
{
sl_v first = sl_nil, lst, lastcons = sl_nil;
int i;
if(nargs == 0)
return sl_nil;
sl_gc_handle(&first);
sl_gc_handle(&lastcons);
for(i = 0; i < nargs; i++){
lst = args[i];
if(iscons(lst)){
lst = copy_list(lst);
if(first == sl_nil)
first = lst;
else
cdr_(lastcons) = lst;
lastcons = tagptr((((sl_cons*)slg.curheap)-1), TAG_CONS);
}else if(lst != sl_nil){
type_error("cons", lst);
}
}
sl_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, true);
}
BUILTIN("stacktrace", stacktrace)
{
USED(args);
argcount(nargs, 0);
return _stacktrace(sl.throwing_frame ? sl.throwing_frame : sl.curr_frame);
}
BUILTIN("map", map)
{
if(sl_unlikely(nargs < 2))
lerrorf(sl_errarg, "too few arguments");
sl_v *k = sl.sp;
PUSH(sl_nil);
PUSH(sl_nil);
for(bool first = true;;){
PUSH(args[0]);
for(int i = 1; i < nargs; i++){
if(!iscons(args[i])){
POPN(2+i);
return k[1];
}
PUSH(car(args[i]));
args[i] = cdr_(args[i]);
}
sl_v v = _applyn(nargs-1);
POPN(nargs);
PUSH(v);
sl_v c = alloc_cons();
car_(c) = POP(); cdr_(c) = sl_nil;
if(first)
k[1] = c;
else
cdr_(k[0]) = c;
k[0] = c;
first = false;
}
}
BUILTIN("for-each", for_each)
{
if(sl_unlikely(nargs < 2))
lerrorf(sl_errarg, "too few arguments");
for(usize n = 0;; n++){
PUSH(args[0]);
int pargs = 0;
for(int i = 1; i < nargs; i++, pargs++){
sl_v v = args[i];
if(iscons(v)){
PUSH(car_(v));
args[i] = cdr_(v);
continue;
}
if(isvec(v)){
usize sz = vec_size(v);
if(n < sz){
PUSH(vec_elt(v, n));
continue;
}
}
if(isarr(v)){
usize sz = cvalue_arrlen(v);
if(n < sz){
sl_v a[2];
a[0] = v;
a[1] = fixnum(n);
PUSH(cvalue_arr_aref(a));
continue;
}
}
if(ishashtable(v)){
sl_htable *h = totable(v);
assert(n != 0 || h->i == 0);
void **table = h->table;
for(; h->i < h->size; h->i += 2){
if(table[h->i+1] != HT_NOTFOUND)
break;
}
if(h->i < h->size){
PUSH((sl_v)table[h->i]);
pargs++;
PUSH((sl_v)table[h->i+1]);
h->i += 2;
continue;
}
h->i = 0;
}
POPN(pargs+1);
return sl_void;
}
_applyn(pargs);
POPN(pargs+1);
}
}
BUILTIN("sleep", sl_sleep)
{
if(nargs > 1)
argcount(nargs, 1);
double s = nargs > 0 ? todouble(args[0]) : 0;
sleep_ms(s * 1000.0);
return sl_void;
}
BUILTIN("vm-stats", vm_stats)
{
USED(args);
argcount(nargs, 0);
sl_ios *io = toio(sym_value(sl_iooutsym));
ios_printf(io, "heap total %10"PRIuPTR" bytes\n", slg.heapsize);
ios_printf(io, "heap free %10"PRIuPTR" bytes\n", (uintptr)(slg.lim-slg.curheap));
ios_printf(io, "heap used %10"PRIuPTR" bytes\n", (uintptr)(slg.curheap-slg.fromspace));
ios_printf(io, "stack %10"PRIu64" bytes\n", (u64int)sl.nstack*sizeof(sl_v));
ios_printf(io, "finalizers %10"PRIu32"\n", (u32int)slg.nfinalizers);
ios_printf(io, "max finalizers %10"PRIu32"\n", (u32int)slg.maxfinalizers);
ios_printf(io, "gc handles %10"PRIu32"\n", (u32int)slg.ngchandles);
ios_printf(io, "gc calls %10"PRIu64"\n", (u64int)slg.gccalls);
ios_printf(io, "opcodes %10d\n", N_OPCODES);
return sl_void;
}
static const sl_builtinspec builtin_fns[] = {
#define BUILTIN_FN(l, c, attr){l, (builtin_t)fn_builtin_##c},
#include "builtin_fns.h"
#undef BUILTIN_FN
};
// initialization -------------------------------------------------------------
int
sl_init(usize heapsize, usize stacksize)
{
int i;
if((slp = MEM_CALLOC(1, sizeof(*slp))) == nil)
return -1;
sl.scr_width = 100;
slg.heapsize = heapsize*sizeof(sl_v);
if((slg.fromspace = sl_segalloc(slg.heapsize)) == nil){
failed:
MEM_FREE(sl.consflags);
MEM_FREE(slg.finalizers);
sl_segfree(slg.fromspace, slg.heapsize);
sl_segfree(slg.tospace, slg.heapsize);
sl_segfree(sl.stack, stacksize*sizeof(sl_v));
htable_free(&sl.printconses);
MEM_FREE(slp);
return -1;
}
if((slg.tospace = sl_segalloc(slg.heapsize)) == nil)
goto failed;
slg.curheap = slg.fromspace;
slg.lim = slg.curheap+slg.heapsize-sizeof(sl_cons);
if((sl.stack = sl_segalloc(stacksize*sizeof(sl_v))) == nil)
goto failed;
sl.curr_frame = sl.sp = sl.stack;
sl.nstack = stacksize;
slg.maxfinalizers = 512;
if((slg.finalizers = MEM_ALLOC(slg.maxfinalizers * sizeof(*slg.finalizers))) == nil)
goto failed;
if((sl.consflags = bitvector_new(slg.heapsize/sizeof(sl_cons), 1)) == nil)
goto failed;
if((htable_new(&sl.printconses, 32)) == nil)
goto failed;
comparehash_init();
sl_lambda = mk_csym("λ");
sl_quote = mk_csym("quote");
sl_trycatch = mk_csym("trycatch");
sl_backquote = mk_csym("quasiquote");
sl_comma = mk_csym("unquote");
sl_commaat = mk_csym("unquote-splicing");
sl_commadot = mk_csym("unquote-nsplicing");
sl_errio = mk_csym("io-error");
sl_errparse = mk_csym("parse-error");
sl_errtype = mk_csym("type-error");
sl_errarg = mk_csym("arg-error");
sl_errunbound = mk_csym("unbound-error");
sl_errkey = mk_csym("key-error");
sl_errmem = mk_csym("memory-error");
sl_errconst = mk_csym("const-error");
sl_errbounds = mk_csym("bounds-error");
sl_errdiv0 = mk_csym("divide-error");
sl_err = mk_csym("error");
sl_conssym = mk_csym("cons");
sl_symsym = mk_csym("symbol");
sl_fixnumsym = mk_csym("fixnum");
sl_vecsym = mk_csym("vec");
sl_builtinsym = mk_csym("builtin");
sl_booleansym = mk_csym("boolean");
sl_nullsym = mk_csym("null");
sl_defsym = mk_csym("def");
sl_defmacrosym = mk_csym("defmacro");
sl_forsym = mk_csym("for");
sl_setqsym = mk_csym("set!");
sl_evalsym = mk_csym("eval");
sl_vu8sym = mk_csym("vu8");
sl_fnsym = mk_csym("fn");
sl_trimsym = mk_csym(":trim");
sl_nulsym = mk_csym("nul");
sl_alarmsym = mk_csym("alarm");
sl_backspacesym = mk_csym("backspace");
sl_tabsym = mk_csym("tab");
sl_linefeedsym = mk_csym("linefeed");
sl_vtabsym = mk_csym("vtab");
sl_pagesym = mk_csym("page");
sl_returnsym = mk_csym("return");
sl_escsym = mk_csym("esc");
sl_spacesym = mk_csym("space");
sl_deletesym = mk_csym("delete");
sl_newlinesym = mk_csym("newline");
sl_builtinssym = mk_csym("*builtins*");
set(sl_printprettysym = mk_csym("*print-pretty*"), sl_t);
set(sl_printreadablysym = mk_csym("*print-readably*"), sl_t);
set(sl_printwidthsym = mk_csym("*print-width*"), fixnum(sl.scr_width));
set(sl_printlengthsym = mk_csym("*print-length*"), sl_nil);
set(sl_printlevelsym = mk_csym("*print-level*"), sl_nil);
sl.lasterror = sl_nil;
for(i = 0; i < nelem(builtins); i++){
if(builtins[i].name)
set(mk_sym(builtins[i].name, false), builtin(i));
}
sl_emptyvec = tagptr(alloc_words(1), TAG_VEC);
vec_setsize(sl_emptyvec, 0);
cvalues_init();
set(mk_csym("*os-name*"), cvalue_static_cstr(__os_name__));
#if defined(__os_version__)
set(mk_csym("*os-version*"), cvalue_static_cstr(__os_version__));
#endif
sl_erroom = mk_list2(sl_errmem, cvalue_static_cstr("out of memory"));
const sl_builtinspec *b;
for(i = 0, b = builtin_fns; i < nelem(builtin_fns); i++, b++)
cbuiltin(b->name, b->fptr);
table_init();
io_init();
compress_init();
sys_init();
return 0;
}
// top level ------------------------------------------------------------------
sl_v
sl_toplevel_eval(sl_v expr)
{
return sl_applyn(1, sym_value(sl_evalsym), expr);
}
int
sl_load_system_image(sl_v sys_image_io)
{
slg.loading = true;
PUSH(sys_image_io);
sl_v *saveSP = sl.sp;
SL_TRY{
while(1){
sl.sp = saveSP;
sl_v e = sl_read_sexpr(sl.sp[-1]);
if(ios_eof(value2c(sl_ios*, sl.sp[-1])))
break;
if(isfn(e)){
// stage 0 format: series of thunks
PUSH(e);
(void)_applyn(0);
}else{
// stage 1 format: list alternating symbol/value
while(iscons(e)){
sl_sym *sym = tosym(car_(e));
e = cdr_(e);
if(sym->binding != UNBOUND)
ios_printf(ios_stderr, "%s redefined on boot\n", sym->name);
sym->binding = car_(e);
e = cdr_(e);
}
break;
}
}
}
SL_CATCH_NO_INC{
ios_puts(ios_stderr, "fatal error during bootstrap: ");
sl_print(ios_stderr, sl.lasterror);
ios_putc(ios_stderr, '\n');
return -1;
}
sl.sp = saveSP-1;
slg.loading = false;
return 0;
}