#:use-module (language cps primitives)
#:use-module (language tree-il analyze)
#:use-module (language tree-il optimize)
- #:use-module ((language tree-il) #:hide (let-gensyms))
+ #:use-module (language tree-il)
#:export (compile-cps))
;;; Guile's semantics are that a toplevel lambda captures a reference on
(define current-topbox-scope (make-parameter #f))
(define (toplevel-box src name bound? val-proc)
- (let-gensyms (name-sym bound?-sym kbox box)
+ (let-fresh (kbox) (name-sym bound?-sym box)
(build-cps-term
($letconst (('name name-sym name)
('bound? bound?-sym bound?))
($primcall 'resolve
(name-sym bound?-sym)))))
(scope
- (let-gensyms (scope-sym)
+ (let-fresh () (scope-sym)
(build-cps-term
($letconst (('scope scope-sym scope))
($continue kbox src
(scope-sym name-sym bound?-sym)))))))))))))
(define (module-box src module name public? bound? val-proc)
- (let-gensyms (module-sym name-sym public?-sym bound?-sym kbox box)
+ (let-fresh (kbox) (module-sym name-sym public?-sym bound?-sym box)
(build-cps-term
($letconst (('module module-sym module)
('name name-sym name)
(module-sym name-sym public?-sym bound?-sym))))))))
(define (capture-toplevel-scope src scope k)
- (let-gensyms (module scope-sym kmodule)
+ (let-fresh (kmodule) (module scope-sym)
(build-cps-term
($letconst (('scope scope-sym scope))
($letk ((kmodule ($kargs ('module) (module)
(define tc8-iflag 4)
(define unbound-val 9)
(define unbound-bits (logior (ash unbound-val 8) tc8-iflag))
- (let-gensyms (unbound ktest)
+ (let-fresh (ktest) (unbound)
(build-cps-term
- ($letconst (('unbound unbound (pointer->scm (make-pointer unbound-bits))))
+ ($letconst (('unbound unbound
+ (pointer->scm (make-pointer unbound-bits))))
($letk ((ktest ($kif kt kf)))
($continue ktest src
($primcall 'eq? (sym unbound))))))))
(let ((src (tree-il-src init)))
(define (maybe-box k make-body)
(if box?
- (let-gensyms (kbox phi)
+ (let-fresh (kbox) (phi)
(build-cps-term
($letk ((kbox ($kargs (name) (phi)
($continue k src ($primcall 'box (phi))))))
,(make-body kbox))))
(make-body k)))
- (let-gensyms (knext kbound kunbound kreceive krest val rest)
+ (let-fresh (knext kbound kunbound kreceive krest) (val rest)
(build-cps-term
($letk ((knext ($kargs (name) (subst-sym) ,body)))
,(maybe-box
(($ <lexical-ref> src name sym)
(match (assq-ref subst sym)
((box #t)
- (let-gensyms (kunboxed unboxed)
+ (let-fresh (kunboxed) (unboxed)
(build-cps-term
($letk ((kunboxed ($kargs ('unboxed) (unboxed) ,(k unboxed))))
($continue kunboxed src ($primcall 'box-ref (box)))))))
((subst #f) (k subst))
(#f (k sym))))
(else
- (let-gensyms (kreceive karg arg rest)
+ (let-fresh (kreceive karg) (arg rest)
(build-cps-term
($letk ((karg ($kargs ('arg 'rest) (arg rest) ,(k arg)))
(kreceive ($kreceive '(arg) 'rest karg)))
(define (box-bound-var name sym body)
(match (assq-ref subst sym)
((box #t)
- (let-gensyms (k)
+ (let-fresh (k) ()
(build-cps-term
($letk ((k ($kargs (name) (box) ,body)))
($continue k #f ($primcall 'box (sym)))))))
'()
arity gensyms inits)))
(cons
- (let-gensyms (kclause kargs)
+ (let-fresh (kclause kargs) ()
(build-cps-cont
(kclause
($kclause ,arity
arity gensyms inits)))))))
(convert-clauses alternate ktail))))))
(if (current-topbox-scope)
- (let-gensyms (kentry self ktail)
+ (let-fresh (kentry ktail) (self)
(build-cps-term
($continue k fun-src
($fun fun-src meta '()
(kentry ($kentry self (ktail ($ktail))
,(convert-clauses body ktail)))))))
- (let-gensyms (scope kscope)
+ (let-fresh (kscope) (scope)
(build-cps-term
($letk ((kscope ($kargs () ()
,(parameterize ((current-topbox-scope scope))
(($ <toplevel-define> src name exp)
(convert-arg exp
(lambda (val)
- (let-gensyms (kname name-sym)
+ (let-fresh (kname) (name-sym)
(build-cps-term
($letconst (('name name-sym name))
($continue k src ($primcall 'define! (name-sym val)))))))))
;; it's quite tricky there and quite easy here, so hold your nose
;; while we drop some smelly code.
(convert (let ((len (length args)))
- (let-gensyms (v)
+ (let-fresh () (v)
(make-let src
(list 'v)
(list v)
(build-cps-term
($continue k src ($const '()))))
((arg . args)
- (let-gensyms (ktail tail)
+ (let-fresh (ktail) (tail)
(build-cps-term
($letk ((ktail ($kargs ('tail) (tail)
,(convert-arg arg
(convert-arg tag
(lambda (tag)
(let ((hnames (append hreq (if hrest (list hrest) '()))))
- (let-gensyms (khargs khbody kret kprim prim kpop krest vals kbody)
+ (let-fresh (khargs khbody kret kprim kpop krest kbody) (prim vals)
(build-cps-term
;; FIXME: Attach hsrc to $kreceive.
($letk* ((khbody ($kargs hnames hsyms
;; Eta-convert prompts without inline handlers.
(($ <prompt> src escape-only? tag body handler)
- (let-gensyms (h args)
+ (let ((h (gensym "h "))
+ (args (gensym "args ")))
(convert
(make-let
src (list 'h) (list h) (list handler)
($continue k src ($primcall 'apply args*))))))
(($ <conditional> src test consequent alternate)
- (let-gensyms (kif kt kf)
+ (let-fresh (kif kt kf) ()
(build-cps-term
($letk* ((kt ($kargs () () ,(convert consequent k subst)))
(kf ($kargs () () ,(convert alternate k subst)))
($continue k src ($primcall 'box-set! (box exp)))))))))
(($ <seq> src head tail)
- (let-gensyms (kreceive kseq vals)
+ (let-fresh (kreceive kseq) (vals)
(build-cps-term
($letk* ((kseq ($kargs ('vals) (vals)
,(convert tail k subst)))
(match (list names syms vals)
((() () ()) (convert body k subst))
(((name . names) (sym . syms) (val . vals))
- (let-gensyms (kreceive klet rest)
+ (let-fresh (kreceive klet) (rest)
(build-cps-term
($letk* ((klet ($kargs (name 'rest) (sym rest)
,(box-bound-var name sym
(($ <fix> src names gensyms funs body)
;; Some letrecs can be contified; that happens later.
(if (current-topbox-scope)
- (let-gensyms (self)
+ (let-fresh () (self)
(build-cps-term
($letrec names
gensyms
fun)))
funs)
,(convert body k subst))))
- (let-gensyms (scope kscope)
+ (let-fresh (kscope) (scope)
(build-cps-term
($letk ((kscope ($kargs () ()
,(parameterize ((current-topbox-scope scope))
(($ <let-values> src exp
($ <lambda-case> lsrc req #f rest #f () syms body #f))
(let ((names (append req (if rest (list rest) '()))))
- (let-gensyms (kreceive kargs)
+ (let-fresh (kreceive kargs) ()
(build-cps-term
($letk* ((kargs ($kargs names syms
,(fold box-bound-var
(tree-il-fold box-set-vars default-args '() exp))
(define (cps-convert/thunk exp)
- (let ((src (tree-il-src exp)))
- (let-gensyms (kinit init ktail kclause kbody)
- (build-cps-exp
- ($fun src '() '()
- (kinit ($kentry init
- (ktail ($ktail))
- ((kclause
- ($kclause ('() '() #f '() #f)
- (kbody ($kargs () ()
- ,(convert exp ktail
- (build-subst exp))))))))))))))
+ (parameterize ((label-counter 0)
+ (var-counter 0))
+ (let ((src (tree-il-src exp)))
+ (let-fresh (kinit ktail kclause kbody) (init)
+ (build-cps-exp
+ ($fun src '() '()
+ (kinit ($kentry init
+ (ktail ($ktail))
+ ((kclause
+ ($kclause ('() '() #f '() #f)
+ (kbody ($kargs () ()
+ ,(convert exp ktail
+ (build-subst exp)))))))))))))))
(define *comp-module* (make-fluid))
HCoop / bpt / guile.git / blobdiff