[Guile-commits] 01/01: Avoid generating arity-adapting continuations if not needed

[Andy Wingo]

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

commit 83042571c1281d7fffb8882b3cfdd6dbaa19dbe0
Author: Andy Wingo <address@hidden>
Date:   Thu Nov 30 18:15:01 2017 +0100

    Avoid generating arity-adapting continuations if not needed
    
    * module/language/tree-il/compile-cps.scm (adapt-arity): Allow k to be
      $kargs for the 1-valued case.
      (convert): For single-valued continuations where the definition is
      clearly single-valued, avoid making a needless $kreceive and extra
      "rest" binding that will just be filled with () and have to be
      eliminated later.
---
 module/language/tree-il/compile-cps.scm | 42 ++++++++++++++++++++++++++++-----
 1 file changed, 36 insertions(+), 6 deletions(-)

diff --git a/module/language/tree-il/compile-cps.scm 
b/module/language/tree-il/compile-cps.scm
index 3e1c1d4..4c71dc7 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 2014, 2015, 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
@@ -289,6 +289,7 @@
           (letk kval ($kargs ('val) (val)
                        ($continue k src ($values (val)))))
           kval))
+       (($ $kargs (_)) (with-cps cps k))
        (($ $kreceive arity kargs)
         (match arity
           (($ $arity () () (not #f) () #f)
@@ -321,6 +322,23 @@
 
 ;; cps exp k-name alist -> cps term
 (define (convert cps exp k subst)
+  (define (single-valued? exp)
+    (match exp
+      ((or ($ <void>) ($ <const>) ($ <primitive-ref>) ($ <module-ref>)
+           ($ <toplevel-ref>) ($ <lambda>))
+       #t)
+      (($ <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))
+      (($ <primcall> src name args)
+       (match (prim-instruction name)
+         (#f #f)
+         (inst
+          (match (prim-arity inst)
+            ((out . in)
+             (and (eqv? out 1)
+                  (eqv? in (length args))))))))
+      (_ #f)))
   ;; exp (v-name -> term) -> term
   (define (convert-arg cps exp k)
     (match exp
@@ -334,7 +352,13 @@
             (build-term ($continue kunboxed src ($primcall 'box-ref (box))))))
          ((orig-var subst-var #f) (k cps subst-var))
          (var (k cps var))))
-      (else
+      ((? single-valued?)
+       (with-cps cps
+         (letv arg)
+         (let$ body (k arg))
+         (letk karg ($kargs ('arg) (arg) ,body))
+         ($ (convert exp karg subst))))
+      (_
        (with-cps cps
          (letv arg rest)
          (let$ body (k arg))
@@ -836,10 +860,16 @@
           (with-cps cps
             (let$ body (lp names syms vals))
             (let$ body (box-bound-var name sym body))
-            (letv rest)
-            (letk klet ($kargs (name 'rest) ((bound-var sym) rest) ,body))
-            (letk kreceive ($kreceive (list name) 'rest klet))
-            ($ (convert val kreceive subst)))))))
+            ($ ((lambda (cps)
+                  (if (single-valued? val)
+                      (with-cps cps
+                        (letk klet ($kargs (name) ((bound-var sym)) ,body))
+                        ($ (convert val klet subst)))
+                      (with-cps cps
+                        (letv rest)
+                        (letk klet ($kargs (name 'rest) ((bound-var sym) rest) 
,body))
+                        (letk kreceive ($kreceive (list name) 'rest klet))
+                        ($ (convert val kreceive subst))))))))))))
 
     (($ <fix> src names gensyms funs body)
      ;; Some letrecs can be contified; that happens later.