summaryrefslogtreecommitdiff
path: root/module/language/cps/compile-rtl.scm
blob: b1267385c58302694d6ca66ef7d2b7ff10fce5c4 (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
;;; Continuation-passing style (CPS) intermediate language (IL)

;; Copyright (C) 2013 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 RTL.  The result is in the RTL language, which
;;; happens to be an ELF image as a bytecode.
;;;
;;; Code:

(define-module (language cps compile-rtl)
  #: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 dfg)
  #:use-module (language cps primitives)
  #:use-module (language cps reify-primitives)
  #:use-module (language cps slot-allocation)
  #:use-module (system vm assembler)
  #:export (compile-rtl))

;; TODO: Source info, local var names.  Needs work in the linker and the
;; debugger.

(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))

  ;; Calls to source-to-source optimization passes go here.
  (let* ((exp (run-pass exp contify #:contify? #t)))
    ;; Passes that are needed:
    ;; 
    ;;  * Abort contification: turning abort primcalls into continuation
    ;;    calls, and eliding prompts if possible.
    ;;
    ;;  * Common subexpression elimination.  Desperately needed.  Requires
    ;;    effects analysis.
    ;;
    ;;  * 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).
    ;;
    ;;  * Generic simplification pass, to be run as needed.  Used to
    ;;    "clean up", both on the original raw input and after specific
    ;;    optimization passes.

    exp))

(define (visit-funs proc exp)
  (match exp
    (($ $continue _ exp)
     (visit-funs proc exp))

    (($ $fun meta free body)
     (proc exp)
     (visit-funs proc body))

    (($ $letk conts body)
     (visit-funs proc body)
     (for-each (lambda (cont) (visit-funs proc cont)) conts))

    (($ $cont sym src ($ $kargs names syms body))
     (visit-funs proc body))

    (($ $cont sym src ($ $kclause arity body))
     (visit-funs proc body))

    (($ $cont sym src ($ $kentry self tail clauses))
     (for-each (lambda (clause) (visit-funs proc clause)) clauses))

    (_ (values))))

(define (emit-rtl-sequence asm exp allocation nlocals cont-table)
  (define (slot sym)
    (lookup-slot sym allocation))

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

  (define (emit-rtl label k exp next-label)
    (define (maybe-mov dst src)
      (unless (= dst src)
        (emit-mov asm dst src)))

    (define (maybe-jump label)
      (unless (eq? label next-label)
        (emit-br asm label)))

    (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 (emit-tail)
      ;; 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))))
        (($ $values args)
         (let ((tail-slots (cdr (iota (1+ (length args))))))
           (for-each (match-lambda
                      ((src . dst) (emit-mov asm dst src)))
                     (lookup-parallel-moves label allocation))
           (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 (emit-val sym)
      (let ((dst (slot sym)))
        (match exp
          (($ $var sym)
           (maybe-mov dst (slot sym)))
          (($ $void)
           (when dst
             (emit-load-constant asm dst *unspecified*)))
          (($ $const exp)
           (when dst
             (emit-load-constant asm dst exp)))
          (($ $fun meta () ($ $cont k))
           (emit-load-static-procedure asm dst k))
          (($ $fun meta free ($ $cont k))
           (emit-make-closure asm dst k (length free)))
          (($ $call proc args)
           (let ((proc-slot (lookup-call-proc-slot label allocation))
                 (nargs (length args)))
             (or (maybe-load-constant proc-slot proc)
                 (maybe-mov proc-slot (slot proc)))
             (let lp ((n (1+ proc-slot)) (args args))
               (match args
                 (()
                  (emit-call asm proc-slot (+ nargs 1))
                  (emit-receive asm dst proc-slot nlocals))
                 ((arg . args)
                  (or (maybe-load-constant n arg)
                      (maybe-mov n (slot arg)))
                  (lp (1+ n) args))))))
          (($ $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 name args)
           ;; FIXME: Inline all the cases.
           (let ((inst (prim-rtl-instruction name)))
             (emit-text asm `((,inst ,dst ,@(map slot args))))))
          (($ $values (arg))
           (or (maybe-load-constant dst arg)
               (maybe-mov dst (slot arg))))
          (($ $prompt escape? tag handler)
           (emit-prompt asm escape? tag handler)))
        (maybe-jump k)))

    (define (emit-vals syms)
      (match exp
        (($ $primcall name args)
         (error "unimplemented primcall in values context" name))
        (($ $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)))
      (maybe-jump k))

    (define (emit-seq)
      (match exp
        (($ $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! (struct index value))
         (emit-struct-set! asm (slot struct) (slot index) (slot value)))
        (($ $primcall 'vector-set! (vector index value))
         (emit-vector-set asm (slot vector) (slot 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 name args)
         (error "unhandled primcall in seq context" name))
        (($ $values ()) #f))
      (maybe-jump k))

    (define (emit-test kt kf)
      (define (unary op sym)
        (cond
         ((eq? kt next-label)
          (op asm (slot sym) #t kf))
         (else
          (op asm (slot sym) #f kt)
          (maybe-jump 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)
          (maybe-jump kf))))
      (match exp
        (($ $var sym) (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))
        ;; Add TC7 tests here
        (($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b))
        (($ $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 (emit-trunc nreq rest? k)
      (match exp
        (($ $call proc args)
         (let ((proc-slot (lookup-call-proc-slot label allocation))
               (nargs (length args)))
           (or (maybe-load-constant proc-slot proc)
               (maybe-mov proc-slot (slot proc)))
           (let lp ((n (1+ proc-slot)) (args args))
             (match args
               (()
                (emit-call asm proc-slot (+ nargs 1))
                (emit-receive-values asm proc-slot nreq)
                (when rest?
                  (emit-bind-rest asm (+ proc-slot 1 nreq)))
                (for-each (match-lambda
                           ((src . dst) (emit-mov asm dst src)))
                          (lookup-parallel-moves label allocation))
                (emit-reset-frame asm nlocals))
               ((arg . args)
                (or (maybe-load-constant n arg)
                    (maybe-mov n (slot arg)))
                (lp (1+ n) args)))))))
      (maybe-jump k))

    (match (lookup-cont k cont-table)
      (($ $ktail) (emit-tail))
      (($ $kargs (name) (sym)) (emit-val sym))
      (($ $kargs () ()) (emit-seq))
      (($ $kargs names syms) (emit-vals syms))
      (($ $kargs (name) (sym)) (emit-val sym))
      (($ $kif kt kf) (emit-test kt kf))
      (($ $ktrunc ($ $arity req () rest () #f) k)
       (emit-trunc (length req) (and rest #t) k))))

  (define (collect-exps k src cont tail)
    (define (find-exp k src term)
      (match term
        (($ $continue exp-k exp)
         (cons (list k src exp-k exp) tail))
        (($ $letk conts body)
         (find-exp k src body))))
    (match cont
      (($ $kargs names syms body)
       (find-exp k src body))
      (_ tail)))

  (let lp ((exps (reverse (fold-local-conts collect-exps '() exp))))
    (match exps
      (() #t)
      (((k src exp-k exp) . exps)
       (let ((next-label (match exps
                           (((k . _) . _) k)
                           (() #f))))
         (emit-label asm k)
         (emit-rtl k exp-k exp next-label)
         (lp exps))))))

(define (compile-fun f asm)
  (let ((allocation (allocate-slots f))
        (cont-table (match f
                      (($ $fun meta free body)
                       (build-local-cont-table body)))))
    (define (emit-fun-clause clause alternate)
      (match clause
        (($ $cont k src
            ($ $kclause ($ $arity req opt rest kw allow-other-keys?)
               body))
         (let ((kw-indices (map (match-lambda
                                 ((key name sym)
                                  (cons key (lookup-slot sym allocation))))
                                kw))
               (nlocals (lookup-nlocals k allocation)))
           (emit-label asm k)
           (emit-begin-kw-arity asm req opt rest kw-indices allow-other-keys?
                                nlocals alternate)
           (emit-rtl-sequence asm body allocation nlocals cont-table)
           (emit-end-arity asm)))))

    (define (emit-fun-clauses clauses)
      (match clauses
        ((clause . clauses)
         (let ((kalternate (match clauses
                             (() #f)
                             ((($ $cont k) . _) k))))
           (emit-fun-clause clause kalternate)
           (when kalternate
             (emit-fun-clauses clauses))))))

    (match f
      (($ $fun meta free ($ $cont k src ($ $kentry self tail clauses)))
       (emit-begin-program asm k (or meta '()))
       (emit-fun-clauses clauses)
       (emit-end-program asm)))))

(define (compile-rtl exp env opts)
  (let* ((exp (fix-arities exp))
         (exp (optimize exp opts))
         (exp (convert-closures exp))
         (exp (reify-primitives exp))
         (asm (make-assembler)))
    (visit-funs (lambda (fun)
                  (compile-fun fun asm))
                exp)
    (values (link-assembly asm #:page-aligned? (kw-arg-ref opts #:to-file? #f))
            env
            env)))