[Guile-commits] 01/08: Bailouts can continue directly to tail

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 9db628ee296d85e385b5b33dee70ddfa91af4b7d
Author: Andy Wingo <address@hidden>
Date:   Tue Dec 5 14:25:12 2017 +0100

    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 |  4 +++-
 module/language/cps/prune-bailouts.scm   | 37 +++++++++++++++-----------------
 module/language/cps/reify-primitives.scm |  3 +--
 module/language/cps/verify.scm           |  3 ++-
 4 files changed, 23 insertions(+), 24 deletions(-)

diff --git a/module/language/cps/compile-bytecode.scm 
b/module/language/cps/compile-bytecode.scm
index 0baa309..b4daf69 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/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
diff --git a/module/language/cps/prune-bailouts.scm 
b/module/language/cps/prune-bailouts.scm
index dece1a0..5d2f7c3 100644
--- a/module/language/cps/prune-bailouts.scm
+++ b/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
-       (intmap-fold
-        (lambda (label cont out)
-          (match cont
-            (($ $kargs names vars
-                ($ $continue k src
-                   (and exp ($ $primcall
-                               (or 'throw 'throw/value 'throw/value+data)))))
-             (match (intmap-ref tails k (lambda (_) #f))
-               (#f out)
-               (ktail
-                (with-cps out
-                  (letk knil ($kargs () ()
-                               ($continue ktail src ($values ()))))
-                  (setk label ($kargs names vars
-                                ($continue knil src ,exp)))))))
-            (_ out)))
-        conts
-        conts)))))
+    (persistent-intmap
+     (intmap-fold
+      (lambda (label cont out)
+        (match cont
+          (($ $kargs names vars
+              ($ $continue k src
+                 (and exp ($ $primcall
+                             (or 'throw 'throw/value 'throw/value+data)))))
+           (match (intmap-ref tails k (lambda (_) #f))
+             (#f out)
+             (ktail
+              (with-cps out
+                (setk label ($kargs names vars
+                              ($continue ktail src ,exp)))))))
+          (_ out)))
+      conts
+      conts))))
diff --git a/module/language/cps/reify-primitives.scm 
b/module/language/cps/reify-primitives.scm
index 71e1ba9..e5b92e3 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/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))
diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm
index e55cf83..67a8304 100644
--- a/module/language/cps/verify.scm
+++ b/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)