Bailouts can continue directly to tail

* module/language/cps/compile-bytecode.scm (compile-function): Allow a
  'throw primcall in tail position.
* module/language/cps/prune-bailouts.scm (prune-bailouts): Continue
  directly to the nearest tail continuation, so we don't cause
  unreachable handle-interrupts / return 0 instructions to be emitted.
* module/language/cps/reify-primitives.scm (reify-clause): Residualized
  'throw primcall continues directly to tail.
* module/language/cps/verify.scm (check-arities): Relax check for
  'throw.

module/language/cps/compile-bytecode.scm

@@ -125,7 +125,9 @@
          (for-each (match-lambda
                     ((src . dst) (emit-mov asm (from-sp dst) (from-sp src))))
                    (lookup-parallel-moves label allocation))
-         (emit-return-values asm (1+ (length args))))))
+         (emit-return-values asm (1+ (length args))))
+        (($ $primcall (or 'throw 'throw/value 'throw/value+data))
+         (compile-effect label exp #f))))
 
     (define (compile-value label exp dst)
       (match exp

module/language/cps/prune-bailouts.scm

@@ -51,23 +51,20 @@ unreferenced terms.  In that case TAIL-LABEL is either absent or #f."
 
 (define (prune-bailouts conts)
   (let ((tails (compute-tails conts)))
-    (with-fresh-name-state conts
+    (persistent-intmap
-      (persistent-intmap
+     (intmap-fold
-       (intmap-fold
+      (lambda (label cont out)
-        (lambda (label cont out)
+        (match cont
-          (match cont
+          (($ $kargs names vars
-            (($ $kargs names vars
+              ($ $continue k src
-                ($ $continue k src
+                 (and exp ($ $primcall
-                   (and exp ($ $primcall
+                             (or 'throw 'throw/value 'throw/value+data)))))
-                               (or 'throw 'throw/value 'throw/value+data)))))
+           (match (intmap-ref tails k (lambda (_) #f))
-             (match (intmap-ref tails k (lambda (_) #f))
+             (#f out)
-               (#f out)
+             (ktail
-               (ktail
+              (with-cps out
-                (with-cps out
+                (setk label ($kargs names vars
-                  (letk knil ($kargs () ()
+                              ($continue ktail src ,exp)))))))
-                               ($continue ktail src ($values ()))))
+          (_ out)))
-                  (setk label ($kargs names vars
+      conts
-                                ($continue knil src ,exp)))))))
+      conts))))
-            (_ out)))
-        conts
-        conts)))))

module/language/cps/reify-primitives.scm

@@ -100,12 +100,11 @@
 
 (define (reify-clause cps ktail)
   (with-cps cps
-    (letk knil ($kargs () () ($continue ktail #f ($values ()))))
     (let$ body
           (with-cps-constants ((wna 'wrong-number-of-args)
                                (args '(#f "Wrong number of arguments" () #f)))
             (build-term
-              ($continue knil #f
+              ($continue ktail #f
                 ($primcall 'throw #f (wna args))))))
     (letk kbody ($kargs () () ,body))
     (letk kclause ($kclause ('() '() #f '() #f) kbody #f))

module/language/cps/verify.scm

@@ -255,7 +255,8 @@ definitions that are available at LABEL."
           (when (false-if-exception (prim-arity name))
             (error "primitive should continue to $kargs, not $kreceive" name)))
          (($ $ktail)
-          (error "primitive should continue to $kargs, not $ktail" name))))
+          (unless (memv name '(throw throw/value throw/value+data))
+            (error "primitive should continue to $kargs, not $ktail" name)))))
       (($ $prompt escape? tag handler)
        (assert-nullary)
        (match (intmap-ref conts handler)