1 ;;; Continuation-passing style (CPS) intermediate language (IL)
3 ;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.
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.
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.
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
21 ;;; Compiling CPS to bytecode. The result is in the bytecode language,
22 ;;; which happens to be an ELF image as a bytecode.
26 (define-module (language cps compile-bytecode)
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)
32 #:use-module (language cps contification)
33 #:use-module (language cps constructors)
34 #:use-module (language cps dce)
35 #:use-module (language cps dfg)
36 #:use-module (language cps elide-values)
37 #:use-module (language cps primitives)
38 #:use-module (language cps prune-top-level-scopes)
39 #:use-module (language cps reify-primitives)
40 #:use-module (language cps simplify)
41 #:use-module (language cps slot-allocation)
42 #:use-module (language cps specialize-primcalls)
43 #:use-module (system vm assembler)
44 #:export (compile-bytecode))
46 ;; TODO: Local var names.
48 (define (kw-arg-ref args kw default)
53 (define (optimize exp opts)
54 (define (run-pass exp pass kw default)
55 (if (kw-arg-ref opts kw default)
59 ;; The first DCE pass is mainly to eliminate functions that aren't
60 ;; called. The last is mainly to eliminate rest parameters that
61 ;; aren't used, and thus shouldn't be consed.
63 (let* ((exp (run-pass exp eliminate-dead-code #:eliminate-dead-code? #t))
64 (exp (run-pass exp prune-top-level-scopes #:prune-top-level-scopes? #t))
65 (exp (run-pass exp simplify #:simplify? #t))
66 (exp (run-pass exp contify #:contify? #t))
67 (exp (run-pass exp inline-constructors #:inline-constructors? #t))
68 (exp (run-pass exp specialize-primcalls #:specialize-primcalls? #t))
69 (exp (run-pass exp elide-values #:elide-values? #t))
70 (exp (run-pass exp eliminate-dead-code #:eliminate-dead-code? #t))
71 (exp (run-pass exp simplify #:simplify? #t)))
72 ;; Passes that are needed:
74 ;; * Abort contification: turning abort primcalls into continuation
75 ;; calls, and eliding prompts if possible.
77 ;; * Common subexpression elimination. Desperately needed.
79 ;; * Loop peeling. Unrolls the first round through a loop if the
80 ;; loop has effects that CSE can work on. Requires effects
81 ;; analysis. When run before CSE, loop peeling is the equivalent
82 ;; of loop-invariant code motion (LICM).
86 (define (collect-conts f cfa)
87 (let ((contv (make-vector (cfa-k-count cfa) #f)))
90 (let ((idx (cfa-k-idx cfa k #:default (lambda (k) #f))))
92 (vector-set! contv idx cont))))
97 (define (compile-fun f asm)
98 (let* ((dfg (compute-dfg f #:global? #f))
99 (cfa (analyze-control-flow f dfg))
100 (allocation (allocate-slots f dfg))
101 (contv (collect-conts f cfa)))
102 (define (lookup-cont k)
103 (vector-ref contv (cfa-k-idx cfa k)))
105 (define (maybe-slot sym)
106 (lookup-maybe-slot sym allocation))
109 (lookup-slot sym allocation))
111 (define (constant sym)
112 (lookup-constant-value sym allocation))
114 (define (maybe-mov dst src)
116 (emit-mov asm dst src)))
118 (define (maybe-load-constant slot src)
119 (call-with-values (lambda ()
120 (lookup-maybe-constant-value src allocation))
121 (lambda (has-const? val)
124 (emit-load-constant asm slot val)
127 (define (compile-entry meta)
128 (match (vector-ref contv 0)
129 (($ $kentry self tail clauses)
130 (emit-begin-program asm (cfa-k-sym cfa 0) meta)
132 (ks (map (match-lambda (($ $cont k) k)) clauses)))
135 (unless (= n (vector-length contv))
136 (error "unexpected end of clauses"))
137 (emit-end-program asm))
139 (unless (eq? (cfa-k-sym cfa n) k)
140 (error "unexpected k" k))
141 (lp (compile-clause n (and (pair? ks) (car ks)))
144 (define (compile-clause n alternate)
145 (match (vector-ref contv n)
146 (($ $kclause ($ $arity req opt rest kw allow-other-keys?))
147 (let* ((kw-indices (map (match-lambda
149 (cons key (lookup-slot sym allocation))))
151 (k (cfa-k-sym cfa n))
152 (nlocals (lookup-nlocals k allocation)))
154 (emit-begin-kw-arity asm req opt rest kw-indices
155 allow-other-keys? nlocals alternate)
156 (let ((next (compile-body (1+ n) nlocals)))
160 (define (compile-body n nlocals)
161 (let compile-cont ((n n))
162 (if (= n (vector-length contv))
164 (match (vector-ref contv n)
167 (emit-label asm (cfa-k-sym cfa n))
168 (let find-exp ((term term))
170 (($ $letk conts term)
172 (($ $continue k src exp)
174 (emit-source asm src))
175 (compile-expression n k exp nlocals)
176 (compile-cont (1+ n))))))
178 (emit-label asm (cfa-k-sym cfa n))
179 (compile-cont (1+ n)))))))
181 (define (compile-expression n k exp nlocals)
182 (let* ((label (cfa-k-sym cfa n))
183 (k-idx (cfa-k-idx cfa k))
184 (fallthrough? (= k-idx (1+ n))))
185 (define (maybe-emit-jump)
186 (unless (= k-idx (1+ n))
188 (match (vector-ref contv k-idx)
190 (compile-tail label exp))
191 (($ $kargs (name) (sym))
192 (let ((dst (maybe-slot sym)))
194 (compile-value label exp dst nlocals)))
197 (compile-effect label exp k nlocals)
199 (($ $kargs names syms)
200 (compile-values label exp syms)
203 (compile-test label exp kt kf
204 (and (= k-idx (1+ n))
205 (< (+ n 2) (cfa-k-count cfa))
206 (cfa-k-sym cfa (+ n 2)))))
207 (($ $kreceive ($ $arity req () rest () #f) kargs)
208 (compile-trunc label k exp (length req)
210 (match (vector-ref contv (cfa-k-idx cfa kargs))
211 (($ $kargs names (_ ... rest)) rest)))
213 (unless (and (= k-idx (1+ n))
214 (< (+ n 2) (cfa-k-count cfa))
215 (eq? (cfa-k-sym cfa (+ n 2)) kargs))
216 (emit-br asm kargs))))))
218 (define (compile-tail label exp)
219 ;; There are only three kinds of expressions in tail position:
220 ;; tail calls, multiple-value returns, and single-value returns.
223 (for-each (match-lambda
224 ((src . dst) (emit-mov asm dst src)))
225 (lookup-parallel-moves label allocation))
226 (let ((tail-slots (cdr (iota (1+ (length args))))))
227 (for-each maybe-load-constant tail-slots args))
228 (emit-tail-call asm (1+ (length args))))
229 (($ $callk k proc args)
230 (for-each (match-lambda
231 ((src . dst) (emit-mov asm dst src)))
232 (lookup-parallel-moves label allocation))
233 (let ((tail-slots (cdr (iota (1+ (length args))))))
234 (for-each maybe-load-constant tail-slots args))
235 (emit-tail-call-label asm (1+ (length args)) k))
237 (emit-reset-frame asm 1)
238 (emit-return-values asm))
241 (emit-return asm (slot arg))
243 (emit-load-constant asm 1 (constant arg))
244 (emit-return asm 1))))
246 (for-each (match-lambda
247 ((src . dst) (emit-mov asm dst src)))
248 (lookup-parallel-moves label allocation))
249 (let ((tail-slots (cdr (iota (1+ (length args))))))
250 (for-each maybe-load-constant tail-slots args))
251 (emit-reset-frame asm (1+ (length args)))
252 (emit-return-values asm))
253 (($ $primcall 'return (arg))
254 (emit-return asm (slot arg)))))
256 (define (compile-value label exp dst nlocals)
259 (or (maybe-load-constant dst arg)
260 (maybe-mov dst (slot arg))))
262 (emit-load-constant asm dst *unspecified*))
264 (emit-load-constant asm dst exp))
265 (($ $fun src meta () ($ $cont k))
266 (emit-load-static-procedure asm dst k))
267 (($ $fun src meta free ($ $cont k))
268 (emit-make-closure asm dst k (length free)))
269 (($ $primcall 'current-module)
270 (emit-current-module asm dst))
271 (($ $primcall 'cached-toplevel-box (scope name bound?))
272 (emit-cached-toplevel-box asm dst (constant scope) (constant name)
274 (($ $primcall 'cached-module-box (mod name public? bound?))
275 (emit-cached-module-box asm dst (constant mod) (constant name)
276 (constant public?) (constant bound?)))
277 (($ $primcall 'resolve (name bound?))
278 (emit-resolve asm dst (constant bound?) (slot name)))
279 (($ $primcall 'free-ref (closure idx))
280 (emit-free-ref asm dst (slot closure) (constant idx)))
281 (($ $primcall 'vector-ref (vector index))
282 (emit-vector-ref asm dst (slot vector) (slot index)))
283 (($ $primcall 'make-vector/immediate (length init))
284 (emit-make-vector/immediate asm dst (constant length) (slot init)))
285 (($ $primcall 'vector-ref/immediate (vector index))
286 (emit-vector-ref/immediate asm dst (slot vector) (constant index)))
287 (($ $primcall 'allocate-struct/immediate (vtable nfields))
288 (emit-allocate-struct/immediate asm dst (slot vtable) (constant nfields)))
289 (($ $primcall 'struct-ref/immediate (struct n))
290 (emit-struct-ref/immediate asm dst (slot struct) (constant n)))
291 (($ $primcall 'builtin-ref (name))
292 (emit-builtin-ref asm dst (constant name)))
293 (($ $primcall 'bv-u8-ref (bv idx))
294 (emit-bv-u8-ref asm dst (slot bv) (slot idx)))
295 (($ $primcall 'bv-s8-ref (bv idx))
296 (emit-bv-s8-ref asm dst (slot bv) (slot idx)))
297 (($ $primcall 'bv-u16-ref (bv idx))
298 (emit-bv-u16-ref asm dst (slot bv) (slot idx)))
299 (($ $primcall 'bv-s16-ref (bv idx))
300 (emit-bv-s16-ref asm dst (slot bv) (slot idx)))
301 (($ $primcall 'bv-u32-ref (bv idx val))
302 (emit-bv-u32-ref asm dst (slot bv) (slot idx)))
303 (($ $primcall 'bv-s32-ref (bv idx val))
304 (emit-bv-s32-ref asm dst (slot bv) (slot idx)))
305 (($ $primcall 'bv-u64-ref (bv idx val))
306 (emit-bv-u64-ref asm dst (slot bv) (slot idx)))
307 (($ $primcall 'bv-s64-ref (bv idx val))
308 (emit-bv-s64-ref asm dst (slot bv) (slot idx)))
309 (($ $primcall 'bv-f32-ref (bv idx val))
310 (emit-bv-f32-ref asm dst (slot bv) (slot idx)))
311 (($ $primcall 'bv-f64-ref (bv idx val))
312 (emit-bv-f64-ref asm dst (slot bv) (slot idx)))
313 (($ $primcall name args)
314 ;; FIXME: Inline all the cases.
315 (let ((inst (prim-instruction name)))
316 (emit-text asm `((,inst ,dst ,@(map slot args))))))))
318 (define (compile-effect label exp k nlocals)
321 (($ $prompt escape? tag handler)
322 (match (lookup-cont handler)
323 (($ $kreceive ($ $arity req () rest () #f) khandler-body)
324 (let ((receive-args (gensym "handler"))
326 (proc-slot (lookup-call-proc-slot handler allocation)))
327 (emit-prompt asm (slot tag) escape? proc-slot receive-args)
329 (emit-label asm receive-args)
330 (unless (and rest (zero? nreq))
331 (emit-receive-values asm proc-slot (->bool rest) nreq))
333 (match (vector-ref contv (cfa-k-idx cfa khandler-body))
334 (($ $kargs names (_ ... rest))
336 (emit-bind-rest asm (+ proc-slot 1 nreq)))
337 (for-each (match-lambda
338 ((src . dst) (emit-mov asm dst src)))
339 (lookup-parallel-moves handler allocation))
340 (emit-reset-frame asm nlocals)
341 (emit-br asm khandler-body)))))
342 (($ $primcall 'cache-current-module! (sym scope))
343 (emit-cache-current-module! asm (slot sym) (constant scope)))
344 (($ $primcall 'free-set! (closure idx value))
345 (emit-free-set! asm (slot closure) (slot value) (constant idx)))
346 (($ $primcall 'box-set! (box value))
347 (emit-box-set! asm (slot box) (slot value)))
348 (($ $primcall 'struct-set!/immediate (struct index value))
349 (emit-struct-set!/immediate asm (slot struct) (constant index) (slot value)))
350 (($ $primcall 'vector-set! (vector index value))
351 (emit-vector-set! asm (slot vector) (slot index) (slot value)))
352 (($ $primcall 'vector-set!/immediate (vector index value))
353 (emit-vector-set!/immediate asm (slot vector) (constant index)
355 (($ $primcall 'variable-set! (var val))
356 (emit-box-set! asm (slot var) (slot val)))
357 (($ $primcall 'set-car! (pair value))
358 (emit-set-car! asm (slot pair) (slot value)))
359 (($ $primcall 'set-cdr! (pair value))
360 (emit-set-cdr! asm (slot pair) (slot value)))
361 (($ $primcall 'define! (sym value))
362 (emit-define! asm (slot sym) (slot value)))
363 (($ $primcall 'push-fluid (fluid val))
364 (emit-push-fluid asm (slot fluid) (slot val)))
365 (($ $primcall 'pop-fluid ())
366 (emit-pop-fluid asm))
367 (($ $primcall 'wind (winder unwinder))
368 (emit-wind asm (slot winder) (slot unwinder)))
369 (($ $primcall 'bv-u8-set! (bv idx val))
370 (emit-bv-u8-set! asm (slot bv) (slot idx) (slot val)))
371 (($ $primcall 'bv-s8-set! (bv idx val))
372 (emit-bv-s8-set! asm (slot bv) (slot idx) (slot val)))
373 (($ $primcall 'bv-u16-set! (bv idx val))
374 (emit-bv-u16-set! asm (slot bv) (slot idx) (slot val)))
375 (($ $primcall 'bv-s16-set! (bv idx val))
376 (emit-bv-s16-set! asm (slot bv) (slot idx) (slot val)))
377 (($ $primcall 'bv-u32-set! (bv idx val))
378 (emit-bv-u32-set! asm (slot bv) (slot idx) (slot val)))
379 (($ $primcall 'bv-s32-set! (bv idx val))
380 (emit-bv-s32-set! asm (slot bv) (slot idx) (slot val)))
381 (($ $primcall 'bv-u64-set! (bv idx val))
382 (emit-bv-u64-set! asm (slot bv) (slot idx) (slot val)))
383 (($ $primcall 'bv-s64-set! (bv idx val))
384 (emit-bv-s64-set! asm (slot bv) (slot idx) (slot val)))
385 (($ $primcall 'bv-f32-set! (bv idx val))
386 (emit-bv-f32-set! asm (slot bv) (slot idx) (slot val)))
387 (($ $primcall 'bv-f64-set! (bv idx val))
388 (emit-bv-f64-set! asm (slot bv) (slot idx) (slot val)))
389 (($ $primcall 'unwind ())
392 (define (compile-values label exp syms)
395 (for-each (match-lambda
396 ((src . dst) (emit-mov asm dst src)))
397 (lookup-parallel-moves label allocation))
398 (for-each maybe-load-constant (map slot syms) args))))
400 (define (compile-test label exp kt kf next-label)
401 (define (unary op sym)
404 (op asm (slot sym) #t kf))
406 (op asm (slot sym) #f kt)
407 (unless (eq? kf next-label)
409 (define (binary op a b)
412 (op asm (slot a) (slot b) #t kf))
414 (op asm (slot a) (slot b) #f kt)
415 (unless (eq? kf next-label)
419 (call-with-values (lambda ()
420 (lookup-maybe-constant-value sym allocation))
421 (lambda (has-const? val)
424 (unless (eq? kt next-label)
426 (unless (eq? kf next-label)
428 (unary emit-br-if-true sym)))))
429 (($ $primcall 'null? (a)) (unary emit-br-if-null a))
430 (($ $primcall 'nil? (a)) (unary emit-br-if-nil a))
431 (($ $primcall 'pair? (a)) (unary emit-br-if-pair a))
432 (($ $primcall 'struct? (a)) (unary emit-br-if-struct a))
433 (($ $primcall 'char? (a)) (unary emit-br-if-char a))
434 (($ $primcall 'symbol? (a)) (unary emit-br-if-symbol a))
435 (($ $primcall 'variable? (a)) (unary emit-br-if-variable a))
436 (($ $primcall 'vector? (a)) (unary emit-br-if-vector a))
437 (($ $primcall 'string? (a)) (unary emit-br-if-string a))
438 (($ $primcall 'bytevector? (a)) (unary emit-br-if-bytevector a))
439 ;; Add more TC7 tests here. Keep in sync with
440 ;; *branching-primcall-arities* in (language cps primitives) and
441 ;; the set of macro-instructions in assembly.scm.
442 (($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b))
443 (($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b))
444 (($ $primcall 'equal? (a b)) (binary emit-br-if-equal a b))
445 (($ $primcall '< (a b)) (binary emit-br-if-< a b))
446 (($ $primcall '<= (a b)) (binary emit-br-if-<= a b))
447 (($ $primcall '= (a b)) (binary emit-br-if-= a b))
448 (($ $primcall '>= (a b)) (binary emit-br-if-<= b a))
449 (($ $primcall '> (a b)) (binary emit-br-if-< b a))))
451 (define (compile-trunc label k exp nreq rest-var nlocals)
452 (define (do-call proc args emit-call)
453 (let* ((proc-slot (lookup-call-proc-slot label allocation))
454 (nargs (1+ (length args)))
455 (arg-slots (map (lambda (x) (+ x proc-slot)) (iota nargs))))
456 (for-each (match-lambda
457 ((src . dst) (emit-mov asm dst src)))
458 (lookup-parallel-moves label allocation))
459 (for-each maybe-load-constant arg-slots (cons proc args))
460 (emit-call asm proc-slot nargs)
461 (emit-dead-slot-map asm proc-slot
462 (lookup-dead-slot-map label allocation))
464 ((and (= 1 nreq) (and rest-var) (not (maybe-slot rest-var))
465 (match (lookup-parallel-moves k allocation)
466 ((((? (lambda (src) (= src (1+ proc-slot))) src)
469 ;; The usual case: one required live return value, ignoring
470 ;; any additional values.
472 (emit-receive asm dst proc-slot nlocals)))
474 (unless (and (zero? nreq) rest-var)
475 (emit-receive-values asm proc-slot (->bool rest-var) nreq))
476 (when (and rest-var (maybe-slot rest-var))
477 (emit-bind-rest asm (+ proc-slot 1 nreq)))
478 (for-each (match-lambda
479 ((src . dst) (emit-mov asm dst src)))
480 (lookup-parallel-moves k allocation))
481 (emit-reset-frame asm nlocals)))))
485 (lambda (asm proc-slot nargs)
486 (emit-call asm proc-slot nargs))))
487 (($ $callk k proc args)
489 (lambda (asm proc-slot nargs)
490 (emit-call-label asm proc-slot nargs k))))))
493 (($ $fun src meta free ($ $cont k ($ $kentry self tail clauses)))
494 ;; FIXME: src on kentry instead?
496 (emit-source asm src))
497 (compile-entry (or meta '()))))))
499 (define (visit-funs proc exp)
501 (($ $continue _ _ exp)
502 (visit-funs proc exp))
504 (($ $fun src meta free body)
506 (visit-funs proc body))
508 (($ $letk conts body)
509 (visit-funs proc body)
510 (for-each (lambda (cont) (visit-funs proc cont)) conts))
512 (($ $cont sym ($ $kargs names syms body))
513 (visit-funs proc body))
515 (($ $cont sym ($ $kclause arity body))
516 (visit-funs proc body))
518 (($ $cont sym ($ $kentry self tail clauses))
519 (for-each (lambda (clause) (visit-funs proc clause)) clauses))
523 (define (compile-bytecode exp env opts)
524 (let* ((exp (fix-arities exp))
525 (exp (optimize exp opts))
526 (exp (convert-closures exp))
527 (exp (reify-primitives exp))
528 (asm (make-assembler)))
529 (visit-funs (lambda (fun)
530 (compile-fun fun asm))
532 (values (link-assembly asm #:page-aligned? (kw-arg-ref opts #:to-file? #f))