mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-17 09:10:22 +02:00
Code Activity

CPS renumbering pass sorts conts in topological order

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2014-04-01 12:03:37 +02:00
parent 2c3c086ef3
commit 09220d215f
1 changed files with 142 additions and 34 deletions
Download patch file Download diff file Expand all files Collapse all files

174
module/language/cps/renumber.scm
View file

@ -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)
(match cont
(($ $cont label cont)
(let ((label (relabel label)))
(and
label
(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))))))
(($ $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))))