diff --git a/Makefile b/Makefile index d522430d..8da79642 100644 --- a/Makefile +++ b/Makefile @@ -25,7 +25,7 @@ PREFIX?=/usr/local BINDIR=$(PREFIX)/bin -CFLAGS=-std=c99 -Wall -Wextra -Isrc/include -Os -s +CFLAGS=-std=c99 -Wall -Wextra -Isrc/include -O3 -s CLIBS=-lm -ldl PREFIX=/usr/local DST_TARGET=dst diff --git a/src/compiler/boot.dst b/src/compiler/boot.dst index 5f007bd3..d734ecc0 100644 --- a/src/compiler/boot.dst +++ b/src/compiler/boot.dst @@ -2,7 +2,7 @@ # Copyright 2018 (C) Calvin Rose (var *env* - "The current environment. Is dynamically bound." + "The current environment." _env) (def defn :macro @@ -39,6 +39,7 @@ (apply1 tuple (array-concat ['defn name :private] more))) +# Basic predicates (defn even? [x] (== 0 (% x 2))) (defn odd? [x] (== 1 (% x 2))) (defn nil? [x] (= x nil)) @@ -46,8 +47,6 @@ (defn pos? [x] (> x 0)) (defn neg? [x] (< x 0)) (defn one? [x] (== x 1)) -(defn inc [x] (+ x 1)) -(defn dec [x] (- x 1)) (def atomic? (do (def non-atomic-types { :array true @@ -57,7 +56,9 @@ }) (fn [x] (not (get non-atomic-types (type x)))))) -# C style macros for imperative sugar +# C style macros and functions for imperative sugar +(defn inc [x] (+ x 1)) +(defn dec [x] (- x 1)) (defmacro ++ [x] (tuple ':= x (tuple + x 1))) (defmacro -- [x] (tuple ':= x (tuple - x 1))) (defmacro += [x n] (tuple ':= x (tuple + x n))) @@ -266,6 +267,10 @@ If no match is found, returns nil" ret) }) +(defn partial [f & more] + (if (zero? (length more)) f + (fn [& r] (apply1 f (array-concat [] more r))))) + (defmacro for [head & body] (def head (ast-unwrap1 head)) (def sym (get head 0)) @@ -281,6 +286,23 @@ If no match is found, returns nil" (tuple-prepend body 'do) (tuple ':= sym (tuple '+ sym inc))))) +(defn juxt* + [& funs] + (def len (length funs)) + (fn [& args] + (def ret []) + (for [i 0 len] + (array-push ret (apply1 (get funs i) args))) + (apply1 tuple ret))) + +(defmacro juxt + [& funs] + (def parts ['tuple]) + (def $args (gensym)) + (for [i 0 (length funs)] + (array-push parts (tuple apply1 (get funs i) $args))) + (tuple 'fn ['& $args] (apply1 tuple parts))) + (defmacro -> [x & forms] (defn fop [last nextform] @@ -514,11 +536,36 @@ onvalue." (def res (resume f)) (if good (if (= (fiber-status f) :error) - (onerr "runtime" res) + (onerr "runtime" res f) (onvalue res)))) (foreach (val-stream chunks onerr) doone) env))) +(defn default-error-handler + [t x f] + (print) + (file-write stdout "error: ") + (pp x) + (when f + (def st (fiber-stack f)) + (def len (length st)) + (for [i 0 len] + (def { + :function func + :tail tail + :pc pc + :c c + :name name + } (get st i)) + (file-write stdout " in") + (when c (file-write stdout " cfunction")) + (when name (file-write stdout (string " " name))) + (when func (file-write stdout (string " " func))) + (when pc (file-write stdout (string " (pc=" pc ")"))) + (when tail (file-write stdout " (tailcall)")) + (file-write stdout "\n"))) + (print)) + (def require (do (def cache @{}) (def loading @{}) @@ -534,8 +581,7 @@ onvalue." (defn chunks [buf] (file-read f 1024 buf)) (def oldenv *env*) (:= *env* newenv) - (run-context newenv chunks identity - (fn [t x] (print (string t " error: " x)))) + (run-context newenv chunks identity default-error-handler) (file-close f) (:= *env* oldenv) (put loading path nil) @@ -551,7 +597,7 @@ onvalue." (put env (symbol (if prefix prefix "") k) v))))) (defmacro import [path & args] - (apply1 tuple (array-concat [import* '_env path] args))) + (apply tuple import* '_env path args)) (defn repl [getchunk] (def newenv (make-env)) @@ -562,5 +608,5 @@ onvalue." (defn onvalue [x] (put newenv '_ @{:value x}) (pp x)) - (run-context newenv (if getchunk getchunk chunks) onvalue - (fn [t x] (print (string t " error: " x))))) + (run-context newenv (if getchunk getchunk chunks) + onvalue default-error-handler)) diff --git a/src/compiler/specials.c b/src/compiler/specials.c index bdca0db9..86209adc 100644 --- a/src/compiler/specials.c +++ b/src/compiler/specials.c @@ -589,6 +589,7 @@ DstSlot dstc_fn(DstFopts opts, DstAst *ast, int32_t argn, const Dst *argv) { def = dstc_pop_funcdef(c); def->arity = arity; if (varargs) def->flags |= DST_FUNCDEF_FLAG_VARARG; + if (selfref) def->name = dst_unwrap_symbol(head); defindex = dstc_addfuncdef(c, def); /* Ensure enough slots for vararg function. */ diff --git a/src/compiler/stl.c b/src/compiler/stl.c index 96013e4b..eb7f23c1 100644 --- a/src/compiler/stl.c +++ b/src/compiler/stl.c @@ -41,8 +41,6 @@ static const DstReg cfuns[] = { {"array", dst_core_array}, {"tuple", dst_core_tuple}, {"struct", dst_core_struct}, - {"fiber", dst_core_fiber}, - {"fiber-status", dst_core_fiber_status}, {"buffer", dst_core_buffer}, {"gensym", dst_core_gensym}, {"get", dst_core_get}, @@ -110,6 +108,7 @@ DstTable *dst_stl_env() { dst_lib_tuple(args); dst_lib_buffer(args); dst_lib_table(args); + dst_lib_fiber(args); dst_lib_parse(args); dst_lib_compile(args); dst_lib_asm(args); diff --git a/src/core/bytecode.c b/src/core/bytecode.c index 1a6ec168..c8b3536a 100644 --- a/src/core/bytecode.c +++ b/src/core/bytecode.c @@ -215,6 +215,7 @@ DstFuncDef *dst_funcdef_alloc() { def->source = NULL; def->sourcepath = NULL; def->sourcemap = NULL; + def->name = NULL; def->defs = NULL; def->defs_length = 0; def->constants_length = 0; diff --git a/src/core/corelib.c b/src/core/corelib.c index 190de25c..6b534cc4 100644 --- a/src/core/corelib.c +++ b/src/core/corelib.c @@ -134,15 +134,6 @@ int dst_core_struct(DstArgs args) { return dst_return(args, dst_wrap_struct(dst_struct_end(st))); } -int dst_core_fiber(DstArgs args) { - DstFiber *fiber; - if (args.n < 1) return dst_throw(args, "expected at least 1 argument"); - if (!dst_checktype(args.v[0], DST_FUNCTION)) - return dst_throw(args, "expected a function"); - fiber = dst_fiber(dst_unwrap_function(args.v[0]), 64); - return dst_return(args, dst_wrap_fiber(fiber)); -} - int dst_core_gensym(DstArgs args) { if (args.n > 1) return dst_throw(args, "expected one argument"); if (args.n == 0) { @@ -198,33 +189,6 @@ int dst_core_setproto(DstArgs args) { return dst_return(args, args.v[0]); } -int dst_core_fiber_status(DstArgs args) { - const char *status = ""; - if (args.n != 1) return dst_throw(args, "expected 1 argument"); - if (!dst_checktype(args.v[0], DST_FIBER)) return dst_throw(args, "expected fiber"); - switch(dst_unwrap_fiber(args.v[0])->status) { - case DST_FIBER_PENDING: - status = ":pending"; - break; - case DST_FIBER_NEW: - status = ":new"; - break; - case DST_FIBER_ALIVE: - status = ":alive"; - break; - case DST_FIBER_DEAD: - status = ":dead"; - break; - case DST_FIBER_ERROR: - status = ":error"; - break; - case DST_FIBER_DEBUG: - status = ":debug"; - break; - } - return dst_return(args, dst_csymbolv(status)); -} - int dst_core_put(DstArgs args) { Dst ds, key, value; DstArgs subargs = args; diff --git a/src/core/fiber.c b/src/core/fiber.c index fe30539e..bab9262f 100644 --- a/src/core/fiber.c +++ b/src/core/fiber.c @@ -133,6 +133,7 @@ void dst_fiber_funcframe(DstFiber *fiber, DstFunction *func) { newframe->pc = func->def->bytecode; newframe->func = func; newframe->env = NULL; + newframe->flags = 0; /* Check varargs */ if (func->def->flags & DST_FUNCDEF_FLAG_VARARG) { @@ -211,6 +212,7 @@ void dst_fiber_funcframe_tail(DstFiber *fiber, DstFunction *func) { /* Set frame stuff */ dst_fiber_frame(fiber)->func = func; dst_fiber_frame(fiber)->pc = func->def->bytecode; + dst_fiber_frame(fiber)->flags |= DST_STACKFRAME_TAILCALL; } /* Push a stack frame to a fiber for a c function */ @@ -235,6 +237,7 @@ void dst_fiber_cframe(DstFiber *fiber) { newframe->pc = NULL; newframe->func = NULL; newframe->env = NULL; + newframe->flags = 0; } /* Pop a stack frame from the fiber. Returns the new stack frame, or @@ -251,3 +254,108 @@ void dst_fiber_popframe(DstFiber *fiber) { fiber->stacktop = fiber->stackstart = fiber->frame; fiber->frame = frame->prevframe; } + +/* CFuns */ + +static int cfun_fiber(DstArgs args) { + DstFiber *fiber; + if (args.n < 1) return dst_throw(args, "expected at least 1 argument"); + if (!dst_checktype(args.v[0], DST_FUNCTION)) + return dst_throw(args, "expected a function"); + fiber = dst_fiber(dst_unwrap_function(args.v[0]), 64); + return dst_return(args, dst_wrap_fiber(fiber)); +} + +static int cfun_status(DstArgs args) { + const char *status = ""; + if (args.n != 1) return dst_throw(args, "expected 1 argument"); + if (!dst_checktype(args.v[0], DST_FIBER)) return dst_throw(args, "expected fiber"); + switch(dst_unwrap_fiber(args.v[0])->status) { + case DST_FIBER_PENDING: + status = ":pending"; + break; + case DST_FIBER_NEW: + status = ":new"; + break; + case DST_FIBER_ALIVE: + status = ":alive"; + break; + case DST_FIBER_DEAD: + status = ":dead"; + break; + case DST_FIBER_ERROR: + status = ":error"; + break; + case DST_FIBER_DEBUG: + status = ":debug"; + break; + } + return dst_return(args, dst_csymbolv(status)); +} + +/* Extract info from one stack frame */ +static Dst doframe(DstStackFrame *frame) { + int32_t off; + DstTable *t = dst_table(3); + DstFuncDef *def = NULL; + if (frame->func) { + dst_table_put(t, dst_csymbolv(":function"), dst_wrap_function(frame->func)); + def = frame->func->def; + if (def->name) { + dst_table_put(t, dst_csymbolv(":name"), dst_wrap_string(def->name)); + } + } else { + dst_table_put(t, dst_csymbolv(":c"), dst_wrap_true()); + } + if (frame->flags & DST_STACKFRAME_TAILCALL) { + dst_table_put(t, dst_csymbolv(":tail"), dst_wrap_true()); + } + if (frame->pc) { + off = frame->pc - def->bytecode; + dst_table_put(t, dst_csymbolv(":pc"), dst_wrap_integer(off)); + if (def->sourcemap) { + DstSourceMapping mapping = def->sourcemap[off]; + dst_table_put(t, dst_csymbolv(":source-start"), dst_wrap_integer(mapping.start)); + dst_table_put(t, dst_csymbolv(":source-end"), dst_wrap_integer(mapping.end)); + } + if (def->source) { + dst_table_put(t, dst_csymbolv(":source"), dst_wrap_string(def->source)); + } else if (def->sourcepath) { + dst_table_put(t, dst_csymbolv(":sourcepath"), dst_wrap_string(def->sourcepath)); + } + } + return dst_wrap_table(t); +} + +static int cfun_stack(DstArgs args) { + DstFiber *fiber; + DstArray *array; + if (args.n != 1) return dst_throw(args, "expected 1 argument"); + if (!dst_checktype(args.v[0], DST_FIBER)) return dst_throw(args, "expected fiber"); + fiber = dst_unwrap_fiber(args.v[0]); + array = dst_array(0); + { + int32_t i = fiber->frame; + DstStackFrame *frame; + while (i > 0) { + frame = (DstStackFrame *)(fiber->data + i - DST_FRAME_SIZE); + dst_array_push(array, doframe(frame)); + i = frame->prevframe; + } + } + return dst_return(args, dst_wrap_array(array)); +} + +static const DstReg cfuns[] = { + {"fiber", cfun_fiber}, + {"fiber-status", cfun_status}, + {"fiber-stack", cfun_stack}, + {NULL, NULL} +}; + +/* Module entry point */ +int dst_lib_fiber(DstArgs args) { + DstTable *env = dst_env_arg(args); + dst_env_cfuns(env, cfuns); + return 0; +} diff --git a/src/core/gc.c b/src/core/gc.c index dfc9b6e0..fa80a5d8 100644 --- a/src/core/gc.c +++ b/src/core/gc.c @@ -162,6 +162,8 @@ static void dst_mark_funcdef(DstFuncDef *def) { dst_mark_string(def->source); if (def->sourcepath) dst_mark_string(def->sourcepath); + if (def->name) + dst_mark_string(def->name); } static void dst_mark_function(DstFunction *func) { diff --git a/src/core/string.c b/src/core/string.c index a2e8df23..79bafda5 100644 --- a/src/core/string.c +++ b/src/core/string.c @@ -103,21 +103,21 @@ const uint8_t *dst_cstring(const char *str) { } /* Temporary buffer size */ -#define DST_BUFSIZE 36 +#define BUFSIZE 36 static int32_t real_to_string_impl(uint8_t *buf, double x) { /* Use 16 decimal places to ignore one ulp errors for now */ - int count = snprintf((char *) buf, DST_BUFSIZE, "%.16gR", x); + int count = snprintf((char *) buf, BUFSIZE, "%.16gR", x); return (int32_t) count; } static void real_to_string_b(DstBuffer *buffer, double x) { - dst_buffer_ensure(buffer, buffer->count + DST_BUFSIZE); + dst_buffer_ensure(buffer, buffer->count + BUFSIZE); buffer->count += real_to_string_impl(buffer->data + buffer->count, x); } static const uint8_t *real_to_string(double x) { - uint8_t buf[DST_BUFSIZE]; + uint8_t buf[BUFSIZE]; return dst_string(buf, real_to_string_impl(buf, x)); } @@ -152,12 +152,12 @@ static int32_t integer_to_string_impl(uint8_t *buf, int32_t x) { } static void integer_to_string_b(DstBuffer *buffer, int32_t x) { - dst_buffer_extra(buffer, DST_BUFSIZE); + dst_buffer_extra(buffer, BUFSIZE); buffer->count += integer_to_string_impl(buffer->data + buffer->count, x); } static const uint8_t *integer_to_string(int32_t x) { - uint8_t buf[DST_BUFSIZE]; + uint8_t buf[BUFSIZE]; return dst_string(buf, integer_to_string_impl(buf, x)); } @@ -191,19 +191,19 @@ static int32_t string_description_impl(uint8_t *buf, const char *title, void *po } static void string_description_b(DstBuffer *buffer, const char *title, void *pointer) { - dst_buffer_ensure(buffer, buffer->count + DST_BUFSIZE); + dst_buffer_ensure(buffer, buffer->count + BUFSIZE); buffer->count += string_description_impl(buffer->data + buffer->count, title, pointer); } /* Describes a pointer with a title (string_description("bork", myp) returns * a string "") */ static const uint8_t *string_description(const char *title, void *pointer) { - uint8_t buf[DST_BUFSIZE]; + uint8_t buf[BUFSIZE]; return dst_string(buf, string_description_impl(buf, title, pointer)); } #undef HEX -#undef DST_BUFSIZE +#undef BUFSIZE /* TODO - add more characters to escape. * diff --git a/src/include/dst/dstcorelib.h b/src/include/dst/dstcorelib.h index b59c78e9..180f9087 100644 --- a/src/include/dst/dstcorelib.h +++ b/src/include/dst/dstcorelib.h @@ -87,7 +87,6 @@ int dst_core_tuple(DstArgs args); int dst_core_array(DstArgs args); int dst_core_table(DstArgs args); int dst_core_struct(DstArgs args); -int dst_core_fiber(DstArgs args); int dst_core_buffer(DstArgs args); int dst_core_gensym(DstArgs args); int dst_core_length(DstArgs args); @@ -95,8 +94,6 @@ int dst_core_get(DstArgs args); int dst_core_rawget(DstArgs args); int dst_core_getproto(DstArgs args); int dst_core_setproto(DstArgs args); -int dst_core_fiber_status(DstArgs args); -int dst_core_fiber_location(DstArgs args); int dst_core_put(DstArgs args); int dst_core_gccollect(DstArgs args); int dst_core_gcsetinterval(DstArgs args); @@ -113,6 +110,7 @@ int dst_lib_array(DstArgs args); int dst_lib_tuple(DstArgs args); int dst_lib_buffer(DstArgs args); int dst_lib_table(DstArgs args); +int dst_lib_fiber(DstArgs args); /* Useful for compiler */ Dst dst_op_add(Dst lhs, Dst rhs); diff --git a/src/include/dst/dsttypes.h b/src/include/dst/dsttypes.h index 53a70ff8..7efc59cf 100644 --- a/src/include/dst/dsttypes.h +++ b/src/include/dst/dsttypes.h @@ -335,12 +335,16 @@ struct DstFiber { } status; }; +/* Mark if a stack frame is a tail call for debugging */ +#define DST_STACKFRAME_TAILCALL 1 + /* A stack frame on the fiber. Is stored along with the stack values. */ struct DstStackFrame { DstFunction *func; uint32_t *pc; - int32_t prevframe; DstFuncEnv *env; + int32_t prevframe; + uint32_t flags; }; /* Number of Dsts a frame takes up in the stack */ @@ -395,6 +399,7 @@ struct DstFuncDef { DstSourceMapping *sourcemap; const uint8_t *source; const uint8_t *sourcepath; + const uint8_t *name; uint32_t flags; int32_t slotcount; /* The amount of stack space required for the function */