[Guile-commits] 01/01: Avoid generating arity-adapting zero-value conts where possible

[Andy Wingo]

wingo pushed a commit to branch stable-2.2
in repository guile.

commit 19c0e302430af50d1b41316b929159d592f27ce3
Author: Andy Wingo <address@hidden>
Date:   Thu Nov 30 18:42:35 2017 +0100

    Avoid generating arity-adapting zero-value conts where possible
    
    * module/language/tree-il/compile-cps.scm (adapt-arity, convert): Avoid
      generating arity-adapting continuations for nullary continuations.
---
 module/language/tree-il/compile-cps.scm | 39 ++++++++++++++++++++++++++++-----
 1 file changed, 33 insertions(+), 6 deletions(-)

diff --git a/module/language/tree-il/compile-cps.scm 
b/module/language/tree-il/compile-cps.scm
index 4c71dc7..6afbc17 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -252,6 +252,7 @@
                          ($continue k src ($values (unspecified))))))
           (letk kvoid ($kargs () () ,body))
           kvoid))
+       (($ $kargs ()) (with-cps cps k))
        (($ $kreceive arity kargs)
         (match arity
           (($ $arity () () (not #f) () #f)
@@ -322,6 +323,26 @@
 
 ;; cps exp k-name alist -> cps term
 (define (convert cps exp k subst)
+  (define (zero-valued? exp)
+    (match exp
+      ((or ($ <module-set>) ($ <toplevel-set>) ($ <toplevel-define>)
+           ($ <lexical-set>))
+       #t)
+      (($ <let> src names syms vals body) (zero-valued? body))
+      ;; Can't use <fix> here as the hack that <fix> uses to convert its
+      ;; functions relies on continuation being single-valued.
+      ;; (($ <fix> src names syms vals body) (zero-valued? body))
+      (($ <let-values> src exp body) (zero-valued? body))
+      (($ <seq> src head tail) (zero-valued? tail))
+      (($ <primcall> src name args)
+       (match (prim-instruction name)
+         (#f #f)
+         (inst
+          (match (prim-arity inst)
+            ((out . in)
+             (and (eqv? out 0)
+                  (eqv? in (length args))))))))
+      (_ #f)))
   (define (single-valued? exp)
     (match exp
       ((or ($ <void>) ($ <const>) ($ <primitive-ref>) ($ <module-ref>)
@@ -330,6 +351,7 @@
       (($ <let> src names syms vals body) (single-valued? body))
       (($ <fix> src names syms vals body) (single-valued? body))
       (($ <let-values> src exp body) (single-valued? body))
+      (($ <seq> src head tail) (single-valued? tail))
       (($ <primcall> src name args)
        (match (prim-instruction name)
          (#f #f)
@@ -845,12 +867,17 @@
                 ($continue k src ($primcall 'box-set! (box exp))))))))))
 
     (($ <seq> src head tail)
-     (with-cps cps
-       (let$ tail (convert tail k subst))
-       (letv vals)
-       (letk kseq ($kargs ('vals) (vals) ,tail))
-       (letk kreceive ($kreceive '() 'vals kseq))
-       ($ (convert head kreceive subst))))
+     (if (zero-valued? head)
+         (with-cps cps
+           (let$ tail (convert tail k subst))
+           (letk kseq ($kargs () () ,tail))
+           ($ (convert head kseq subst)))
+         (with-cps cps
+           (let$ tail (convert tail k subst))
+           (letv vals)
+           (letk kseq ($kargs ('vals) (vals) ,tail))
+           (letk kreceive ($kreceive '() 'vals kseq))
+           ($ (convert head kreceive subst)))))
 
     (($ <let> src names syms vals body)
      (let lp ((cps cps) (names names) (syms syms) (vals vals))