summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2013-11-01 14:37:57 +0100
committerAndy Wingo <wingo@pobox.com>2013-11-01 14:37:57 +0100
commitd258fcccee2d96dc3cf90cecf3f3ee9ebb25b9db (patch)
tree9b0c06d924e12081eec94f243e94cf0d6a7ab4f4 /module
parent4a565538bd9fe196494b3a4d4c9918bf5a6ed029 (diff)
downloadguile-d258fcccee2d96dc3cf90cecf3f3ee9ebb25b9db.tar.gz
RTL compilation sorts continuations topologically before visiting them
* module/language/cps/compile-rtl.scm (compile-fun): Rewrite to visit conts in reverse-post-order, which is a topological sort on the basic blocks. * module/language/cps/slot-allocation.scm (allocate-slots): Expect a DFG as an argument.
Diffstat (limited to 'module')
-rw-r--r--module/language/cps/compile-rtl.scm774
-rw-r--r--module/language/cps/slot-allocation.scm9
2 files changed, 407 insertions, 376 deletions
diff --git a/module/language/cps/compile-rtl.scm b/module/language/cps/compile-rtl.scm
index 51478c125..7ed0c1113 100644
--- a/module/language/cps/compile-rtl.scm
+++ b/module/language/cps/compile-rtl.scm
@@ -39,8 +39,7 @@
#:use-module (system vm assembler)
#:export (compile-rtl))
-;; TODO: Source info, local var names. Needs work in the linker and the
-;; debugger.
+;; TODO: Local var names.
(define (kw-arg-ref args kw default)
(match (memq kw args)
@@ -78,6 +77,408 @@
exp))
+(define (collect-conts f cfa)
+ (let ((srcv (make-vector (cfa-k-count cfa) #f))
+ (contv (make-vector (cfa-k-count cfa) #f)))
+ (fold-local-conts
+ (lambda (k src cont tail)
+ (let ((idx (cfa-k-idx cfa k #:default (lambda (k) #f))))
+ (when idx
+ (when src
+ (vector-set! srcv idx src))
+ (vector-set! contv idx cont))))
+ '()
+ (match f
+ (($ $fun meta free entry)
+ entry)))
+ (values srcv contv)))
+
+(define (compile-fun f asm)
+ (let* ((dfg (compute-dfg f #:global? #f))
+ (cfa (analyze-control-flow f dfg))
+ (allocation (allocate-slots f dfg)))
+ (call-with-values (lambda () (collect-conts f cfa))
+ (lambda (srcv contv)
+ (define (lookup-cont k)
+ (vector-ref contv (cfa-k-idx cfa k)))
+
+ (define (maybe-emit-source n)
+ (let ((src (vector-ref srcv n)))
+ (when src
+ (emit-source asm src))))
+
+ (define (emit-label-and-maybe-source n)
+ (emit-label asm (cfa-k-sym cfa n))
+ (maybe-emit-source n))
+
+ (define (immediate-u8? val)
+ (and (integer? val) (exact? val) (<= 0 val 255)))
+
+ (define (maybe-immediate-u8 sym)
+ (call-with-values (lambda ()
+ (lookup-maybe-constant-value sym allocation))
+ (lambda (has-const? val)
+ (and has-const? (immediate-u8? val) val))))
+
+ (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 meta)
+ (match (vector-ref contv 0)
+ (($ $kentry self tail clauses)
+ (emit-begin-program asm (cfa-k-sym cfa 0) meta)
+ (maybe-emit-source 0)
+ (let lp ((n 1)
+ (ks (map (match-lambda (($ $cont k) k)) clauses)))
+ (match ks
+ (()
+ (unless (= n (vector-length contv))
+ (error "unexpected end of clauses"))
+ (emit-end-program asm))
+ ((k . ks)
+ (unless (eq? (cfa-k-sym cfa n) k)
+ (error "unexpected k" k))
+ (lp (compile-clause n (and (pair? ks) (car ks)))
+ ks)))))))
+
+ (define (compile-clause n alternate)
+ (match (vector-ref contv n)
+ (($ $kclause ($ $arity req opt rest kw allow-other-keys?))
+ (let ((kw-indices (map (match-lambda
+ ((key name sym)
+ (cons key (lookup-slot sym allocation))))
+ kw))
+ (nlocals (lookup-nlocals (cfa-k-sym cfa n) allocation)))
+ (emit-label-and-maybe-source n)
+ (emit-begin-kw-arity asm req opt rest kw-indices
+ allow-other-keys? nlocals alternate)
+ (let ((next (compile-body (1+ n) nlocals)))
+ (emit-end-arity asm)
+ next)))))
+
+ (define (compile-body n nlocals)
+ (let compile-cont ((n n))
+ (if (= n (vector-length contv))
+ n
+ (match (vector-ref contv n)
+ (($ $kclause) n)
+ (($ $kargs _ _ term)
+ (emit-label-and-maybe-source n)
+ (let find-exp ((term term))
+ (match term
+ (($ $letk conts term)
+ (find-exp term))
+ (($ $continue k exp)
+ (compile-expression n k exp nlocals)
+ (compile-cont (1+ n))))))
+ (_
+ (emit-label-and-maybe-source n)
+ (compile-cont (1+ n)))))))
+
+ (define (compile-expression n k exp nlocals)
+ (let* ((label (cfa-k-sym cfa n))
+ (k-idx (cfa-k-idx cfa k))
+ (fallthrough? (= k-idx (1+ n))))
+ (define (maybe-emit-jump)
+ (unless (= k-idx (1+ n))
+ (emit-br asm k)))
+ (match (vector-ref contv k-idx)
+ (($ $ktail)
+ (compile-tail label exp))
+ (($ $kargs (name) (sym))
+ (let ((dst (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 (= k-idx (1+ n))
+ (< (+ n 2) (cfa-k-count cfa))
+ (cfa-k-sym cfa (+ n 2)))))
+ (($ $ktrunc ($ $arity req () rest () #f) k)
+ (compile-trunc label exp (length req) (and rest #t) nlocals)
+ (unless (and (= k-idx (1+ n))
+ (< (+ n 2) (cfa-k-count cfa))
+ (eq? (cfa-k-sym cfa (+ n 2)) k))
+ (emit-br asm k))))))
+
+ (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))))
+ (($ $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 (compile-value label exp dst nlocals)
+ (match exp
+ (($ $var sym)
+ (maybe-mov dst (slot sym)))
+ ;; FIXME: Remove ($var sym), replace with ($values (sym))
+ (($ $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))
+ (($ $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 'make-vector (length init))
+ (cond
+ ((maybe-immediate-u8 length)
+ => (lambda (length)
+ (emit-constant-make-vector asm dst length (slot init))))
+ (else
+ (emit-make-vector asm dst (slot length) (slot init)))))
+ (($ $primcall 'vector-ref (vector index))
+ (cond
+ ((maybe-immediate-u8 index)
+ => (lambda (index)
+ (emit-constant-vector-ref asm dst (slot vector) index)))
+ (else
+ (emit-vector-ref asm dst (slot vector) (slot index)))))
+ (($ $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-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-rtl-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 pop)
+ (match (lookup-cont handler)
+ (($ $ktrunc ($ $arity req () rest () #f) khandler-body)
+ (let ((receive-args (gensym "handler"))
+ (nreq (length req))
+ (proc-slot (lookup-call-proc-slot label allocation)))
+ (emit-prompt asm (slot tag) escape? proc-slot receive-args)
+ (emit-br asm k)
+ (emit-label asm receive-args)
+ (emit-receive-values asm proc-slot (->bool rest) 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 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! (struct index value))
+ (emit-struct-set! asm (slot struct) (slot index) (slot value)))
+ (($ $primcall 'vector-set! (vector index value))
+ (call-with-values (lambda ()
+ (lookup-maybe-constant-value index allocation))
+ (lambda (has-const? index-val)
+ (if (and has-const? (integer? index-val) (exact? index-val)
+ (<= 0 index-val 255))
+ (emit-constant-vector-set! asm (slot vector) index-val
+ (slot value))
+ (emit-vector-set! asm (slot vector) (slot index)
+ (slot value))))))
+ (($ $primcall 'variable-set! (var val))
+ (emit-box-set! asm (slot var) (slot val)))
+ (($ $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-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
+ (($ $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))
+ (($ $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 exp nreq rest? nlocals)
+ (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))
+ ;; FIXME: Only allow more values if there is a rest arg.
+ ;; Express values truncation by the presence of an
+ ;; unused rest arg instead of implicitly.
+ (emit-receive-values asm proc-slot #t 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))))))))
+
+ (match f
+ (($ $fun meta free ($ $cont k src ($ $kentry self tail clauses)))
+ (compile-entry (or meta '()))))))))
+
(define (visit-funs proc exp)
(match exp
(($ $continue _ exp)
@@ -102,375 +503,6 @@
(_ (values))))
-(define (emit-rtl-sequence asm exp allocation nlocals cont-table)
- (define (immediate-u8? val)
- (and (integer? val) (exact? val) (<= 0 val 255)))
-
- (define (maybe-immediate-u8 sym)
- (call-with-values (lambda ()
- (lookup-maybe-constant-value sym allocation))
- (lambda (has-const? val)
- (and has-const? (immediate-u8? val) val))))
-
- (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 'make-vector (length init))
- (cond
- ((maybe-immediate-u8 length)
- => (lambda (length)
- (emit-constant-make-vector asm dst length (slot init))))
- (else
- (emit-make-vector asm dst (slot length) (slot init)))))
- (($ $primcall 'vector-ref (vector index))
- (cond
- ((maybe-immediate-u8 index)
- => (lambda (index)
- (emit-constant-vector-ref asm dst (slot vector) index)))
- (else
- (emit-vector-ref asm dst (slot vector) (slot index)))))
- (($ $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-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-rtl-instruction name)))
- (emit-text asm `((,inst ,dst ,@(map slot args))))))
- (($ $values (arg))
- (or (maybe-load-constant dst arg)
- (maybe-mov dst (slot arg)))))
- (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))
- (call-with-values (lambda ()
- (lookup-maybe-constant-value index allocation))
- (lambda (has-const? index-val)
- (if (and has-const? (integer? index-val) (exact? index-val)
- (<= 0 index-val 255))
- (emit-constant-vector-set! asm (slot vector) index-val
- (slot value))
- (emit-vector-set! asm (slot vector) (slot index)
- (slot value))))))
- (($ $primcall 'variable-set! (var val))
- (emit-box-set! asm (slot var) (slot val)))
- (($ $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-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))
- (($ $primcall name args)
- (error "unhandled primcall in seq context" name))
- (($ $values ()) #f)
- (($ $prompt escape? tag handler pop)
- (match (lookup-cont handler cont-table)
- (($ $ktrunc ($ $arity req () rest () #f) khandler-body)
- (let ((receive-args (gensym "handler"))
- (nreq (length req))
- (proc-slot (lookup-call-proc-slot label allocation)))
- (emit-prompt asm (slot tag) escape? proc-slot receive-args)
- (emit-br asm k)
- (emit-label asm receive-args)
- (emit-receive-values asm proc-slot (->bool rest) 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 handler allocation))
- (emit-reset-frame asm nlocals)
- (emit-br asm khandler-body))))))
- (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))
- (($ $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 (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))
- ;; FIXME: Only allow more values if there is a rest arg.
- ;; Express values truncation by the presence of an
- ;; unused rest arg instead of implicitly.
- (emit-receive-values asm proc-slot #t 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)
- (when src
- (emit-source asm src))
- (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)
- (when src
- (emit-source asm src))
- (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 '()))
- (when src
- (emit-source asm src))
- (emit-fun-clauses clauses)
- (emit-end-program asm)))))
-
(define (compile-rtl exp env opts)
(pk 'COMPILING)
(let* ((exp (fix-arities exp))
diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm
index ddc3751cf..c0d21d9ec 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -198,7 +198,7 @@ are comparable with eqv?. A tmp slot may be used."
(let ((l (dfa-k-idx dfa use-k)))
(not (bitvector-ref (dfa-k-out dfa l) v-idx))))
-(define (allocate-slots fun)
+(define (allocate-slots fun dfg)
(define (empty-live-slots)
#b0)
@@ -231,7 +231,7 @@ are comparable with eqv?. A tmp slot may be used."
live-slots)))
live-slots)))))
- (define (visit-clause clause dfg dfa allocation slots live-slots)
+ (define (visit-clause clause dfa allocation slots live-slots)
(define nlocals (compute-slot live-slots #f))
(define nargs
(match clause
@@ -426,13 +426,12 @@ are comparable with eqv?. A tmp slot may be used."
(match fun
(($ $fun meta free ($ $cont k _ ($ $kentry self tail clauses)))
- (let* ((dfg (compute-dfg fun #:global? #f))
- (dfa (compute-live-variables fun dfg))
+ (let* ((dfa (compute-live-variables fun dfg))
(allocation (make-hash-table))
(slots (make-vector (dfa-var-count dfa) #f))
(live-slots (add-live-slot 0 (empty-live-slots))))
(vector-set! slots (dfa-var-idx dfa self) 0)
(hashq-set! allocation self (make-allocation 0 #f #f))
- (for-each (cut visit-clause <> dfg dfa allocation slots live-slots)
+ (for-each (cut visit-clause <> dfa allocation slots live-slots)
clauses)
allocation))))