Better simplification of literal constants that continue to branches

[bpt/guile.git] / module / language / cps / elide-values.scm

diff --git a/module/language/cps/elide-values.scm b/module/language/cps/elide-values.scm
index 5835b2a..6823deb 100644 (file)
--- a/module/language/cps/elide-values.scm
+++ b/module/language/cps/elide-values.scm
@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 2014 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
@@ -35,48 +35,76 @@
   #:use-module (language cps dfg)
   #:export (elide-values))
 
-(define (elide-values fun)
-  (let ((conts (build-local-cont-table
-                (match fun (($ $fun src meta free body) body)))))
-    (define (visit-cont cont)
-      (rewrite-cps-cont cont
-        (($ $cont sym ($ $kargs names syms body))
-         (sym ($kargs names syms ,(visit-term body))))
-        (($ $cont sym ($ $kentry self tail clauses))
-         (sym ($kentry self ,tail ,(map visit-cont clauses))))
-        (($ $cont sym ($ $kclause arity body))
-         (sym ($kclause ,arity ,(visit-cont body))))
-        (($ $cont)
-         ,cont)))
-    (define (visit-term term)
-      (rewrite-cps-term term
-        (($ $letk conts body)
-         ($letk ,(map visit-cont conts)
-           ,(visit-term body)))
-        (($ $letrec names syms funs body)
-         ($letrec names syms (map elide-values funs)
-                  ,(visit-term body)))
-        (($ $continue k src ($ $primcall 'values vals))
-         ,(rewrite-cps-term (lookup-cont k conts)
-            (($ $ktail)
-             ($continue k src ($values vals)))
-            (($ $ktrunc ($ $arity req () rest () #f) kargs)
-             ,(if (or rest (< (length vals) (length req)))
-                  term
-                  (let ((vals (list-head vals (length req))))
-                    (build-cps-term
-                      ($continue kargs src ($values vals))))))
-            (($ $kargs args)
-             ,(if (< (length vals) (length args))
-                  term
-                  (let ((vals (list-head vals (length args))))
-                    (build-cps-term
-                      ($continue k src ($values vals))))))))
-        (($ $continue k src (and fun ($ $fun)))
-         ($continue k src ,(elide-values fun)))
-        (($ $continue)
-         ,term)))
-
+(define (elide-values* fun conts)
+  (define (visit-cont cont)
+    (rewrite-cps-cont cont
+      (($ $cont sym ($ $kargs names syms body))
+       (sym ($kargs names syms ,(visit-term body))))
+      (($ $cont sym ($ $kfun src meta self tail clause))
+       (sym ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))
+      (($ $cont sym ($ $kclause arity body alternate))
+       (sym ($kclause ,arity ,(visit-cont body)
+                      ,(and alternate (visit-cont alternate)))))
+      (($ $cont)
+       ,cont)))
+  (define (visit-term term)
+    (rewrite-cps-term term
+      (($ $letk conts body)
+       ($letk ,(map visit-cont conts)
+         ,(visit-term body)))
+      (($ $letrec names syms funs body)
+       ($letrec names syms (map visit-fun funs)
+         ,(visit-term body)))
+      (($ $continue k src ($ $primcall 'values vals))
+       ,(rewrite-cps-term (vector-ref conts k)
+          (($ $ktail)
+           ($continue k src ($values vals)))
+          (($ $kreceive ($ $arity req () rest () #f) kargs)
+           ,(cond
+             ((and (not rest) (= (length vals) (length req)))
+              (build-cps-term
+                ($continue kargs src ($values vals))))
+             ((and rest (>= (length vals) (length req)))
+              (let-fresh (krest) (rest)
+                (let ((vals* (append (list-head vals (length req))
+                                     (list rest))))
+                  (build-cps-term
+                    ($letk ((krest ($kargs ('rest) (rest)
+                                     ($continue kargs src
+                                       ($values vals*)))))
+                      ,(let lp ((tail (list-tail vals (length req)))
+                                (k krest))
+                         (match tail
+                           (()
+                            (build-cps-term ($continue k src
+                                              ($const '()))))
+                           ((v . tail)
+                            (let-fresh (krest) (rest)
+                              (build-cps-term
+                                ($letk ((krest ($kargs ('rest) (rest)
+                                                 ($continue k src
+                                                   ($primcall 'cons
+                                                              (v rest))))))
+                                  ,(lp tail krest))))))))))))
+             (else term)))
+          (($ $kargs args)
+           ,(if (< (length vals) (length args))
+                term
+                (let ((vals (list-head vals (length args))))
+                  (build-cps-term
+                    ($continue k src ($values vals))))))))
+      (($ $continue k src (and fun ($ $fun)))
+       ($continue k src ,(visit-fun fun)))
+      (($ $continue)
+       ,term)))
+  (define (visit-fun fun)
     (rewrite-cps-exp fun
-      (($ $fun src meta free body)
-       ($fun src meta free ,(visit-cont body))))))
+      (($ $fun free cont)
+       ($fun free ,(visit-cont cont)))))
+
+  (visit-cont fun))
+
+(define (elide-values fun)
+  (with-fresh-name-state fun
+    (let ((conts (build-cont-table fun)))
+      (elide-values* fun conts))))