summaryrefslogtreecommitdiff
path: root/module/language/js-il/inlining.scm
blob: 5b51f580e90de02a8129601dc89660a12944c7c7 (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
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
;;; JavaScript Intermediate Language (JS-IL) Inliner

;; Copyright (C) 2015, 2017 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

;;; Code:

;; FIXME: It is currently wrong to think of inlining as an optimisation
;; since in the cps-soup world we need inlining to rebuild the scope
;; tree for variables.
;; FIXME: since *all* conts are passed to each clause, there can be
;; "dead" conts thare are included in a clause

(define-module (language js-il inlining)
  #:use-module ((srfi srfi-1) #:select (partition))
  #:use-module (ice-9 match)
  #:use-module (language js-il)
  #:export (count-calls
            inline-single-calls
            ))

(define (count-calls exp)
  (define counts (make-hash-table))
  (define (count-inc! key)
    (hashv-set! counts key (+ 1 (hashv-ref counts key 0))))
  (define (count-inf! key)
    (hashv-set! counts key +inf.0))
  (define (analyse-args arg-list)
    (for-each (match-lambda
               (($ kid name)
                (count-inf! name))
               (($ id name) #f))
              arg-list))
  (define (analyse exp)
    (match exp
      (($ program ((ids . funs) ...))
       (for-each analyse funs))

      (($ function self tail ((($ kid ids) _ bodies) ...))
       (for-each count-inc! ids) ;; count-inf! ?
       (for-each analyse bodies))

      (($ continuation params body)
       (analyse body))

      (($ local bindings body)
       (for-each (match-lambda
                  ((i . b) (analyse b)))
                 bindings)
       (analyse body))

      (($ continue ($ kid cont) args)
       (count-inc! cont)
       (for-each analyse args))

      (($ primcall name args)
       (analyse-args args))

      (($ call name ($ kid k) args)
       (count-inf! k)
       (analyse-args args))

      (($ closure ($ kid label) num-free)
       (count-inf! label))

      (($ branch test consequence alternate)
       (analyse test)
       (analyse consequence)
       (analyse alternate))

      (($ kid name)
       (count-inf! name))

      (($ seq body)
       (for-each analyse body))

      (($ prompt escape? tag ($ kid handler))
       (count-inf! handler))

      (else #f)))
  (analyse exp)
  counts)

(define no-values-primitives
  '(
    cache-current-module!
    set-cdr!
    set-car!
    vector-set!
    free-set!
    vector-set!/immediate
    box-set!
    struct-set!
    struct-set!/immediate
    wind
    unwind
    push-fluid
    pop-fluid
    handle-interrupts
    push-dynamic-state
    pop-dynamic-state
    fluid-set!
    ))

(define no-values-primitive?
  (let ((h (make-hash-table)))
    (for-each (lambda (prim)
                (hashv-set! h prim #t))
              no-values-primitives)
    (lambda (prim)
      (hashv-ref h prim))))


(define (inline-single-calls exp)
  (define (handle-function fun)
    (match fun
      (($ function self tail ((ids params bodies) ...))
       (make-function self
                      tail
                      (map (lambda (id param body)
                             (list id param (inline-clause body)))
                           ids
                           params
                           bodies)))))
  (match exp
    (($ program ((ids . funs) ...))
     (make-program (map (lambda (id fun)
                          (cons id (handle-function fun)))
                        ids
                        funs)))))

(define (inline-clause exp)

  (define calls (count-calls exp))

  (define (inlinable? k)
    (eqv? 1 (hashv-ref calls k)))

  (define (split-inlinable bindings)
    (partition (match-lambda
                ((($ kid id) . _) (inlinable? id)))
               bindings))

  (define (lookup kont substs)
    (match substs
      (((($ kid id) . exp) . rest)
       (if (= id kont)
           exp
           (lookup kont rest)))
      (() kont)
      (else
       (throw 'lookup-failed kont))))

  (define (inline exp substs)
    (match exp

      ;; FIXME: This hacks around the fact that define doesn't return
      ;; arguments to the continuation. This should be handled when
      ;; converting to js-il, not here.
      (($ continue
          ($ kid (? inlinable? cont))
          (($ primcall (? no-values-primitive? prim) args)))
       (match (lookup cont substs)
         (($ continuation () body)
          (make-seq
           (list
            (make-primcall prim args)
            (inline body substs))))
         (else
          ;; inlinable but not locally bound
          exp)))

      (($ continue ($ kid (? inlinable? cont)) args)
       (match (lookup cont substs)
         (($ continuation kargs body)
          (if (not (= (length args) (length kargs)))
              (throw 'args-dont-match cont args kargs)
              (make-local (map cons kargs args)
                          ;; gah, this doesn't work
                          ;; identifiers need to be separated earlier
                          ;; not just as part of compilation
                          (inline body substs))))
         (else
          ;; inlinable but not locally bound
          ;; FIXME: This handles tail continuations, but only by accident
          exp)))

      (($ continue cont args)
       exp)

      (($ continuation params body)
       (make-continuation params (inline body substs)))

      (($ local bindings body)
       (call-with-values
           (lambda ()
             (split-inlinable bindings))
         (lambda (new-substs uninlinable-bindings)
           (define substs* (append new-substs substs))
           (make-local (map (match-lambda
                             ((id . val)
                              `(,id . ,(inline val substs*))))
                            uninlinable-bindings)
                       (inline body substs*)))))

      (($ seq body)
       (make-seq (map (lambda (x) (inline x substs))
                      body)))

      (($ branch test consequence alternate)
       (make-branch test
                    (inline consequence substs)
                    (inline alternate substs)))

      (exp exp)))

  (inline exp '()))