mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-29 16:30:19 +02:00
Code Activity

Allocate-slots avoids building CFA

Browse source 
* module/language/cps/slot-allocation.scm (allocate-slots): Rework to
  avoid computing a CFA, and just relying on the incoming term to have
  sorted labels.
This commit is contained in:
Andy Wingo 2014-04-01 15:21:28 +02:00
parent a8430ab1d7
commit 7dbf40ea8b
1 changed files with 47 additions and 53 deletions
Download patch file Download diff file Expand all files Collapse all files

100
module/language/cps/slot-allocation.scm
View file

@ -233,10 +233,10 @@ are comparable with eqv?. A tmp slot may be used."
(define (allocate-slots fun dfg) (define (allocate-slots fun dfg)
(let* ((dfa (compute-live-variables fun dfg)) (let* ((dfa (compute-live-variables fun dfg))
(cfa (analyze-control-flow fun dfg)) (min-label (dfg-min-label dfg))
(usev (make-vector (cfa-k-count cfa) '())) (label-count (dfg-label-count dfg))
(defv (make-vector (cfa-k-count cfa) '())) (usev (make-vector label-count '()))
(contv (make-vector (cfa-k-count cfa) #f)) (defv (make-vector label-count '()))
(slots (make-vector (dfa-var-count dfa) #f)) (slots (make-vector (dfa-var-count dfa) #f))
(constant-values (make-vector (dfa-var-count dfa) #f)) (constant-values (make-vector (dfa-var-count dfa) #f))
(has-constv (make-bitvector (dfa-var-count dfa) #f)) (has-constv (make-bitvector (dfa-var-count dfa) #f))
@ -247,6 +247,9 @@ are comparable with eqv?. A tmp slot may be used."
(nlocals 0) ; Mutable. It pains me. (nlocals 0) ; Mutable. It pains me.
(nlocals-table (make-hash-table))) (nlocals-table (make-hash-table)))
(define (label->idx label) (- label min-label))
(define (idx->label idx) (+ idx min-label))
(define (bump-nlocals! nlocals*) (define (bump-nlocals! nlocals*)
(when (< nlocals nlocals*) (when (< nlocals nlocals*)
(set! nlocals nlocals*))) (set! nlocals nlocals*)))
@ -328,20 +331,12 @@ are comparable with eqv?. A tmp slot may be used."
(bitvector-set! needs-slotv n #f))) (bitvector-set! needs-slotv n #f)))
(lp (1+ n)))))))) (lp (1+ n))))))))
;; Transform the DFG's continuation table to a vector, for easy
;; access.
(define (compute-conts!)
(let lp ((n 0))
(when (< n (vector-length contv))
(vector-set! contv n (lookup-cont (cfa-k-sym cfa n) dfg))
(lp (1+ n)))))
;; Record uses and defs, as lists of variable indexes, indexed by ;; Record uses and defs, as lists of variable indexes, indexed by
;; CFA continuation index. ;; label index.
(define (compute-uses-and-defs!) (define (compute-uses-and-defs!)
(let lp ((n 0)) (let lp ((n 0))
(when (< n (vector-length usev)) (when (< n (vector-length usev))
(match (vector-ref contv n) (match (lookup-cont (idx->label n) dfg)
(($ $kentry self) (($ $kentry self)
(vector-set! defv n (list (dfa-var-idx dfa self)))) (vector-set! defv n (list (dfa-var-idx dfa self))))
(($ $kargs names syms body) (($ $kargs names syms body)
@ -366,30 +361,30 @@ are comparable with eqv?. A tmp slot may be used."
;; Results of function calls that are not used don't need to be ;; Results of function calls that are not used don't need to be
;; allocated to slots. ;; allocated to slots.
(define (compute-unused-results!) (define (compute-unused-results!)
(define (kreceive-get-kargs n) (define (kreceive-get-kargs kreceive)
(match (vector-ref contv n) (match (lookup-cont kreceive dfg)
(($ $kreceive arity kargs) (cfa-k-idx cfa kargs)) (($ $kreceive arity kargs) kargs)
(_ #f))) (_ #f)))
(let ((candidates (make-bitvector (vector-length contv) #f))) (let ((candidates (make-bitvector label-count #f)))
;; Find all $kargs that are the successors of $kreceive nodes. ;; Find all $kargs that are the successors of $kreceive nodes.
(let lp ((n 0)) (let lp ((n 0))
(when (< n (vector-length contv)) (when (< n label-count)
(and=> (kreceive-get-kargs n) (and=> (kreceive-get-kargs (idx->label n))
(lambda (kargs) (lambda (kargs)
(bitvector-set! candidates kargs #t))) (bitvector-set! candidates (label->idx kargs) #t)))
(lp (1+ n)))) (lp (1+ n))))
;; For $kargs that only have $kreceive predecessors, remove unused ;; For $kargs that only have $kreceive predecessors, remove unused
;; variables from the needs-slotv set. ;; variables from the needs-slotv set.
(let lp ((n 0)) (let lp ((n 0))
(let ((n (bit-position #t candidates n))) (let ((n (bit-position #t candidates n)))
(when n (when n
(match (cfa-predecessors cfa n) (match (lookup-predecessors (idx->label n) dfg)
;; At least one kreceive is in the predecessor set, so we ;; At least one kreceive is in the predecessor set, so we
;; only need to do the check for nodes with >1 ;; only need to do the check for nodes with >1
;; predecessor. ;; predecessor.
((or (_) ((? kreceive-get-kargs) ...)) ((or (_) ((? kreceive-get-kargs) ...))
(for-each (lambda (var) (for-each (lambda (var)
(when (dead-after-def? (cfa-k-sym cfa n) var dfa) (when (dead-after-def? (idx->label n) var dfa)
(bitvector-set! needs-slotv var #f))) (bitvector-set! needs-slotv var #f)))
(vector-ref defv n))) (vector-ref defv n)))
(_ #f)) (_ #f))
@ -408,20 +403,20 @@ are comparable with eqv?. A tmp slot may be used."
;; control-flow graph, but we did the live variable analysis in ;; control-flow graph, but we did the live variable analysis in
;; the opposite direction -- so the continuation numbers don't ;; the opposite direction -- so the continuation numbers don't
;; correspond. This helper adapts them. ;; correspond. This helper adapts them.
(define (cfa-k-idx->dfa-k-idx n) (define (label-idx->dfa-k-idx n)
(dfa-k-idx dfa (cfa-k-sym cfa n))) (dfa-k-idx dfa (idx->label n)))
(define (live-before n) (define (live-before n)
(dfa-k-in dfa (cfa-k-idx->dfa-k-idx n))) (dfa-k-in dfa (label-idx->dfa-k-idx n)))
(define (live-after n) (define (live-after n)
(dfa-k-out dfa (cfa-k-idx->dfa-k-idx n))) (dfa-k-out dfa (label-idx->dfa-k-idx n)))
;; Walk backwards. At a call, compute the set of variables that ;; Walk backwards. At a call, compute the set of variables that
;; have allocated slots and are live before but not after. This ;; have allocated slots and are live before but not after. This
;; set contains candidates for needs-hintv. ;; set contains candidates for needs-hintv.
(define (scan-for-call n) (define (scan-for-call n)
(when (<= 0 n) (when (<= 0 n)
(match (vector-ref contv n) (match (lookup-cont (idx->label n) dfg)
(($ $kargs names syms body) (($ $kargs names syms body)
(match (find-expression body) (match (find-expression body)
((or ($ $call) ($ $callk)) ((or ($ $call) ($ $callk))
@ -439,10 +434,10 @@ are comparable with eqv?. A tmp slot may be used."
;; ends, we reach a call, or when an expression kills a value. ;; ends, we reach a call, or when an expression kills a value.
(define (scan-for-hints n args) (define (scan-for-hints n args)
(when (< 0 n) (when (< 0 n)
(match (vector-ref contv n) (match (lookup-cont (idx->label n) dfg)
(($ $kargs names syms body) (($ $kargs names syms body)
(match (cfa-predecessors cfa (1+ n)) (match (lookup-predecessors (idx->label (1+ n)) dfg)
(((? (cut eqv? <> n))) (((? (cut eqv? <> (idx->label n))))
;; If we are indeed in the same basic block, then if we ;; If we are indeed in the same basic block, then if we
;; are finished with the scan, we kill uses of the ;; are finished with the scan, we kill uses of the
;; terminator, but leave its definitions. ;; terminator, but leave its definitions.
@ -481,10 +476,10 @@ are comparable with eqv?. A tmp slot may be used."
(bit-set*! no-slot-needed needs-slotv #t) (bit-set*! no-slot-needed needs-slotv #t)
(bit-invert! no-slot-needed) (bit-invert! no-slot-needed)
(scan-for-call (1- (vector-length contv)))) (scan-for-call (1- label-count)))
(define (allocate-call label k uses pre-live post-live) (define (allocate-call label k uses pre-live post-live)
(match (vector-ref contv (cfa-k-idx cfa k)) (match (lookup-cont k dfg)
(($ $ktail) (($ $ktail)
(let* ((tail-nlocals (length uses)) (let* ((tail-nlocals (length uses))
(tail-slots (iota tail-nlocals)) (tail-slots (iota tail-nlocals))
@ -503,7 +498,7 @@ are comparable with eqv?. A tmp slot may be used."
call-slots call-slots
(compute-tmp-slot pre-live (compute-tmp-slot pre-live
call-slots))) call-slots)))
(result-vars (vector-ref defv (cfa-k-idx cfa kargs))) (result-vars (vector-ref defv (label->idx kargs)))
(value-slots (map (cut + proc-slot 1 <>) (value-slots (map (cut + proc-slot 1 <>)
(iota (length result-vars)))) (iota (length result-vars))))
;; Shuffle the first result down to the lowest slot, and ;; Shuffle the first result down to the lowest slot, and
@ -547,7 +542,7 @@ are comparable with eqv?. A tmp slot may be used."
(make-call-allocation proc-slot arg-moves #f)))))) (make-call-allocation proc-slot arg-moves #f))))))
(define (allocate-values label k uses pre-live post-live) (define (allocate-values label k uses pre-live post-live)
(match (vector-ref contv (cfa-k-idx cfa k)) (match (lookup-cont k dfg)
(($ $ktail) (($ $ktail)
(let* ((src-slots (map (cut vector-ref slots <>) uses)) (let* ((src-slots (map (cut vector-ref slots <>) uses))
(tail-nlocals (1+ (length uses))) (tail-nlocals (1+ (length uses)))
@ -565,12 +560,12 @@ are comparable with eqv?. A tmp slot may be used."
;; slot, we can't really compute the parallel moves in that ;; slot, we can't really compute the parallel moves in that
;; case, so just bail and rely on the bytecode emitter to ;; case, so just bail and rely on the bytecode emitter to
;; handle the one-value case specially. ;; handle the one-value case specially.
(match (cons uses (vector-ref defv (cfa-k-idx cfa k))) (match (cons uses (vector-ref defv (label->idx k)))
(((src) . (dst)) (((src) . (dst))
(allocate! dst (vector-ref slots src) post-live)))) (allocate! dst (vector-ref slots src) post-live))))
(($ $kargs) (($ $kargs)
(let* ((src-slots (map (cut vector-ref slots <>) uses)) (let* ((src-slots (map (cut vector-ref slots <>) uses))
(dst-vars (vector-ref defv (cfa-k-idx cfa k))) (dst-vars (vector-ref defv (label->idx k)))
(result-live (fold allocate! post-live dst-vars src-slots)) (result-live (fold allocate! post-live dst-vars src-slots))
(dst-slots (map (cut vector-ref slots <>) dst-vars)) (dst-slots (map (cut vector-ref slots <>) dst-vars))
(moves (parallel-move src-slots dst-slots (moves (parallel-move src-slots dst-slots
@ -581,11 +576,11 @@ are comparable with eqv?. A tmp slot may be used."
(($ $kif) #f))) (($ $kif) #f)))
(define (allocate-prompt label k handler nargs) (define (allocate-prompt label k handler nargs)
(match (vector-ref contv (cfa-k-idx cfa handler)) (match (lookup-cont handler dfg)
(($ $kreceive arity kargs) (($ $kreceive arity kargs)
(let* ((handler-live (recompute-live-slots handler nargs)) (let* ((handler-live (recompute-live-slots handler nargs))
(proc-slot (compute-prompt-handler-proc-slot handler-live)) (proc-slot (compute-prompt-handler-proc-slot handler-live))
(result-vars (vector-ref defv (cfa-k-idx cfa kargs))) (result-vars (vector-ref defv (label->idx kargs)))
(value-slots (map (cut + proc-slot 1 <>) (value-slots (map (cut + proc-slot 1 <>)
(iota (length result-vars)))) (iota (length result-vars))))
(result-live (fold allocate! (result-live (fold allocate!
@ -611,23 +606,23 @@ are comparable with eqv?. A tmp slot may be used."
;; before it, in reverse post-order. ;; before it, in reverse post-order.
(define (visit-clause n nargs live) (define (visit-clause n nargs live)
(let lp ((n n) (live live)) (let lp ((n n) (live live))
(define (kill-dead live vars-by-cfa-idx pred) (define (kill-dead live vars-by-label-idx pred)
(fold (lambda (v live) (fold (lambda (v live)
(let ((slot (vector-ref slots v))) (let ((slot (vector-ref slots v)))
(if (and slot (if (and slot
(> slot nargs) (> slot nargs)
(pred (cfa-k-sym cfa n) v dfa)) (pred (idx->label n) v dfa))
(kill-dead-slot slot live) (kill-dead-slot slot live)
live))) live)))
live live
(vector-ref vars-by-cfa-idx n))) (vector-ref vars-by-label-idx n)))
(define (kill-dead-defs live) (define (kill-dead-defs live)
(kill-dead live defv dead-after-def?)) (kill-dead live defv dead-after-def?))
(define (kill-dead-uses live) (define (kill-dead-uses live)
(kill-dead live usev dead-after-use?)) (kill-dead live usev dead-after-use?))
(if (= n (cfa-k-count cfa)) (if (= n label-count)
n n
(let* ((label (cfa-k-sym cfa n)) (let* ((label (idx->label n))
(live (if (control-point? label dfg) (live (if (control-point? label dfg)
(recompute-live-slots label nargs) (recompute-live-slots label nargs)
live)) live))
@ -636,7 +631,7 @@ are comparable with eqv?. A tmp slot may be used."
;; LIVE are the live slots coming into the term. ;; LIVE are the live slots coming into the term.
;; POST-LIVE is the subset that is still live after the ;; POST-LIVE is the subset that is still live after the
;; term uses its inputs. ;; term uses its inputs.
(match (vector-ref contv n) (match (lookup-cont (idx->label n) dfg)
(($ $kclause) n) (($ $kclause) n)
(($ $kargs names syms body) (($ $kargs names syms body)
(let ((uses (vector-ref usev n))) (let ((uses (vector-ref usev n)))
@ -658,28 +653,27 @@ are comparable with eqv?. A tmp slot may be used."
(unless (eqv? live (add-live-slot 0 (empty-live-slots))) (unless (eqv? live (add-live-slot 0 (empty-live-slots)))
(error "Unexpected clause live set")) (error "Unexpected clause live set"))
(set! nlocals 1) (set! nlocals 1)
(match (vector-ref contv n) (match (lookup-cont (idx->label n) dfg)
(($ $kclause arity ($ $cont kbody ($ $kargs names)) alternate) (($ $kclause arity ($ $cont kbody ($ $kargs names)) alternate)
(unless (eq? (cfa-k-sym cfa (1+ n)) kbody) (unless (eq? (idx->label (1+ n)) kbody)
(error "Unexpected CFA order")) (error "Unexpected label order"))
(let* ((nargs (length names)) (let* ((nargs (length names))
(next (visit-clause (1+ n) (next (visit-clause (1+ n)
nargs nargs
(fold allocate! live (fold allocate! live
(vector-ref defv (1+ n)) (vector-ref defv (1+ n))
(cdr (iota (1+ nargs))))))) (cdr (iota (1+ nargs)))))))
(hashq-set! nlocals-table (cfa-k-sym cfa n) nlocals) (hashq-set! nlocals-table (idx->label n) nlocals)
(when (< next (cfa-k-count cfa)) (when (< next label-count)
(match alternate (match alternate
(($ $cont kalt) (($ $cont kalt)
(unless (eq? kalt (cfa-k-sym cfa next)) (unless (eq? kalt (idx->label next))
(error "Unexpected clause order")))) (error "Unexpected clause order"))))
(visit-clauses next live)))))) (visit-clauses next live))))))
(match (vector-ref contv 0) (match (lookup-cont (idx->label 0) dfg)
(($ $kentry self) (($ $kentry self)
(visit-clauses 1 (allocate-defs! 0 (empty-live-slots)))))) (visit-clauses 1 (allocate-defs! 0 (empty-live-slots))))))
(compute-conts!)
(compute-constants!) (compute-constants!)
(compute-uses-and-defs!) (compute-uses-and-defs!)
(compute-unused-results!) (compute-unused-results!)