mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-23 04:50:28 +02:00
Code Activity

Convert slot allocation to use intsets

Browse source 
* module/language/cps/dfg.scm (compute-live-variables): Convert to use
  intsets, and fold in compute-maximum-fixed-point.
  (print-dfa): Update.

* module/language/cps/slot-allocation.scm (dead-after-def?)
  (dead-after-use?, allocate-slots): Convert to use intsets.
This commit is contained in:
Andy Wingo 2014-07-03 11:24:37 +02:00
parent 7f6aafa5ae
commit 5ded849813
2 changed files with 66 additions and 70 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -138,7 +138,7 @@
(define (compute-reachable dfg min-label label-count)
"Compute and return the continuations that may be reached if flow
reaches a continuation N. Returns a vector of bitvectors, whose first
reaches a continuation N. Returns a vector of intsets, whose first
index corresponds to MIN-LABEL, and so on."
(let (;; Vector of intsets, indicating that continuation N can
;; reach a set M...
@ -395,41 +395,6 @@ body continuation in the prompt."
;; We'll need it again eventually but for now it can be found in the git
;; history.
;; Compute the maximum fixed point of the data-flow constraint problem.
;;
;; This always completes, as the graph is finite and the in and out sets
;; are complete semi-lattices. If the graph is reducible and the blocks
;; are sorted in reverse post-order, this completes in a maximum of LC +
;; 2 iterations, where LC is the loop connectedness number. See Hecht
;; and Ullman, "Analysis of a simple algorithm for global flow
;; problems", POPL 1973, or the recent summary in "Notes on graph
;; algorithms used in optimizing compilers", Offner 2013.
(define (compute-maximum-fixed-point preds inv outv killv genv union?)
(define (bitvector-copy! dst src)
(bitvector-fill! dst #f)
(bit-set*! dst src #t))
(define (bitvector-meet! accum src)
(bit-set*! accum src union?))
(let lp ((n 0) (changed? #f))
(cond
((< n (vector-length preds))
(let ((in (vector-ref inv n))
(out (vector-ref outv n))
(kill (vector-ref killv n))
(gen (vector-ref genv n)))
(let ((out-count (or changed? (bit-count #t out))))
(for-each
(lambda (pred)
(bitvector-meet! in (vector-ref outv pred)))
(vector-ref preds n))
(bitvector-copy! out in)
(for-each (cut bitvector-set! out <> #f) kill)
(for-each (cut bitvector-set! out <> #t) gen)
(lp (1+ n)
(or changed? (not (eqv? out-count (bit-count #t out))))))))
(changed?
(lp 0 #f)))))
;; Data-flow analysis.
(define-record-type $dfa
(make-dfa min-label min-var var-count in out)
@ -440,9 +405,9 @@ body continuation in the prompt."
(min-var dfa-min-var)
;; Var count in this function.
(var-count dfa-var-count)
;; Vector of k-idx -> bitvector
;; Vector of k-idx -> intset
(in dfa-in)
;; Vector of k-idx -> bitvector
;; Vector of k-idx -> intset
(out dfa-out))
(define (dfa-k-idx dfa k)
@ -472,6 +437,49 @@ body continuation in the prompt."
(vector-ref (dfa-out dfa) idx))
(define (compute-live-variables fun dfg)
;; Compute the maximum fixed point of the data-flow constraint problem.
;;
;; This always completes, as the graph is finite and the in and out sets
;; are complete semi-lattices. If the graph is reducible and the blocks
;; are sorted in reverse post-order, this completes in a maximum of LC +
;; 2 iterations, where LC is the loop connectedness number. See Hecht
;; and Ullman, "Analysis of a simple algorithm for global flow
;; problems", POPL 1973, or the recent summary in "Notes on graph
;; algorithms used in optimizing compilers", Offner 2013.
(define (compute-maximum-fixed-point preds inv outv killv genv)
(define (fold f seed l)
(if (null? l) seed (fold f (f (car l) seed) (cdr l))))
(let lp ((n 0) (changed? #f))
(cond
((< n (vector-length preds))
(let* ((in (vector-ref inv n))
(in* (or
(fold (lambda (pred set)
(cond
((vector-ref outv pred)
=> (lambda (out)
(if set
(intset-union set out)
out)))
(else set)))
in
(vector-ref preds n))
empty-intset)))
(if (eq? in in*)
(lp (1+ n) changed?)
(let ((out* (fold (lambda (gen set)
(intset-add set gen))
(fold (lambda (kill set)
(intset-remove set kill))
in*
(vector-ref killv n))
(vector-ref genv n))))
(vector-set! inv n in*)
(vector-set! outv n out*)
(lp (1+ n) #t)))))
(changed?
(lp 0 #f)))))
(unless (and (= (vector-length (dfg-uses dfg)) (dfg-var-count dfg))
(= (vector-length (dfg-cont-table dfg)) (dfg-label-count dfg)))
(error "function needs renumbering"))
@ -508,18 +516,11 @@ body continuation in the prompt."
(vector-ref uses n))
(lp (1+ n))))))
;; Initialize live-in and live-out sets.
(let lp ((n 0))
(when (< n (vector-length live-out))
(vector-set! live-in n (make-bitvector nvars #f))
(vector-set! live-out n (make-bitvector nvars #f))
(lp (1+ n))))
;; Liveness is a reverse data-flow problem, so we give
;; compute-maximum-fixed-point a reversed graph, swapping in for
;; out, usev for defv, and using successors instead of
;; predecessors. Continuation 0 is ktail.
(compute-maximum-fixed-point succs live-out live-in defv usev #t)
(compute-maximum-fixed-point succs live-out live-in defv usev)
;; Now rewrite the live-in and live-out sets to be indexed by
;; (LABEL - MIN-LABEL).
@ -539,7 +540,7 @@ body continuation in the prompt."
(($ $dfa min-label min-var var-count in out)
(define (print-var-set bv)
(let lp ((n 0))
(let ((n (bit-position #t bv n)))
(let ((n (intset-next bv n)))
(when n
(format #t " ~A" (+ n min-var))
(lp (1+ n))))))

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

@ -29,6 +29,7 @@
#:use-module (srfi srfi-26)
#:use-module (language cps)
#:use-module (language cps dfg)
#:use-module (language cps intset)
#:export (allocate-slots
lookup-slot
lookup-maybe-slot
@ -224,10 +225,10 @@ are comparable with eqv?. A tmp slot may be used."
(loop to-move b (cons s+d moved) last-source))))))))))
(define (dead-after-def? k-idx v-idx dfa)
(not (bitvector-ref (dfa-k-in dfa k-idx) v-idx)))
(not (intset-ref (dfa-k-in dfa k-idx) v-idx)))
(define (dead-after-use? k-idx v-idx dfa)
(not (bitvector-ref (dfa-k-out dfa k-idx) v-idx)))
(not (intset-ref (dfa-k-out dfa k-idx) v-idx)))
(define (allocate-slots fun dfg)
(let* ((dfa (compute-live-variables fun dfg))
@ -283,7 +284,7 @@ are comparable with eqv?. A tmp slot may be used."
(define (recompute-live-slots k nargs)
(let ((in (dfa-k-in dfa (label->idx k))))
(let lp ((v 0) (live-slots 0))
(let ((v (bit-position #t in v)))
(let ((v (intset-next in v)))
(if v
(let ((slot (vector-ref slots v)))
(lp (1+ v)
@ -419,6 +420,8 @@ are comparable with eqv?. A tmp slot may be used."
(dfa-k-in dfa n))
(define (live-after n)
(dfa-k-out dfa n))
(define needs-slot
(bitvector->intset needs-slotv))
;; Walk backwards. At a call, compute the set of variables that
;; have allocated slots and are live before but not after. This
@ -429,12 +432,10 @@ are comparable with eqv?. A tmp slot may be used."
(($ $kargs names syms body)
(match (find-expression body)
((or ($ $call) ($ $callk))
(let ((args (make-bitvector (bitvector-length needs-slotv) #f)))
(bit-set*! args (live-before n) #t)
(bit-set*! args (live-after n) #f)
(bit-set*! args no-slot-needed #f)
(if (bit-position #t args 0)
(scan-for-hints (1- n) args)
(let* ((args (intset-subtract (live-before n) (live-after n)))
(args-needing-slots (intset-intersect args needs-slot)))
(if (intset-next args-needing-slots #f)
(scan-for-hints (1- n) args-needing-slots)
(scan-for-call (1- n)))))
(_ (scan-for-call (1- n)))))
(_ (scan-for-call (1- n))))))
@ -458,11 +459,8 @@ are comparable with eqv?. A tmp slot may be used."
;; assumptions that slots not allocated are not
;; used.
($ $values (or () (_))))
(let ((dead (make-bitvector (bitvector-length args) #f)))
(bit-set*! dead (live-before n) #t)
(bit-set*! dead (live-after n) #f)
(bit-set*! dead no-slot-needed #f)
(if (bit-position #t dead 0)
(let ((killed (intset-subtract (live-before n) (live-after n))))
(if (intset-next (intset-intersect killed needs-slot) #f)
(finish-hints n (live-before n) args)
(scan-for-hints (1- n) args))))
((or ($ $call) ($ $callk) ($ $values) ($ $branch))
@ -474,17 +472,14 @@ are comparable with eqv?. A tmp slot may be used."
;; Add definitions ARGS minus KILL to NEED-HINTS, and go back to
;; looking for calls.
(define (finish-hints n kill args)
(bit-invert! args)
(bit-set*! args kill #t)
(bit-invert! args)
(bit-set*! needs-hintv args #t)
(let ((new-hints (intset-subtract args kill)))
(let lp ((n 0))
(let ((n (intset-next new-hints n)))
(when n
(bitvector-set! needs-hintv n #t)
(lp (1+ n))))))
(scan-for-call n))
(define no-slot-needed
(make-bitvector (bitvector-length needs-slotv) #f))
(bit-set*! no-slot-needed needs-slotv #t)
(bit-invert! no-slot-needed)
(scan-for-call (1- label-count)))
(define (allocate-call label k uses pre-live post-live)