mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 20:00:19 +02:00
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.
This commit is contained in:
Andy Wingo
parent
4a565538bd
commit
d258fcccee
2 changed files with 407 additions and 376 deletions
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue