[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-866-gce1dbe8
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-866-gce1dbe8 |
|
Date: |
Wed, 02 Apr 2014 13:46:59 +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=ce1dbe8c1bc3f1d37978d2ca1d5949b03514a5e3
The branch, master has been updated
via ce1dbe8c1bc3f1d37978d2ca1d5949b03514a5e3 (commit)
via b7dc00b1e73e83beedcb4102e7b9f2ea95097f4e (commit)
via 2896942751daf2f8dfce1dfd1a77d2a9cf325262 (commit)
via a7324faf1b0a7051b08abef12251d070f543ec0c (commit)
via a57f6e1e364bb8a27f087df49af9cbaf94fdabd9 (commit)
via 4ec3ded05d004a446faac0ce3f30f03a5b73585b (commit)
via ae0388b69846463f1cf97de59ae3abd13b6eb54d (commit)
via 16af91e862e5ed584b2be6fd460501f6743dc926 (commit)
from 0a44542fce2f010dcf7e9edefe05187a62d08a05 (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 ce1dbe8c1bc3f1d37978d2ca1d5949b03514a5e3
Author: Andy Wingo <address@hidden>
Date: Wed Apr 2 15:41:14 2014 +0200
Fix DCE for refactor-introduced borkage
* module/language/cps/dce.scm ($fun-data, compute-live-code)
(process-eliminations): Fix clownshoes regarding fun-data field names
and order.
commit b7dc00b1e73e83beedcb4102e7b9f2ea95097f4e
Author: Andy Wingo <address@hidden>
Date: Wed Apr 2 15:40:03 2014 +0200
Fix prune-top-level-scopes to allow collisions between var, scope, cont
names
* module/language/cps/prune-top-level-scopes.scm
(compute-referenced-scopes):
Fix to not assume that scope names, continuation names, and var names
are mutually unique.
(prune-top-level-scopes): Better variable names.
commit 2896942751daf2f8dfce1dfd1a77d2a9cf325262
Author: Andy Wingo <address@hidden>
Date: Wed Apr 2 12:08:48 2014 +0200
Update old-style REPL code for deprecation
* module/ice-9/scm-style-repl.scm:
* module/ice-9/save-stack.scm: As the deprecated bindings have been
removed from the default environment, use #:export instead of
#:replace.
commit a7324faf1b0a7051b08abef12251d070f543ec0c
Author: Andy Wingo <address@hidden>
Date: Wed Apr 2 12:00:09 2014 +0200
Remove CFA data type
* 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.
commit a57f6e1e364bb8a27f087df49af9cbaf94fdabd9
Author: Andy Wingo <address@hidden>
Date: Wed Apr 2 11:45:26 2014 +0200
$dfa includes CFA fields
* module/language/cps/dfg.scm ($dfa): Include CFA min-label, k-map, and
k-order inline.
(dfa-k-idx, dfa-k-sym, dfa-k-count): Adapt.
(compute-live-variables): Extract fields of CFA for make-dfa.
(print-dfa): Adapt (and fix positional record matching).
commit 4ec3ded05d004a446faac0ce3f30f03a5b73585b
Author: Andy Wingo <address@hidden>
Date: Wed Apr 2 11:23:41 2014 +0200
More CFA removals
* module/language/cps/dfg.scm (compute-reachable): Reword docstring.
(visit-prompt-control-flow): Likewise.
($dominator-analysis): Change to store min-label instead of CFA.
(compute-idoms, compute-join-edges, mark-loop-body, identify-loops):
Take min-label and label-count, and use the DFG's preds list instead
of requiring a fresh renumbered one.
(analyze-dominators): Adapt to use a DFG with a label range instead of
a CFA.
commit ae0388b69846463f1cf97de59ae3abd13b6eb54d
Author: Andy Wingo <address@hidden>
Date: Wed Apr 2 11:04:04 2014 +0200
Simplify analyze-reverse-control-flow
* module/language/cps/dfg.scm (analyze-reverse-control-flow): Use the
DFG's label count and min label analysis instead of rolling our own.
commit 16af91e862e5ed584b2be6fd460501f6743dc926
Author: Andy Wingo <address@hidden>
Date: Wed Apr 2 11:01:39 2014 +0200
analyze-control-flow only used in reverse direction; make private
* module/language/cps/dfg.scm ($cfa): Use a vector to map labels to
indices. Don't export any CFA bindings.
(cfa-k-idx): Adapt.
(compute-reachable, find-prompts, compute-interval):
(find-prompt-bodies, visit-prompt-control-flow): Take a DFG as an
argument instead of a CFA.
(analyze-reverse-control-flow): Refactor from analyze-control-flow, as
it is only used in the reverse case. Simplify accordingly, inlining
the RPO sort.
(compute-live-variables): Adapt to call analyze-reverse-control-flow
instead.
-----------------------------------------------------------------------
Summary of changes:
module/ice-9/save-stack.scm | 8 +-
module/ice-9/scm-style-repl.scm | 24 +-
module/language/cps/dce.scm | 13 +-
module/language/cps/dfg.scm | 506 +++++++++++-------------
module/language/cps/prune-top-level-scopes.scm | 36 +-
5 files changed, 275 insertions(+), 312 deletions(-)
diff --git a/module/ice-9/save-stack.scm b/module/ice-9/save-stack.scm
index 126ed83..8ba0067 100644
--- a/module/ice-9/save-stack.scm
+++ b/module/ice-9/save-stack.scm
@@ -1,6 +1,6 @@
;;; -*- mode: scheme; coding: utf-8; -*-
-;;;; Copyright (C)
1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010
+;;;; Copyright (C)
1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2014
;;;; Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
@@ -31,9 +31,9 @@
(define-module (ice-9 save-stack)
;; Replace deprecated root-module bindings, if present.
- #:replace (stack-saved?
- the-last-stack
- save-stack))
+ #:export (stack-saved?
+ the-last-stack
+ save-stack))
;; FIXME: stack-saved? is broken in the presence of threads.
(define stack-saved? #f)
diff --git a/module/ice-9/scm-style-repl.scm b/module/ice-9/scm-style-repl.scm
index e71798b..12c4463 100644
--- a/module/ice-9/scm-style-repl.scm
+++ b/module/ice-9/scm-style-repl.scm
@@ -1,4 +1,4 @@
-;;;; Copyright (C)
1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010
+;;;; Copyright (C)
1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2014
;;;; Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
@@ -22,19 +22,17 @@
#:export (scm-repl-silent
scm-repl-print-unspecified
scm-repl-verbose
- scm-repl-prompt)
-
- ;; #:replace, as with deprecated code enabled these will be in the root env
- #:replace (assert-repl-silence
- assert-repl-print-unspecified
- assert-repl-verbosity
-
- default-pre-unwind-handler
- bad-throw
- error-catching-loop
- error-catching-repl
- scm-style-repl
- handle-system-error))
+ scm-repl-prompt
+ assert-repl-silence
+ assert-repl-print-unspecified
+ assert-repl-verbosity
+
+ default-pre-unwind-handler
+ bad-throw
+ error-catching-loop
+ error-catching-repl
+ scm-style-repl
+ handle-system-error))
(define scm-repl-silent #f)
(define (assert-repl-silence v) (set! scm-repl-silent v))
diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm
index eae551a..0aa08f7 100644
--- a/module/language/cps/dce.scm
+++ b/module/language/cps/dce.scm
@@ -43,11 +43,10 @@
#:export (eliminate-dead-code))
(define-record-type $fun-data
- (make-fun-data min-label effects conts live-conts defs)
+ (make-fun-data min-label effects live-conts defs)
fun-data?
(min-label fun-data-min-label)
(effects fun-data-effects)
- (conts fun-data-conts)
(live-conts fun-data-live-conts)
(defs fun-data-defs))
@@ -100,14 +99,14 @@
(effects (compute-effects dfg min-label label-count))
(live-conts (make-bitvector label-count #f))
(defs (compute-defs dfg min-label label-count))
- (fun-data (make-fun-data min-label label-count
- effects live-conts defs)))
+ (fun-data (make-fun-data
+ min-label effects live-conts defs)))
(hashq-set! fun-data-table fun fun-data)
(set! changed? #t)
fun-data)))))
(define (visit-fun fun)
(match (ensure-fun-data fun)
- (($ $fun-data min-label label-count effects live-conts defs)
+ (($ $fun-data min-label effects live-conts defs)
(define (visit-grey-exp n)
(let ((defs (vector-ref defs n)))
(cond
@@ -118,7 +117,7 @@
(else
(or-map value-live? defs)))))
(define (idx->label idx) (+ idx min-label))
- (let lp ((n (1- label-count)))
+ (let lp ((n (1- (vector-length effects))))
(unless (< n 0)
(let ((cont (lookup-cont (idx->label n) dfg)))
(match cont
@@ -191,7 +190,7 @@
($continue k #f ($values live)))))))
(define (visit-fun fun)
(match (hashq-ref fun-data-table fun)
- (($ $fun-data min-label label-count effects live-conts defs)
+ (($ $fun-data min-label effects live-conts defs)
(define (label->idx label) (- label min-label))
(define (visit-cont cont)
(match (visit-cont* cont)
diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm
index c390427..c52093a 100644
--- a/module/language/cps/dfg.scm
+++ b/module/language/cps/dfg.scm
@@ -65,10 +65,6 @@
control-point?
lookup-bound-syms
- ;; Control flow analysis.
- analyze-control-flow
- cfa-k-idx cfa-k-count cfa-k-sym cfa-predecessors
-
;; Data flow analysis.
compute-live-variables
dfa-k-idx dfa-k-sym dfa-k-count dfa-k-in dfa-k-out
@@ -126,162 +122,93 @@
(min-var dfg-min-var)
(var-count dfg-var-count))
-;; 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 are reachable from an end node as well, or all nodes in a
-;; function. In that case pass an appropriate implementation of
-;; fold-all-conts, as analyze-control-flow does.
-(define (reverse-post-order k0 get-successors fold-all-conts)
- (let ((order '())
- (visited? (make-hash-table)))
- (let visit ((k k0))
- (hashq-set! visited? k #t)
- (for-each (lambda (k)
- (unless (hashq-ref visited? k)
- (visit k)))
- (get-successors k))
- (set! order (cons k order)))
- (list->vector (fold-all-conts
- (lambda (k seed)
- (if (hashq-ref visited? k)
- seed
- (begin
- (hashq-set! visited? k #t)
- (cons k seed))))
- order))))
-
-(define (make-block-mapping 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))))
- mapping))
-
-(define (convert-predecessors order get-predecessors)
- (let ((preds-vec (make-vector (vector-length order) #f)))
- (let lp ((n 0))
- (when (< n (vector-length order))
- (vector-set! preds-vec n (get-predecessors (vector-ref order n)))
- (lp (1+ n))))
- preds-vec))
-
-;; Control-flow analysis.
-(define-record-type $cfa
- (make-cfa k-map order preds)
- cfa?
- ;; Hash table mapping k-sym -> 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
- #:key (default (lambda (k)
- (error "unknown k" k))))
- (or (hashq-ref (cfa-k-map cfa) k)
- (default k)))
-
-(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)
(let ((v vec) (i idx))
(vector-set! v i (cons val (vector-ref v i)))))
-(define (compute-reachable cfa dfg)
- "Given the forward control-flow analysis in CFA, compute and return
-the continuations that may be reached if flow reaches a continuation N.
-Returns a vector of bitvectors. The given CFA should be a forward CFA,
-for quickest convergence."
- (let* ((k-count (cfa-k-count cfa))
- ;; Vector of bitvectors, indicating that continuation N can
- ;; reach a set M...
- (reachable (make-vector k-count #f))
- ;; Vector of lists, indicating that continuation N can directly
- ;; reach continuations M...
- (succs (make-vector k-count '())))
+(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
+index corresponds to MIN-LABEL, and so on."
+ (let (;; Vector of bitvectors, indicating that continuation N can
+ ;; reach a set M...
+ (reachable (make-vector label-count #f)))
+
+ (define (label->idx label) (- label min-label))
;; All continuations are reachable from themselves.
(let lp ((n 0))
- (when (< n k-count)
- (let ((bv (make-bitvector k-count #f)))
+ (when (< n label-count)
+ (let ((bv (make-bitvector label-count #f)))
(bitvector-set! bv n #t)
(vector-set! reachable n bv)
(lp (1+ n)))))
- ;; Initialize successor lists.
- (let lp ((n 0))
- (when (< n k-count)
- (for-each (lambda (succ)
- (vector-push! succs n (cfa-k-idx cfa succ)))
- (lookup-successors (cfa-k-sym cfa n) dfg))
- (lp (1+ n))))
-
- ;; Iterate cfa backwards, to converge quickly.
- (let ((tmp (make-bitvector k-count #f)))
- (let lp ((n k-count) (changed? #f))
+ ;; Iterate labels backwards, to converge quickly.
+ (let ((tmp (make-bitvector label-count #f)))
+ (define (add-reachable! succ)
+ (bit-set*! tmp (vector-ref reachable (label->idx succ)) #t))
+ (let lp ((label (+ min-label label-count)) (changed? #f))
(cond
- ((zero? n)
+ ((= label min-label)
(if changed?
- (lp k-count #f)
+ (lp (+ min-label label-count) #f)
reachable))
(else
- (let ((n (1- n)))
+ (let* ((label (1- label))
+ (idx (label->idx label)))
(bitvector-fill! tmp #f)
- (for-each (lambda (succ)
- (bit-set*! tmp (vector-ref reachable succ) #t))
- (vector-ref succs n))
- (bitvector-set! tmp n #t)
- (bit-set*! tmp (vector-ref reachable n) #f)
+ (visit-cont-successors
+ (case-lambda
+ (() #t)
+ ((succ0) (add-reachable! succ0))
+ ((succ0 succ1) (add-reachable! succ0) (add-reachable! succ1)))
+ (lookup-cont label dfg))
+ (bitvector-set! tmp idx #t)
+ (bit-set*! tmp (vector-ref reachable idx) #f)
(cond
((bit-position #t tmp 0)
- (bit-set*! (vector-ref reachable n) tmp #t)
- (lp n #t))
+ (bit-set*! (vector-ref reachable idx) tmp #t)
+ (lp label #t))
(else
- (lp n changed?))))))))))
+ (lp label changed?))))))))))
-(define (find-prompts cfa dfg)
- "Find the prompts in CFA, and return them as a list of PROMPT-INDEX,
-HANDLER-INDEX pairs."
- (let lp ((n 0) (prompts '()))
+(define (find-prompts dfg min-label label-count)
+ "Find the prompts in DFG between MIN-LABEL and MIN-LABEL +
+LABEL-COUNT, and return them as a list of PROMPT-LABEL, HANDLER-LABEL
+pairs."
+ (let lp ((label min-label) (prompts '()))
(cond
- ((= n (cfa-k-count cfa))
+ ((= label (+ min-label label-count))
(reverse prompts))
(else
- (match (lookup-cont (cfa-k-sym cfa n) dfg)
+ (match (lookup-cont label dfg)
(($ $kargs names syms body)
(match (find-expression body)
(($ $prompt escape? tag handler)
- (lp (1+ n) (acons n (cfa-k-idx cfa handler) prompts)))
- (_ (lp (1+ n) prompts))))
- (_ (lp (1+ n) prompts)))))))
+ (lp (1+ label) (acons label handler prompts)))
+ (_ (lp (1+ label) prompts))))
+ (_ (lp (1+ label) prompts)))))))
-(define (compute-interval cfa dfg reachable start end)
+(define (compute-interval reachable min-label label-count start end)
"Compute and return the set of continuations that may be reached from
START, inclusive, but not reached by END, exclusive. Returns a
bitvector."
- (let ((body (make-bitvector (cfa-k-count cfa) #f)))
- (bit-set*! body (vector-ref reachable start) #t)
- (bit-set*! body (vector-ref reachable end) #f)
+ (let ((body (make-bitvector label-count #f)))
+ (bit-set*! body (vector-ref reachable (- start min-label)) #t)
+ (bit-set*! body (vector-ref reachable (- end min-label)) #f)
body))
-(define (find-prompt-bodies cfa dfg)
- "Find all the prompts in CFA, and compute the set of continuations
-that is reachable from the prompt bodies but not from the corresponding
-handler. Returns a list of PROMPT, HANDLER, BODY lists, where the BODY
-is a bitvector."
- (match (find-prompts cfa dfg)
+(define (find-prompt-bodies dfg min-label label-count)
+ "Find all the prompts in DFG from the LABEL-COUNT continuations
+starting at MIN-LABEL, and compute the set of continuations that is
+reachable from the prompt bodies but not from the corresponding handler.
+Returns a list of PROMPT, HANDLER, BODY lists, where the BODY is a
+bitvector."
+ (match (find-prompts dfg min-label label-count)
(() '())
(((prompt . handler) ...)
- (let ((reachable (compute-reachable cfa dfg)))
+ (let ((reachable (compute-reachable dfg min-label label-count)))
(map (lambda (prompt handler)
;; FIXME: It isn't correct to use all continuations
;; reachable from the prompt, because that includes
@@ -291,18 +218,22 @@ is a bitvector."
;;
;; One counter-example is when the handler contifies an
;; infinite loop; in that case we compute a too-large
- ;; prompt body. This error is currently innocuous, but
- ;; we should fix it at some point.
+ ;; prompt body. This error is currently innocuous, but we
+ ;; should fix it at some point.
;;
;; The fix is to end the body at the corresponding "pop"
;; primcall, if any.
- (let ((body (compute-interval cfa dfg reachable prompt handler)))
+ (let ((body (compute-interval reachable min-label label-count
+ prompt handler)))
(list prompt handler body)))
prompt handler)))))
-(define* (visit-prompt-control-flow cfa dfg f #:key complete?)
- "For all prompts in CFA, invoke F with arguments PROMPT, HANDLER, and
-BODY for each body continuation in the prompt."
+(define* (visit-prompt-control-flow dfg min-label label-count f #:key
complete?)
+ "For all prompts in DFG in the range [MIN-LABEL, MIN-LABEL +
+LABEL-COUNT), invoke F with arguments PROMPT, HANDLER, and BODY for each
+body continuation in the prompt."
+ (define (label->idx label) (- label min-label))
+ (define (idx->label idx) (+ idx min-label))
(for-each
(match-lambda
((prompt handler body)
@@ -319,84 +250,103 @@ BODY for each body continuation in the prompt."
;; not continue to the pop if it never terminates. The pop could
;; even be removed by DCE, in that case.
(or-map (lambda (succ)
- (let ((succ (cfa-k-idx cfa succ)))
+ (let ((succ (label->idx succ)))
(or (not (bitvector-ref body succ))
(<= succ n))))
- (lookup-successors (cfa-k-sym cfa n) dfg)))
+ (lookup-successors (idx->label n) dfg)))
(let lp ((n 0))
(let ((n (bit-position #t body n)))
(when n
(when (or complete? (out-or-back-edge? n))
- (f prompt handler n))
+ (f prompt handler (idx->label n)))
(lp (1+ n)))))))
- (find-prompt-bodies cfa dfg)))
-
-(define* (analyze-control-flow fun dfg #:key reverse? add-handler-preds?)
- (define (build-cfa kentry lookup-succs lookup-preds forward-cfa)
- (define (reachable-preds mapping)
- ;; It's possible for a predecessor to not be in the mapping, if
- ;; the predecessor is not reachable from the entry node.
- (lambda (k)
- (filter-map (cut hashq-ref mapping <>) (lookup-preds k dfg))))
- (let* ((order (reverse-post-order
- kentry
- (lambda (k)
- ;; RPO numbering is going to visit this list of
- ;; successors in the order that we give it. Sort
- ;; it so that all things being equal, we preserve
- ;; the existing numbering order. This also has the
- ;; effect of preserving clause order.
- (let ((succs (lookup-succs k dfg)))
- (if (or (null? succs) (null? (cdr succs)))
- succs
- (sort succs >))))
- (if forward-cfa
- (lambda (f seed)
- (let lp ((n (cfa-k-count forward-cfa)) (seed seed))
- (if (zero? n)
- seed
- (lp (1- n)
- (f (cfa-k-sym forward-cfa (1- n)) seed)))))
- (lambda (f seed) seed))))
- (k-map (make-block-mapping order))
- (preds (convert-predecessors order (reachable-preds k-map)))
- (cfa (make-cfa k-map order preds)))
- (when add-handler-preds?
- ;; Any expression in the prompt body could cause an abort to the
- ;; handler. This code adds links from every block in the prompt
- ;; body to the handler. This causes all values used by the
- ;; handler to be seen as live in the prompt body, as indeed they
- ;; are.
- (let ((forward-cfa (or forward-cfa cfa)))
- (visit-prompt-control-flow
- forward-cfa dfg
- (lambda (prompt handler body)
- (define (renumber n)
- (if (eq? forward-cfa cfa)
- n
- (cfa-k-idx cfa (cfa-k-sym forward-cfa n))))
- (let ((handler (renumber handler))
- (body (renumber body)))
- (if reverse?
- (vector-push! preds body handler)
- (vector-push! preds handler body)))))))
- cfa))
+ (find-prompt-bodies dfg min-label label-count)))
+
+(define (analyze-reverse-control-flow fun dfg min-label label-count)
+ (define (compute-reverse-control-flow-order ktail dfg)
+ (let ((order (make-vector label-count #f))
+ (label-map (make-vector label-count #f))
+ (next -1))
+ (define (label->idx label) (- label min-label))
+ (define (idx->label idx) (+ idx min-label))
+
+ (let visit ((k ktail))
+ ;; Mark this label as visited.
+ (vector-set! label-map (label->idx k) #t)
+ (for-each (lambda (k)
+ ;; Visit predecessors unless they are already visited.
+ (unless (vector-ref label-map (label->idx k))
+ (visit k)))
+ (lookup-predecessors k dfg))
+ ;; Add to reverse post-order chain.
+ (vector-set! label-map (label->idx k) next)
+ (set! next k))
+
+ (let lp ((n 0) (head next))
+ (if (< head 0)
+ ;; Add nodes that are not reachable from the tail.
+ (let lp ((n n) (m label-count))
+ (unless (= n label-count)
+ (let find-unvisited ((m (1- m)))
+ (if (vector-ref label-map m)
+ (find-unvisited (1- m))
+ (begin
+ (vector-set! label-map m n)
+ (lp (1+ n) m))))))
+ ;; Pop the head off the chain, give it its
+ ;; reverse-post-order numbering, and continue.
+ (let ((next (vector-ref label-map (label->idx head))))
+ (vector-set! label-map (label->idx head) n)
+ (lp (1+ n) next))))
+
+ (let lp ((n 0))
+ (when (< n label-count)
+ (vector-set! order (vector-ref label-map n) (idx->label n))
+ (lp (1+ n))))
+
+ (values order label-map)))
+
+ (define (convert-successors k-map)
+ (define (idx->label idx) (+ idx min-label))
+ (define (renumber label)
+ (vector-ref k-map (- label min-label)))
+ (let ((succs (make-vector (vector-length k-map) #f)))
+ (let lp ((n 0))
+ (when (< n (vector-length succs))
+ (vector-set! succs (vector-ref k-map n)
+ (map renumber
+ (lookup-successors (idx->label n) dfg)))
+ (lp (1+ n))))
+ succs))
+
(match fun
(($ $fun src meta free
- ($ $cont kentry
- (and entry ($ $kentry self ($ $cont ktail tail)))))
- (if reverse?
- (build-cfa ktail lookup-predecessors lookup-successors
- (analyze-control-flow fun dfg #:reverse? #f
- #:add-handler-preds? #f))
- (build-cfa kentry lookup-successors lookup-predecessors #f)))))
+ ($ $cont kentry ($ $kentry self ($ $cont ktail tail))))
+ (call-with-values
+ (lambda ()
+ (compute-reverse-control-flow-order ktail dfg))
+ (lambda (order k-map)
+ (let ((succs (convert-successors k-map)))
+ ;; Any expression in the prompt body could cause an abort to
+ ;; the handler. This code adds links from every block in the
+ ;; prompt body to the handler. This causes all values used
+ ;; by the handler to be seen as live in the prompt body, as
+ ;; indeed they are.
+ (visit-prompt-control-flow
+ 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))))
+
+ (values k-map order succs)))))))
;; Dominator analysis.
(define-record-type $dominator-analysis
- (make-dominator-analysis cfa idoms dom-levels loop-header irreducible)
+ (make-dominator-analysis min-label idoms dom-levels loop-header irreducible)
dominator-analysis?
- ;; The corresponding $cfa
- (cfa dominator-analysis-cfa)
+ ;; Label corresponding to first entry in idoms, dom-levels, etc
+ (min-label dominator-analysis-min-label)
;; Vector of k-idx -> k-idx
(idoms dominator-analysis-idoms)
;; Vector of k-idx -> dom-level
@@ -420,8 +370,10 @@ BODY for each body continuation in the prompt."
(lp (1+ n))))
dom-levels))
-(define (compute-idoms preds)
- (let ((idoms (make-vector (vector-length preds) 0)))
+(define (compute-idoms preds min-label label-count)
+ (define (label->idx label) (- label min-label))
+ (define (idx->label idx) (+ idx min-label))
+ (let ((idoms (make-vector label-count 0)))
(define (common-idom d0 d1)
;; We exploit the fact that a reverse post-order is a topological
;; sort, and so the idom of a node is always numerically less than
@@ -434,20 +386,20 @@ BODY for each body continuation in the prompt."
(match preds
(() 0)
((pred . preds)
- (let lp ((idom pred) (preds preds))
+ (let lp ((idom (label->idx pred)) (preds preds))
(match preds
(() idom)
((pred . preds)
- (lp (common-idom idom pred) preds)))))))
+ (lp (common-idom idom (label->idx pred)) preds)))))))
;; This is the iterative O(n^2) fixpoint algorithm, originally from
;; Allen and Cocke ("Graph-theoretic constructs for program flow
;; analysis", 1972). See the discussion in Cooper, Harvey, and
;; Kennedy's "A Simple, Fast Dominance Algorithm", 2001.
(let iterate ((n 0) (changed? #f))
(cond
- ((< n (vector-length preds))
+ ((< n label-count)
(let ((idom (vector-ref idoms n))
- (idom* (compute-idom (vector-ref preds n))))
+ (idom* (compute-idom (vector-ref preds (idx->label n)))))
(cond
((eqv? idom idom*)
(iterate (1+ n) changed?))
@@ -472,18 +424,19 @@ BODY for each body continuation in the prompt."
;; Compute a vector containing, for each node, a list of the successors
;; of that node that are not dominated by that node. These are the "J"
;; edges in the DJ tree.
-(define (compute-join-edges preds idoms)
+(define (compute-join-edges preds min-label idoms)
(define (dominates? n1 n2)
(or (= n1 n2)
(and (< n1 n2)
(dominates? n1 (vector-ref idoms n2)))))
(let ((joins (make-vector (vector-length idoms) '())))
(let lp ((n 0))
- (when (< n (vector-length preds))
+ (when (< n (vector-length idoms))
(for-each (lambda (pred)
- (unless (dominates? pred n)
- (vector-push! joins pred n)))
- (vector-ref preds n))
+ (let ((pred (- pred min-label)))
+ (unless (dominates? pred n)
+ (vector-push! joins pred n))))
+ (vector-ref preds (+ n min-label)))
(lp (1+ n))))
joins))
@@ -571,7 +524,7 @@ BODY for each body continuation in the prompt."
;; dominated by the loop header, and mark them as belonging to the loop.
;; If they already have a loop header, that means they are either in a
;; nested loop, or they have already been visited already.
-(define (mark-loop-body header back-nodes preds idoms loop-headers)
+(define (mark-loop-body header back-nodes preds min-label idoms loop-headers)
(define (strictly-dominates? n1 n2)
(and (< n1 n2)
(let ((idom (vector-ref idoms n2)))
@@ -583,7 +536,8 @@ BODY for each body continuation in the prompt."
((vector-ref loop-headers node) => visit)
(else
(vector-set! loop-headers node header)
- (for-each visit (vector-ref preds node))))))
+ (for-each (lambda (pred) (visit (- pred min-label)))
+ (vector-ref preds (+ node min-label)))))))
(for-each visit back-nodes))
(define (mark-irreducible-loops level idoms dom-levels loop-headers)
@@ -593,33 +547,32 @@ BODY for each body continuation in the prompt."
;; "Identifying Loops Using DJ Graphs" by Sreedhar, Gao, and Lee, ACAPS
;; Technical Memo 98, 1995.
-(define (identify-loops preds idoms dom-levels)
+(define (identify-loops preds min-label idoms dom-levels)
(let* ((doms (compute-dom-edges idoms))
- (joins (compute-join-edges preds idoms))
+ (joins (compute-join-edges preds min-label idoms))
(back-edges (compute-reducible-back-edges joins idoms))
(irreducible-levels
(compute-irreducible-dom-levels doms joins idoms dom-levels))
- (loop-headers (make-vector (vector-length preds) #f))
+ (loop-headers (make-vector (vector-length idoms) #f))
(nodes-by-level (compute-nodes-by-level dom-levels)))
(let lp ((level (1- (vector-length nodes-by-level))))
(when (>= level 0)
(for-each (lambda (n)
(let ((edges (vector-ref back-edges n)))
(unless (null? edges)
- (mark-loop-body n edges preds idoms loop-headers))))
+ (mark-loop-body n edges preds min-label
+ idoms loop-headers))))
(vector-ref nodes-by-level level))
(when (logbit? level irreducible-levels)
(mark-irreducible-loops level idoms dom-levels loop-headers))
(lp (1- level))))
loop-headers))
-(define (analyze-dominators cfa)
- (match cfa
- (($ $cfa k-map order preds)
- (let* ((idoms (compute-idoms preds))
- (dom-levels (compute-dom-levels idoms))
- (loop-headers (identify-loops preds idoms dom-levels)))
- (make-dominator-analysis cfa idoms dom-levels loop-headers #f)))))
+(define (analyze-dominators dfg min-label label-count)
+ (let* ((idoms (compute-idoms (dfg-preds dfg) min-label label-count))
+ (dom-levels (compute-dom-levels idoms))
+ (loop-headers (identify-loops (dfg-preds dfg) min-label idoms
dom-levels)))
+ (make-dominator-analysis min-label idoms dom-levels loop-headers #f)))
;; Compute the maximum fixed point of the data-flow constraint problem.
@@ -659,10 +612,15 @@ BODY for each body continuation in the prompt."
;; Data-flow analysis.
(define-record-type $dfa
- (make-dfa cfa min-var var-count in out)
+ (make-dfa min-label k-map k-order min-var var-count in out)
dfa?
- ;; CFA, for its reverse-post-order numbering
- (cfa dfa-cfa)
+ ;; Minimum label.
+ (min-label dfa-min-label)
+ ;; Vector of (k - min-label) -> k-idx
+ (k-map dfa-k-map)
+ ;; Vector of k-idx -> k-sym, in (possibly reversed) control-flow order
+ (k-order dfa-k-order)
+
;; Minimum var in this function.
(min-var dfa-min-var)
;; Minimum var in this function.
@@ -673,13 +631,13 @@ BODY for each body continuation in the prompt."
(out dfa-out))
(define (dfa-k-idx dfa k)
- (cfa-k-idx (dfa-cfa dfa) k))
+ (vector-ref (dfa-k-map dfa) (- k (dfa-min-label dfa))))
(define (dfa-k-sym dfa idx)
- (cfa-k-sym (dfa-cfa dfa) idx))
+ (vector-ref (dfa-k-order dfa) idx))
(define (dfa-k-count dfa)
- (cfa-k-count (dfa-cfa dfa)))
+ (vector-length (dfa-k-map dfa)))
(define (dfa-var-idx dfa var)
(let ((idx (- var (dfa-min-var dfa))))
@@ -702,53 +660,57 @@ BODY for each body continuation in the prompt."
(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"))
- (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))
- (cfa (analyze-control-flow fun dfg #:reverse? #t
- #:add-handler-preds? #t))
- (usev (make-vector (cfa-k-count cfa) '()))
- (defv (make-vector (cfa-k-count cfa) '()))
- (live-in (make-vector (cfa-k-count cfa) #f))
- (live-out (make-vector (cfa-k-count cfa) #f)))
- (define (var->idx var) (- var min-var))
- (define (idx->var idx) (+ idx min-var))
-
- ;; Initialize defv and usev.
- (let ((defs (dfg-defs dfg))
- (uses (dfg-uses dfg)))
- (let lp ((n 0))
- (when (< n (vector-length defs))
- (let ((def (vector-ref defs n)))
- (unless def
- (error "internal error -- var array not packed"))
- (for-each (lambda (def)
- (vector-push! defv (cfa-k-idx cfa def) n))
- (lookup-predecessors def dfg))
- (for-each (lambda (use)
- (vector-push! usev (cfa-k-idx cfa use) n))
- (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, and usev for defv. Note that since we are using
- ;; a reverse CFA, cfa-preds are actually successors, and
- ;; continuation 0 is ktail.
- (compute-maximum-fixed-point (cfa-preds cfa)
- live-out live-in defv usev #t)
-
- (make-dfa cfa min-var nvars live-in live-out)))
+ (usev (make-vector nlabels '()))
+ (defv (make-vector nlabels '()))
+ (live-in (make-vector nlabels #f))
+ (live-out (make-vector nlabels #f)))
+ (call-with-values
+ (lambda ()
+ (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.
+ (let ((defs (dfg-defs dfg))
+ (uses (dfg-uses dfg)))
+ (let lp ((n 0))
+ (when (< n (vector-length defs))
+ (let ((def (vector-ref defs n)))
+ (unless def
+ (error "internal error -- var array not packed"))
+ (for-each (lambda (def)
+ (vector-push! defv (label->idx def) n))
+ (lookup-predecessors def dfg))
+ (for-each (lambda (use)
+ (vector-push! usev (label->idx use) n))
+ (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)
+
+ (make-dfa min-label k-map k-order min-var nvars live-in live-out)))))
(define (print-dfa dfa)
(match dfa
- (($ $dfa cfa min-var in out)
+ (($ $dfa min-label k-map k-order min-var var-count in out)
(define (print-var-set bv)
(let lp ((n 0))
(let ((n (bit-position #t bv n)))
@@ -756,8 +718,8 @@ BODY for each body continuation in the prompt."
(format #t " ~A" (+ n min-var))
(lp (1+ n))))))
(let lp ((n 0))
- (when (< n (cfa-k-count cfa))
- (format #t "~A:\n" (cfa-k-sym cfa n))
+ (when (< n (vector-length k-order))
+ (format #t "~A:\n" (vector-ref k-order n))
(format #t " in:")
(print-var-set (vector-ref in n))
(newline)
diff --git a/module/language/cps/prune-top-level-scopes.scm
b/module/language/cps/prune-top-level-scopes.scm
index 7ee7972..84f3730 100644
--- a/module/language/cps/prune-top-level-scopes.scm
+++ b/module/language/cps/prune-top-level-scopes.scm
@@ -28,13 +28,17 @@
#:export (prune-top-level-scopes))
(define (compute-referenced-scopes fun)
- (let ((refs (make-hash-table)))
+ (let ((scope-name->used? (make-hash-table))
+ (scope-var->used? (make-hash-table))
+ (k->scope-var (make-hash-table)))
+ ;; Visit uses before defs. That way we know when visiting defs
+ ;; whether the scope is used or not.
(define (visit-cont cont)
(match cont
- (($ $cont k ($ $kargs (name) (sym) body))
+ (($ $cont k ($ $kargs (name) (var) body))
(visit-term body)
- (when (hashq-get-handle refs sym)
- (hashq-set! refs k sym)))
+ (when (hashq-get-handle scope-var->used? var)
+ (hashq-set! k->scope-var k var)))
(($ $cont k ($ $kargs names syms body))
(visit-term body))
(($ $cont k ($ $kentry self tail clause))
@@ -56,25 +60,25 @@
(match exp
(($ $fun) (visit-fun exp))
(($ $primcall 'cached-toplevel-box (scope name bound?))
- (hashq-set! refs scope #t))
+ (hashq-set! scope-var->used? scope #t))
(($ $primcall 'cache-current-module! (module scope))
- (hashq-set! refs scope #f))
+ (hashq-set! scope-var->used? scope #f))
(($ $const val)
;; If there is an entry in the table for "k", it means "val"
;; is a scope symbol, bound for use by cached-toplevel-box
;; or cache-current-module!, or possibly both (though this
;; is not currently the case).
- (and=> (hashq-ref refs k)
- (lambda (sym)
- (when (hashq-ref refs sym)
+ (and=> (hashq-ref k->scope-var k)
+ (lambda (scope-var)
+ (when (hashq-ref scope-var->used? scope-var)
;; We have a use via cached-toplevel-box. Mark
;; this scope as used.
- (hashq-set! refs val #t))
- (when (and (hashq-ref refs val)
- (not (hashq-ref refs sym)))
+ (hashq-set! scope-name->used? val #t))
+ (when (and (hashq-ref scope-name->used? val)
+ (not (hashq-ref scope-var->used? scope-var)))
;; There is a use, and this sym is used by
;; cache-current-module!.
- (hashq-set! refs sym #t)))))
+ (hashq-set! scope-var->used? scope-var #t)))))
(_ #t)))))
(define (visit-fun fun)
(match fun
@@ -82,10 +86,10 @@
(visit-cont body))))
(visit-fun fun)
- refs))
+ scope-var->used?))
(define (prune-top-level-scopes fun)
- (let ((referenced-scopes (compute-referenced-scopes fun)))
+ (let ((scope-var->used? (compute-referenced-scopes fun)))
(define (visit-cont cont)
(rewrite-cps-cont cont
(($ $cont sym ($ $kargs names syms body))
@@ -106,7 +110,7 @@
(($ $continue k src
(and ($ $primcall 'cache-current-module! (module scope))
(? (lambda _
- (not (hashq-ref referenced-scopes scope))))))
+ (not (hashq-ref scope-var->used? scope))))))
($continue k src ($primcall 'values ())))
(($ $continue)
,term)))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-866-gce1dbe8,
Andy Wingo <=