[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-848-ga8430ab
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-848-ga8430ab |
|
Date: |
Tue, 01 Apr 2014 12:58:02 +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=a8430ab1d779278c08b389c566243a2ce013093a
The branch, master has been updated
via a8430ab1d779278c08b389c566243a2ce013093a (commit)
via 09220d215f4630e1735677adfe230f7ccf98a34f (commit)
via 2c3c086ef3411c8ddf1dfa11024b188a5068c1b0 (commit)
from 6e5e9ffb7564501e8ef0ce21137ad450f8107761 (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 a8430ab1d779278c08b389c566243a2ce013093a
Author: Andy Wingo <address@hidden>
Date: Tue Apr 1 12:42:09 2014 +0200
Compile-fun takes advantage of sorted output of "renumber", avoids CFA
* module/language/cps/dfg.scm ($dfg): Rename nvars and nlabels fields to
var-count and label-count. Export dfg-min-var, dfg-min-label,
dfg-label-count, dfg-var-count.
* module/language/cps/compile-bytecode.scm (compile-fun): No need to
build a CFA given the renumbering pass. Adapt to treat labels as
ordered small integer in a contiguous vector.
commit 09220d215f4630e1735677adfe230f7ccf98a34f
Author: Andy Wingo <address@hidden>
Date: Tue Apr 1 12:03:37 2014 +0200
CPS renumbering pass sorts conts in topological order
* module/language/cps/renumber.scm (sort-conts)
(compute-new-labels-and-vars): Rework to sort the labels in
topological order, and to prune any unreachable labels.
commit 2c3c086ef3411c8ddf1dfa11024b188a5068c1b0
Author: Andy Wingo <address@hidden>
Date: Tue Apr 1 11:59:03 2014 +0200
Add visit-cont-successors helper
* module/language/cps/dfg.scm (lookup-successors, control-point?): Use
the new helper.
* module/language/cps.scm (visit-cont-successors): New helper.
-----------------------------------------------------------------------
Summary of changes:
module/language/cps.scm | 29 +++++-
module/language/cps/compile-bytecode.scm | 91 ++++++----------
module/language/cps/dfg.scm | 60 +++-------
module/language/cps/renumber.scm | 176 ++++++++++++++++++++++++------
4 files changed, 221 insertions(+), 135 deletions(-)
diff --git a/module/language/cps.scm b/module/language/cps.scm
index cb2cf03..c1bb304 100644
--- a/module/language/cps.scm
+++ b/module/language/cps.scm
@@ -136,7 +136,8 @@
;; Misc.
parse-cps unparse-cps
- make-cont-folder fold-conts fold-local-conts))
+ make-cont-folder fold-conts fold-local-conts
+ visit-cont-successors))
;; FIXME: Use SRFI-99, when Guile adds it.
(define-syntax define-record-type*
@@ -521,3 +522,29 @@
(define (fold-local-conts proc seed fun)
((make-cont-folder #f seed) proc fun seed))
+
+(define (visit-cont-successors proc cont)
+ (match cont
+ (($ $kargs names syms body)
+ (let lp ((body body))
+ (match body
+ (($ $letk conts body) (lp body))
+ (($ $letrec names vars funs body) (lp body))
+ (($ $continue k src exp)
+ (match exp
+ (($ $prompt escape? tag handler) (proc k handler))
+ (_ (proc k)))))))
+
+ (($ $kif kt kf) (proc kt kf))
+
+ (($ $kreceive arity k) (proc k))
+
+ (($ $kclause arity ($ $cont kbody) #f) (proc kbody))
+
+ (($ $kclause arity ($ $cont kbody) ($ $cont kalt)) (proc kbody kalt))
+
+ (($ $kentry self tail ($ $cont clause)) (proc clause))
+
+ (($ $kentry self tail #f) (proc))
+
+ (($ $ktail) (proc))))
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index 3026e59..c016e11 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -84,25 +84,9 @@
exp))
-(define (collect-conts f cfa)
- (let ((contv (make-vector (cfa-k-count cfa) #f)))
- (fold-local-conts
- (lambda (k cont tail)
- (let ((idx (cfa-k-idx cfa k #:default (lambda (k) #f))))
- (when idx
- (vector-set! contv idx cont))))
- '()
- f)
- contv))
-
(define (compile-fun f asm)
(let* ((dfg (compute-dfg f #:global? #f))
- (cfa (analyze-control-flow f dfg))
- (allocation (allocate-slots f dfg))
- (contv (collect-conts f cfa)))
- (define (lookup-cont k)
- (vector-ref contv (cfa-k-idx cfa k)))
-
+ (allocation (allocate-slots f dfg)))
(define (maybe-slot sym)
(lookup-maybe-slot sym allocation))
@@ -126,45 +110,45 @@
#t)))))
(define (compile-entry meta)
- (match (vector-ref contv 0)
- (($ $kentry self tail clause)
- (emit-begin-program asm (cfa-k-sym cfa 0) meta)
- (compile-clause 1)
- (emit-end-program asm))))
-
- (define (compile-clause n)
- (match (vector-ref contv n)
+ (let ((label (dfg-min-label dfg)))
+ (match (lookup-cont label dfg)
+ (($ $kentry self tail clause)
+ (emit-begin-program asm label meta)
+ (compile-clause (1+ label))
+ (emit-end-program asm)))))
+
+ (define (compile-clause label)
+ (match (lookup-cont label dfg)
(($ $kclause ($ $arity req opt rest kw allow-other-keys?)
body alternate)
(let* ((kw-indices (map (match-lambda
((key name sym)
(cons key (lookup-slot sym allocation))))
kw))
- (k (cfa-k-sym cfa n))
- (nlocals (lookup-nlocals k allocation)))
- (emit-label asm k)
+ (nlocals (lookup-nlocals label allocation)))
+ (emit-label asm label)
(emit-begin-kw-arity asm req opt rest kw-indices allow-other-keys?
nlocals
(match alternate (#f #f) (($ $cont alt) alt)))
- (let ((next (compile-body (1+ n) nlocals)))
+ (let ((next (compile-body (1+ label) nlocals)))
(emit-end-arity asm)
(match alternate
(($ $cont alt)
- (unless (eq? (cfa-k-sym cfa next) alt)
+ (unless (eq? next alt)
(error "unexpected k" alt))
(compile-clause next))
(#f
- (unless (= next (vector-length contv))
+ (unless (= next (+ (dfg-min-label dfg) (dfg-label-count dfg)))
(error "unexpected end of clauses")))))))))
- (define (compile-body n nlocals)
- (let compile-cont ((n n))
- (if (= n (vector-length contv))
- n
- (match (vector-ref contv n)
- (($ $kclause) n)
+ (define (compile-body label nlocals)
+ (let compile-cont ((label label))
+ (if (eq? label (+ (dfg-min-label dfg) (dfg-label-count dfg)))
+ label
+ (match (lookup-cont label dfg)
+ (($ $kclause) label)
(($ $kargs _ _ term)
- (emit-label asm (cfa-k-sym cfa n))
+ (emit-label asm label)
(let find-exp ((term term))
(match term
(($ $letk conts term)
@@ -172,20 +156,18 @@
(($ $continue k src exp)
(when src
(emit-source asm src))
- (compile-expression n k exp nlocals)
- (compile-cont (1+ n))))))
+ (compile-expression label k exp nlocals)
+ (compile-cont (1+ label))))))
(_
- (emit-label asm (cfa-k-sym cfa n))
- (compile-cont (1+ n)))))))
+ (emit-label asm label)
+ (compile-cont (1+ label)))))))
- (define (compile-expression n k exp nlocals)
- (let* ((label (cfa-k-sym cfa n))
- (k-idx (cfa-k-idx cfa k))
- (fallthrough? (= k-idx (1+ n))))
+ (define (compile-expression label k exp nlocals)
+ (let* ((fallthrough? (= k (1+ label))))
(define (maybe-emit-jump)
- (unless (= k-idx (1+ n))
+ (unless fallthrough?
(emit-br asm k)))
- (match (vector-ref contv k-idx)
+ (match (lookup-cont k dfg)
(($ $ktail)
(compile-tail label exp))
(($ $kargs (name) (sym))
@@ -200,19 +182,14 @@
(compile-values label exp syms)
(maybe-emit-jump))
(($ $kif kt kf)
- (compile-test label exp kt kf
- (and (= k-idx (1+ n))
- (< (+ n 2) (cfa-k-count cfa))
- (cfa-k-sym cfa (+ n 2)))))
+ (compile-test label exp kt kf (and fallthrough? (1+ k))))
(($ $kreceive ($ $arity req () rest () #f) kargs)
(compile-trunc label k exp (length req)
(and rest
- (match (vector-ref contv (cfa-k-idx cfa kargs))
+ (match (lookup-cont kargs dfg)
(($ $kargs names (_ ... rest)) rest)))
nlocals)
- (unless (and (= k-idx (1+ n))
- (< (+ n 2) (cfa-k-count cfa))
- (eq? (cfa-k-sym cfa (+ n 2)) kargs))
+ (unless (and fallthrough? (= kargs (1+ k)))
(emit-br asm kargs))))))
(define (compile-tail label exp)
@@ -319,7 +296,7 @@
(match exp
(($ $values ()) #f)
(($ $prompt escape? tag handler)
- (match (lookup-cont handler)
+ (match (lookup-cont handler dfg)
(($ $kreceive ($ $arity req () rest () #f) khandler-body)
(let ((receive-args (gensym "handler"))
(nreq (length req))
@@ -330,7 +307,7 @@
(unless (and rest (zero? nreq))
(emit-receive-values asm proc-slot (->bool rest) nreq))
(when (and rest
- (match (vector-ref contv (cfa-k-idx cfa
khandler-body))
+ (match (lookup-cont khandler-body dfg)
(($ $kargs names (_ ... rest))
(maybe-slot rest))))
(emit-bind-rest asm (+ proc-slot 1 nreq)))
diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm
index 768dcab..4b4986d 100644
--- a/module/language/cps/dfg.scm
+++ b/module/language/cps/dfg.scm
@@ -45,6 +45,10 @@
compute-dfg
dfg-cont-table
+ dfg-min-label
+ dfg-label-count
+ dfg-min-var
+ dfg-var-count
lookup-def
lookup-uses
lookup-predecessors
@@ -102,7 +106,7 @@
;; Data-flow graph for CPS: both for values and continuations.
(define-record-type $dfg
(make-dfg conts preds defs uses scopes scope-levels
- min-label nlabels min-var nvars)
+ min-label label-count min-var var-count)
dfg?
;; vector of label -> $kif, $kargs, etc
(conts dfg-cont-table)
@@ -118,9 +122,9 @@
(scope-levels dfg-scope-levels)
(min-label dfg-min-label)
- (nlabels dfg-nlabels)
+ (label-count dfg-label-count)
(min-var dfg-min-var)
- (nvars dfg-nvars))
+ (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
@@ -696,7 +700,7 @@ BODY for each body continuation in the prompt."
(define (compute-live-variables fun dfg)
(let* ((var-map (make-hash-table))
(min-var (dfg-min-var dfg))
- (nvars (dfg-nvars dfg))
+ (nvars (dfg-var-count dfg))
(cfa (analyze-control-flow fun dfg #:reverse? #t
#:add-handler-preds? #t))
(syms (make-vector nvars #f))
@@ -931,30 +935,8 @@ BODY for each body continuation in the prompt."
(vector-ref (dfg-preds dfg) (- k (dfg-min-label dfg))))
(define (lookup-successors k dfg)
- (match (vector-ref (dfg-cont-table dfg) (- k (dfg-min-label dfg)))
- (($ $kargs names syms body)
- (let lp ((body body))
- (match body
- (($ $letk conts body) (lp body))
- (($ $letrec names vars funs body) (lp body))
- (($ $continue k src exp)
- (match exp
- (($ $prompt escape? tag handler) (list k handler))
- (_ (list k)))))))
-
- (($ $kif kt kf) (list kt kf))
-
- (($ $kreceive arity k) (list k))
-
- (($ $kclause arity ($ $cont kbody) #f) (list kbody))
-
- (($ $kclause arity ($ $cont kbody) ($ $cont kalt)) (list kbody kalt))
-
- (($ $kentry self tail ($ $cont clause)) (list clause))
-
- (($ $kentry self tail #f) '())
-
- (($ $ktail) '())))
+ (let ((cont (vector-ref (dfg-cont-table dfg) (- k (dfg-min-label dfg)))))
+ (visit-cont-successors list cont)))
(define (lookup-def var dfg)
(vector-ref (dfg-defs dfg) (- var (dfg-min-var dfg))))
@@ -1069,21 +1051,13 @@ BODY for each body continuation in the prompt."
(define (control-point? k dfg)
(match (lookup-predecessors k dfg)
((pred)
- (match (vector-ref (dfg-cont-table dfg) (- pred (dfg-min-label dfg)))
- (($ $kargs names syms body)
- (let lp ((body body))
- (match body
- (($ $letk conts body) (lp body))
- (($ $letrec names vars funs body) (lp body))
- (($ $continue k src exp)
- (match exp
- (($ $prompt) #t)
- (_ #f))))))
- (($ $kif) #t)
- (($ $kreceive) #f)
- (($ $kclause) #f)
- (($ $kentry) #f)
- (($ $ktail) #t)))
+ (let ((cont (vector-ref (dfg-cont-table dfg)
+ (- pred (dfg-min-label dfg)))))
+ (visit-cont-successors (case-lambda
+ (() #t)
+ ((succ0) #f)
+ ((succ1 succ2) #t))
+ cont)))
(_ #t)))
(define (lookup-bound-syms k dfg)
diff --git a/module/language/cps/renumber.scm b/module/language/cps/renumber.scm
index 056b1ad..85ac52b 100644
--- a/module/language/cps/renumber.scm
+++ b/module/language/cps/renumber.scm
@@ -19,7 +19,8 @@
;;; Commentary:
;;;
;;; A pass to renumber variables and continuation labels so that they
-;;; are contiguous within each function.
+;;; are contiguous within each function and, in the case of labels,
+;;; topologically sorted.
;;;
;;; Code:
@@ -63,30 +64,69 @@
(visit-cont body))))
(visit-fun fun))
+;; Topologically sort the continuation tree starting at k0, using
+;; reverse post-order numbering.
+(define (sort-conts k0 conts new-k0)
+ (define (for-each-successor f cont)
+ (visit-cont-successors
+ (case-lambda
+ (() #t)
+ ((succ0) (f succ0))
+ ((succ0 succ1)
+ ;; Visit higher-numbered successors first, so that if they are
+ ;; unordered, their original order is preserved.
+ (cond
+ ((< succ0 succ1) (f succ1) (f succ0))
+ (else (f succ0) (f succ1)))))
+ cont))
+
+ (let ((next -1))
+ (let visit ((k k0))
+ (let ((cont (vector-ref conts k)))
+ ;; Clear the cont table entry to mark this continuation as
+ ;; visited.
+ (vector-set! conts k #f)
+ (for-each-successor (lambda (k)
+ (let ((entry (vector-ref conts k)))
+ ;; Visit the successor if it has not been
+ ;; visited yet.
+ (when (and entry (not (exact-integer? entry)))
+ (visit k))))
+ cont)
+ ;; Chain this label to the label that will follow it in the sort
+ ;; order, and record this label as the new head of the order.
+ (vector-set! conts k next)
+ (set! next k)))
+
+ ;; Finally traverse the label chain, giving each label its final
+ ;; name.
+ (let lp ((n new-k0) (head next))
+ (if (< head 0)
+ n
+ (let ((next (vector-ref conts head)))
+ (vector-set! conts head n)
+ (lp (1+ n) next))))))
+
(define (compute-new-labels-and-vars fun)
(call-with-values (lambda () (compute-max-label-and-var fun))
(lambda (max-label max-var)
- (let ((labels (make-vector (1+ max-label)))
+ (let ((labels (make-vector (1+ max-label) #f))
(next-label 0)
- (vars (make-vector (1+ max-var)))
+ (vars (make-vector (1+ max-var) #f))
(next-var 0))
- (define (relabel! label)
- (vector-set! labels label next-label)
- (set! next-label (1+ next-label)))
(define (rename! var)
(vector-set! vars var next-var)
(set! next-var (1+ next-var)))
- (define (compute-names-in-fun fun)
+
+ (define (collect-conts fun)
(define (visit-cont cont)
(match cont
(($ $cont label cont)
- (relabel! label)
+ (vector-set! labels label cont)
(match cont
(($ $kargs names vars body)
- (for-each rename! vars)
(visit-term body))
(($ $kentry self tail clause)
- (rename! self)
(visit-cont tail)
(when clause
(visit-cont clause)))
@@ -102,14 +142,65 @@
(for-each visit-cont conts)
(visit-term body))
(($ $letrec names syms funs body)
- (for-each rename! syms)
(visit-term body))
- (($ $continue k src _)
- #f)))
+ (($ $continue k src _) #f)))
(match fun
(($ $fun src meta free body)
(visit-cont body))))
+ (define (compute-names-in-fun fun)
+ (define (visit-cont cont)
+ (match cont
+ (($ $cont label cont)
+ (let ((reachable? (exact-integer? (vector-ref labels label))))
+ ;; This cont is reachable if it was given a number.
+ ;; Otherwise the cont table entry still contains the
+ ;; cont itself; clear it out to indicate that the cont
+ ;; should not be residualized.
+ (unless reachable?
+ (vector-set! labels label #f))
+ (match cont
+ (($ $kargs names vars body)
+ (when reachable?
+ (for-each rename! vars))
+ (visit-term body reachable?))
+ (($ $kentry self tail clause)
+ (when reachable?
+ (rename! self))
+ (visit-cont tail)
+ (when clause
+ (visit-cont clause)))
+ (($ $kclause arity body alternate)
+ (visit-cont body)
+ (when alternate
+ (visit-cont alternate)))
+ (($ $ktail)
+ (unless reachable?
+ ;; It's possible for the tail to be unreachable,
+ ;; if all paths contify to infinite loops. Make
+ ;; sure we mark as reachable.
+ (vector-set! labels label next-label)
+ (set! next-label (1+ next-label))))
+ ((or ($ $ktail) ($ $kreceive) ($ $kif))
+ #f))))))
+ (define (visit-term term reachable?)
+ (match term
+ (($ $letk conts body)
+ (for-each visit-cont conts)
+ (visit-term body reachable?))
+ (($ $letrec names syms funs body)
+ (when reachable?
+ (for-each rename! syms))
+ (visit-term body reachable?))
+ (($ $continue k src _)
+ #f)))
+
+ (collect-conts fun)
+ (match fun
+ (($ $fun src meta free (and entry ($ $cont kentry)))
+ (set! next-label (sort-conts kentry labels next-label))
+ (visit-cont entry))))
+
(visit-funs compute-names-in-fun fun)
(values labels vars)))))
@@ -127,30 +218,47 @@
(list kw kw-name (rename kw-var))))
kw)
aok?))))
+ (define (must-visit-cont cont)
+ (or (visit-cont cont)
+ (error "internal error -- failed to visit cont")))
+ (define (visit-conts conts)
+ (match conts
+ (() '())
+ ((cont . conts)
+ (cond
+ ((visit-cont cont)
+ => (lambda (cont)
+ (cons cont (visit-conts conts))))
+ (else (visit-conts conts))))))
(define (visit-cont cont)
- (rewrite-cps-cont cont
- (($ $cont label ($ $kargs names vars body))
- ((relabel label)
- ($kargs names (map rename vars) ,(visit-term body))))
- (($ $cont label ($ $kentry self tail clause))
- ((relabel label)
- ($kentry (rename self) ,(visit-cont tail)
- ,(and clause (visit-cont clause)))))
- (($ $cont label ($ $ktail))
- ((relabel label) ($ktail)))
- (($ $cont label ($ $kclause arity body alternate))
- ((relabel label)
- ($kclause ,(rename-kw-arity arity) ,(visit-cont body)
- ,(and alternate (visit-cont alternate)))))
- (($ $cont label ($ $kreceive ($ $arity req () rest () #f) kargs))
- ((relabel label) ($kreceive req rest (relabel kargs))))
- (($ $cont label ($ $kif kt kf))
- ((relabel label) ($kif (relabel kt) (relabel kf))))))
+ (match cont
+ (($ $cont label cont)
+ (let ((label (relabel label)))
+ (and
+ label
+ (rewrite-cps-cont cont
+ (($ $kargs names vars body)
+ (label ($kargs names (map rename vars) ,(visit-term body))))
+ (($ $kentry self tail clause)
+ (label
+ ($kentry (rename self) ,(must-visit-cont tail)
+ ,(and clause (must-visit-cont clause)))))
+ (($ $ktail)
+ (label ($ktail)))
+ (($ $kclause arity body alternate)
+ (label
+ ($kclause ,(rename-kw-arity arity) ,(must-visit-cont body)
+ ,(and alternate (must-visit-cont alternate)))))
+ (($ $kreceive ($ $arity req () rest () #f) kargs)
+ (label ($kreceive req rest (relabel kargs))))
+ (($ $kif kt kf)
+ (label ($kif (relabel kt) (relabel kf))))))))))
(define (visit-term term)
(rewrite-cps-term term
(($ $letk conts body)
- ($letk ,(map visit-cont conts)
- ,(visit-term body)))
+ ,(match (visit-conts conts)
+ (() (visit-term body))
+ (conts (build-cps-term ($letk ,conts ,(visit-term body))))))
(($ $letrec names vars funs body)
($letrec names (map rename vars) (map visit-fun funs)
,(visit-term body)))
@@ -180,5 +288,5 @@
(define (visit-fun fun)
(rewrite-cps-exp fun
(($ $fun src meta free body)
- ($fun src meta (map rename free) ,(visit-cont body)))))
+ ($fun src meta (map rename free) ,(must-visit-cont body)))))
(visit-fun fun))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-848-ga8430ab,
Andy Wingo <=