summaryrefslogtreecommitdiff
path: root/module/language/tree-il/inline.scm
blob: 4e3863ef6710ad898028f9847ce822959207d856 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
;;; a simple inliner

;; Copyright (C) 2009, 2010 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 pmatch)
  #: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)
  (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 alternate)
                    (if (and (= (length vars) (length req) (length args)))
                        (let ((x (make-let src req vars args body)))
                          (or (inline1 x) x))
                        (lp alternate)))))))

         ((<primitive-ref> name)
          (case name
            ((@call-with-values)
             (pmatch args
               ;; (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.
               ((,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-alternate (lambda-body consumer))))
                (make-let-values
                 src
                 (let ((x (make-application src producer '())))
                   (or (inline1 x) x))
                 (lambda-body consumer)))
               (else #f)))

            ((memq memv)
             (pmatch args
               ((,k ,l) (guard (const? l) (list? (const-exp l)))
                (if (null? (const-exp l))
                    (make-const #f #f)
                    (let lp ((elts (const-exp l)))
                      (let ((test (make-application
                                   #f
                                   (make-primitive-ref #f (case name
                                                            ((memq) 'eq?)
                                                            ((memv) 'eqv?)
                                                            (else (error "what"))))
                                   (list k (make-const #f (car elts))))))
                        (if (null? (cdr elts))
                            test
                            (make-conditional
                             src
                             test
                             (make-const #f #t)
                             (lp (cdr elts))))))))

               (else #f)))

            (else #f)))

         (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))
       
      ((<lambda-case> req opt rest kw vars body alternate)
       (define (args-compatible? args vars)
         (let lp ((args args) (vars vars))
           (cond
            ((null? args) (null? vars))
            ((null? vars) #f)
            ((and (lexical-ref? (car args))
                  (eq? (lexical-ref-gensym (car args)) (car vars)))
             (lp (cdr args) (cdr vars)))
            (else #f))))
         
       (and (not opt) (not kw) (not alternate)
            (record-case body
              ((<application> proc args)
               ;; (lambda args (apply (lambda ...) args)) => (lambda ...)
               (and (primitive-ref? proc)
                    (eq? (primitive-ref-name proc) '@apply)
                    (pair? args)
                    (lambda? (car args))
                    (args-compatible? (cdr args) vars)
                    (lambda-body (car args))))
              (else #f))))

      ;; Actually the opposite of inlining -- if the prompt cannot be proven to
      ;; be escape-only, ensure that its body is the application of a thunk.
      ((<prompt> src tag body handler)
       (define (escape-only? handler)
         (and (pair? (lambda-case-req handler))
              (let ((cont (car (lambda-case-vars handler))))
                (tree-il-fold (lambda (leaf escape-only?)
                                (and escape-only?
                                     (not
                                      (and (lexical-ref? leaf)
                                           (eq? (lexical-ref-gensym leaf) cont)))))
                              (lambda (down escape-only?) escape-only?)
                              (lambda (up escape-only?) escape-only?)
                              #t
                              (lambda-case-body handler)))))
       (define (make-thunk body)
         (make-lambda #f '() (make-lambda-case #f '() #f #f #f '() '() body #f)))

       (if (or (and (application? body)
                    (lambda? (application-proc body))
                    (null? (application-args body)))
               (escape-only? handler))
           x
           (make-prompt src tag
                        (make-application #f (make-thunk body) '())
                        handler)))
      
      (else #f)))
  (post-order! inline1 x))