Add new "throw" VM ops

* libguile/throw.h (scm_ithrow, scm_throw): Mark as SCM_NORETURN.
* libguile/throw.c (scm_throw, scm_ithrow): Adapt to not return.
* libguile/vm-engine.c (throw, throw/value, throw/value+data): New
  instructions.
* libguile/vm.c (vm_throw, vm_throw_with_value)
  (vm_throw_with_value_and_data): New helpers.
* module/language/cps/compile-bytecode.scm (compile-function): Add cases
  for new instructions.
* module/language/cps/prune-bailouts.scm (prune-bailouts): More simple,
  now that there are no $kreceives in play.
* module/language/cps/reify-primitives.scm (reify-clause): Update
  reification of no-clause functions to use new throw op.
* module/language/tree-il/compile-cps.scm (convert): Convert invocations
  of the variable-arity 'throw primitive from Tree-IL to the new
  fixed-arity CPS instructions.
* module/system/vm/assembler.scm (emit-throw/value*)
  (emit-throw/value+data*, emit-throw): Export new instructions.
* module/system/vm/disassembler.scm (code-annotation): Add annotation.

libguile/throw.c

@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2017 Free Software Foundation, Inc.
  * 
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -263,7 +263,9 @@ scm_with_throw_handler (SCM key, SCM thunk, SCM handler)
 SCM
 scm_throw (SCM key, SCM args)
 {
-  return scm_apply_1 (scm_variable_ref (throw_var), key, args);
+  scm_apply_1 (scm_variable_ref (throw_var), key, args);
+  /* Should not be reached.  */
+  abort ();
 }
 
 
@@ -608,7 +610,7 @@ scm_handle_by_throw (void *handler_data SCM_UNUSED, SCM tag, SCM args)
 SCM
 scm_ithrow (SCM key, SCM args, int no_return SCM_UNUSED)
 {
-  return scm_throw (key, args);
+  scm_throw (key, args);
 }
 
 SCM_SYMBOL (scm_stack_overflow_key, "stack-overflow");

libguile/throw.h

@@ -3,7 +3,7 @@
 #ifndef SCM_THROW_H
 #define SCM_THROW_H
 
-/* Copyright (C) 1995,1996,1998,2000, 2006, 2008, 2010, 2014 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000, 2006, 2008, 2010, 2014, 2017 Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -84,7 +84,7 @@ SCM_API int scm_exit_status (SCM args);
 SCM_API SCM scm_catch_with_pre_unwind_handler (SCM tag, SCM thunk, SCM handler, SCM lazy_handler);
 SCM_API SCM scm_catch (SCM tag, SCM thunk, SCM handler);
 SCM_API SCM scm_with_throw_handler (SCM tag, SCM thunk, SCM handler);
-SCM_API SCM scm_ithrow (SCM key, SCM args, int no_return);
+SCM_API SCM scm_ithrow (SCM key, SCM args, int no_return) SCM_NORETURN;
 
 /* This throws to the `stack-overflow' key, without running pre-unwind
    handlers.  */
@@ -94,7 +94,7 @@ SCM_API void scm_report_stack_overflow (void);
    handlers.  */
 SCM_API void scm_report_out_of_memory (void);
 
-SCM_API SCM scm_throw (SCM key, SCM args);
+SCM_API SCM scm_throw (SCM key, SCM args) SCM_NORETURN;
 SCM_INTERNAL void scm_init_throw (void);
 
 #endif  /* SCM_THROW_H */

libguile/vm-engine.c

@@ -931,12 +931,82 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
    * Function prologues
    */
 
-  VM_DEFINE_OP (18, unused_18, NULL, NOP)
+  /* throw key:12 args:12
-  VM_DEFINE_OP (19, unused_19, NULL, NOP)
+   *
-  VM_DEFINE_OP (20, unused_20, NULL, NOP)
+   * Throw to KEY and ARGS.  ARGS should be a list.
+   */
+  VM_DEFINE_OP (18, throw, "throw", OP1 (X8_S12_S12))
     {
-      vm_error_bad_instruction (op);
+      scm_t_uint16 a, b;
-      abort ();
+      SCM key, args;
+
+      UNPACK_12_12 (op, a, b);
+
+      key = SP_REF (a);
+      args = SP_REF (b);
+
+      SYNC_IP ();
+      vm_throw (key, args);
+
+      abort (); /* never reached */
+    }
+
+  /* throw/value val:24 key-subr-and-message:32
+   *
+   * Raise an error, indicating VAL as the bad value.
+   * KEY-SUBR-AND-MESSAGE should be a vector, where the first element is
+   * the symbol to which to throw, the second is the procedure in which
+   * to signal the error (a string) or #f, and the third is a format
+   * string for the message, with one template.
+   */
+  VM_DEFINE_OP (19, throw_value, "throw/value", OP2 (X8_S24, N32))
+    {
+      scm_t_uint32 a;
+      scm_t_int32 offset;
+      scm_t_bits key_subr_and_message_bits;
+      SCM val, key_subr_and_message;
+
+      UNPACK_24 (op, a);
+      val = SP_REF (a);
+
+      offset = ip[1];
+      key_subr_and_message_bits = (scm_t_bits) (ip + offset);
+      VM_ASSERT (!(key_subr_and_message_bits & 0x7), abort());
+      key_subr_and_message = SCM_PACK (key_subr_and_message_bits);
+
+      SYNC_IP ();
+      vm_throw_with_value (val, key_subr_and_message);
+
+      abort (); /* never reached */
+    }
+
+  /* throw/value+data val:24 key-subr-and-message:32
+   *
+   * Raise an error, indicating VAL as the bad value.
+   * KEY-SUBR-AND-MESSAGE should be a vector, where the first element is
+   * the symbol to which to throw, the second is the procedure in which
+   * to signal the error (a string) or #f, and the third is a format
+   * string for the message, with one template.
+   */
+  VM_DEFINE_OP (20, throw_value_and_data, "throw/value+data", OP2 (X8_S24, N32))
+    {
+      scm_t_uint32 a;
+      scm_t_int32 offset;
+      scm_t_bits key_subr_and_message_bits;
+      SCM val, key_subr_and_message;
+
+      UNPACK_24 (op, a);
+      val = SP_REF (a);
+
+      offset = ip[1];
+      key_subr_and_message_bits = (scm_t_bits) (ip + offset);
+      VM_ASSERT (!(key_subr_and_message_bits & 0x7), abort());
+      key_subr_and_message = SCM_PACK (key_subr_and_message_bits);
+
+      SYNC_IP ();
+      vm_throw_with_value_and_data (val, key_subr_and_message);
+
+      abort (); /* never reached */
     }
 
   /* assert-nargs-ee expected:24

libguile/vm.c

@@ -418,6 +418,10 @@ vm_reinstate_partial_continuation (struct scm_vm *vp, SCM cont, size_t nargs,
  * VM Error Handling
  */
 
+static void vm_throw (SCM key, SCM args) SCM_NORETURN;
+static void vm_throw_with_value (SCM val, SCM key_subr_and_message) SCM_NORETURN SCM_NOINLINE;
+static void vm_throw_with_value_and_data (SCM val, SCM key_subr_and_message) SCM_NORETURN SCM_NOINLINE;
+
 static void vm_error (const char *msg, SCM arg) SCM_NORETURN;
 static void vm_error_bad_instruction (scm_t_uint32 inst) SCM_NORETURN SCM_NOINLINE;
 static void vm_error_unbound (SCM sym) SCM_NORETURN SCM_NOINLINE;
@@ -447,13 +451,47 @@ static void vm_error_not_enough_values (void) SCM_NORETURN SCM_NOINLINE;
 static void vm_error_wrong_number_of_values (scm_t_uint32 expected) SCM_NORETURN SCM_NOINLINE;
 static void vm_error_continuation_not_rewindable (SCM cont) SCM_NORETURN SCM_NOINLINE;
 
+static void
+vm_throw (SCM key, SCM args)
+{
+  scm_throw (key, args);
+  abort(); /* not reached */
+}
+
+static void
+vm_throw_with_value (SCM val, SCM key_subr_and_message)
+{
+  SCM key, subr, message, args, data;
+
+  key = SCM_SIMPLE_VECTOR_REF (key_subr_and_message, 0);
+  subr = SCM_SIMPLE_VECTOR_REF (key_subr_and_message, 1);
+  message = SCM_SIMPLE_VECTOR_REF (key_subr_and_message, 2);
+  args = scm_list_1 (val);
+  data = SCM_BOOL_F;
+
+  vm_throw (key, scm_list_4 (subr, message, args, data));
+}
+
+static void
+vm_throw_with_value_and_data (SCM val, SCM key_subr_and_message)
+{
+  SCM key, subr, message, args, data;
+
+  key = SCM_SIMPLE_VECTOR_REF (key_subr_and_message, 0);
+  subr = SCM_SIMPLE_VECTOR_REF (key_subr_and_message, 1);
+  message = SCM_SIMPLE_VECTOR_REF (key_subr_and_message, 2);
+  args = scm_list_1 (val);
+  data = args;
+
+  vm_throw (key, scm_list_4 (subr, message, args, data));
+}
+
 static void
 vm_error (const char *msg, SCM arg)
 {
-  scm_throw (sym_vm_error,
+  vm_throw (sym_vm_error,
-             scm_list_3 (sym_vm_run, scm_from_latin1_string (msg),
+            scm_list_3 (sym_vm_run, scm_from_latin1_string (msg),
-                         SCM_UNBNDP (arg) ? SCM_EOL : scm_list_1 (arg)));
+                        SCM_UNBNDP (arg) ? SCM_EOL : scm_list_1 (arg)));
-  abort(); /* not reached */
 }
 
 static void

module/language/cps/compile-bytecode.scm

@@ -375,7 +375,13 @@
         (($ $primcall 'atomic-box-set! #f (box val))
          (emit-atomic-box-set! asm (from-sp (slot box)) (from-sp (slot val))))
         (($ $primcall 'handle-interrupts #f ())
-         (emit-handle-interrupts asm))))
+         (emit-handle-interrupts asm))
+        (($ $primcall 'throw #f (key args))
+         (emit-throw asm (from-sp (slot key)) (from-sp (slot args))))
+        (($ $primcall 'throw/value param (val))
+         (emit-throw/value asm (from-sp (slot val)) param))
+        (($ $primcall 'throw/value+data param (val))
+         (emit-throw/value+data asm (from-sp (slot val)) param))))
 
     (define (compile-values label exp syms)
       (match exp

module/language/cps/prune-bailouts.scm

@@ -49,22 +49,6 @@ unreferenced terms.  In that case TAIL-LABEL is either absent or #f."
    conts
    empty-intmap))
 
-(define (prune-bailout out tails k src exp)
-  (match (intmap-ref out k)
-    (($ $ktail)
-     (with-cps out #f))
-    (_
-     (match (intmap-ref tails k (lambda (_) #f))
-       (#f
-        (with-cps out #f))
-       (ktail
-        (with-cps out
-          (letv prim rest)
-          (letk kresult ($kargs ('rest) (rest)
-                          ($continue ktail src ($values ()))))
-          (letk kreceive ($kreceive '() 'rest kresult))
-          (build-term ($continue kreceive src ,exp))))))))
-
 (define (prune-bailouts conts)
   (let ((tails (compute-tails conts)))
     (with-fresh-name-state conts
@@ -73,13 +57,17 @@ unreferenced terms.  In that case TAIL-LABEL is either absent or #f."
         (lambda (label cont out)
           (match cont
             (($ $kargs names vars
-                ($ $continue k src (and exp ($ $primcall 'throw))))
+                ($ $continue k src
-             (call-with-values (lambda () (prune-bailout out tails k src exp))
+                   (and exp ($ $primcall
-               (lambda (out term)
+                               (or 'throw 'throw/value 'throw/value+data)))))
-                 (if term
+             (match (intmap-ref tails k (lambda (_) #f))
-                     (let ((cont (build-cont ($kargs names vars ,term))))
+               (#f out)
-                       (intmap-replace! out label cont))
+               (ktail
-                     out))))
+                (with-cps out
+                  (letk knil ($kargs () ()
+                               ($continue ktail src ($values ()))))
+                  (setk label ($kargs names vars
+                                ($continue knil src ,exp)))))))
             (_ out)))
         conts
         conts)))))

module/language/cps/reify-primitives.scm

@@ -100,17 +100,13 @@
 
 (define (reify-clause cps ktail)
   (with-cps cps
-    (letv throw)
+    (letk knil ($kargs () () ($continue ktail #f ($values ()))))
-    (let$ throw-body
+    (let$ body
           (with-cps-constants ((wna 'wrong-number-of-args)
-                               (false #f)
+                               (args '(#f "Wrong number of arguments" () #f)))
-                               (str "Wrong number of arguments")
-                               (eol '()))
             (build-term
-              ($continue ktail #f
+              ($continue knil #f
-                ($call throw (wna false str eol false))))))
+                ($primcall 'throw #f (wna args))))))
-    (letk kthrow ($kargs ('throw) (throw) ,throw-body))
-    (let$ body (primitive-ref 'throw kthrow #f))
     (letk kbody ($kargs () () ,body))
     (letk kclause ($kclause ('() '() #f '() #f) kbody #f))
     kclause))

module/language/tree-il/compile-cps.scm

@@ -533,6 +533,41 @@
                                            ($primcall 'cons #f (head tail))))))))
                       (letk ktail ($kargs ('tail) (tail) ,body))
                       ($ (lp args ktail)))))))))))
+      ((eq? name 'throw)
+       (let ()
+         (define (fallback)
+           (match args
+             ((key . args)
+              (convert-args cps (list key (make-primcall src 'list args))
+                (lambda (cps args)
+                  (with-cps cps
+                    (let$ k (adapt-arity k src 0))
+                    (build-term
+                      ($continue k src ($primcall 'throw #f args)))))))))
+         (define (specialize op param . args)
+           (convert-args cps args
+             (lambda (cps args)
+               (with-cps cps
+                 (let$ k (adapt-arity k src 0))
+                 (build-term
+                   ($continue k src ($primcall op param args)))))))
+         (match args
+           ((($ <const> _ key) ($ <const> _ subr) ($ <const> _ msg) args data)
+            ;; Specialize `throw' invocations corresponding to common
+            ;; "error" invocations.
+            (let ()
+              (match (vector args data)
+                (#(($ <primcall> _ 'list (x)) ($ <primcall> _ 'list (x)))
+                 (specialize 'throw/value+data `#(,key ,subr ,msg) x))
+                (#(($ <primcall> _ 'cons (x ($ <const> _ ())))
+                   ($ <primcall> _ 'cons (x ($ <const> _ ()))))
+                 (specialize 'throw/value+data `#(,key ,subr ,msg) x))
+                (#(($ <primcall> _ 'list (x)) ($ <const> _ #f))
+                 (specialize 'throw/value `#(,key ,subr ,msg) x))
+                (#(($ <primcall> _ 'cons (x ($ <const> _ ()))) ($ <const> _ #f))
+                 (specialize 'throw/value `#(,key ,subr ,msg) x))
+                (_ (fallback)))))
+           (_ (fallback)))))
       ((prim-instruction name)
        => (lambda (instruction)
             (define (box+adapt-arity cps k src out)
@@ -1131,6 +1166,9 @@ integer."
        (($ <primcall> src 'logand (($ <primcall> _ 'lognot (y)) x))
         (make-primcall src 'logsub (list x y)))
 
+       (($ <primcall> src 'throw ())
+        (make-call src (make-primitive-ref src 'throw) '()))
+
        (($ <prompt> src escape-only? tag body
            ($ <lambda> hsrc hmeta
               ($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f)))

module/system/vm/assembler.scm

@@ -99,6 +99,10 @@
 
             emit-untag-fixnum
 
+            emit-throw
+            (emit-throw/value* . emit-throw/value)
+            (emit-throw/value+data* . emit-throw/value+data)
+
             emit-pair?
             emit-struct?
             emit-symbol?
@@ -975,6 +979,12 @@ later by the linker."
         (emit-fmov* asm dst (1+ proc))
         (emit-reset-frame asm nlocals))))
 
+(define (emit-throw/value* asm val param)
+  (emit-throw/value asm val (intern-non-immediate asm param)))
+
+(define (emit-throw/value+data* asm val param)
+  (emit-throw/value+data asm val (intern-non-immediate asm param)))
+
 (define (emit-text asm instructions)
   "Assemble @var{instructions} using the assembler @var{asm}.
 @var{instructions} is a sequence of instructions, expressed as a list of

module/system/vm/disassembler.scm

@@ -260,6 +260,8 @@ address of that offset."
        (when (program? val)
          (push-addr! (program-code val) val))
        (list "~@Y" val)))
+    (((or 'throw/value 'throw/value+data) dst target)
+     (list "~@Y" (reference-scm target)))
     (('builtin-ref dst idx)
      (list "~A" (builtin-index->name idx)))
     (((or 'static-ref 'static-set!) _ target)
@@ -511,6 +513,7 @@ address of that offset."
 (define (instruction-has-fallthrough? code pos)
   (define non-fallthrough-set
     (static-opcode-set halt
+                       throw throw/value throw/value+data
                        tail-call tail-call-label tail-call/shuffle
                        return-values
                        subr-call foreign-call continuation-call