mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-25 06:00:18 +02:00
Code Activity

Fix prune-top-level-scopes to allow collisions between var, scope, cont names

Browse source 
* module/language/cps/prune-top-level-scopes.scm (compute-referenced-scopes):
  Fix to not assume that scope names, continuation names, and var names
  are mutually unique.
  (prune-top-level-scopes): Better variable names.
This commit is contained in:
Andy Wingo 2014-04-02 15:40:03 +02:00
parent 2896942751
commit b7dc00b1e7
1 changed files with 20 additions and 16 deletions
Download patch file Download diff file Expand all files Collapse all files

36
module/language/cps/prune-top-level-scopes.scm
View file

@ -28,13 +28,17 @@
#:export (prune-top-level-scopes)) #:export (prune-top-level-scopes))
(define (compute-referenced-scopes fun) (define (compute-referenced-scopes fun)
(let ((refs (make-hash-table))) (let ((scope-name->used? (make-hash-table))
(scope-var->used? (make-hash-table))
(k->scope-var (make-hash-table)))
;; Visit uses before defs. That way we know when visiting defs
;; whether the scope is used or not.
(define (visit-cont cont) (define (visit-cont cont)
(match cont (match cont
(($ $cont k ($ $kargs (name) (sym) body)) (($ $cont k ($ $kargs (name) (var) body))
(visit-term body) (visit-term body)
(when (hashq-get-handle refs sym) (when (hashq-get-handle scope-var->used? var)
(hashq-set! refs k sym))) (hashq-set! k->scope-var k var)))
(($ $cont k ($ $kargs names syms body)) (($ $cont k ($ $kargs names syms body))
(visit-term body)) (visit-term body))
(($ $cont k ($ $kentry self tail clause)) (($ $cont k ($ $kentry self tail clause))
@ -56,25 +60,25 @@
(match exp (match exp
(($ $fun) (visit-fun exp)) (($ $fun) (visit-fun exp))
(($ $primcall 'cached-toplevel-box (scope name bound?)) (($ $primcall 'cached-toplevel-box (scope name bound?))
(hashq-set! refs scope #t)) (hashq-set! scope-var->used? scope #t))
(($ $primcall 'cache-current-module! (module scope)) (($ $primcall 'cache-current-module! (module scope))
(hashq-set! refs scope #f)) (hashq-set! scope-var->used? scope #f))
(($ $const val) (($ $const val)
;; If there is an entry in the table for "k", it means "val" ;; If there is an entry in the table for "k", it means "val"
;; is a scope symbol, bound for use by cached-toplevel-box ;; is a scope symbol, bound for use by cached-toplevel-box
;; or cache-current-module!, or possibly both (though this ;; or cache-current-module!, or possibly both (though this
;; is not currently the case). ;; is not currently the case).
(and=> (hashq-ref refs k) (and=> (hashq-ref k->scope-var k)
(lambda (sym) (lambda (scope-var)
(when (hashq-ref refs sym) (when (hashq-ref scope-var->used? scope-var)
;; We have a use via cached-toplevel-box. Mark ;; We have a use via cached-toplevel-box. Mark
;; this scope as used. ;; this scope as used.
(hashq-set! refs val #t)) (hashq-set! scope-name->used? val #t))
(when (and (hashq-ref refs val) (when (and (hashq-ref scope-name->used? val)
(not (hashq-ref refs sym))) (not (hashq-ref scope-var->used? scope-var)))
;; There is a use, and this sym is used by ;; There is a use, and this sym is used by
;; cache-current-module!. ;; cache-current-module!.
(hashq-set! refs sym #t))))) (hashq-set! scope-var->used? scope-var #t)))))
(_ #t))))) (_ #t)))))
(define (visit-fun fun) (define (visit-fun fun)
(match fun (match fun
@ -82,10 +86,10 @@
(visit-cont body)))) (visit-cont body))))
(visit-fun fun) (visit-fun fun)
refs)) scope-var->used?))
(define (prune-top-level-scopes fun) (define (prune-top-level-scopes fun)
(let ((referenced-scopes (compute-referenced-scopes fun))) (let ((scope-var->used? (compute-referenced-scopes fun)))
(define (visit-cont cont) (define (visit-cont cont)
(rewrite-cps-cont cont (rewrite-cps-cont cont
(($ $cont sym ($ $kargs names syms body)) (($ $cont sym ($ $kargs names syms body))
@ -106,7 +110,7 @@
(($ $continue k src (($ $continue k src
(and ($ $primcall 'cache-current-module! (module scope)) (and ($ $primcall 'cache-current-module! (module scope))
(? (lambda _ (? (lambda _
(not (hashq-ref referenced-scopes scope)))))) (not (hashq-ref scope-var->used? scope))))))
($continue k src ($primcall 'values ()))) ($continue k src ($primcall 'values ())))
(($ $continue) (($ $continue)
,term))) ,term)))