module/language/tree-il/inline.scm

   1 ;;; a simple inliner
   2
   3 ;; Copyright (C) 2009, 2010 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 gensyms body alternate)
  48                     (if (and (= (length gensyms) (length req) (length args)))
  49                         (let ((x (make-let src req gensyms args body)))
  50                           (or (inline1 x) x))
  51                         (lp alternate)))))))
  52
  53          ((<primitive-ref> name)
  54           (case name
  55             ((@call-with-values)
  56              (pmatch args
  57                ;; (call-with-values (lambda () foo) (lambda (a b . c) bar))
  58                ;; => (let-values (((a b . c) foo)) bar)
  59                ;;
  60                ;; Note that this is a singly-binding form of let-values.
  61                ;; Also note that Scheme's let-values expands into
  62                ;; call-with-values, then here we reduce it to tree-il's
  63                ;; let-values.
  64                ((,producer ,consumer)
  65                 (guard (lambda? consumer)
  66                        (lambda-case? (lambda-body consumer))
  67                        (not (lambda-case-opt (lambda-body consumer)))
  68                        (not (lambda-case-kw (lambda-body consumer)))
  69                        (not (lambda-case-alternate (lambda-body consumer))))
  70                 (make-let-values
  71                  src
  72                  (let ((x (make-application src producer '())))
  73                    (or (inline1 x) x))
  74                  (lambda-body consumer)))
  75                (else #f)))
  76
  77             ((memq memv)
  78              (pmatch args
  79                ((,k ,l) (guard (const? l) (list? (const-exp l)))
  80                 (if (null? (const-exp l))
  81                     (make-const #f #f)
  82                     (let lp ((elts (const-exp l)))
  83                       (let ((test (make-application
  84                                    #f
  85                                    (make-primitive-ref #f (case name
  86                                                             ((memq) 'eq?)
  87                                                             ((memv) 'eqv?)
  88                                                             (else (error "what"))))
  89                                    (list k (make-const #f (car elts))))))
  90                         (if (null? (cdr elts))
  91                             test
  92                             (make-conditional
  93                              src
  94                              test
  95                              (make-const #f #t)
  96                              (lp (cdr elts))))))))
  97
  98                (else #f)))
  99
 100             (else #f)))
 101
 102          (else #f)))
 103
 104       ((<let> gensyms body)
 105        (if (null? gensyms) body x))
 106
 107       ((<letrec> gensyms body)
 108        (if (null? gensyms) body x))
 109
 110       ((<fix> gensyms body)
 111        (if (null? gensyms) body x))
 112
 113       ((<lambda-case> req opt rest kw gensyms body alternate)
 114        (define (args-compatible? args gensyms)
 115          (let lp ((args args) (gensyms gensyms))
 116            (cond
 117             ((null? args) (null? gensyms))
 118             ((null? gensyms) #f)
 119             ((and (lexical-ref? (car args))
 120                   (eq? (lexical-ref-gensym (car args)) (car gensyms)))
 121              (lp (cdr args) (cdr gensyms)))
 122             (else #f))))
 123
 124        (and (not opt) (not kw) rest (not alternate)
 125             (record-case body
 126               ((<application> proc args)
 127                ;; (lambda args (apply (lambda ...) args)) => (lambda ...)
 128                (and (primitive-ref? proc)
 129                     (eq? (primitive-ref-name proc) '@apply)
 130                     (pair? args)
 131                     (lambda? (car args))
 132                     (args-compatible? (cdr args) gensyms)
 133                     (lambda-body (car args))))
 134               (else #f))))
 135
 136       ;; Actually the opposite of inlining -- if the prompt cannot be proven to
 137       ;; be escape-only, ensure that its body is the application of a thunk.
 138       ((<prompt> src tag body handler)
 139        (define (escape-only? handler)
 140          (and (pair? (lambda-case-req handler))
 141               (let ((cont (car (lambda-case-gensyms handler))))
 142                 (tree-il-fold (lambda (leaf escape-only?)
 143                                 (and escape-only?
 144                                      (not
 145                                       (and (lexical-ref? leaf)
 146                                            (eq? (lexical-ref-gensym leaf) cont)))))
 147                               (lambda (down escape-only?) escape-only?)
 148                               (lambda (up escape-only?) escape-only?)
 149                               #t
 150                               (lambda-case-body handler)))))
 151        (define (make-thunk body)
 152          (make-lambda #f '() (make-lambda-case #f '() #f #f #f '() '() body #f)))
 153
 154        (if (or (and (application? body)
 155                     (lambda? (application-proc body))
 156                     (null? (application-args body)))
 157                (escape-only? handler))
 158            x
 159            (make-prompt src tag
 160                         (make-application #f (make-thunk body) '())
 161                         handler)))
 162
 163       (else #f)))
 164   (post-order! inline1 x))