mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-29 08:20:20 +02:00
Code Activity

Renumber doesn't visit unreachable continuations

Browse source 
* module/language/cps/renumber.scm (compute-new-labels-and-vars): Don't
  visit functions that are not reachable.
  (renumber): Reindent.
This commit is contained in:
Andy Wingo 2014-04-01 17:51:26 +02:00
parent cc8eb19545
commit f9bceb770b
1 changed files with 19 additions and 47 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -26,44 +26,10 @@
(define-module (language cps renumber) (define-module (language cps renumber)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (language cps) #:use-module (language cps)
#:export (renumber)) #:export (renumber))
(define (visit-funs proc fun)
(define (visit-cont cont)
(match cont
(($ $cont label cont)
(match cont
(($ $kargs names vars body)
(visit-term body))
(($ $kentry self tail clause)
(when clause
(visit-cont clause)))
(($ $kclause arity body alternate)
(visit-cont body)
(when alternate
(visit-cont alternate)))
((or ($ $kreceive) ($ $kif))
#f)))))
(define (visit-term term)
(match term
(($ $letk conts body)
(for-each visit-cont conts)
(visit-term body))
(($ $letrec names syms funs body)
(for-each visit-fun funs)
(visit-term body))
(($ $continue k src (and fun ($ $fun)))
(visit-fun fun))
(($ $continue k src _)
#f)))
(define (visit-fun fun)
(proc fun)
(match fun
(($ $fun src meta free body)
(visit-cont body))))
(visit-fun fun))
;; Topologically sort the continuation tree starting at k0, using ;; Topologically sort the continuation tree starting at k0, using
;; reverse post-order numbering. ;; reverse post-order numbering.
(define (sort-conts k0 conts new-k0) (define (sort-conts k0 conts new-k0)
@ -149,6 +115,7 @@
(visit-cont body)))) (visit-cont body))))
(define (compute-names-in-fun fun) (define (compute-names-in-fun fun)
(define queue '())
(define (visit-cont cont) (define (visit-cont cont)
(match cont (match cont
(($ $cont label cont) (($ $cont label cont)
@ -165,12 +132,13 @@
(for-each rename! vars)) (for-each rename! vars))
(visit-term body reachable?)) (visit-term body reachable?))
(($ $kentry self tail clause) (($ $kentry self tail clause)
(when reachable? (unless reachable? (error "entry should be reachable"))
(rename! self)) (rename! self)
(visit-cont tail) (visit-cont tail)
(when clause (when clause
(visit-cont clause))) (visit-cont clause)))
(($ $kclause arity body alternate) (($ $kclause arity body alternate)
(unless reachable? (error "clause should be reachable"))
(visit-cont body) (visit-cont body)
(when alternate (when alternate
(visit-cont alternate))) (visit-cont alternate)))
@ -181,7 +149,7 @@
;; sure we mark as reachable. ;; sure we mark as reachable.
(vector-set! labels label next-label) (vector-set! labels label next-label)
(set! next-label (1+ next-label)))) (set! next-label (1+ next-label))))
((or ($ $ktail) ($ $kreceive) ($ $kif)) ((or ($ $kreceive) ($ $kif))
#f)))))) #f))))))
(define (visit-term term reachable?) (define (visit-term term reachable?)
(match term (match term
@ -190,18 +158,22 @@
(visit-term body reachable?)) (visit-term body reachable?))
(($ $letrec names syms funs body) (($ $letrec names syms funs body)
(when reachable? (when reachable?
(for-each rename! syms)) (for-each rename! syms)
(set! queue (fold cons queue funs)))
(visit-term body reachable?)) (visit-term body reachable?))
(($ $continue k src _) (($ $continue k src (and fun ($ $fun)))
#f))) (when reachable?
(set! queue (cons fun queue))))
(($ $continue) #f)))
(collect-conts fun) (collect-conts fun)
(match fun (match fun
(($ $fun src meta free (and entry ($ $cont kentry))) (($ $fun src meta free (and entry ($ $cont kentry)))
(set! next-label (sort-conts kentry labels next-label)) (set! next-label (sort-conts kentry labels next-label))
(visit-cont entry)))) (visit-cont entry)
(for-each compute-names-in-fun (reverse queue)))))
(visit-funs compute-names-in-fun fun) (compute-names-in-fun fun)
(values labels vars next-label next-var))))) (values labels vars next-label next-var)))))
(define (renumber fun) (define (renumber fun)
@ -272,16 +244,16 @@
(visit-fun exp)) (visit-fun exp))
(($ $values args) (($ $values args)
(let ((args (map rename args))) (let ((args (map rename args)))
(build-cps-exp ($values args)))) (build-cps-exp ($values args))))
(($ $call proc args) (($ $call proc args)
(let ((args (map rename args))) (let ((args (map rename args)))
(build-cps-exp ($call (rename proc) args)))) (build-cps-exp ($call (rename proc) args))))
(($ $callk k proc args) (($ $callk k proc args)
(let ((args (map rename args))) (let ((args (map rename args)))
(build-cps-exp ($callk (relabel k) (rename proc) args)))) (build-cps-exp ($callk (relabel k) (rename proc) args))))
(($ $primcall name args) (($ $primcall name args)
(let ((args (map rename args))) (let ((args (map rename args)))
(build-cps-exp ($primcall name args)))) (build-cps-exp ($primcall name args))))
(($ $prompt escape? tag handler) (($ $prompt escape? tag handler)
(build-cps-exp (build-cps-exp
($prompt escape? (rename tag) (relabel handler)))))) ($prompt escape? (rename tag) (relabel handler))))))