[Guile-commits] 13/16: Contification also inlines "elide-values" pass

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit cf1611ef3887cdfe8121aefb578516b7fe106203
Author: Andy Wingo <address@hidden>
Date:   Wed Dec 27 10:57:04 2017 +0100

    Contification also inlines "elide-values" pass
    
    * module/language/cps/contification.scm (apply-contification): Inline
      returns to the corresponding $kargs.
    * module/language/cps/licm.scm (loop-invariant?): Remove handling of
      "values" primcall, as this doesn't exist any more.
---
 module/language/cps/contification.scm | 116 ++++++++++++++++++++++------------
 module/language/cps/licm.scm          |   1 -
 2 files changed, 76 insertions(+), 41 deletions(-)

diff --git a/module/language/cps/contification.scm 
b/module/language/cps/contification.scm
index a913a71..1b1fc62 100644
--- a/module/language/cps/contification.scm
+++ b/module/language/cps/contification.scm
@@ -37,6 +37,7 @@
   #:use-module (language cps utils)
   #:use-module (language cps intmap)
   #:use-module (language cps intset)
+  #:use-module (language cps with-cps)
   #:export (contify))
 
 (define (compute-singly-referenced-labels conts)
@@ -369,72 +370,107 @@ function set."
             (if (arity-matches? arity nargs)
                 body
                 (lp alt))))))))
-  (define (continue k src exp)
+  (define (inline-return cps k* kargs src nreq rest vals)
+    (define (build-list cps k src vals)
+      (match vals
+        (()
+         (with-cps cps
+           (build-term ($continue k src ($const '())))))
+        ((v . vals)
+         (with-cps cps
+           (letv tail)
+           (letk ktail ($kargs ('tail) (tail)
+                         ($continue k src ($primcall 'cons #f (v tail)))))
+           ($ (build-list ktail src vals))))))
+    (cond
+     ((and (not rest) (eqv? (length vals) nreq))
+      (with-cps cps
+        (build-term ($continue kargs src ($values vals)))))
+     ((and rest (<= nreq (length vals)))
+      (with-cps cps
+        (letv rest)
+        (letk krest ($kargs ('rest) (rest)
+                      ($continue kargs src
+                        ($values ,(append (list-head vals nreq)
+                                          (list rest))))))
+        ($ (build-list krest src (list-tail vals nreq)))))
+     (else
+      ;; Fallback case if values don't match.
+      (with-cps cps
+        (letv prim)
+        (letk kprim ($kargs ('prim) (prim)
+                      ($continue k* src ($call prim vals))))
+        (build-term ($continue kprim src ($prim 'values)))))))
+  (define (continue cps k src exp)
     (define (lookup-return-cont k)
       (match (return-subst k)
         (#f k)
         (k (lookup-return-cont k))))
     (let ((k* (lookup-return-cont k)))
       (if (eq? k k*)
-          (build-term ($continue k src ,exp))
+          (with-cps cps (build-term ($continue k src ,exp)))
           ;; We are contifying this return.  It must be a call, a
-          ;; $values expression, or a return primcall.  k* will be
-          ;; either a $ktail or a $kreceive continuation.  CPS has this
-          ;; thing though where $kreceive can't be the target of a
-          ;; $values expression, and "return" can only continue to a
-          ;; tail continuation, so we might have to rewrite to a
-          ;; "values" primcall.
-          (build-term
-            ($continue k* src
-              ,(match (intmap-ref conts k*)
-                 (($ $kreceive)
-                  (match exp
-                    (($ $call) exp)
-                    ;; A primcall that can continue to $ktail can also
-                    ;; continue to $kreceive.
-                    (($ $primcall) exp)
-                    (($ $values vals)
-                     (build-exp ($primcall 'values #f vals)))))
-                 (($ $ktail) exp)))))))
-  (define (visit-exp k src exp)
+          ;; $primcall that can continue to $ktail (basically this is
+          ;; only "throw" and friends), or a $values expression.  k*
+          ;; will be either a $ktail or a $kreceive continuation.
+          (match (intmap-ref conts k*)
+            (($ $kreceive ($ $arity req () rest () #f) kargs)
+             (match exp
+               (($ $call)
+                (with-cps cps (build-term ($continue k* src ,exp))))
+               ;; A primcall that can continue to $ktail can also
+               ;; continue to $kreceive.
+               (($ $primcall)
+                (with-cps cps (build-term ($continue k* src ,exp))))
+               ;; We need to punch through the $kreceive; otherwise we'd
+               ;; have to rewrite as a call to the 'values primitive.
+               (($ $values vals)
+                (inline-return cps k* kargs src (length req) rest vals))))
+            (($ $ktail)
+             (with-cps cps (build-term ($continue k* src ,exp))))))))
+  (define (visit-exp cps k src exp)
     (match exp
       (($ $call proc args)
        ;; If proc is contifiable, replace call with jump.
        (match (call-subst proc)
-         (#f (continue k src exp))
+         (#f (continue cps k src exp))
          (kfun
           (let ((body (find-body kfun (length args))))
-            (build-term ($continue body src ($values args)))))))
+            (with-cps cps
+              (build-term ($continue body src ($values args))))))))
       (($ $fun kfun)
        ;; If the function's tail continuation has been
        ;; substituted, that means it has been contified.
        (if (return-subst (tail-label conts kfun))
-           (continue k src (build-exp ($values ())))
-           (continue k src exp)))
+           (continue cps k src (build-exp ($values ())))
+           (continue cps k src exp)))
       (($ $rec names vars funs)
        (match (filter (match-lambda ((n v f) (not (call-subst v))))
                       (map list names vars funs))
-         (() (continue k src (build-exp ($values ()))))
+         (() (continue cps k src (build-exp ($values ()))))
          (((names vars funs) ...)
-          (continue k src (build-exp ($rec names vars funs))))))
-      (_ (continue k src exp))))
+          (continue cps k src (build-exp ($rec names vars funs))))))
+      (_ (continue cps k src exp))))
 
   ;; Renumbering is not strictly necessary but some passes may not be
   ;; equipped to deal with stale $kfun nodes whose bodies have been
   ;; wired into other functions.
   (renumber
-   (intmap-map
-    (lambda (label cont)
-      (match cont
-        (($ $kargs names vars ($ $continue k src exp))
-         ;; Remove bindings for functions that have been contified.
-         (match (filter (match-lambda ((name var) (not (call-subst var))))
-                        (map list names vars))
-           (((names vars) ...)
-            (build-cont
-              ($kargs names vars ,(visit-exp k src exp))))))
-        (_ cont)))
-    conts)))
+   (with-fresh-name-state conts
+     (intmap-fold
+      (lambda (label cont out)
+        (match cont
+          (($ $kargs names vars ($ $continue k src exp))
+           ;; Remove bindings for functions that have been contified.
+           (match (filter (match-lambda ((name var) (not (call-subst var))))
+                          (map list names vars))
+             (((names vars) ...)
+              (with-cps out
+                (let$ term (visit-exp k src exp))
+                (setk label ($kargs names vars ,term))))))
+          (_ out)))
+      conts
+      conts))))
 
 (define (contify conts)
   ;; FIXME: Renumbering isn't really needed but dead continuations may
diff --git a/module/language/cps/licm.scm b/module/language/cps/licm.scm
index 5d9db9d..3e612a2 100644
--- a/module/language/cps/licm.scm
+++ b/module/language/cps/licm.scm
@@ -70,7 +70,6 @@
        ((or ($ $const) ($ $prim) ($ $closure)) #t)
        (($ $prompt) #f) ;; ?
        (($ $branch) #f)
-       (($ $primcall 'values #f) #f)
        (($ $primcall name param args)
         (and-map (lambda (arg) (not (intset-ref loop-vars arg)))
                  args))