;;; 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:
(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)))
(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)))))
(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)))
(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))))
HCoop / bpt / guile.git / commitdiff