From 09220d215f4630e1735677adfe230f7ccf98a34f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 1 Apr 2014 12:03:37 +0200 Subject: [PATCH] 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. --- module/language/cps/renumber.scm | 176 +++++++++++++++++++++++++------ 1 file changed, 142 insertions(+), 34 deletions(-) diff --git a/module/language/cps/renumber.scm b/module/language/cps/renumber.scm index 056b1ad18..85ac52b38 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))))