[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, wip-rtl-halloween, updated. v2.1.0-319
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, wip-rtl-halloween, updated. v2.1.0-319-gd258fcc |
|
Date: |
Fri, 01 Nov 2013 13:46:35 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=d258fcccee2d96dc3cf90cecf3f3ee9ebb25b9db
The branch, wip-rtl-halloween has been updated
via d258fcccee2d96dc3cf90cecf3f3ee9ebb25b9db (commit)
via 4a565538bd9fe196494b3a4d4c9918bf5a6ed029 (commit)
via 58dee5b9e47c8186d894e847da0ff81aa9e9c073 (commit)
from cb8054c7acf7bcc05cefbe93ae242f394b9a105c (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit d258fcccee2d96dc3cf90cecf3f3ee9ebb25b9db
Author: Andy Wingo <address@hidden>
Date: Fri Nov 1 14:37:57 2013 +0100
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.
commit 4a565538bd9fe196494b3a4d4c9918bf5a6ed029
Author: Andy Wingo <address@hidden>
Date: Fri Nov 1 13:37:27 2013 +0100
Failed match errors generate less code
* module/ice-9/match.upstream.scm (match-next): Call out to an external
procedure on error, and use a begin instead of double-parens. This
results in less generated code.
commit 58dee5b9e47c8186d894e847da0ff81aa9e9c073
Author: Andy Wingo <address@hidden>
Date: Fri Nov 1 08:51:52 2013 +0100
Add compile-cps hack for vectors
* module/language/tree-il/compile-cps.scm (convert): Add a special case
for "vector" primcalls. Boo!
-----------------------------------------------------------------------
Summary of changes:
module/ice-9/match.upstream.scm | 13 +-
module/language/cps/compile-rtl.scm | 774 ++++++++++++++++---------------
module/language/cps/slot-allocation.scm | 9 +-
module/language/tree-il/compile-cps.scm | 44 ++-
4 files changed, 453 insertions(+), 387 deletions(-)
diff --git a/module/ice-9/match.upstream.scm b/module/ice-9/match.upstream.scm
index 4609883..e32ba85 100644
--- a/module/ice-9/match.upstream.scm
+++ b/module/ice-9/match.upstream.scm
@@ -280,14 +280,19 @@
;; clauses. `g+s' is a list of two elements, the get! and set!
;; expressions respectively.
+(define (match-error v)
+ (error 'match "no matching pattern" v))
+
(define-syntax match-next
(syntax-rules (=>)
;; no more clauses, the match failed
((match-next v g+s)
- ;; Here we wrap error within a double set of parentheses, so that
- ;; the call to 'error' won't be in tail position. This allows the
- ;; backtrace to show the source location of the failing match form.
- ((error 'match "no matching pattern" v)))
+ ;; Here we call match-error in non-tail context, so that the
+ ;; backtrace can show the source location of the failing match
+ ;; form.
+ (begin
+ (match-error v)
+ #f))
;; named failure continuation
((match-next v g+s (pat (=> failure) . body) . rest)
(let ((failure (lambda () (match-next v g+s . rest))))
diff --git a/module/language/cps/compile-rtl.scm
b/module/language/cps/compile-rtl.scm
index 51478c1..7ed0c11 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 ddc3751..c0d21d9 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))))
diff --git a/module/language/tree-il/compile-cps.scm
b/module/language/tree-il/compile-cps.scm
index 1d68644..9d19062 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -332,13 +332,43 @@
(build-cps-term ($continue k ($call proc args)))))))
(($ <primcall> src name args)
- (if (branching-primitive? name)
- (convert (make-conditional src exp (make-const #f #t)
- (make-const #f #f))
- k subst)
- (convert-args args
- (lambda (args)
- (build-cps-term ($continue k ($primcall name args)))))))
+ (cond
+ ((branching-primitive? name)
+ (convert (make-conditional src exp (make-const #f #t)
+ (make-const #f #f))
+ k subst))
+ ((eq? name 'vector)
+ ;; Some macros generate calls to "vector" with like 300
+ ;; arguments. Since we eventually compile to make-vector and
+ ;; vector-set!, it reduces live variable pressure to allocate the
+ ;; vector first, then set values as they are produced. Normally
+ ;; we would do this transformation in the compiler, but it's
+ ;; quite tricky there and quite easy here, so hold your nose
+ ;; while we drop some smelly code.
+ (convert (let ((len (length args)))
+ (let-gensyms (v)
+ (make-let src
+ (list 'v)
+ (list v)
+ (list (make-primcall src 'make-vector
+ (list (make-const #f len)
+ (make-const #f #f))))
+ (fold (lambda (arg n tail)
+ (make-seq
+ src
+ (make-primcall
+ src 'vector-set!
+ (list (make-lexical-ref src 'v v)
+ (make-const #f n)
+ arg))
+ tail))
+ (make-lexical-ref src 'v v)
+ (reverse args) (reverse (iota len))))))
+ k subst))
+ (else
+ (convert-args args
+ (lambda (args)
+ (build-cps-term ($continue k ($primcall name args))))))))
;; Prompts with inline handlers.
(($ <prompt> src escape-only? tag body
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, wip-rtl-halloween, updated. v2.1.0-319-gd258fcc,
Andy Wingo <=