module/language/tree-il/inline.scm

   1 ;;; a simple inliner
   2
   3 ;; Copyright (C) 2009 Free Software Foundation, Inc.
   4
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 (define-module (language tree-il inline)
  20   #:use-module (system base pmatch)
  21   #:use-module (system base syntax)
  22   #:use-module (language tree-il)
  23   #:export (inline!))
  24
  25 ;; Possible optimizations:
  26 ;; * constant folding, propagation
  27 ;; * procedure inlining
  28 ;;   * always when single call site
  29 ;;   * always for "trivial" procs
  30 ;;   * otherwise who knows
  31 ;; * dead code elimination
  32 ;; * degenerate case optimizations
  33 ;; * "fixing letrec"
  34
  35 ;; This is a completely brain-dead optimization pass whose sole claim to
  36 ;; fame is ((lambda () x)) => x.
  37 (define (inline! x)
  38   (define (inline1 x)
  39     (record-case x
  40       ((<application> src proc args)
  41        (record-case proc
  42          ;; ((lambda (y ...) x) z ...) => (let ((y z) ...) x)
  43          ((<lambda> body)
  44           (let lp ((lcase body))
  45             (and lcase
  46                  (record-case lcase
  47                    ((<lambda-case> req opt rest kw inits vars body else)
  48                     (if (and (= (length vars) (length req) (length args)))
  49                         (let ((x (make-let src req vars args body)))
  50                           (or (inline1 x) x))
  51                         (lp else)))))))
  52
  53          ;; (call-with-values (lambda () foo) (lambda (a b . c) bar))
  54          ;; => (let-values (((a b . c) foo)) bar)
  55          ;;
  56          ;; Note that this is a singly-binding form of let-values. Also
  57          ;; note that Scheme's let-values expands into call-with-values,
  58          ;; then here we reduce it to tree-il's let-values.
  59          ((<primitive-ref> name)
  60           (and (eq? name '@call-with-values)
  61                (pmatch args
  62                  ((,producer ,consumer)
  63                   (guard (lambda? consumer)
  64                          (lambda-case? (lambda-body consumer))
  65                          (not (lambda-case-opt (lambda-body consumer)))
  66                          (not (lambda-case-kw (lambda-body consumer)))
  67                          (not (lambda-case-else (lambda-body consumer))))
  68                   (make-let-values
  69                    src
  70                    (let ((x (make-application src producer '())))
  71                      (or (inline1 x) x))
  72                    (lambda-body consumer)))
  73                  (else #f))))
  74
  75          (else #f)))
  76
  77       ((<let> vars body)
  78        (if (null? vars) body x))
  79
  80       ((<letrec> vars body)
  81        (if (null? vars) body x))
  82
  83       ((<fix> vars body)
  84        (if (null? vars) body x))
  85
  86       (else #f)))
  87   (post-order! inline1 x))