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

Refactor toplevel scope name generation in compile-cps

Browse source 
* module/language/tree-il/compile-cps.scm (scope-counter, fresh-scope-id):
  (toplevel-box, capture-toplevel-scope, convert, cps-convert/thunk):
  Refactor to avoid abusing the var counter to generate scope
  identifiers.
This commit is contained in:
Andy Wingo 2014-04-02 15:58:06 +02:00
parent 408da79015
commit 48e65b4468
1 changed files with 28 additions and 17 deletions
Download patch file Download diff file Expand all files Collapse all files

45
module/language/tree-il/compile-cps.scm
View file

@ -75,6 +75,12 @@
;;; doesn't work for files auto-compiled for use with `load'. ;;; doesn't work for files auto-compiled for use with `load'.
;;; ;;;
(define current-topbox-scope (make-parameter #f)) (define current-topbox-scope (make-parameter #f))
(define scope-counter (make-parameter #f))
(define (fresh-scope-id)
(let ((scope-id (scope-counter)))
(scope-counter (1+ scope-id))
scope-id))
(define (toplevel-box src name bound? val-proc) (define (toplevel-box src name bound? val-proc)
(let-fresh (kbox) (name-sym bound?-sym box) (let-fresh (kbox) (name-sym bound?-sym box)
@ -88,10 +94,10 @@
($continue kbox src ($continue kbox src
($primcall 'resolve ($primcall 'resolve
(name-sym bound?-sym))))) (name-sym bound?-sym)))))
(scope (scope-id
(let-fresh () (scope-sym) (let-fresh () (scope-sym)
(build-cps-term (build-cps-term
($letconst (('scope scope-sym scope)) ($letconst (('scope scope-sym scope-id))
($continue kbox src ($continue kbox src
($primcall 'cached-toplevel-box ($primcall 'cached-toplevel-box
(scope-sym name-sym bound?-sym))))))))))))) (scope-sym name-sym bound?-sym)))))))))))))
@ -108,10 +114,10 @@
($primcall 'cached-module-box ($primcall 'cached-module-box
(module-sym name-sym public?-sym bound?-sym)))))))) (module-sym name-sym public?-sym bound?-sym))))))))
(define (capture-toplevel-scope src scope k) (define (capture-toplevel-scope src scope-id k)
(let-fresh (kmodule) (module scope-sym) (let-fresh (kmodule) (module scope-sym)
(build-cps-term (build-cps-term
($letconst (('scope scope-sym scope)) ($letconst (('scope scope-sym scope-id))
($letk ((kmodule ($kargs ('module) (module) ($letk ((kmodule ($kargs ('module) (module)
($continue k src ($continue k src
($primcall 'cache-current-module! ($primcall 'cache-current-module!
@ -294,12 +300,14 @@
($fun fun-src meta '() ($fun fun-src meta '()
(kentry ($kentry self (ktail ($ktail)) (kentry ($kentry self (ktail ($ktail))
,(convert-clauses body ktail))))))) ,(convert-clauses body ktail)))))))
(let-fresh (kscope) (scope) (let ((scope-id (fresh-scope-id)))
(build-cps-term (let-fresh (kscope) ()
($letk ((kscope ($kargs () () (build-cps-term
,(parameterize ((current-topbox-scope scope)) ($letk ((kscope
(convert exp k subst))))) ($kargs () ()
,(capture-toplevel-scope fun-src scope kscope))))))) ,(parameterize ((current-topbox-scope scope-id))
(convert exp k subst)))))
,(capture-toplevel-scope fun-src scope-id kscope))))))))
(($ <module-ref> src mod name public?) (($ <module-ref> src mod name public?)
(module-box (module-box
@ -517,12 +525,14 @@
fun))) fun)))
funs) funs)
,(convert body k subst)))) ,(convert body k subst))))
(let-fresh (kscope) (scope) (let ((scope-id (fresh-scope-id)))
(build-cps-term (let-fresh (kscope) ()
($letk ((kscope ($kargs () () (build-cps-term
,(parameterize ((current-topbox-scope scope)) ($letk ((kscope
(convert exp k subst))))) ($kargs () ()
,(capture-toplevel-scope src scope kscope)))))) ,(parameterize ((current-topbox-scope scope-id))
(convert exp k subst)))))
,(capture-toplevel-scope src scope-id kscope)))))))
(($ <let-values> src exp (($ <let-values> src exp
($ <lambda-case> lsrc req #f rest #f () syms body #f)) ($ <lambda-case> lsrc req #f rest #f () syms body #f))
@ -589,7 +599,8 @@ integer."
(define (cps-convert/thunk exp) (define (cps-convert/thunk exp)
(parameterize ((label-counter 0) (parameterize ((label-counter 0)
(var-counter 0)) (var-counter 0)
(scope-counter 0))
(let ((src (tree-il-src exp))) (let ((src (tree-il-src exp)))
(let-fresh (kinit ktail kclause kbody) (init) (let-fresh (kinit ktail kclause kbody) (init)
(build-cps-exp (build-cps-exp