1
0
mirror of https://github.com/janet-lang/janet synced 2024-11-28 11:09:54 +00:00

Add propagate function and opcode

This allows better stacktraces when manually intercepting
signals to clean up resources. Also allows functionality
from Common Lisp's unwind-protect, such as calling cleanup code
while unwindinding the stack, restarting on certain signals, and
just in general having more control over signal and signal propagation.

Also fix a bug encountered while implementing with-resource in the
compiler. Desturcturing arguments that were not the last argument
would often result in bad code generation, as slots used to destructure
the earlier arguments would invalidate the later parameters. This is
fixed by allocating all named parameters before doing any destructuring.
This commit is contained in:
Calvin Rose 2019-06-24 12:44:13 -04:00
parent 8d1e6ddffc
commit b8032ec61d
10 changed files with 84 additions and 3 deletions

View File

@ -263,6 +263,21 @@
(++ i)) (++ i))
~(let (,;accum) ,;body)) ~(let (,;accum) ,;body))
(defmacro with-resource
"Evaluate body with some resource, which will be automatically cleaned up
if there is an error in body. binding is bound to the expression ctor, and
dtor is a function or callable that is passed the binding. If no destructor
(dtor) is given, will call :close on the resource."
[[binding ctor dtor] & body]
(with-syms [res f]
~(let [,binding ,ctor
,f (,fiber/new (fn [] ,;body) :ie)
,res (,resume ,f)]
(,(or dtor :close) ,binding)
(if (,= (,fiber/status ,f) :error)
(,propagate ,res ,f)
,res))))
(defn- for-template (defn- for-template
[binding start stop step comparison delta body] [binding start stop step comparison delta body]
(with-syms [i s] (with-syms [i s]

View File

@ -112,6 +112,7 @@ static const JanetInstructionDef janet_ops[] = {
{"mul", JOP_MULTIPLY}, {"mul", JOP_MULTIPLY},
{"mulim", JOP_MULTIPLY_IMMEDIATE}, {"mulim", JOP_MULTIPLY_IMMEDIATE},
{"noop", JOP_NOOP}, {"noop", JOP_NOOP},
{"prop", JOP_PROPAGATE},
{"push", JOP_PUSH}, {"push", JOP_PUSH},
{"push2", JOP_PUSH_2}, {"push2", JOP_PUSH_2},
{"push3", JOP_PUSH_3}, {"push3", JOP_PUSH_3},

View File

@ -79,6 +79,7 @@ enum JanetInstructionType janet_instructions[JOP_INSTRUCTION_COUNT] = {
JINT_S, /* JOP_TAILCALL, */ JINT_S, /* JOP_TAILCALL, */
JINT_SSS, /* JOP_RESUME, */ JINT_SSS, /* JOP_RESUME, */
JINT_SSU, /* JOP_SIGNAL, */ JINT_SSU, /* JOP_SIGNAL, */
JINT_SSS, /* JOP_PROPAGATE */
JINT_SSS, /* JOP_GET, */ JINT_SSS, /* JOP_GET, */
JINT_SSS, /* JOP_PUT, */ JINT_SSS, /* JOP_PUT, */
JINT_SSU, /* JOP_GET_INDEX, */ JINT_SSU, /* JOP_GET_INDEX, */

View File

@ -92,6 +92,9 @@ static JanetSlot opreduce(
/* Function optimizers */ /* Function optimizers */
static JanetSlot do_propagate(JanetFopts opts, JanetSlot *args) {
return opreduce(opts, args, JOP_PROPAGATE, janet_wrap_nil());
}
static JanetSlot do_error(JanetFopts opts, JanetSlot *args) { static JanetSlot do_error(JanetFopts opts, JanetSlot *args) {
janetc_emit_s(opts.compiler, JOP_ERROR, args[0], 0); janetc_emit_s(opts.compiler, JOP_ERROR, args[0], 0);
return janetc_cslot(janet_wrap_nil()); return janetc_cslot(janet_wrap_nil());
@ -297,7 +300,8 @@ static const JanetFunOptimizer optimizers[] = {
{NULL, do_gte}, {NULL, do_gte},
{NULL, do_lte}, {NULL, do_lte},
{NULL, do_eq}, {NULL, do_eq},
{NULL, do_neq} {NULL, do_neq},
{fixarity2, do_propagate}
}; };
const JanetFunOptimizer *janetc_funopt(uint32_t flags) { const JanetFunOptimizer *janetc_funopt(uint32_t flags) {

View File

@ -60,6 +60,7 @@
#define JANET_FUN_LTE 29 #define JANET_FUN_LTE 29
#define JANET_FUN_EQ 30 #define JANET_FUN_EQ 30
#define JANET_FUN_NEQ 31 #define JANET_FUN_NEQ 31
#define JANET_FUN_PROP 32
/* Compiler typedefs */ /* Compiler typedefs */
typedef struct JanetCompiler JanetCompiler; typedef struct JanetCompiler JanetCompiler;

View File

@ -855,6 +855,10 @@ static const uint32_t bnot_asm[] = {
JOP_BNOT, JOP_BNOT,
JOP_RETURN JOP_RETURN
}; };
static const uint32_t propagate_asm[] = {
JOP_PROPAGATE | (1 << 24),
JOP_RETURN
};
#endif /* ifndef JANET_NO_BOOTSTRAP */ #endif /* ifndef JANET_NO_BOOTSTRAP */
JanetTable *janet_core_env(JanetTable *replacements) { JanetTable *janet_core_env(JanetTable *replacements) {
@ -862,6 +866,13 @@ JanetTable *janet_core_env(JanetTable *replacements) {
janet_core_cfuns(env, NULL, corelib_cfuns); janet_core_cfuns(env, NULL, corelib_cfuns);
#ifdef JANET_BOOTSTRAP #ifdef JANET_BOOTSTRAP
janet_quick_asm(env, JANET_FUN_PROP,
"propagate", 2, 2, 2, 2, propagate_asm, sizeof(propagate_asm),
JDOC("(propagate x fiber)\n\n"
"Propagate a signal from a fiber to the current fiber. The resulting "
"stack trace from the current fiber will include frames from fiber. If "
"fiber is in a state that can be resumed, resuming the current fiber will "
"first resume fiber."));
janet_quick_asm(env, JANET_FUN_DEBUG, janet_quick_asm(env, JANET_FUN_DEBUG,
"debug", 0, 0, 0, 1, debug_asm, sizeof(debug_asm), "debug", 0, 0, 0, 1, debug_asm, sizeof(debug_asm),
JDOC("(debug)\n\n" JDOC("(debug)\n\n"

View File

@ -675,6 +675,9 @@ static JanetSlot janetc_fn(JanetFopts opts, int32_t argn, const Janet *argv) {
goto error; goto error;
} }
/* Keep track of destructured parameters */
JanetSlot *destructed_params = NULL;
/* Compile function parameters */ /* Compile function parameters */
params = janet_unwrap_tuple(argv[parami]); params = janet_unwrap_tuple(argv[parami]);
paramcount = janet_tuple_length(params); paramcount = janet_tuple_length(params);
@ -726,10 +729,22 @@ static JanetSlot janetc_fn(JanetFopts opts, int32_t argn, const Janet *argv) {
janetc_nameslot(c, janet_unwrap_symbol(param), janetc_farslot(c)); janetc_nameslot(c, janet_unwrap_symbol(param), janetc_farslot(c));
} }
} else { } else {
destructure(c, param, janetc_farslot(c), defleaf, NULL); janet_v_push(destructed_params, janetc_farslot(c));
} }
} }
/* Compile destructed params */
int32_t j = 0;
for (i = 0; i < paramcount; i++) {
Janet param = params[i];
if (!janet_checktype(param, JANET_SYMBOL)) {
JanetSlot reg = destructed_params[j++];
destructure(c, param, reg, defleaf, NULL);
janetc_freeslot(c, reg);
}
}
janet_v_free(destructed_params);
max_arity = (vararg || allow_extra) ? INT32_MAX : arity; max_arity = (vararg || allow_extra) ? INT32_MAX : arity;
if (!seenopt) min_arity = arity; if (!seenopt) min_arity = arity;

View File

@ -245,6 +245,7 @@ static JanetSignal run_vm(JanetFiber *fiber, Janet in, JanetFiberStatus status)
&&label_JOP_TAILCALL, &&label_JOP_TAILCALL,
&&label_JOP_RESUME, &&label_JOP_RESUME,
&&label_JOP_SIGNAL, &&label_JOP_SIGNAL,
&&label_JOP_PROPAGATE,
&&label_JOP_GET, &&label_JOP_GET,
&&label_JOP_PUT, &&label_JOP_PUT,
&&label_JOP_GET_INDEX, &&label_JOP_GET_INDEX,
@ -277,7 +278,9 @@ static JanetSignal run_vm(JanetFiber *fiber, Janet in, JanetFiberStatus status)
* DO NOT use input when resuming a fiber that has been interrupted at a * DO NOT use input when resuming a fiber that has been interrupted at a
* breakpoint. */ * breakpoint. */
if (status != JANET_STATUS_NEW && if (status != JANET_STATUS_NEW &&
((*pc & 0xFF) == JOP_SIGNAL || (*pc & 0xFF) == JOP_RESUME)) { ((*pc & 0xFF) == JOP_SIGNAL ||
(*pc & 0xFF) == JOP_PROPAGATE ||
(*pc & 0xFF) == JOP_RESUME)) {
stack[A] = in; stack[A] = in;
pc++; pc++;
} }
@ -673,6 +676,18 @@ static JanetSignal run_vm(JanetFiber *fiber, Janet in, JanetFiberStatus status)
vm_return(s, stack[B]); vm_return(s, stack[B]);
} }
VM_OP(JOP_PROPAGATE) {
Janet fv = stack[C];
vm_assert_type(fv, JANET_FIBER);
JanetFiber *f = janet_unwrap_fiber(fv);
JanetFiberStatus status = janet_fiber_status(f);
if (status > JANET_STATUS_USER9) {
vm_throw("cannot propagate from new or alive fiber");
}
janet_vm_fiber->child = f;
vm_return((int) status, stack[B]);
}
VM_OP(JOP_PUT) VM_OP(JOP_PUT)
vm_commit(); vm_commit();
janet_put(stack[A], stack[B], stack[C]); janet_put(stack[A], stack[B], stack[C]);

View File

@ -1014,6 +1014,7 @@ enum JanetOpCode {
JOP_TAILCALL, JOP_TAILCALL,
JOP_RESUME, JOP_RESUME,
JOP_SIGNAL, JOP_SIGNAL,
JOP_PROPAGATE,
JOP_GET, JOP_GET,
JOP_PUT, JOP_PUT,
JOP_GET_INDEX, JOP_GET_INDEX,

View File

@ -88,4 +88,21 @@
(assert (peg/match p "abc") "complex peg grammar 1") (assert (peg/match p "abc") "complex peg grammar 1")
(assert (peg/match p "[1 2 3 4]") "complex peg grammar 2") (assert (peg/match p "[1 2 3 4]") "complex peg grammar 2")
#
# fn compilation special
#
(defn myfn1 [[x y z] & more]
more)
(defn myfn2 [head & more]
more)
(assert (= (myfn1 [1 2 3] 4 5 6) (myfn2 [:a :b :c] 4 5 6)) "destructuring and varargs")
#
# Test propagation of signals via fibers
#
(def f (fiber/new (fn [] (error :abc) 1) :ei))
(def res (resume f))
(assert-error :abc (propagate res f) "propagate 1")
(end-suite) (end-suite)