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.

src/boot/boot.janet

@@ -263,6 +263,21 @@
     (++ i))
   ~(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
   [binding start stop step comparison delta body]
   (with-syms [i s]

src/core/asm.c

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

src/core/bytecode.c

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

src/core/cfuns.c

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

src/core/compile.h

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

src/core/corelib.c

@@ -855,6 +855,10 @@ static const uint32_t bnot_asm[] = {
     JOP_BNOT,
     JOP_RETURN
 };
+static const uint32_t propagate_asm[] = {
+    JOP_PROPAGATE | (1 << 24),
+    JOP_RETURN
+};
 #endif /* ifndef JANET_NO_BOOTSTRAP */
 
 JanetTable *janet_core_env(JanetTable *replacements) {
@@ -862,6 +866,13 @@ JanetTable *janet_core_env(JanetTable *replacements) {
     janet_core_cfuns(env, NULL, corelib_cfuns);
 
 #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,
                     "debug", 0, 0, 0, 1, debug_asm, sizeof(debug_asm),
                     JDOC("(debug)\n\n"

src/core/specials.c

@@ -675,6 +675,9 @@ static JanetSlot janetc_fn(JanetFopts opts, int32_t argn, const Janet *argv) {
         goto error;
     }
 
+    /* Keep track of destructured parameters */
+    JanetSlot *destructed_params = NULL;
+
     /* Compile function parameters */
     params = janet_unwrap_tuple(argv[parami]);
     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));
             }
         } 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;
     if (!seenopt) min_arity = arity;
 

src/core/vm.c

@@ -245,6 +245,7 @@ static JanetSignal run_vm(JanetFiber *fiber, Janet in, JanetFiberStatus status)
         &&label_JOP_TAILCALL,
         &&label_JOP_RESUME,
         &&label_JOP_SIGNAL,
+        &&label_JOP_PROPAGATE,
         &&label_JOP_GET,
         &&label_JOP_PUT,
         &&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
      * breakpoint. */
     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;
         pc++;
     }
@@ -673,6 +676,18 @@ static JanetSignal run_vm(JanetFiber *fiber, Janet in, JanetFiberStatus status)
         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_commit();
     janet_put(stack[A], stack[B], stack[C]);

src/include/janet.h

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

test/suite7.janet

@@ -88,4 +88,21 @@
 (assert (peg/match p "abc") "complex peg grammar 1")
 (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)