;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
#: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)
+ (let-fresh (knext kbound kunbound kreceive krest) (val rest)
(build-cps-term
($letk ((knext ($kargs (name) (subst-sym) ,body)))
,(maybe-box
knext
(lambda (k)
(build-cps-term
- ($letk ((kbound ($kargs () () ($continue k src ($var sym))))
- (kunbound ($kargs () () ,(convert init k subst))))
+ ($letk ((kbound ($kargs () () ($continue k src
+ ($values (sym)))))
+ (krest ($kargs (name 'rest) (val rest)
+ ($continue k src ($values (val)))))
+ (kreceive ($kreceive (list name) 'rest krest))
+ (kunbound ($kargs () ()
+ ,(convert init kreceive subst))))
,(unbound? src sym kunbound kbound))))))))))))
;; exp k-name alist -> term
(($ <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 (karg arg)
+ (let-fresh (kreceive karg) (arg rest)
(build-cps-term
- ($letk ((karg ($kargs ('arg) (arg) ,(k arg))))
- ,(convert exp karg subst)))))))
+ ($letk ((karg ($kargs ('arg 'rest) (arg rest) ,(k arg)))
+ (kreceive ($kreceive '(arg) 'rest karg)))
+ ,(convert exp kreceive subst)))))))
;; (exp ...) ((v-name ...) -> term) -> term
(define (convert-args exps k)
(match exps
(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)))))))
(($ <lexical-ref> src name sym)
(match (assq-ref subst sym)
((box #t) (build-cps-term ($continue k src ($primcall 'box-ref (box)))))
- ((subst #f) (build-cps-term ($continue k src ($var subst))))
- (#f (build-cps-term ($continue k src ($var sym))))))
+ ((subst #f) (build-cps-term ($continue k src ($values (subst)))))
+ (#f (build-cps-term ($continue k src ($values (sym)))))))
(($ <void> src)
(build-cps-term ($continue k src ($void))))
'()
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 $ktrunc.
+ ;; FIXME: Attach hsrc to $kreceive.
($letk* ((khbody ($kargs hnames hsyms
,(fold box-bound-var
(convert hbody k subst)
hnames hsyms)))
- (khargs ($ktrunc hreq hrest khbody))
+ (khargs ($kreceive hreq hrest khbody))
(kpop ($kargs ('rest) (vals)
($letk ((kret
($kargs () ()
($prim 'values))))))
($continue kret src
($primcall 'unwind ())))))
- (krest ($ktrunc '() 'rest kpop)))
+ (krest ($kreceive '() 'rest kpop)))
,(if escape-only?
(build-cps-term
($letk ((kbody ($kargs () ()
,(convert body krest subst))))
- ($continue kbody src ($prompt #t tag khargs kpop))))
+ ($continue kbody src ($prompt #t tag khargs))))
(convert-arg body
(lambda (thunk)
(build-cps-term
($primcall 'call-thunk/no-inline
(thunk))))))
($continue kbody (tree-il-src body)
- ($prompt #f tag khargs kpop))))))))))))))
+ ($prompt #f tag khargs))))))))))))))
;; 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)))
(_ (convert-arg test
(lambda (test)
(build-cps-term
- ($continue kif src ($var test)))))))))))
+ ($continue kif src ($values (test))))))))))))
(($ <lexical-set> src name gensym exp)
(convert-arg exp
($continue k src ($primcall 'box-set! (box exp)))))))))
(($ <seq> src head tail)
- (let-gensyms (ktrunc kseq)
+ (let-fresh (kreceive kseq) (vals)
(build-cps-term
- ($letk* ((kseq ($kargs () ()
+ ($letk* ((kseq ($kargs ('vals) (vals)
,(convert tail k subst)))
- (ktrunc ($ktrunc '() #f kseq)))
- ,(convert head ktrunc subst)))))
+ (kreceive ($kreceive '() 'vals kseq)))
+ ,(convert head kreceive subst)))))
(($ <let> src names syms vals body)
(let lp ((names names) (syms syms) (vals vals))
(match (list names syms vals)
((() () ()) (convert body k subst))
(((name . names) (sym . syms) (val . vals))
- (let-gensyms (klet)
+ (let-fresh (kreceive klet) (rest)
(build-cps-term
- ($letk ((klet ($kargs (name) (sym)
- ,(box-bound-var name sym
- (lp names syms vals)))))
- ,(convert val klet subst))))))))
+ ($letk* ((klet ($kargs (name 'rest) (sym rest)
+ ,(box-bound-var name sym
+ (lp names syms vals))))
+ (kreceive ($kreceive (list name) 'rest klet)))
+ ,(convert val kreceive subst))))))))
(($ <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 (ktrunc kargs)
+ (let-fresh (kreceive kargs) ()
(build-cps-term
($letk* ((kargs ($kargs names syms
,(fold box-bound-var
(convert body k subst)
names syms)))
- (ktrunc ($ktrunc req rest kargs)))
- ,(convert exp ktrunc subst))))))))
+ (kreceive ($kreceive req rest kargs)))
+ ,(convert exp kreceive subst))))))))
(define (build-subst exp)
"Compute a mapping from lexical gensyms to substituted gensyms. The
(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