summaryrefslogtreecommitdiff
path: root/module/language/cps/compile-bytecode.scm
blob: e958b4cf8bae09e6d016628c462cafee365047af (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
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
;;; Continuation-passing style (CPS) intermediate language (IL)

;; Copyright (C) 2013, 2014 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

;;; Commentary:
;;;
;;; Compiling CPS to bytecode.  The result is in the bytecode language,
;;; which happens to be an ELF image as a bytecode.
;;;
;;; Code:

(define-module (language cps compile-bytecode)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (language cps)
  #:use-module (language cps arities)
  #:use-module (language cps closure-conversion)
  #:use-module (language cps contification)
  #:use-module (language cps constructors)
  #:use-module (language cps cse)
  #:use-module (language cps dce)
  #:use-module (language cps dfg)
  #:use-module (language cps elide-values)
  #:use-module (language cps primitives)
  #:use-module (language cps prune-bailouts)
  #:use-module (language cps prune-top-level-scopes)
  #:use-module (language cps reify-primitives)
  #:use-module (language cps renumber)
  #:use-module (language cps self-references)
  #:use-module (language cps simplify)
  #:use-module (language cps slot-allocation)
  #:use-module (language cps specialize-primcalls)
  #:use-module (system vm assembler)
  #:export (compile-bytecode))

;; TODO: Local var names.

(define (kw-arg-ref args kw default)
  (match (memq kw args)
    ((_ val . _) val)
    (_ default)))

(define (optimize exp opts)
  (define (run-pass exp pass kw default)
    (if (kw-arg-ref opts kw default)
        (pass exp)
        exp))

  ;; The first DCE pass is mainly to eliminate functions that aren't
  ;; called.  The last is mainly to eliminate rest parameters that
  ;; aren't used, and thus shouldn't be consed.

  (let* ((exp (run-pass exp eliminate-dead-code #:eliminate-dead-code? #t))
         (exp (run-pass exp prune-top-level-scopes #:prune-top-level-scopes? #t))
         (exp (run-pass exp simplify #:simplify? #t))
         (exp (run-pass exp contify #:contify? #t))
         (exp (run-pass exp inline-constructors #:inline-constructors? #t))
         (exp (run-pass exp specialize-primcalls #:specialize-primcalls? #t))
         (exp (run-pass exp elide-values #:elide-values? #t))
         (exp (run-pass exp prune-bailouts #:prune-bailouts? #t))
         (exp (run-pass exp eliminate-common-subexpressions #:cse? #t))
         (exp (run-pass exp resolve-self-references #:resolve-self-references? #t))
         (exp (run-pass exp eliminate-dead-code #:eliminate-dead-code? #t))
         (exp (run-pass exp simplify #:simplify? #t)))
    ;; Passes that are needed:
    ;; 
    ;;  * Abort contification: turning abort primcalls into continuation
    ;;    calls, and eliding prompts if possible.
    ;;
    ;;  * Loop peeling.  Unrolls the first round through a loop if the
    ;;    loop has effects that CSE can work on.  Requires effects
    ;;    analysis.  When run before CSE, loop peeling is the equivalent
    ;;    of loop-invariant code motion (LICM).

    exp))

(define (compile-fun f asm)
  (let* ((dfg (compute-dfg f #:global? #f))
         (allocation (allocate-slots f dfg)))
    (define (maybe-slot sym)
      (lookup-maybe-slot sym allocation))

    (define (slot sym)
      (lookup-slot sym allocation))

    (define (constant sym)
      (lookup-constant-value sym allocation))

    (define (maybe-mov dst src)
      (unless (= dst src)
        (emit-mov asm dst src)))

    (define (maybe-load-constant slot src)
      (call-with-values (lambda ()
                          (lookup-maybe-constant-value src allocation))
        (lambda (has-const? val)
          (and has-const?
               (begin
                 (emit-load-constant asm slot val)
                 #t)))))

    (define (compile-entry)
      (let ((label (dfg-min-label dfg)))
        (match (lookup-cont label dfg)
          (($ $kfun src meta self tail clause)
           (when src
             (emit-source asm src))
           (emit-begin-program asm label meta)
           (compile-clause (1+ label))
           (emit-end-program asm)))))

    (define (compile-clause label)
      (match (lookup-cont label dfg)
        (($ $kclause ($ $arity req opt rest kw allow-other-keys?)
            body alternate)
         (let* ((kw-indices (map (match-lambda
                                  ((key name sym)
                                   (cons key (lookup-slot sym allocation))))
                                 kw))
                (nlocals (lookup-nlocals label allocation)))
           (emit-label asm label)
           (emit-begin-kw-arity asm req opt rest kw-indices allow-other-keys?
                                nlocals
                                (match alternate (#f #f) (($ $cont alt) alt)))
           (let ((next (compile-body (1+ label) nlocals)))
             (emit-end-arity asm)
             (match alternate
               (($ $cont alt)
                (unless (eq? next alt)
                  (error "unexpected k" alt))
                (compile-clause next))
               (#f
                (unless (= next (+ (dfg-min-label dfg) (dfg-label-count dfg)))
                  (error "unexpected end of clauses")))))))))

    (define (compile-body label nlocals)
      (let compile-cont ((label label))
        (if (eq? label (+ (dfg-min-label dfg) (dfg-label-count dfg)))
            label
            (match (lookup-cont label dfg)
              (($ $kclause) label)
              (($ $kargs names vars term)
               (emit-label asm label)
               (for-each (lambda (name var)
                           (let ((slot (maybe-slot var)))
                             (when slot
                               (emit-definition asm name slot))))
                         names vars)
               (let find-exp ((term term))
                 (match term
                   (($ $letk conts term)
                    (find-exp term))
                   (($ $continue k src exp)
                    (when src
                      (emit-source asm src))
                    (compile-expression label k exp nlocals)
                    (compile-cont (1+ label))))))
              (_
               (emit-label asm label)
               (compile-cont (1+ label)))))))

    (define (compile-expression label k exp nlocals)
      (let* ((fallthrough? (= k (1+ label))))
        (define (maybe-emit-jump)
          (unless fallthrough?
            (emit-br asm k)))
        (match (lookup-cont k dfg)
          (($ $ktail)
           (compile-tail label exp))
          (($ $kargs (name) (sym))
           (let ((dst (maybe-slot sym)))
             (when dst
               (compile-value label exp dst nlocals)))
           (maybe-emit-jump))
          (($ $kargs () ())
           (compile-effect label exp k nlocals)
           (maybe-emit-jump))
          (($ $kargs names syms)
           (compile-values label exp syms)
           (maybe-emit-jump))
          (($ $kif kt kf)
           (compile-test label exp kt kf (and fallthrough? (1+ k))))
          (($ $kreceive ($ $arity req () rest () #f) kargs)
           (compile-trunc label k exp (length req)
                          (and rest
                               (match (lookup-cont kargs dfg)
                                 (($ $kargs names (_ ... rest)) rest)))
                          nlocals)
           (unless (and fallthrough? (= kargs (1+ k)))
             (emit-br asm kargs))))))

    (define (compile-tail label exp)
      ;; There are only three kinds of expressions in tail position:
      ;; tail calls, multiple-value returns, and single-value returns.
      (match exp
        (($ $call proc args)
         (for-each (match-lambda
                    ((src . dst) (emit-mov asm dst src)))
                   (lookup-parallel-moves label allocation))
         (let ((tail-slots (cdr (iota (1+ (length args))))))
           (for-each maybe-load-constant tail-slots args))
         (emit-tail-call asm (1+ (length args))))
        (($ $callk k proc args)
         (for-each (match-lambda
                    ((src . dst) (emit-mov asm dst src)))
                   (lookup-parallel-moves label allocation))
         (let ((tail-slots (cdr (iota (1+ (length args))))))
           (for-each maybe-load-constant tail-slots args))
         (emit-tail-call-label asm (1+ (length args)) k))
        (($ $values ())
         (emit-reset-frame asm 1)
         (emit-return-values asm))
        (($ $values (arg))
         (if (maybe-slot arg)
             (emit-return asm (slot arg))
             (begin
               (emit-load-constant asm 1 (constant arg))
               (emit-return asm 1))))
        (($ $values args)
         (for-each (match-lambda
                    ((src . dst) (emit-mov asm dst src)))
                   (lookup-parallel-moves label allocation))
         (let ((tail-slots (cdr (iota (1+ (length args))))))
           (for-each maybe-load-constant tail-slots args))
         (emit-reset-frame asm (1+ (length args)))
         (emit-return-values asm))
        (($ $primcall 'return (arg))
         (emit-return asm (slot arg)))))

    (define (compile-value label exp dst nlocals)
      (match exp
        (($ $values (arg))
         (or (maybe-load-constant dst arg)
             (maybe-mov dst (slot arg))))
        (($ $void)
         (emit-load-constant asm dst *unspecified*))
        (($ $const exp)
         (emit-load-constant asm dst exp))
        (($ $closure k 0)
         (emit-load-static-procedure asm dst k))
        (($ $closure k nfree)
         (emit-make-closure asm dst k nfree))
        (($ $primcall 'current-module)
         (emit-current-module asm dst))
        (($ $primcall 'cached-toplevel-box (scope name bound?))
         (emit-cached-toplevel-box asm dst (constant scope) (constant name)
                                   (constant bound?)))
        (($ $primcall 'cached-module-box (mod name public? bound?))
         (emit-cached-module-box asm dst (constant mod) (constant name)
                                 (constant public?) (constant bound?)))
        (($ $primcall 'resolve (name bound?))
         (emit-resolve asm dst (constant bound?) (slot name)))
        (($ $primcall 'free-ref (closure idx))
         (emit-free-ref asm dst (slot closure) (constant idx)))
        (($ $primcall 'vector-ref (vector index))
         (emit-vector-ref asm dst (slot vector) (slot index)))
        (($ $primcall 'make-vector (length init))
         (emit-make-vector asm dst (slot length) (slot init)))
        (($ $primcall 'make-vector/immediate (length init))
         (emit-make-vector/immediate asm dst (constant length) (slot init)))
        (($ $primcall 'vector-ref/immediate (vector index))
         (emit-vector-ref/immediate asm dst (slot vector) (constant index)))
        (($ $primcall 'allocate-struct/immediate (vtable nfields))
         (emit-allocate-struct/immediate asm dst (slot vtable) (constant nfields)))
        (($ $primcall 'struct-ref/immediate (struct n))
         (emit-struct-ref/immediate asm dst (slot struct) (constant n)))
        (($ $primcall 'builtin-ref (name))
         (emit-builtin-ref asm dst (constant name)))
        (($ $primcall 'bv-u8-ref (bv idx))
         (emit-bv-u8-ref asm dst (slot bv) (slot idx)))
        (($ $primcall 'bv-s8-ref (bv idx))
         (emit-bv-s8-ref asm dst (slot bv) (slot idx)))
        (($ $primcall 'bv-u16-ref (bv idx))
         (emit-bv-u16-ref asm dst (slot bv) (slot idx)))
        (($ $primcall 'bv-s16-ref (bv idx))
         (emit-bv-s16-ref asm dst (slot bv) (slot idx)))
        (($ $primcall 'bv-u32-ref (bv idx val))
         (emit-bv-u32-ref asm dst (slot bv) (slot idx)))
        (($ $primcall 'bv-s32-ref (bv idx val))
         (emit-bv-s32-ref asm dst (slot bv) (slot idx)))
        (($ $primcall 'bv-u64-ref (bv idx val))
         (emit-bv-u64-ref asm dst (slot bv) (slot idx)))
        (($ $primcall 'bv-s64-ref (bv idx val))
         (emit-bv-s64-ref asm dst (slot bv) (slot idx)))
        (($ $primcall 'bv-f32-ref (bv idx val))
         (emit-bv-f32-ref asm dst (slot bv) (slot idx)))
        (($ $primcall 'bv-f64-ref (bv idx val))
         (emit-bv-f64-ref asm dst (slot bv) (slot idx)))
        (($ $primcall name args)
         ;; FIXME: Inline all the cases.
         (let ((inst (prim-instruction name)))
           (emit-text asm `((,inst ,dst ,@(map slot args))))))))

    (define (compile-effect label exp k nlocals)
      (match exp
        (($ $values ()) #f)
        (($ $prompt escape? tag handler)
         (match (lookup-cont handler dfg)
           (($ $kreceive ($ $arity req () rest () #f) khandler-body)
            (let ((receive-args (gensym "handler"))
                  (nreq (length req))
                  (proc-slot (lookup-call-proc-slot handler allocation)))
              (emit-prompt asm (slot tag) escape? proc-slot receive-args)
              (emit-br asm k)
              (emit-label asm receive-args)
              (unless (and rest (zero? nreq))
                (emit-receive-values asm proc-slot (->bool rest) nreq))
              (when (and rest
                         (match (lookup-cont khandler-body dfg)
                           (($ $kargs names (_ ... rest))
                            (maybe-slot rest))))
                (emit-bind-rest asm (+ proc-slot 1 nreq)))
              (for-each (match-lambda
                         ((src . dst) (emit-mov asm dst src)))
                        (lookup-parallel-moves handler allocation))
              (emit-reset-frame asm nlocals)
              (emit-br asm khandler-body)))))
        (($ $primcall 'cache-current-module! (sym scope))
         (emit-cache-current-module! asm (slot sym) (constant scope)))
        (($ $primcall 'free-set! (closure idx value))
         (emit-free-set! asm (slot closure) (slot value) (constant idx)))
        (($ $primcall 'box-set! (box value))
         (emit-box-set! asm (slot box) (slot value)))
        (($ $primcall 'struct-set!/immediate (struct index value))
         (emit-struct-set!/immediate asm (slot struct) (constant index) (slot value)))
        (($ $primcall 'vector-set! (vector index value))
         (emit-vector-set! asm (slot vector) (slot index) (slot value)))
        (($ $primcall 'vector-set!/immediate (vector index value))
         (emit-vector-set!/immediate asm (slot vector) (constant index)
                                     (slot value)))
        (($ $primcall 'set-car! (pair value))
         (emit-set-car! asm (slot pair) (slot value)))
        (($ $primcall 'set-cdr! (pair value))
         (emit-set-cdr! asm (slot pair) (slot value)))
        (($ $primcall 'define! (sym value))
         (emit-define! asm (slot sym) (slot value)))
        (($ $primcall 'push-fluid (fluid val))
         (emit-push-fluid asm (slot fluid) (slot val)))
        (($ $primcall 'pop-fluid ())
         (emit-pop-fluid asm))
        (($ $primcall 'wind (winder unwinder))
         (emit-wind asm (slot winder) (slot unwinder)))
        (($ $primcall 'bv-u8-set! (bv idx val))
         (emit-bv-u8-set! asm (slot bv) (slot idx) (slot val)))
        (($ $primcall 'bv-s8-set! (bv idx val))
         (emit-bv-s8-set! asm (slot bv) (slot idx) (slot val)))
        (($ $primcall 'bv-u16-set! (bv idx val))
         (emit-bv-u16-set! asm (slot bv) (slot idx) (slot val)))
        (($ $primcall 'bv-s16-set! (bv idx val))
         (emit-bv-s16-set! asm (slot bv) (slot idx) (slot val)))
        (($ $primcall 'bv-u32-set! (bv idx val))
         (emit-bv-u32-set! asm (slot bv) (slot idx) (slot val)))
        (($ $primcall 'bv-s32-set! (bv idx val))
         (emit-bv-s32-set! asm (slot bv) (slot idx) (slot val)))
        (($ $primcall 'bv-u64-set! (bv idx val))
         (emit-bv-u64-set! asm (slot bv) (slot idx) (slot val)))
        (($ $primcall 'bv-s64-set! (bv idx val))
         (emit-bv-s64-set! asm (slot bv) (slot idx) (slot val)))
        (($ $primcall 'bv-f32-set! (bv idx val))
         (emit-bv-f32-set! asm (slot bv) (slot idx) (slot val)))
        (($ $primcall 'bv-f64-set! (bv idx val))
         (emit-bv-f64-set! asm (slot bv) (slot idx) (slot val)))
        (($ $primcall 'unwind ())
         (emit-unwind asm))))

    (define (compile-values label exp syms)
      (match exp
        (($ $values args)
         (for-each (match-lambda
                    ((src . dst) (emit-mov asm dst src)))
                   (lookup-parallel-moves label allocation))
         (for-each maybe-load-constant (map slot syms) args))))

    (define (compile-test label exp kt kf next-label)
      (define (unary op sym)
        (cond
         ((eq? kt next-label)
          (op asm (slot sym) #t kf))
         (else
          (op asm (slot sym) #f kt)
          (unless (eq? kf next-label)
            (emit-br asm kf)))))
      (define (binary op a b)
        (cond
         ((eq? kt next-label)
          (op asm (slot a) (slot b) #t kf))
         (else
          (op asm (slot a) (slot b) #f kt)
          (unless (eq? kf next-label)
            (emit-br asm kf)))))
      (match exp
        (($ $values (sym))
         (call-with-values (lambda ()
                             (lookup-maybe-constant-value sym allocation))
           (lambda (has-const? val)
             (if has-const?
                 (if val
                     (unless (eq? kt next-label)
                       (emit-br asm kt))
                     (unless (eq? kf next-label)
                       (emit-br asm kf)))
                 (unary emit-br-if-true sym)))))
        (($ $primcall 'null? (a)) (unary emit-br-if-null a))
        (($ $primcall 'nil? (a)) (unary emit-br-if-nil a))
        (($ $primcall 'pair? (a)) (unary emit-br-if-pair a))
        (($ $primcall 'struct? (a)) (unary emit-br-if-struct a))
        (($ $primcall 'char? (a)) (unary emit-br-if-char a))
        (($ $primcall 'symbol? (a)) (unary emit-br-if-symbol a))
        (($ $primcall 'variable? (a)) (unary emit-br-if-variable a))
        (($ $primcall 'vector? (a)) (unary emit-br-if-vector a))
        (($ $primcall 'string? (a)) (unary emit-br-if-string a))
        (($ $primcall 'bytevector? (a)) (unary emit-br-if-bytevector a))
        ;; Add more TC7 tests here.  Keep in sync with
        ;; *branching-primcall-arities* in (language cps primitives) and
        ;; the set of macro-instructions in assembly.scm.
        (($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b))
        (($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b))
        (($ $primcall 'equal? (a b)) (binary emit-br-if-equal a b))
        (($ $primcall '< (a b)) (binary emit-br-if-< a b))
        (($ $primcall '<= (a b)) (binary emit-br-if-<= a b))
        (($ $primcall '= (a b)) (binary emit-br-if-= a b))
        (($ $primcall '>= (a b)) (binary emit-br-if-<= b a))
        (($ $primcall '> (a b)) (binary emit-br-if-< b a))))

    (define (compile-trunc label k exp nreq rest-var nlocals)
      (define (do-call proc args emit-call)
        (let* ((proc-slot (lookup-call-proc-slot label allocation))
               (nargs (1+ (length args)))
               (arg-slots (map (lambda (x) (+ x proc-slot)) (iota nargs))))
          (for-each (match-lambda
                     ((src . dst) (emit-mov asm dst src)))
                    (lookup-parallel-moves label allocation))
          (for-each maybe-load-constant arg-slots (cons proc args))
          (emit-call asm proc-slot nargs)
          (emit-dead-slot-map asm proc-slot
                              (lookup-dead-slot-map label allocation))
          (cond
           ((and (= 1 nreq) (and rest-var) (not (maybe-slot rest-var))
                 (match (lookup-parallel-moves k allocation)
                   ((((? (lambda (src) (= src (1+ proc-slot))) src)
                      . dst)) dst)
                   (_ #f)))
            ;; The usual case: one required live return value, ignoring
            ;; any additional values.
            => (lambda (dst)
                 (emit-receive asm dst proc-slot nlocals)))
           (else
            (unless (and (zero? nreq) rest-var)
              (emit-receive-values asm proc-slot (->bool rest-var) nreq))
            (when (and rest-var (maybe-slot rest-var))
              (emit-bind-rest asm (+ proc-slot 1 nreq)))
            (for-each (match-lambda
                       ((src . dst) (emit-mov asm dst src)))
                      (lookup-parallel-moves k allocation))
            (emit-reset-frame asm nlocals)))))
      (match exp
        (($ $call proc args)
         (do-call proc args
                  (lambda (asm proc-slot nargs)
                    (emit-call asm proc-slot nargs))))
        (($ $callk k proc args)
         (do-call proc args
                  (lambda (asm proc-slot nargs)
                    (emit-call-label asm proc-slot nargs k))))))

    (match f
      (($ $cont k ($ $kfun src meta self tail clause))
       (compile-entry)))))

(define (compile-bytecode exp env opts)
  (let* ((exp (fix-arities exp))
         (exp (optimize exp opts))
         (exp (convert-closures exp))
         ;; first-order optimization should go here
         (exp (reify-primitives exp))
         (exp (renumber exp))
         (asm (make-assembler)))
    (match exp
      (($ $program funs)
       (for-each (lambda (fun) (compile-fun fun asm))
                 funs)))
    (values (link-assembly asm #:page-aligned? (kw-arg-ref opts #:to-file? #f))
            env
            env)))