module/language/tree-il/inline.scm

   1 ;;; a simple inliner
   2
   3 ;; Copyright (C) 2009, 2010, 2011 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 (define (boolean-value x)
  36   (let ((src (tree-il-src x)))
  37     (record-case x
  38       ((<void>)
  39        (make-const src #t))
  40
  41       ;; FIXME: This is redundant with what the partial evaluator does.
  42       ((<conditional> test consequent alternate)
  43        (record-case (boolean-value test)
  44          ((<const> exp)
  45           (case exp
  46             ((#t) (boolean-value consequent))
  47             ((#f) (boolean-value alternate))
  48             (else x)))
  49          (else x)))
  50
  51       ((<application> src proc args)
  52        (record-case proc
  53          ;; ((lambda (y ...) x) z ...) => (let ((y z) ...) x)
  54          ((<primitive-ref> name)
  55           (case name
  56             ((memq memv)
  57              (pmatch args
  58                ((,k ,l) (guard (const? l) (list? (const-exp l)))
  59                 (cond
  60                  ((null? (const-exp l))
  61                   (make-const #f #f))
  62                  ((const? k)
  63                   (make-const #f (->bool ((case name
  64                                             ((memq) memq)
  65                                             ((memv) memv)
  66                                             (else (error "unexpected member func" name)))
  67                                           (const-exp k) (const-exp l)))))
  68                  (else
  69                   (let lp ((elts (const-exp l)))
  70                     (let ((test (make-application
  71                                  #f
  72                                  (make-primitive-ref #f (case name
  73                                                           ((memq) 'eq?)
  74                                                           ((memv) 'eqv?)
  75                                                           (else (error "what"))))
  76                                  (list k (make-const #f (car elts))))))
  77                       (if (null? (cdr elts))
  78                           test
  79                           (make-conditional
  80                            src
  81                            test
  82                            (make-const #f #t)
  83                            (lp (cdr elts)))))))))
  84
  85                (else x)))
  86
  87             (else x)))
  88
  89          (else x)))
  90
  91       ((<lambda> meta body)
  92        (make-const src #t))
  93
  94       ((<const> exp)
  95        (make-const src (not (not exp))))
  96
  97       (else
  98        x))))
  99
 100 ;; This is a completely brain-dead optimization pass whose sole claim to
 101 ;; fame is ((lambda () x)) => x.
 102 (define (inline! x)
 103   (define (inline1 x)
 104     (record-case x
 105       ((<application> src proc args)
 106        (record-case proc
 107          ;; ((lambda (y ...) x) z ...) => (let ((y z) ...) x)
 108          ((<lambda> body)
 109           (let lp ((lcase body))
 110             (and lcase
 111                  (record-case lcase
 112                    ((<lambda-case> req opt rest kw inits gensyms body alternate)
 113                     (if (and (= (length gensyms) (length req) (length args)))
 114                         (let ((x (make-let src req gensyms args body)))
 115                           (or (inline1 x) x))
 116                         (lp alternate)))))))
 117
 118          ((<primitive-ref> name)
 119           (case name
 120             ((@call-with-values)
 121              (pmatch args
 122                ;; (call-with-values (lambda () foo) (lambda (a b . c) bar))
 123                ;; => (let-values (((a b . c) foo)) bar)
 124                ;;
 125                ;; Note that this is a singly-binding form of let-values.
 126                ;; Also note that Scheme's let-values expands into
 127                ;; call-with-values, then here we reduce it to tree-il's
 128                ;; let-values.
 129                ((,producer ,consumer)
 130                 (guard (lambda? consumer)
 131                        (lambda-case? (lambda-body consumer))
 132                        (not (lambda-case-opt (lambda-body consumer)))
 133                        (not (lambda-case-kw (lambda-body consumer)))
 134                        (not (lambda-case-alternate (lambda-body consumer))))
 135                 (make-let-values
 136                  src
 137                  (let ((x (make-application src producer '())))
 138                    (or (inline1 x) x))
 139                  (lambda-body consumer)))
 140                (else #f)))
 141
 142             (else #f)))
 143
 144          (else #f)))
 145
 146       ((<conditional> test consequent alternate)
 147        (let ((btest (boolean-value test)))
 148          (or (record-case btest
 149                ((<const> exp)
 150                 (case exp
 151                   ((#t) consequent)
 152                   ((#f) alternate)
 153                   (else #f)))
 154                (else #f))
 155              (if (eq? test btest)
 156                  x
 157                  (make-conditional (conditional-src x)
 158                                    btest consequent alternate)))))
 159
 160       ((<let> gensyms body)
 161        (if (null? gensyms) body x))
 162
 163       ((<letrec> gensyms body)
 164        (if (null? gensyms) body x))
 165
 166       ((<fix> gensyms body)
 167        (if (null? gensyms) body x))
 168
 169       ((<lambda-case> req opt rest kw gensyms body alternate)
 170        (define (args-compatible? args gensyms)
 171          (let lp ((args args) (gensyms gensyms))
 172            (cond
 173             ((null? args) (null? gensyms))
 174             ((null? gensyms) #f)
 175             ((and (lexical-ref? (car args))
 176                   (eq? (lexical-ref-gensym (car args)) (car gensyms)))
 177              (lp (cdr args) (cdr gensyms)))
 178             (else #f))))
 179
 180        (and (not opt) (not kw) rest (not alternate)
 181             (record-case body
 182               ((<application> proc args)
 183                ;; (lambda args (apply (lambda ...) args)) => (lambda ...)
 184                (and (primitive-ref? proc)
 185                     (eq? (primitive-ref-name proc) '@apply)
 186                     (pair? args)
 187                     (lambda? (car args))
 188                     (args-compatible? (cdr args) gensyms)
 189                     (lambda-body (car args))))
 190               (else #f))))
 191
 192       ;; Actually the opposite of inlining -- if the prompt cannot be proven to
 193       ;; be escape-only, ensure that its body is the application of a thunk.
 194       ((<prompt> src tag body handler)
 195        (define (escape-only? handler)
 196          (and (pair? (lambda-case-req handler))
 197               (let ((cont (car (lambda-case-gensyms handler))))
 198                 (tree-il-fold (lambda (leaf escape-only?)
 199                                 (and escape-only?
 200                                      (not
 201                                       (and (lexical-ref? leaf)
 202                                            (eq? (lexical-ref-gensym leaf) cont)))))
 203                               (lambda (down escape-only?) escape-only?)
 204                               (lambda (up escape-only?) escape-only?)
 205                               #t
 206                               (lambda-case-body handler)))))
 207        (define (make-thunk body)
 208          (make-lambda #f '() (make-lambda-case #f '() #f #f #f '() '() body #f)))
 209
 210        (if (or (and (application? body)
 211                     (lambda? (application-proc body))
 212                     (null? (application-args body)))
 213                (escape-only? handler))
 214            x
 215            (make-prompt src tag
 216                         (make-application #f (make-thunk body) '())
 217                         handler)))
 218
 219       (else #f)))
 220   (post-order! inline1 x))