mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-11 22:31:12 +02:00
Code Activity

Compile-fun takes advantage of sorted output of "renumber", avoids CFA

Browse source 
* module/language/cps/dfg.scm ($dfg): Rename nvars and nlabels fields to
  var-count and label-count.  Export dfg-min-var, dfg-min-label,
  dfg-label-count, dfg-var-count.

* module/language/cps/compile-bytecode.scm (compile-fun): No need to
  build a CFA given the renumbering pass.  Adapt to treat labels as
  ordered small integer in a contiguous vector.
This commit is contained in:
Andy Wingo 2014-04-01 12:42:09 +02:00
parent 09220d215f
commit a8430ab1d7
2 changed files with 42 additions and 61 deletions
Download patch file Download diff file Expand all files Collapse all files

91
module/language/cps/compile-bytecode.scm
View file

@ -84,25 +84,9 @@
exp)) exp))
(define (collect-conts f cfa)
(let ((contv (make-vector (cfa-k-count cfa) #f)))
(fold-local-conts
(lambda (k cont tail)
(let ((idx (cfa-k-idx cfa k #:default (lambda (k) #f))))
(when idx
(vector-set! contv idx cont))))
'()
f)
contv))
(define (compile-fun f asm) (define (compile-fun f asm)
(let* ((dfg (compute-dfg f #:global? #f)) (let* ((dfg (compute-dfg f #:global? #f))
(cfa (analyze-control-flow f dfg)) (allocation (allocate-slots f dfg)))
(allocation (allocate-slots f dfg))
(contv (collect-conts f cfa)))
(define (lookup-cont k)
(vector-ref contv (cfa-k-idx cfa k)))
(define (maybe-slot sym) (define (maybe-slot sym)
(lookup-maybe-slot sym allocation)) (lookup-maybe-slot sym allocation))
@ -126,45 +110,45 @@
#t))))) #t)))))
(define (compile-entry meta) (define (compile-entry meta)
(match (vector-ref contv 0) (let ((label (dfg-min-label dfg)))
(($ $kentry self tail clause) (match (lookup-cont label dfg)
(emit-begin-program asm (cfa-k-sym cfa 0) meta) (($ $kentry self tail clause)
(compile-clause 1) (emit-begin-program asm label meta)
(emit-end-program asm)))) (compile-clause (1+ label))
(emit-end-program asm)))))
(define (compile-clause n) (define (compile-clause label)
(match (vector-ref contv n) (match (lookup-cont label dfg)
(($ $kclause ($ $arity req opt rest kw allow-other-keys?) (($ $kclause ($ $arity req opt rest kw allow-other-keys?)
body alternate) body alternate)
(let* ((kw-indices (map (match-lambda (let* ((kw-indices (map (match-lambda
((key name sym) ((key name sym)
(cons key (lookup-slot sym allocation)))) (cons key (lookup-slot sym allocation))))
kw)) kw))
(k (cfa-k-sym cfa n)) (nlocals (lookup-nlocals label allocation)))
(nlocals (lookup-nlocals k allocation))) (emit-label asm label)
(emit-label asm k)
(emit-begin-kw-arity asm req opt rest kw-indices allow-other-keys? (emit-begin-kw-arity asm req opt rest kw-indices allow-other-keys?
nlocals nlocals
(match alternate (#f #f) (($ $cont alt) alt))) (match alternate (#f #f) (($ $cont alt) alt)))
(let ((next (compile-body (1+ n) nlocals))) (let ((next (compile-body (1+ label) nlocals)))
(emit-end-arity asm) (emit-end-arity asm)
(match alternate (match alternate
(($ $cont alt) (($ $cont alt)
(unless (eq? (cfa-k-sym cfa next) alt) (unless (eq? next alt)
(error "unexpected k" alt)) (error "unexpected k" alt))
(compile-clause next)) (compile-clause next))
(#f (#f
(unless (= next (vector-length contv)) (unless (= next (+ (dfg-min-label dfg) (dfg-label-count dfg)))
(error "unexpected end of clauses"))))))))) (error "unexpected end of clauses")))))))))
(define (compile-body n nlocals) (define (compile-body label nlocals)
(let compile-cont ((n n)) (let compile-cont ((label label))
(if (= n (vector-length contv)) (if (eq? label (+ (dfg-min-label dfg) (dfg-label-count dfg)))
n label
(match (vector-ref contv n) (match (lookup-cont label dfg)
(($ $kclause) n) (($ $kclause) label)
(($ $kargs _ _ term) (($ $kargs _ _ term)
(emit-label asm (cfa-k-sym cfa n)) (emit-label asm label)
(let find-exp ((term term)) (let find-exp ((term term))
(match term (match term
(($ $letk conts term) (($ $letk conts term)
@ -172,20 +156,18 @@
(($ $continue k src exp) (($ $continue k src exp)
(when src (when src
(emit-source asm src)) (emit-source asm src))
(compile-expression n k exp nlocals) (compile-expression label k exp nlocals)
(compile-cont (1+ n)))))) (compile-cont (1+ label))))))
(_ (_
(emit-label asm (cfa-k-sym cfa n)) (emit-label asm label)
(compile-cont (1+ n))))))) (compile-cont (1+ label)))))))
(define (compile-expression n k exp nlocals) (define (compile-expression label k exp nlocals)
(let* ((label (cfa-k-sym cfa n)) (let* ((fallthrough? (= k (1+ label))))
(k-idx (cfa-k-idx cfa k))
(fallthrough? (= k-idx (1+ n))))
(define (maybe-emit-jump) (define (maybe-emit-jump)
(unless (= k-idx (1+ n)) (unless fallthrough?
(emit-br asm k))) (emit-br asm k)))
(match (vector-ref contv k-idx) (match (lookup-cont k dfg)
(($ $ktail) (($ $ktail)
(compile-tail label exp)) (compile-tail label exp))
(($ $kargs (name) (sym)) (($ $kargs (name) (sym))
@ -200,19 +182,14 @@
(compile-values label exp syms) (compile-values label exp syms)
(maybe-emit-jump)) (maybe-emit-jump))
(($ $kif kt kf) (($ $kif kt kf)
(compile-test label exp kt kf (compile-test label exp kt kf (and fallthrough? (1+ k))))
(and (= k-idx (1+ n))
(< (+ n 2) (cfa-k-count cfa))
(cfa-k-sym cfa (+ n 2)))))
(($ $kreceive ($ $arity req () rest () #f) kargs) (($ $kreceive ($ $arity req () rest () #f) kargs)
(compile-trunc label k exp (length req) (compile-trunc label k exp (length req)
(and rest (and rest
(match (vector-ref contv (cfa-k-idx cfa kargs)) (match (lookup-cont kargs dfg)
(($ $kargs names (_ ... rest)) rest))) (($ $kargs names (_ ... rest)) rest)))
nlocals) nlocals)
(unless (and (= k-idx (1+ n)) (unless (and fallthrough? (= kargs (1+ k)))
(< (+ n 2) (cfa-k-count cfa))
(eq? (cfa-k-sym cfa (+ n 2)) kargs))
(emit-br asm kargs)))))) (emit-br asm kargs))))))
(define (compile-tail label exp) (define (compile-tail label exp)
@ -319,7 +296,7 @@
(match exp (match exp
(($ $values ()) #f) (($ $values ()) #f)
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)
(match (lookup-cont handler) (match (lookup-cont handler dfg)
(($ $kreceive ($ $arity req () rest () #f) khandler-body) (($ $kreceive ($ $arity req () rest () #f) khandler-body)
(let ((receive-args (gensym "handler")) (let ((receive-args (gensym "handler"))
(nreq (length req)) (nreq (length req))
@ -330,7 +307,7 @@
(unless (and rest (zero? nreq)) (unless (and rest (zero? nreq))
(emit-receive-values asm proc-slot (->bool rest) nreq)) (emit-receive-values asm proc-slot (->bool rest) nreq))
(when (and rest (when (and rest
(match (vector-ref contv (cfa-k-idx cfa khandler-body)) (match (lookup-cont khandler-body dfg)
(($ $kargs names (_ ... rest)) (($ $kargs names (_ ... rest))
(maybe-slot rest)))) (maybe-slot rest))))
(emit-bind-rest asm (+ proc-slot 1 nreq))) (emit-bind-rest asm (+ proc-slot 1 nreq)))

12
module/language/cps/dfg.scm
View file

@ -45,6 +45,10 @@
compute-dfg compute-dfg
dfg-cont-table dfg-cont-table
dfg-min-label
dfg-label-count
dfg-min-var
dfg-var-count
lookup-def lookup-def
lookup-uses lookup-uses
lookup-predecessors lookup-predecessors
@ -102,7 +106,7 @@
;; Data-flow graph for CPS: both for values and continuations. ;; Data-flow graph for CPS: both for values and continuations.
(define-record-type $dfg (define-record-type $dfg
(make-dfg conts preds defs uses scopes scope-levels (make-dfg conts preds defs uses scopes scope-levels
min-label nlabels min-var nvars) min-label label-count min-var var-count)
dfg? dfg?
;; vector of label -> $kif, $kargs, etc ;; vector of label -> $kif, $kargs, etc
(conts dfg-cont-table) (conts dfg-cont-table)
@ -118,9 +122,9 @@
(scope-levels dfg-scope-levels) (scope-levels dfg-scope-levels)
(min-label dfg-min-label) (min-label dfg-min-label)
(nlabels dfg-nlabels) (label-count dfg-label-count)
(min-var dfg-min-var) (min-var dfg-min-var)
(nvars dfg-nvars)) (var-count dfg-var-count))
;; Some analyses assume that the only relevant set of nodes is the set ;; Some analyses assume that the only relevant set of nodes is the set
;; that is reachable from some start node. Others need to include nodes ;; that is reachable from some start node. Others need to include nodes
@ -696,7 +700,7 @@ BODY for each body continuation in the prompt."
(define (compute-live-variables fun dfg) (define (compute-live-variables fun dfg)
(let* ((var-map (make-hash-table)) (let* ((var-map (make-hash-table))
(min-var (dfg-min-var dfg)) (min-var (dfg-min-var dfg))
(nvars (dfg-nvars dfg)) (nvars (dfg-var-count dfg))
(cfa (analyze-control-flow fun dfg #:reverse? #t (cfa (analyze-control-flow fun dfg #:reverse? #t
#:add-handler-preds? #t)) #:add-handler-preds? #t))
(syms (make-vector nvars #f)) (syms (make-vector nvars #f))