[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-259-ge636f42
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-259-ge636f42 |
|
Date: |
Mon, 21 Oct 2013 13:40:17 +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=e636f424b97e8574e0db304f64a1541dd626b3a5
The branch, master has been updated
via e636f424b97e8574e0db304f64a1541dd626b3a5 (commit)
via db11440d380ffb579ff6a4b69acaf818855bd201 (commit)
via fc95a944d3a7c3eda11b9b5fa98aa02fa21e255b (commit)
from d691ac206906d2539cb94667fd10854aafc8955a (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 e636f424b97e8574e0db304f64a1541dd626b3a5
Author: Andy Wingo <address@hidden>
Date: Mon Oct 21 15:45:19 2013 +0200
RTL slot allocator uses more precise, correct liveness information
* module/language/cps/dfg.scm (control-point?): New interface, replaces
branch?.
(dead-after-def?, dead-after-use?, dead-after-branch?): Remove these.
The first one was fine; dead-after-use? was conservative but OK; but
dead-after-branch? was totally bogus. Instead we use precise liveness
information in the allocator.
* module/language/cps/slot-allocation.scm ($allocation): Remove "def"
and "dead" slots. We'll communicate liveness information in some
other way to the compiler.
(allocate-slots): Rework to use precise liveness information.
commit db11440d380ffb579ff6a4b69acaf818855bd201
Author: Andy Wingo <address@hidden>
Date: Mon Oct 21 11:51:51 2013 +0200
DFG: Add code to compute live variable sets.
* module/language/cps/dfg.scm (compute-live-variables)
(compute-maximum-fixed-point, print-dfa): New code to compute live
variable sets.
commit fc95a944d3a7c3eda11b9b5fa98aa02fa21e255b
Author: Andy Wingo <address@hidden>
Date: Mon Oct 21 11:51:11 2013 +0200
DFG: Use maps have variable names
* module/language/cps/dfg.scm ($use-map): Add variable names to the use
maps.
(visit-fun, lookup-def, lookup-uses, constant-needs-allocation?)
(variable-free-in?, dead-after-def?, dead-after-use?)
(dead-after-branch?): Adapt to use-map change.
-----------------------------------------------------------------------
Summary of changes:
module/language/cps/dfg.scm | 278 ++++++++++++++++++++++---------
module/language/cps/slot-allocation.scm | 259 ++++++++++++++---------------
2 files changed, 323 insertions(+), 214 deletions(-)
diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm
index ce36b1f..0e37835 100644
--- a/module/language/cps/dfg.scm
+++ b/module/language/cps/dfg.scm
@@ -61,10 +61,14 @@
constant-needs-allocation?
dead-after-def?
dead-after-use?
- branch?
- find-other-branches
- dead-after-branch?
- lookup-bound-syms))
+ control-point?
+ lookup-bound-syms
+
+ ;; Data flow analysis.
+ compute-live-variables
+ dfa-k-idx dfa-k-sym dfa-k-count dfa-k-in dfa-k-out
+ dfa-var-idx dfa-var-name dfa-var-sym dfa-var-count
+ print-dfa))
(define (build-cont-table fun)
(fold-conts (lambda (k src cont table)
@@ -98,8 +102,9 @@
(use-maps dfg-use-maps))
(define-record-type $use-map
- (make-use-map sym def uses)
+ (make-use-map name sym def uses)
use-map?
+ (name use-map-name)
(sym use-map-sym)
(def use-map-def)
(uses use-map-uses set-use-map-uses!))
@@ -407,16 +412,183 @@
(set-block-pdom-level! b pdom-level)
(lp (1+ n)))))))
+
+;; 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 k->idx order var->idx names syms in out)
+ dfa?
+ ;; Function mapping k-sym -> k-idx
+ (k->idx dfa-k->idx)
+ ;; Vector of k-idx -> k-sym
+ (order dfa-order)
+ ;; Function mapping var-sym -> var-idx
+ (var->idx dfa-var->idx)
+ ;; Vector of var-idx -> name
+ (names dfa-names)
+ ;; Vector of var-idx -> var-sym
+ (syms dfa-syms)
+ ;; Vector of k-idx -> bitvector
+ (in dfa-in)
+ ;; Vector of k-idx -> bitvector
+ (out dfa-out))
+
+(define (dfa-k-idx dfa k)
+ ((dfa-k->idx dfa) k))
+
+(define (dfa-k-sym dfa idx)
+ (vector-ref (dfa-order dfa) idx))
+
+(define (dfa-k-count dfa)
+ (vector-length (dfa-order dfa)))
+
+(define (dfa-var-idx dfa var)
+ ((dfa-var->idx dfa) var))
+
+(define (dfa-var-name dfa idx)
+ (vector-ref (dfa-names dfa) idx))
+
+(define (dfa-var-sym dfa idx)
+ (vector-ref (dfa-syms dfa) idx))
+
+(define (dfa-var-count dfa)
+ (vector-length (dfa-syms dfa)))
+
+(define (dfa-k-in dfa idx)
+ (vector-ref (dfa-in dfa) idx))
+
+(define (dfa-k-out dfa idx)
+ (vector-ref (dfa-out dfa) idx))
+
+(define (compute-live-variables ktail dfg)
+ (define (make-variable-mapper use-maps)
+ (let ((mapping (make-hash-table))
+ (n 0))
+ (hash-for-each (lambda (sym use-map)
+ (hashq-set! mapping sym n)
+ (set! n (1+ n)))
+ use-maps)
+ (values (lambda (sym)
+ (or (hashq-ref mapping sym)
+ (error "unknown sym" sym)))
+ n)))
+ (define (make-block-mapper order)
+ (let ((mapping (make-hash-table)))
+ (let lp ((n 0))
+ (when (< n (vector-length order))
+ (hashq-set! mapping (vector-ref order n) n)
+ (lp (1+ n))))
+ (lambda (k)
+ (or (hashq-ref mapping k)
+ (error "unknown k" k)))))
+
+ (call-with-values (lambda () (make-variable-mapper (dfg-use-maps dfg)))
+ (lambda (var->idx nvars)
+ (let* ((blocks (dfg-blocks dfg))
+ (order (reverse-post-order ktail blocks block-preds))
+ (succs (convert-predecessors order blocks block-succs))
+ (k->idx (make-block-mapper order))
+ (syms (make-vector nvars #f))
+ (names (make-vector nvars #f))
+ (usev (make-vector (vector-length order) '()))
+ (defv (make-vector (vector-length order) '()))
+ (live-in (make-vector (vector-length order) #f))
+ (live-out (make-vector (vector-length order) #f)))
+ ;; Initialize syms, names, defv, and usev.
+ (hash-for-each
+ (lambda (sym use-map)
+ (match use-map
+ (($ $use-map name sym def uses)
+ (let ((v (var->idx sym)))
+ (vector-set! syms v sym)
+ (vector-set! names v name)
+ (for-each (lambda (def)
+ (vector-push! defv (k->idx def) v))
+ (block-preds (lookup-block def blocks)))
+ (for-each (lambda (use)
+ (vector-push! usev (k->idx use) v))
+ uses)))))
+ (dfg-use-maps dfg))
+
+ ;; 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 and
+ ;; out, usev and defv, using successors instead of predecessors,
+ ;; and starting with ktail instead of the entry.
+ (compute-maximum-fixed-point succs live-out live-in defv usev #t)
+
+ (make-dfa k->idx order var->idx names syms live-in live-out)))))
+
+(define (print-dfa dfa)
+ (match dfa
+ (($ $dfa k->idx order var->idx names syms in out)
+ (define (print-var-set bv)
+ (let lp ((n 0))
+ (let ((n (bit-position #t bv n)))
+ (when n
+ (format #t " ~A" (vector-ref syms n))
+ (lp (1+ n))))))
+ (let lp ((n 0))
+ (when (< n (vector-length order))
+ (format #t "~A:\n" (vector-ref order n))
+ (format #t " in:")
+ (print-var-set (vector-ref in n))
+ (newline)
+ (format #t " out:")
+ (print-var-set (vector-ref out n))
+ (newline)
+ (lp (1+ n)))))))
+
(define (visit-fun fun conts blocks use-maps global?)
- (define (add-def! sym def-k)
+ (define (add-def! name sym def-k)
(unless def-k
(error "Term outside labelled continuation?"))
- (hashq-set! use-maps sym (make-use-map sym def-k '())))
+ (hashq-set! use-maps sym (make-use-map name sym def-k '())))
(define (add-use! sym use-k)
(match (hashq-ref use-maps sym)
(#f (error "Symbol out of scope?" sym))
- ((and use-map ($ $use-map sym def uses))
+ ((and use-map ($ $use-map name sym def uses))
(set-use-map-uses! use-map (cons use-k uses)))))
(define* (declare-block! label cont parent
@@ -434,8 +606,8 @@
(set-block-preds! succ-block (cons pred (block-preds succ-block)))))
(define (visit exp exp-k)
- (define (def! sym)
- (add-def! sym exp-k))
+ (define (def! name sym)
+ (add-def! name sym exp-k))
(define (use! sym)
(add-use! sym exp-k))
(define (use-k! k)
@@ -452,7 +624,7 @@
(recur body))
(($ $kargs names syms body)
- (for-each def! syms)
+ (for-each def! names syms)
(recur body))
(($ $kif kt kf)
@@ -465,7 +637,7 @@
(($ $letrec names syms funs body)
(unless global?
(error "$letrec should not be present when building a local DFG"))
- (for-each def! syms)
+ (for-each def! names syms)
(for-each (cut visit-fun <> conts blocks use-maps global?) funs)
(visit body exp-k))
@@ -501,7 +673,7 @@
(and entry
($ $kentry self ($ $cont ktail _ tail) clauses))))
(declare-block! kentry entry #f 0)
- (add-def! self kentry)
+ (add-def! #f self kentry)
(declare-block! ktail tail kentry)
@@ -547,14 +719,14 @@
(match dfg
(($ $dfg conts blocks use-maps)
(match (lookup-use-map sym use-maps)
- (($ $use-map sym def uses)
+ (($ $use-map name sym def uses)
def)))))
(define (lookup-uses sym dfg)
(match dfg
(($ $dfg conts blocks use-maps)
(match (lookup-use-map sym use-maps)
- (($ $use-map sym def uses)
+ (($ $use-map name sym def uses)
uses)))))
(define (lookup-predecessors k dfg)
@@ -610,7 +782,7 @@
(match dfg
(($ $dfg conts blocks use-maps)
(match (lookup-use-map sym use-maps)
- (($ $use-map _ def uses)
+ (($ $use-map _ _ def uses)
(or-map
(lambda (use)
(match (find-expression (lookup-cont use conts))
@@ -676,7 +848,7 @@
(or-map (lambda (use)
(continuation-scope-contains? k use blocks))
(match (lookup-use-map var use-maps)
- (($ $use-map sym def uses)
+ (($ $use-map name sym def uses)
uses))))))
;; Does k1 dominate k2?
@@ -701,72 +873,18 @@
((< k1-level k2-level) (post-dominates? k1 (block-pdom b2) blocks))
((= k1-level k2-level) (eqv? k1 k2))))))
-(define (dead-after-def? sym dfg)
- (match dfg
- (($ $dfg conts blocks use-maps)
- (match (lookup-use-map sym use-maps)
- (($ $use-map sym def uses)
- (null? uses))))))
-
(define (lookup-loop-header k blocks)
(block-loop-header (lookup-block k blocks)))
-(define (dead-after-use? sym use-k dfg)
- (match dfg
- (($ $dfg conts blocks use-maps)
- (match (lookup-use-map sym use-maps)
- (($ $use-map sym def uses)
- ;; If all other uses dominate this use, and the variable was not
- ;; defined outside the current loop, it is now dead. There are
- ;; other ways for it to be dead, but this is an approximation.
- ;; A better check would be if all successors post-dominate all
- ;; uses.
- (and (let ((loop (lookup-loop-header use-k blocks)))
- (or (eqv? def loop)
- (eqv? (lookup-loop-header def blocks) loop)))
- (and-map (cut dominates? <> use-k blocks) uses)))))))
-
-;; A continuation is a "branch" if all of its predecessors are $kif
-;; continuations.
-(define (branch? k dfg)
- (let ((preds (lookup-predecessors k dfg)))
- (and (not (null? preds))
- (and-map (lambda (k)
- (match (lookup-cont k (dfg-cont-table dfg))
- (($ $kif) #t)
- (_ #f)))
- preds))))
-
-(define (find-other-branches k dfg)
- (map (lambda (kif)
- (match (lookup-cont kif (dfg-cont-table dfg))
- (($ $kif (? (cut eq? <> k)) kf)
- kf)
- (($ $kif kt (? (cut eq? <> k)))
- kt)
- (_ (error "Not all predecessors are branches"))))
- (lookup-predecessors k dfg)))
-
-(define (dead-after-branch? sym branch other-branches dfg)
- (match dfg
- (($ $dfg conts blocks use-maps)
- (match (lookup-use-map sym use-maps)
- (($ $use-map sym def uses)
- ;; As in dead-after-use?, we don't kill the variable if it was
- ;; defined outside the current loop.
- (and (let ((loop (lookup-loop-header branch blocks)))
- (or (eqv? def loop)
- (eqv? (lookup-loop-header def blocks) loop)))
- (and-map
- (lambda (use-k)
- ;; A symbol is dead after a branch if at least one of the
- ;; other branches dominates a use of the symbol, and all
- ;; other uses of the symbol dominate the test.
- (if (or-map (cut dominates? <> use-k blocks)
- other-branches)
- (not (dominates? branch use-k blocks))
- (dominates? use-k branch blocks)))
- uses)))))))
+;; A continuation is a control point if it has multiple predecessors, or
+;; if its single predecessor has multiple successors.
+(define (control-point? k dfg)
+ (match (lookup-predecessors k dfg)
+ ((pred)
+ (match (lookup-successors pred dfg)
+ ((_) #f)
+ (_ #t)))
+ (_ #t)))
(define (lookup-bound-syms k dfg)
(match dfg
diff --git a/module/language/cps/slot-allocation.scm
b/module/language/cps/slot-allocation.scm
index e4e85ec..07f6e27 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -48,15 +48,10 @@
;; constant value is set to the CONST slot and HAS-CONST? is set to a
;; true value.
;;
-;; DEF holds the label of the continuation that defines the variable,
-;; and DEAD is a list of continuations at which the variable becomes
-;; dead.
(define-record-type $allocation
- (make-allocation def slot dead has-const? const)
+ (make-allocation slot has-const? const)
allocation?
- (def allocation-def)
(slot allocation-slot)
- (dead allocation-dead set-allocation-dead!)
(has-const? allocation-has-const?)
(const allocation-const))
@@ -109,17 +104,17 @@
(define (lookup-slot sym allocation)
(match (lookup-allocation sym allocation)
- (($ $allocation def slot dead has-const? const) slot)))
+ (($ $allocation slot has-const? const) slot)))
(define (lookup-constant-value sym allocation)
(match (lookup-allocation sym allocation)
- (($ $allocation def slot dead #t const) const)
+ (($ $allocation slot #t const) const)
(_
(error "Variable does not have constant value" sym))))
(define (lookup-maybe-constant-value sym allocation)
(match (lookup-allocation sym allocation)
- (($ $allocation def slot dead has-const? const)
+ (($ $allocation slot has-const? const)
(values has-const? const))))
(define (lookup-call-proc-slot k allocation)
@@ -195,92 +190,90 @@ are comparable with eqv?. A tmp slot may be used."
tmp)
(loop to-move b (cons s+d moved) last-source))))))))))
+(define (dead-after-def? def-k v-idx dfa)
+ (let ((l (dfa-k-idx dfa def-k)))
+ (not (bitvector-ref (dfa-k-in dfa l) v-idx))))
+
+(define (dead-after-use? use-k v-idx dfa)
+ (let ((l (dfa-k-idx dfa use-k)))
+ (not (bitvector-ref (dfa-k-out dfa l) v-idx))))
+
(define (allocate-slots fun)
- (define (empty-live-set)
- (cons #b0 '()))
-
- (define (add-live-variable sym slot live-set)
- (cons (logior (car live-set) (ash 1 slot))
- (acons sym slot (cdr live-set))))
-
- (define (remove-live-variable sym slot live-set)
- (cons (logand (car live-set) (lognot (ash 1 slot)))
- (acons sym #f (cdr live-set))))
-
- (define (fold-live-set proc seed live-set)
- (let lp ((bits (car live-set)) (clauses (cdr live-set)) (seed seed))
- (if (zero? bits)
- seed
- (match clauses
- (((sym . slot) . clauses)
- (if (and slot (logbit? slot bits))
- (lp (logand bits (lognot (ash 1 slot)))
- clauses
- (proc sym slot seed))
- (lp bits clauses seed)))))))
-
- (define (compute-slot live-set hint)
- (if (and hint (not (logbit? hint (car live-set))))
- hint
- (find-first-zero (car live-set))))
+ (define (empty-live-slots)
+ #b0)
- (define (compute-call-proc-slot live-set nlocals)
- (+ 3 (find-first-trailing-zero (car live-set) nlocals)))
+ (define (add-live-slot slot live-slots)
+ (logior live-slots (ash 1 slot)))
- (define (compute-prompt-handler-proc-slot live-set nlocals)
- (1- (find-first-trailing-zero (car live-set) nlocals)))
+ (define (kill-dead-slot slot live-slots)
+ (logand live-slots (lognot (ash 1 slot))))
- (define dfg (compute-dfg fun #:global? #f))
- (define allocation (make-hash-table))
-
- (define (visit-clause clause live-set)
- (define nlocals (compute-slot live-set #f))
+ (define (compute-slot live-slots hint)
+ (if (and hint (not (logbit? hint live-slots)))
+ hint
+ (find-first-zero live-slots)))
+
+ (define (compute-call-proc-slot live-slots nlocals)
+ (+ 3 (find-first-trailing-zero live-slots nlocals)))
+
+ (define (compute-prompt-handler-proc-slot live-slots nlocals)
+ (1- (find-first-trailing-zero live-slots nlocals)))
+
+ (define (recompute-live-slots k slots nargs dfa)
+ (let ((in (dfa-k-in dfa (dfa-k-idx dfa k))))
+ (let lp ((v 0) (live-slots (1- (ash 1 (1+ nargs)))))
+ (let ((v (bit-position #t in v)))
+ (if v
+ (let ((slot (vector-ref slots v)))
+ (lp (1+ v)
+ (if slot
+ (add-live-slot slot live-slots)
+ live-slots)))
+ live-slots)))))
+
+ (define (visit-clause clause dfg dfa allocation slots live-slots)
+ (define nlocals (compute-slot live-slots #f))
(define nargs
(match clause
(($ $cont _ _ ($ $kclause _ ($ $cont _ _ ($ $kargs names syms))))
(length syms))))
- (define (allocate! sym k hint live-set)
+ (define (allocate! sym k hint live-slots)
(match (hashq-ref allocation sym)
- (($ $allocation def slot dead has-const)
+ (($ $allocation slot)
;; Parallel move already allocated this one.
(if slot
- (add-live-variable sym slot live-set)
- live-set))
+ (add-live-slot slot live-slots)
+ live-slots))
(_
(call-with-values (lambda () (find-constant-value sym dfg))
(lambda (has-const? const)
(cond
((and has-const? (not (constant-needs-allocation? sym const
dfg)))
(hashq-set! allocation sym
- (make-allocation k #f '() has-const? const))
- live-set)
+ (make-allocation #f has-const? const))
+ live-slots)
(else
- (let ((slot (compute-slot live-set hint)))
+ (let ((slot (compute-slot live-slots hint)))
(when (>= slot nlocals)
(set! nlocals (+ slot 1)))
+ (vector-set! slots (dfa-var-idx dfa sym) slot)
(hashq-set! allocation sym
- (make-allocation k slot '() has-const? const))
- (add-live-variable sym slot live-set)))))))))
+ (make-allocation slot has-const? const))
+ (add-live-slot slot live-slots)))))))))
- (define (dead sym k live-set)
- (match (lookup-allocation sym allocation)
- ((and allocation ($ $allocation def slot dead has-const? const))
- (set-allocation-dead! allocation (cons k dead))
- (remove-live-variable sym slot live-set))))
-
- (define (allocate-prompt-handler! k live-set)
- (let ((proc-slot (compute-prompt-handler-proc-slot live-set nlocals)))
+ (define (allocate-prompt-handler! k live-slots)
+ (let ((proc-slot (compute-prompt-handler-proc-slot live-slots nlocals)))
(hashq-set! allocation k
(make-cont-allocation
proc-slot
(match (hashq-ref allocation k)
(($ $cont-allocation #f moves) moves)
(#f #f))))
- live-set))
+ live-slots))
- (define (allocate-frame! k nargs live-set)
- (let ((proc-slot (compute-call-proc-slot live-set nlocals)))
+ (define (allocate-frame! k nargs live-slots)
+ (let ((proc-slot (compute-call-proc-slot live-slots nlocals)))
(set! nlocals (max nlocals (+ proc-slot 1 nargs)))
(hashq-set! allocation k
(make-cont-allocation
@@ -288,11 +281,10 @@ are comparable with eqv?. A tmp slot may be used."
(match (hashq-ref allocation k)
(($ $cont-allocation #f moves) moves)
(#f #f))))
- live-set))
+ live-slots))
- (define (parallel-move! src-k src-slots pre-live-set post-live-set
dst-slots)
- (let* ((tmp-slot (find-first-zero (logior (car pre-live-set)
- (car post-live-set))))
+ (define (parallel-move! src-k src-slots pre-live-slots post-live-slots
dst-slots)
+ (let* ((tmp-slot (find-first-zero (logior pre-live-slots
post-live-slots)))
(moves (solve-parallel-move src-slots dst-slots tmp-slot)))
(when (and (>= tmp-slot nlocals) (assv tmp-slot moves))
(set! nlocals (+ tmp-slot 1)))
@@ -302,69 +294,60 @@ are comparable with eqv?. A tmp slot may be used."
(($ $cont-allocation proc-slot #f) proc-slot)
(#f #f))
moves))
- post-live-set))
-
- (define (visit-cont cont label live-set)
- (define (maybe-kill-definition sym live-set)
- (if (and (lookup-slot sym allocation) (dead-after-def? sym dfg))
- (dead sym label live-set)
- live-set))
-
- (define (kill-conditionally-dead live-set)
- (if (branch? label dfg)
- (let ((branches (find-other-branches label dfg)))
- (fold-live-set
- (lambda (sym slot live-set)
- (if (and (> slot nargs)
- (dead-after-branch? sym label branches dfg))
- (dead sym label live-set)
- live-set))
- live-set
- live-set))
- live-set))
+ post-live-slots))
- (match cont
- (($ $kentry self tail clauses)
- (let ((live-set (allocate! self label 0 live-set)))
- (for-each (cut visit-cont <> label live-set) clauses))
- live-set)
+ (define (visit-cont cont label live-slots)
+ (define (maybe-kill-definition sym live-slots)
+ (let* ((v (dfa-var-idx dfa sym))
+ (slot (vector-ref slots v)))
+ (if (and slot (> slot nargs) (dead-after-def? label v dfa))
+ (kill-dead-slot slot live-slots)
+ live-slots)))
+ (define (maybe-recompute-live-slots live-slots)
+ (if (control-point? label dfg)
+ (recompute-live-slots label slots nargs dfa)
+ live-slots))
+
+ (match cont
(($ $kclause arity ($ $cont k src body))
- (visit-cont body k live-set))
+ (visit-cont body k live-slots))
(($ $kargs names syms body)
(visit-term body label
- (kill-conditionally-dead
+ (maybe-recompute-live-slots
(fold maybe-kill-definition
- (fold (cut allocate! <> label #f <>) live-set syms)
+ (fold (cut allocate! <> label #f <>) live-slots
syms)
syms))))
- (($ $ktrunc) live-set)
- (($ $kif) live-set)))
+ (($ $ktrunc) live-slots)
+ (($ $kif) live-slots)))
- (define (visit-term term label live-set)
+ (define (visit-term term label live-slots)
(match term
(($ $letk conts body)
- (let ((live-set (visit-term body label live-set)))
+ (let ((live-slots (visit-term body label live-slots)))
(for-each (match-lambda
(($ $cont k src cont)
- (visit-cont cont k live-set)))
+ (visit-cont cont k live-slots)))
conts))
- live-set)
+ live-slots)
(($ $continue k exp)
- (visit-exp exp label k live-set))))
+ (visit-exp exp label k live-slots))))
- (define (visit-exp exp label k live-set)
- (define (use sym live-set)
- (if (and (and=> (lookup-slot sym allocation) (cut > <> nargs))
- (dead-after-use? sym label dfg))
- (dead sym label live-set)
- live-set))
+ (define (visit-exp exp label k live-slots)
+ (define (use sym live-slots)
+ (let* ((v (dfa-var-idx dfa sym))
+ (l (dfa-k-idx dfa label))
+ (slot (vector-ref slots v)))
+ (if (and slot (> slot nargs) (dead-after-use? label v dfa))
+ (kill-dead-slot slot live-slots)
+ live-slots)))
(match exp
(($ $var sym)
- (use sym live-set))
+ (use sym live-slots))
(($ $call proc args)
(match (lookup-cont k (dfg-cont-table dfg))
@@ -374,33 +357,33 @@ are comparable with eqv?. A tmp slot may be used."
(parallel-move! label
(map (cut lookup-slot <> allocation)
(cons proc args))
- live-set (fold use live-set (cons proc args))
+ live-slots (fold use live-slots (cons proc args))
(iota tail-nlocals))))
(($ $ktrunc arity kargs)
- (let* ((live-set
+ (let* ((live-slots
(fold use
(use proc
- (allocate-frame! label (length args) live-set))
+ (allocate-frame! label (length args)
live-slots))
args))
(proc-slot (lookup-call-proc-slot label allocation))
(dst-syms (lookup-bound-syms kargs dfg))
(nvals (length dst-syms))
(src-slots (map (cut + proc-slot 1 <>) (iota nvals)))
- (live-set* (fold (cut allocate! <> kargs <> <>)
- live-set dst-syms src-slots))
+ (live-slots* (fold (cut allocate! <> kargs <> <>)
+ live-slots dst-syms src-slots))
(dst-slots (map (cut lookup-slot <> allocation)
dst-syms)))
- (parallel-move! label src-slots live-set live-set* dst-slots)))
+ (parallel-move! label src-slots live-slots live-slots*
dst-slots)))
(else
(fold use
- (use proc (allocate-frame! label (length args) live-set))
+ (use proc (allocate-frame! label (length args) live-slots))
args))))
(($ $primcall name args)
- (fold use live-set args))
+ (fold use live-slots args))
(($ $values args)
- (let ((live-set* (fold use live-set args)))
+ (let ((live-slots* (fold use live-slots args)))
(define (compute-dst-slots)
(match (lookup-cont k (dfg-cont-table dfg))
(($ $ktail)
@@ -410,40 +393,48 @@ are comparable with eqv?. A tmp slot may be used."
(_
(let* ((src-slots (map (cut lookup-slot <> allocation) args))
(dst-syms (lookup-bound-syms k dfg))
- (dst-live-set (fold (cut allocate! <> k <> <>)
- live-set* dst-syms src-slots)))
+ (dst-live-slots (fold (cut allocate! <> k <> <>)
+ live-slots* dst-syms src-slots)))
(map (cut lookup-slot <> allocation) dst-syms)))))
(parallel-move! label
(map (cut lookup-slot <> allocation) args)
- live-set live-set*
+ live-slots live-slots*
(compute-dst-slots))))
(($ $prompt escape? tag handler)
(match (lookup-cont handler (dfg-cont-table dfg))
(($ $ktrunc arity kargs)
- (let* ((live-set (allocate-prompt-handler! label live-set))
+ (let* ((live-slots (allocate-prompt-handler! label live-slots))
(proc-slot (lookup-call-proc-slot label allocation))
(dst-syms (lookup-bound-syms kargs dfg))
(nvals (length dst-syms))
(src-slots (map (cut + proc-slot 1 <>) (iota nvals)))
- (live-set* (fold (cut allocate! <> kargs <> <>)
- live-set dst-syms src-slots))
+ (live-slots* (fold (cut allocate! <> kargs <> <>)
+ live-slots dst-syms src-slots))
(dst-slots (map (cut lookup-slot <> allocation)
dst-syms)))
- (parallel-move! handler src-slots live-set live-set*
dst-slots))))
- (use tag live-set))
+ (parallel-move! handler src-slots live-slots live-slots*
dst-slots))))
+ (use tag live-slots))
- (_ live-set)))
+ (_ live-slots)))
(match clause
(($ $cont k _ body)
- (visit-cont body k live-set)
+ (visit-cont body k live-slots)
(hashq-set! allocation k nlocals))))
(match fun
- (($ $fun meta free ($ $cont k _ ($ $kentry self tail clauses)))
- (let ((live-set (add-live-variable self 0 (empty-live-set))))
- (hashq-set! allocation self (make-allocation k 0 '() #f #f))
- (for-each (cut visit-clause <> live-set) clauses)
+ (($ $fun meta free ($ $cont k _ ($ $kentry self
+ ($ $cont ktail _ ($ $ktail))
+ clauses)))
+ (let* ((dfg (compute-dfg fun #:global? #f))
+ (dfa (compute-live-variables ktail 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)
+ clauses)
allocation))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-259-ge636f42,
Andy Wingo <=