Revert "implement #:predicate" and remove predicate from <lambda-case>

[bpt/guile.git] / module / language / tree-il / inline.scm

diff --git a/module/language/tree-il/inline.scm b/module/language/tree-il/inline.scm
index adc3f18..facaa38 100644 (file)
--- a/module/language/tree-il/inline.scm
+++ b/module/language/tree-il/inline.scm
@@ -17,6 +17,7 @@
 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 
 (define-module (language tree-il inline)
+  #:use-module (system base pmatch)
   #:use-module (system base syntax)
   #:use-module (language tree-il)
   #:export (inline!))
@@ -34,16 +35,20 @@
 ;; This is a completely brain-dead optimization pass whose sole claim to
 ;; fame is ((lambda () x)) => x.
 (define (inline! x)
-  (post-order!
-   (lambda (x)
-     (record-case x
-       ((<application> src proc args)
-        (cond
-
-         ;; ((lambda () x)) => x
-         ((and (lambda? proc) (null? (lambda-vars proc))
-               (null? args))
-          (lambda-body proc))
+  (define (inline1 x)
+    (record-case x
+      ((<application> src proc args)
+       (record-case proc
+         ;; ((lambda (y ...) x) z ...) => (let ((y z) ...) x)
+         ((<lambda> body)
+          (let lp ((lcase body))
+            (and lcase
+                 (record-case lcase
+                   ((<lambda-case> req opt rest kw inits vars body else)
+                    (if (and (= (length vars) (length req) (length args)))
+                        (let ((x (make-let src req vars args body)))
+                          (or (inline1 x) x))
+                        (lp else)))))))
 
          ;; (call-with-values (lambda () foo) (lambda (a b . c) bar))
          ;; => (let-values (((a b . c) foo)) bar)
@@ -51,31 +56,32 @@
          ;; Note that this is a singly-binding form of let-values. Also
          ;; note that Scheme's let-values expands into call-with-values,
          ;; then here we reduce it to tree-il's let-values.
-         ((and (primitive-ref? proc)
-               (eq? (primitive-ref-name proc) '@call-with-values)
-               (= (length args) 2)
-               (lambda? (cadr args)))
-          (let ((producer (car args))
-                (consumer (cadr args)))
-            (make-let-values src
-                             (lambda-names consumer)
-                             (lambda-vars consumer)
-                             (if (and (lambda? producer)
-                                      (null? (lambda-names producer)))
-                                 (lambda-body producer)
-                                 (make-application src producer '()))
-                             (lambda-body consumer))))
+         ((<primitive-ref> name)
+          (and (eq? name '@call-with-values)
+               (pmatch args
+                 ((,producer ,consumer)
+                  (guard (lambda? consumer)
+                         (lambda-case? (lambda-body consumer))
+                         (not (lambda-case-opt (lambda-body consumer)))
+                         (not (lambda-case-kw (lambda-body consumer)))
+                         (not (lambda-case-else (lambda-body consumer))))
+                  (make-let-values
+                   src
+                   (let ((x (make-application src producer '())))
+                     (or (inline1 x) x))
+                   (lambda-body consumer)))
+                 (else #f))))
 
          (else #f)))
        
-       ((<let> vars body)
-        (if (null? vars) body x))
+      ((<let> vars body)
+       (if (null? vars) body x))
        
-       ((<letrec> vars body)
-        (if (null? vars) body x))
+      ((<letrec> vars body)
+       (if (null? vars) body x))
        
-       ((<fix> vars body)
-        (if (null? vars) body x))
+      ((<fix> vars body)
+       (if (null? vars) body x))
        
-       (else #f)))
-   x))
+      (else #f)))
+  (post-order! inline1 x))