Commit | Line | Data |
---|---|---|
6e8ad823 AW |
1 | ;;; Continuation-passing style (CPS) intermediate language (IL) |
2 | ||
3 | ;; Copyright (C) 2013 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 | ;;; Commentary: | |
20 | ;;; | |
21 | ;;; Compiling CPS to RTL. The result is in the RTL language, which | |
22 | ;;; happens to be an ELF image as a bytecode. | |
23 | ;;; | |
24 | ;;; Code: | |
25 | ||
26 | (define-module (language cps compile-rtl) | |
27 | #:use-module (ice-9 match) | |
28 | #:use-module (srfi srfi-1) | |
29 | #:use-module (language cps) | |
30 | #:use-module (language cps arities) | |
31 | #:use-module (language cps closure-conversion) | |
8ac8e2df | 32 | #:use-module (language cps contification) |
fa3b6e57 | 33 | #:use-module (language cps constructors) |
6e8ad823 | 34 | #:use-module (language cps dfg) |
7e273b7a | 35 | #:use-module (language cps elide-values) |
6e8ad823 AW |
36 | #:use-module (language cps primitives) |
37 | #:use-module (language cps reify-primitives) | |
38 | #:use-module (language cps slot-allocation) | |
39 | #:use-module (system vm assembler) | |
40 | #:export (compile-rtl)) | |
41 | ||
42 | ;; TODO: Source info, local var names. Needs work in the linker and the | |
43 | ;; debugger. | |
44 | ||
45 | (define (kw-arg-ref args kw default) | |
46 | (match (memq kw args) | |
47 | ((_ val . _) val) | |
48 | (_ default))) | |
49 | ||
50 | (define (optimize exp opts) | |
51 | (define (run-pass exp pass kw default) | |
52 | (if (kw-arg-ref opts kw default) | |
53 | (pass exp) | |
54 | exp)) | |
55 | ||
56 | ;; Calls to source-to-source optimization passes go here. | |
fa3b6e57 | 57 | (let* ((exp (run-pass exp contify #:contify? #t)) |
7e273b7a AW |
58 | (exp (run-pass exp inline-constructors #:inline-constructors? #t)) |
59 | (exp (run-pass exp elide-values #:elide-values? #t))) | |
6e8ad823 AW |
60 | ;; Passes that are needed: |
61 | ;; | |
6e8ad823 AW |
62 | ;; * Abort contification: turning abort primcalls into continuation |
63 | ;; calls, and eliding prompts if possible. | |
64 | ;; | |
65 | ;; * Common subexpression elimination. Desperately needed. Requires | |
66 | ;; effects analysis. | |
67 | ;; | |
68 | ;; * Loop peeling. Unrolls the first round through a loop if the | |
69 | ;; loop has effects that CSE can work on. Requires effects | |
70 | ;; analysis. When run before CSE, loop peeling is the equivalent | |
71 | ;; of loop-invariant code motion (LICM). | |
72 | ;; | |
73 | ;; * Generic simplification pass, to be run as needed. Used to | |
74 | ;; "clean up", both on the original raw input and after specific | |
75 | ;; optimization passes. | |
76 | ||
77 | exp)) | |
78 | ||
79 | (define (visit-funs proc exp) | |
80 | (match exp | |
81 | (($ $continue _ exp) | |
82 | (visit-funs proc exp)) | |
83 | ||
84 | (($ $fun meta free body) | |
85 | (proc exp) | |
86 | (visit-funs proc body)) | |
87 | ||
88 | (($ $letk conts body) | |
89 | (visit-funs proc body) | |
90 | (for-each (lambda (cont) (visit-funs proc cont)) conts)) | |
91 | ||
92 | (($ $cont sym src ($ $kargs names syms body)) | |
93 | (visit-funs proc body)) | |
94 | ||
95 | (($ $cont sym src ($ $kclause arity body)) | |
96 | (visit-funs proc body)) | |
97 | ||
98 | (($ $cont sym src ($ $kentry self tail clauses)) | |
99 | (for-each (lambda (clause) (visit-funs proc clause)) clauses)) | |
100 | ||
101 | (_ (values)))) | |
102 | ||
103 | (define (emit-rtl-sequence asm exp allocation nlocals cont-table) | |
607fe5a6 AW |
104 | (define (immediate-u8? val) |
105 | (and (integer? val) (exact? val) (<= 0 val 255))) | |
106 | ||
107 | (define (maybe-immediate-u8 sym) | |
108 | (call-with-values (lambda () | |
109 | (lookup-maybe-constant-value sym allocation)) | |
110 | (lambda (has-const? val) | |
111 | (and has-const? (immediate-u8? val) val)))) | |
112 | ||
6e8ad823 AW |
113 | (define (slot sym) |
114 | (lookup-slot sym allocation)) | |
115 | ||
116 | (define (constant sym) | |
117 | (lookup-constant-value sym allocation)) | |
118 | ||
119 | (define (emit-rtl label k exp next-label) | |
120 | (define (maybe-mov dst src) | |
121 | (unless (= dst src) | |
122 | (emit-mov asm dst src))) | |
123 | ||
124 | (define (maybe-jump label) | |
125 | (unless (eq? label next-label) | |
126 | (emit-br asm label))) | |
127 | ||
128 | (define (maybe-load-constant slot src) | |
129 | (call-with-values (lambda () | |
130 | (lookup-maybe-constant-value src allocation)) | |
131 | (lambda (has-const? val) | |
132 | (and has-const? | |
133 | (begin | |
134 | (emit-load-constant asm slot val) | |
135 | #t))))) | |
136 | ||
137 | (define (emit-tail) | |
138 | ;; There are only three kinds of expressions in tail position: | |
139 | ;; tail calls, multiple-value returns, and single-value returns. | |
140 | (match exp | |
141 | (($ $call proc args) | |
142 | (for-each (match-lambda | |
143 | ((src . dst) (emit-mov asm dst src))) | |
144 | (lookup-parallel-moves label allocation)) | |
145 | (let ((tail-slots (cdr (iota (1+ (length args)))))) | |
146 | (for-each maybe-load-constant tail-slots args)) | |
147 | (emit-tail-call asm (1+ (length args)))) | |
148 | (($ $values args) | |
149 | (let ((tail-slots (cdr (iota (1+ (length args)))))) | |
150 | (for-each (match-lambda | |
151 | ((src . dst) (emit-mov asm dst src))) | |
152 | (lookup-parallel-moves label allocation)) | |
153 | (for-each maybe-load-constant tail-slots args)) | |
154 | (emit-reset-frame asm (1+ (length args))) | |
155 | (emit-return-values asm)) | |
156 | (($ $primcall 'return (arg)) | |
157 | (emit-return asm (slot arg))))) | |
158 | ||
159 | (define (emit-val sym) | |
160 | (let ((dst (slot sym))) | |
161 | (match exp | |
162 | (($ $var sym) | |
163 | (maybe-mov dst (slot sym))) | |
164 | (($ $void) | |
165 | (when dst | |
166 | (emit-load-constant asm dst *unspecified*))) | |
167 | (($ $const exp) | |
168 | (when dst | |
169 | (emit-load-constant asm dst exp))) | |
170 | (($ $fun meta () ($ $cont k)) | |
171 | (emit-load-static-procedure asm dst k)) | |
172 | (($ $fun meta free ($ $cont k)) | |
173 | (emit-make-closure asm dst k (length free))) | |
174 | (($ $call proc args) | |
175 | (let ((proc-slot (lookup-call-proc-slot label allocation)) | |
176 | (nargs (length args))) | |
177 | (or (maybe-load-constant proc-slot proc) | |
178 | (maybe-mov proc-slot (slot proc))) | |
179 | (let lp ((n (1+ proc-slot)) (args args)) | |
180 | (match args | |
181 | (() | |
182 | (emit-call asm proc-slot (+ nargs 1)) | |
183 | (emit-receive asm dst proc-slot nlocals)) | |
184 | ((arg . args) | |
185 | (or (maybe-load-constant n arg) | |
186 | (maybe-mov n (slot arg))) | |
187 | (lp (1+ n) args)))))) | |
188 | (($ $primcall 'current-module) | |
189 | (emit-current-module asm dst)) | |
190 | (($ $primcall 'cached-toplevel-box (scope name bound?)) | |
191 | (emit-cached-toplevel-box asm dst (constant scope) (constant name) | |
192 | (constant bound?))) | |
193 | (($ $primcall 'cached-module-box (mod name public? bound?)) | |
194 | (emit-cached-module-box asm dst (constant mod) (constant name) | |
195 | (constant public?) (constant bound?))) | |
196 | (($ $primcall 'resolve (name bound?)) | |
197 | (emit-resolve asm dst (constant bound?) (slot name))) | |
198 | (($ $primcall 'free-ref (closure idx)) | |
199 | (emit-free-ref asm dst (slot closure) (constant idx))) | |
607fe5a6 AW |
200 | (($ $primcall 'make-vector (length init)) |
201 | (cond | |
202 | ((maybe-immediate-u8 length) | |
203 | => (lambda (length) | |
204 | (emit-constant-make-vector asm dst length (slot init)))) | |
205 | (else | |
206 | (emit-make-vector asm dst (slot length) (slot init))))) | |
8ba3f20c | 207 | (($ $primcall 'vector-ref (vector index)) |
607fe5a6 AW |
208 | (cond |
209 | ((maybe-immediate-u8 index) | |
210 | => (lambda (index) | |
211 | (emit-constant-vector-ref asm dst (slot vector) index))) | |
212 | (else | |
213 | (emit-vector-ref asm dst (slot vector) (slot index))))) | |
486013d6 AW |
214 | (($ $primcall 'builtin-ref (name)) |
215 | (emit-builtin-ref asm dst (constant name))) | |
6e8ad823 AW |
216 | (($ $primcall name args) |
217 | ;; FIXME: Inline all the cases. | |
218 | (let ((inst (prim-rtl-instruction name))) | |
219 | (emit-text asm `((,inst ,dst ,@(map slot args)))))) | |
220 | (($ $values (arg)) | |
221 | (or (maybe-load-constant dst arg) | |
8d59d55e | 222 | (maybe-mov dst (slot arg))))) |
6e8ad823 AW |
223 | (maybe-jump k))) |
224 | ||
225 | (define (emit-vals syms) | |
226 | (match exp | |
227 | (($ $primcall name args) | |
228 | (error "unimplemented primcall in values context" name)) | |
229 | (($ $values args) | |
230 | (for-each (match-lambda | |
231 | ((src . dst) (emit-mov asm dst src))) | |
232 | (lookup-parallel-moves label allocation)) | |
233 | (for-each maybe-load-constant (map slot syms) args))) | |
234 | (maybe-jump k)) | |
235 | ||
236 | (define (emit-seq) | |
237 | (match exp | |
238 | (($ $primcall 'cache-current-module! (sym scope)) | |
239 | (emit-cache-current-module! asm (slot sym) (constant scope))) | |
240 | (($ $primcall 'free-set! (closure idx value)) | |
241 | (emit-free-set! asm (slot closure) (slot value) (constant idx))) | |
242 | (($ $primcall 'box-set! (box value)) | |
243 | (emit-box-set! asm (slot box) (slot value))) | |
244 | (($ $primcall 'struct-set! (struct index value)) | |
245 | (emit-struct-set! asm (slot struct) (slot index) (slot value))) | |
246 | (($ $primcall 'vector-set! (vector index value)) | |
8ba3f20c AW |
247 | (call-with-values (lambda () |
248 | (lookup-maybe-constant-value index allocation)) | |
249 | (lambda (has-const? index-val) | |
250 | (if (and has-const? (integer? index-val) (exact? index-val) | |
251 | (<= 0 index-val 255)) | |
252 | (emit-constant-vector-set! asm (slot vector) index-val | |
253 | (slot value)) | |
254 | (emit-vector-set! asm (slot vector) (slot index) | |
255 | (slot value)))))) | |
4f406fea AW |
256 | (($ $primcall 'variable-set! (var val)) |
257 | (emit-box-set! asm (slot var) (slot val))) | |
6e8ad823 AW |
258 | (($ $primcall 'set-car! (pair value)) |
259 | (emit-set-car! asm (slot pair) (slot value))) | |
260 | (($ $primcall 'set-cdr! (pair value)) | |
261 | (emit-set-cdr! asm (slot pair) (slot value))) | |
262 | (($ $primcall 'define! (sym value)) | |
263 | (emit-define asm (slot sym) (slot value))) | |
5db3e6bc AW |
264 | (($ $primcall 'push-fluid (fluid val)) |
265 | (emit-push-fluid asm (slot fluid) (slot val))) | |
266 | (($ $primcall 'pop-fluid ()) | |
267 | (emit-pop-fluid asm)) | |
6fb508da AW |
268 | (($ $primcall 'wind (winder unwinder)) |
269 | (emit-wind asm (slot winder) (slot unwinder))) | |
8d59d55e AW |
270 | (($ $primcall 'unwind ()) |
271 | (emit-unwind asm)) | |
6e8ad823 AW |
272 | (($ $primcall name args) |
273 | (error "unhandled primcall in seq context" name)) | |
8d59d55e | 274 | (($ $values ()) #f) |
96af4a18 | 275 | (($ $prompt escape? tag handler pop) |
8d59d55e AW |
276 | (match (lookup-cont handler cont-table) |
277 | (($ $ktrunc ($ $arity req () rest () #f) khandler-body) | |
278 | (let ((receive-args (gensym "handler")) | |
279 | (nreq (length req)) | |
280 | (proc-slot (lookup-call-proc-slot label allocation))) | |
281 | (emit-prompt asm (slot tag) escape? proc-slot receive-args) | |
282 | (emit-br asm k) | |
283 | (emit-label asm receive-args) | |
284 | (emit-receive-values asm proc-slot (->bool rest) nreq) | |
285 | (when rest | |
286 | (emit-bind-rest asm (+ proc-slot 1 nreq))) | |
287 | (for-each (match-lambda | |
288 | ((src . dst) (emit-mov asm dst src))) | |
289 | (lookup-parallel-moves handler allocation)) | |
290 | (emit-reset-frame asm nlocals) | |
291 | (emit-br asm khandler-body)))))) | |
6e8ad823 AW |
292 | (maybe-jump k)) |
293 | ||
294 | (define (emit-test kt kf) | |
295 | (define (unary op sym) | |
296 | (cond | |
297 | ((eq? kt next-label) | |
298 | (op asm (slot sym) #t kf)) | |
299 | (else | |
300 | (op asm (slot sym) #f kt) | |
301 | (maybe-jump kf)))) | |
302 | (define (binary op a b) | |
303 | (cond | |
304 | ((eq? kt next-label) | |
305 | (op asm (slot a) (slot b) #t kf)) | |
306 | (else | |
307 | (op asm (slot a) (slot b) #f kt) | |
308 | (maybe-jump kf)))) | |
309 | (match exp | |
310 | (($ $var sym) (unary emit-br-if-true sym)) | |
311 | (($ $primcall 'null? (a)) (unary emit-br-if-null a)) | |
312 | (($ $primcall 'nil? (a)) (unary emit-br-if-nil a)) | |
313 | (($ $primcall 'pair? (a)) (unary emit-br-if-pair a)) | |
314 | (($ $primcall 'struct? (a)) (unary emit-br-if-struct a)) | |
315 | (($ $primcall 'char? (a)) (unary emit-br-if-char a)) | |
be8b62ca AW |
316 | (($ $primcall 'symbol? (a)) (unary emit-br-if-symbol a)) |
317 | (($ $primcall 'variable? (a)) (unary emit-br-if-variable a)) | |
318 | (($ $primcall 'vector? (a)) (unary emit-br-if-vector a)) | |
319 | (($ $primcall 'string? (a)) (unary emit-br-if-string a)) | |
320 | ;; Add more TC7 tests here. Keep in sync with | |
321 | ;; *branching-primcall-arities* in (language cps primitives) and | |
322 | ;; the set of macro-instructions in assembly.scm. | |
6e8ad823 AW |
323 | (($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b)) |
324 | (($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b)) | |
325 | (($ $primcall 'equal? (a b)) (binary emit-br-if-equal a b)) | |
326 | (($ $primcall '< (a b)) (binary emit-br-if-< a b)) | |
327 | (($ $primcall '<= (a b)) (binary emit-br-if-<= a b)) | |
328 | (($ $primcall '= (a b)) (binary emit-br-if-= a b)) | |
329 | (($ $primcall '>= (a b)) (binary emit-br-if-<= b a)) | |
330 | (($ $primcall '> (a b)) (binary emit-br-if-< b a)))) | |
331 | ||
332 | (define (emit-trunc nreq rest? k) | |
333 | (match exp | |
334 | (($ $call proc args) | |
335 | (let ((proc-slot (lookup-call-proc-slot label allocation)) | |
336 | (nargs (length args))) | |
337 | (or (maybe-load-constant proc-slot proc) | |
338 | (maybe-mov proc-slot (slot proc))) | |
339 | (let lp ((n (1+ proc-slot)) (args args)) | |
340 | (match args | |
341 | (() | |
342 | (emit-call asm proc-slot (+ nargs 1)) | |
82f4bac4 AW |
343 | ;; FIXME: Only allow more values if there is a rest arg. |
344 | ;; Express values truncation by the presence of an | |
345 | ;; unused rest arg instead of implicitly. | |
346 | (emit-receive-values asm proc-slot #t nreq) | |
6e8ad823 AW |
347 | (when rest? |
348 | (emit-bind-rest asm (+ proc-slot 1 nreq))) | |
349 | (for-each (match-lambda | |
350 | ((src . dst) (emit-mov asm dst src))) | |
351 | (lookup-parallel-moves label allocation)) | |
352 | (emit-reset-frame asm nlocals)) | |
353 | ((arg . args) | |
354 | (or (maybe-load-constant n arg) | |
355 | (maybe-mov n (slot arg))) | |
356 | (lp (1+ n) args))))))) | |
357 | (maybe-jump k)) | |
358 | ||
359 | (match (lookup-cont k cont-table) | |
360 | (($ $ktail) (emit-tail)) | |
361 | (($ $kargs (name) (sym)) (emit-val sym)) | |
362 | (($ $kargs () ()) (emit-seq)) | |
363 | (($ $kargs names syms) (emit-vals syms)) | |
364 | (($ $kargs (name) (sym)) (emit-val sym)) | |
365 | (($ $kif kt kf) (emit-test kt kf)) | |
366 | (($ $ktrunc ($ $arity req () rest () #f) k) | |
367 | (emit-trunc (length req) (and rest #t) k)))) | |
368 | ||
369 | (define (collect-exps k src cont tail) | |
370 | (define (find-exp k src term) | |
371 | (match term | |
372 | (($ $continue exp-k exp) | |
373 | (cons (list k src exp-k exp) tail)) | |
374 | (($ $letk conts body) | |
375 | (find-exp k src body)))) | |
376 | (match cont | |
377 | (($ $kargs names syms body) | |
378 | (find-exp k src body)) | |
379 | (_ tail))) | |
380 | ||
381 | (let lp ((exps (reverse (fold-local-conts collect-exps '() exp)))) | |
382 | (match exps | |
383 | (() #t) | |
384 | (((k src exp-k exp) . exps) | |
385 | (let ((next-label (match exps | |
386 | (((k . _) . _) k) | |
387 | (() #f)))) | |
388 | (emit-label asm k) | |
e675e9bd AW |
389 | (when src |
390 | (emit-source asm src)) | |
6e8ad823 AW |
391 | (emit-rtl k exp-k exp next-label) |
392 | (lp exps)))))) | |
393 | ||
394 | (define (compile-fun f asm) | |
395 | (let ((allocation (allocate-slots f)) | |
396 | (cont-table (match f | |
397 | (($ $fun meta free body) | |
398 | (build-local-cont-table body))))) | |
399 | (define (emit-fun-clause clause alternate) | |
400 | (match clause | |
401 | (($ $cont k src | |
402 | ($ $kclause ($ $arity req opt rest kw allow-other-keys?) | |
403 | body)) | |
404 | (let ((kw-indices (map (match-lambda | |
405 | ((key name sym) | |
406 | (cons key (lookup-slot sym allocation)))) | |
407 | kw)) | |
408 | (nlocals (lookup-nlocals k allocation))) | |
409 | (emit-label asm k) | |
e675e9bd AW |
410 | (when src |
411 | (emit-source asm src)) | |
6e8ad823 AW |
412 | (emit-begin-kw-arity asm req opt rest kw-indices allow-other-keys? |
413 | nlocals alternate) | |
414 | (emit-rtl-sequence asm body allocation nlocals cont-table) | |
415 | (emit-end-arity asm))))) | |
416 | ||
417 | (define (emit-fun-clauses clauses) | |
418 | (match clauses | |
419 | ((clause . clauses) | |
420 | (let ((kalternate (match clauses | |
421 | (() #f) | |
422 | ((($ $cont k) . _) k)))) | |
423 | (emit-fun-clause clause kalternate) | |
424 | (when kalternate | |
425 | (emit-fun-clauses clauses)))))) | |
426 | ||
427 | (match f | |
428 | (($ $fun meta free ($ $cont k src ($ $kentry self tail clauses))) | |
429 | (emit-begin-program asm k (or meta '())) | |
e675e9bd AW |
430 | (when src |
431 | (emit-source asm src)) | |
6e8ad823 AW |
432 | (emit-fun-clauses clauses) |
433 | (emit-end-program asm))))) | |
434 | ||
435 | (define (compile-rtl exp env opts) | |
436 | (let* ((exp (fix-arities exp)) | |
437 | (exp (optimize exp opts)) | |
438 | (exp (convert-closures exp)) | |
439 | (exp (reify-primitives exp)) | |
440 | (asm (make-assembler))) | |
441 | (visit-funs (lambda (fun) | |
442 | (compile-fun fun asm)) | |
443 | exp) | |
444 | (values (link-assembly asm #:page-aligned? (kw-arg-ref opts #:to-file? #f)) | |
445 | env | |
446 | env))) |