1 files changed, 81 insertions, 0 deletions
diff --git a/module/language/tree-il/inline.scm b/module/language/tree-il/inline.scm
new file mode 100644
index 000000000..adc3f18bd
--- /dev/null
+++ b/module/language/tree-il/inline.scm
@@ -0,0 +1,81 @@
+;;; a simple inliner
+
+;; Copyright (C) 2009 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
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (language tree-il inline)
+  #:use-module (system base syntax)
+  #:use-module (language tree-il)
+  #:export (inline!))
+
+;; Possible optimizations:
+;; * constant folding, propagation
+;; * procedure inlining
+;;   * always when single call site
+;;   * always for "trivial" procs
+;;   * otherwise who knows
+;; * dead code elimination
+;; * degenerate case optimizations
+;; * "fixing letrec"
+
+;; 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))
+
+         ;; (call-with-values (lambda () foo) (lambda (a b . c) bar))
+         ;; => (let-values (((a b . c) foo)) bar)
+         ;;
+         ;; 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))))
+
+         (else #f)))
+       
+       ((<let> vars body)
+        (if (null? vars) body x))
+       
+       ((<letrec> vars body)
+        (if (null? vars) body x))
+       
+       ((<fix> vars body)
+        (if (null? vars) body x))
+       
+       (else #f)))
+   x))