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

Remove CFA data type

Browse source 
* module/language/cps/dfg.scm: Remove CFA data type.
  (analyze-reverse-control-flow): Take min-label and label-count as
  args, and return multiple values instead of returning a CFA object.
  (compute-live-variables): Rework to accept multiple values from
  analyze-reverse-control-flow.
  ($dfa): Update comments.
This commit is contained in:
Andy Wingo 2014-04-02 12:00:09 +02:00
parent a57f6e1e36
commit a7324faf1b
1 changed files with 68 additions and 95 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -122,31 +122,6 @@
(min-var dfg-min-var) (min-var dfg-min-var)
(var-count dfg-var-count)) (var-count dfg-var-count))
;; Control-flow analysis.
(define-record-type $cfa
(make-cfa min-label k-map order preds)
cfa?
;; Minumum label.
(min-label cfa-min-label)
;; Vector of (k - min-label) -> k-idx
(k-map cfa-k-map)
;; Vector of k-idx -> k-sym, in reverse post order
(order cfa-order)
;; Vector of k-idx -> list of k-idx
(preds cfa-preds))
(define (cfa-k-idx cfa k)
(vector-ref (cfa-k-map cfa) (- k (cfa-min-label cfa))))
(define (cfa-k-count cfa)
(vector-length (cfa-order cfa)))
(define (cfa-k-sym cfa n)
(vector-ref (cfa-order cfa) n))
(define (cfa-predecessors cfa n)
(vector-ref (cfa-preds cfa) n))
(define-inlinable (vector-push! vec idx val) (define-inlinable (vector-push! vec idx val)
(let ((v vec) (i idx)) (let ((v vec) (i idx))
(vector-set! v i (cons val (vector-ref v i))))) (vector-set! v i (cons val (vector-ref v i)))))
@ -287,8 +262,8 @@ body continuation in the prompt."
(lp (1+ n))))))) (lp (1+ n)))))))
(find-prompt-bodies dfg min-label label-count))) (find-prompt-bodies dfg min-label label-count)))
(define (analyze-reverse-control-flow fun dfg) (define (analyze-reverse-control-flow fun dfg min-label label-count)
(define (compute-reverse-control-flow-order ktail dfg min-label label-count) (define (compute-reverse-control-flow-order ktail dfg)
(let ((order (make-vector label-count #f)) (let ((order (make-vector label-count #f))
(label-map (make-vector label-count #f)) (label-map (make-vector label-count #f))
(next -1)) (next -1))
@ -331,7 +306,7 @@ body continuation in the prompt."
(values order label-map))) (values order label-map)))
(define (convert-successors k-map min-label) (define (convert-successors k-map)
(define (idx->label idx) (+ idx min-label)) (define (idx->label idx) (+ idx min-label))
(define (renumber label) (define (renumber label)
(vector-ref k-map (- label min-label))) (vector-ref k-map (- label min-label)))
@ -344,36 +319,27 @@ body continuation in the prompt."
(lp (1+ n)))) (lp (1+ n))))
succs)) succs))
(define (build-cfa ktail min-label label-count order k-map) (match fun
(let* ((succs (convert-successors k-map min-label)) (($ $fun src meta free
(cfa (make-cfa min-label k-map order succs))) ($ $cont kentry ($ $kentry self ($ $cont ktail tail))))
;; Any expression in the prompt body could cause an abort to the (call-with-values
;; handler. This code adds links from every block in the prompt (lambda ()
;; body to the handler. This causes all values used by the (compute-reverse-control-flow-order ktail dfg))
;; handler to be seen as live in the prompt body, as indeed they (lambda (order k-map)
;; are. (let ((succs (convert-successors k-map)))
(visit-prompt-control-flow ;; Any expression in the prompt body could cause an abort to
dfg min-label label-count ;; the handler. This code adds links from every block in the
(lambda (prompt handler body) ;; prompt body to the handler. This causes all values used
(define (renumber label) ;; by the handler to be seen as live in the prompt body, as
(vector-ref k-map (- label min-label))) ;; indeed they are.
(vector-push! succs (renumber body) (renumber handler)))) (visit-prompt-control-flow
cfa)) dfg min-label label-count
(lambda (prompt handler body)
(define (renumber label)
(vector-ref k-map (- label min-label)))
(vector-push! succs (renumber body) (renumber handler))))
(unless (= (vector-length (dfg-cont-table dfg)) (dfg-label-count dfg)) (values k-map order succs)))))))
(error "function needs renumbering"))
(let ((min-label (dfg-min-label dfg))
(label-count (dfg-label-count dfg)))
(match fun
(($ $fun src meta free
($ $cont kentry ($ $kentry self ($ $cont ktail tail))))
(call-with-values
(lambda ()
(compute-reverse-control-flow-order ktail dfg
min-label label-count))
(lambda (order k-map)
(build-cfa ktail min-label label-count order k-map)))))))
;; Dominator analysis. ;; Dominator analysis.
(define-record-type $dominator-analysis (define-record-type $dominator-analysis
@ -648,9 +614,11 @@ body continuation in the prompt."
(define-record-type $dfa (define-record-type $dfa
(make-dfa min-label k-map k-order min-var var-count in out) (make-dfa min-label k-map k-order min-var var-count in out)
dfa? dfa?
;; CFA, for its label sort order ;; Minimum label.
(min-label dfa-min-label) (min-label dfa-min-label)
;; Vector of (k - min-label) -> k-idx
(k-map dfa-k-map) (k-map dfa-k-map)
;; Vector of k-idx -> k-sym, in (possibly reversed) control-flow order
(k-order dfa-k-order) (k-order dfa-k-order)
;; Minimum var in this function. ;; Minimum var in this function.
@ -692,48 +660,53 @@ body continuation in the prompt."
(unless (and (= (vector-length (dfg-uses dfg)) (dfg-var-count dfg)) (unless (and (= (vector-length (dfg-uses dfg)) (dfg-var-count dfg))
(= (vector-length (dfg-cont-table dfg)) (dfg-label-count dfg))) (= (vector-length (dfg-cont-table dfg)) (dfg-label-count dfg)))
(error "function needs renumbering")) (error "function needs renumbering"))
(let* ((min-var (dfg-min-var dfg)) (let* ((min-label (dfg-min-label dfg))
(nlabels (dfg-label-count dfg))
(min-var (dfg-min-var dfg))
(nvars (dfg-var-count dfg)) (nvars (dfg-var-count dfg))
(cfa (analyze-reverse-control-flow fun dfg)) (usev (make-vector nlabels '()))
(usev (make-vector (cfa-k-count cfa) '())) (defv (make-vector nlabels '()))
(defv (make-vector (cfa-k-count cfa) '())) (live-in (make-vector nlabels #f))
(live-in (make-vector (cfa-k-count cfa) #f)) (live-out (make-vector nlabels #f)))
(live-out (make-vector (cfa-k-count cfa) #f))) (call-with-values
(define (var->idx var) (- var min-var)) (lambda ()
(define (idx->var idx) (+ idx min-var)) (analyze-reverse-control-flow fun dfg min-label nlabels))
(lambda (k-map k-order succs)
(define (var->idx var) (- var min-var))
(define (idx->var idx) (+ idx min-var))
(define (label->idx label)
(vector-ref k-map (- label min-label)))
;; Initialize defv and usev. ;; Initialize defv and usev.
(let ((defs (dfg-defs dfg)) (let ((defs (dfg-defs dfg))
(uses (dfg-uses dfg))) (uses (dfg-uses dfg)))
(let lp ((n 0)) (let lp ((n 0))
(when (< n (vector-length defs)) (when (< n (vector-length defs))
(let ((def (vector-ref defs n))) (let ((def (vector-ref defs n)))
(unless def (unless def
(error "internal error -- var array not packed")) (error "internal error -- var array not packed"))
(for-each (lambda (def) (for-each (lambda (def)
(vector-push! defv (cfa-k-idx cfa def) n)) (vector-push! defv (label->idx def) n))
(lookup-predecessors def dfg)) (lookup-predecessors def dfg))
(for-each (lambda (use) (for-each (lambda (use)
(vector-push! usev (cfa-k-idx cfa use) n)) (vector-push! usev (label->idx use) n))
(vector-ref uses n)) (vector-ref uses n))
(lp (1+ n)))))) (lp (1+ n))))))
;; Initialize live-in and live-out sets. ;; Initialize live-in and live-out sets.
(let lp ((n 0)) (let lp ((n 0))
(when (< n (vector-length live-out)) (when (< n (vector-length live-out))
(vector-set! live-in n (make-bitvector nvars #f)) (vector-set! live-in n (make-bitvector nvars #f))
(vector-set! live-out n (make-bitvector nvars #f)) (vector-set! live-out n (make-bitvector nvars #f))
(lp (1+ n)))) (lp (1+ n))))
;; Liveness is a reverse data-flow problem, so we give ;; Liveness is a reverse data-flow problem, so we give
;; compute-maximum-fixed-point a reversed graph, swapping in ;; compute-maximum-fixed-point a reversed graph, swapping in for
;; for out, and usev for defv. Note that since we are using ;; out, usev for defv, and using successors instead of
;; a reverse CFA, cfa-preds are actually successors, and ;; predecessors. Continuation 0 is ktail.
;; continuation 0 is ktail. (compute-maximum-fixed-point succs live-out live-in defv usev #t)
(compute-maximum-fixed-point (cfa-preds cfa)
live-out live-in defv usev #t)
(make-dfa (cfa-min-label cfa) (cfa-k-map cfa) (cfa-order cfa) min-var nvars live-in live-out))) (make-dfa min-label k-map k-order min-var nvars live-in live-out)))))
(define (print-dfa dfa) (define (print-dfa dfa)
(match dfa (match dfa