;;; 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
values in the term."
(if (memq sym bound)
(k sym)
- (let-gensyms (k* sym*)
+ (let-fresh (k*) (sym*)
(receive (exp free) (k sym*)
(values (build-cps-term
($letk ((k* ($kargs (sym*) (sym*) ,exp)))
label of the outer procedure, where the initialization will be
performed, and @var{outer-bound} is the list of bound variables there."
(fold (lambda (free idx body)
- (let-gensyms (k idxsym)
+ (let-fresh (k) (idxsym)
(build-cps-term
($letk ((k ($kargs () () ,body)))
,(convert-free-var
(values (build-cps-cont (sym ($kargs names syms ,body)))
free)))
- (($ $cont sym ($ $kentry self tail clauses))
- (receive (clauses free) (cc* clauses self (list self))
- (values (build-cps-cont (sym ($kentry self ,tail ,clauses)))
+ (($ $cont sym ($ $kentry self tail clause))
+ (receive (clause free) (if clause
+ (cc clause self (list self))
+ (values #f '()))
+ (values (build-cps-cont (sym ($kentry self ,tail ,clause)))
free)))
- (($ $cont sym ($ $kclause arity body))
+ (($ $cont sym ($ $kclause arity body alternate))
(receive (body free) (cc body self bound)
- (values (build-cps-cont (sym ($kclause ,arity ,body)))
- free)))
+ (receive (alternate free*) (if alternate
+ (cc alternate self bound)
+ (values #f '()))
+ (values (build-cps-cont (sym ($kclause ,arity ,body ,alternate)))
+ (union free free*)))))
(($ $cont)
;; Other kinds of continuations don't bind values and don't have
(receive (fun-body fun-free) (cc fun-body #f '())
(lp in
(lambda (body)
- (let-gensyms (k)
+ (let-fresh (k) ()
(build-cps-term
($letk ((k ($kargs (name) (sym) ,(bindings body))))
($continue k src
free))
(_
(values
- (let-gensyms (kinit v)
+ (let-fresh (kinit) (v)
(build-cps-term
($letk ((kinit ($kargs (v) (v)
,(init-closure
($continue k src ($call proc args)))
'())))))
+ (($ $continue k src ($ $callk k* proc args))
+ (convert-free-vars (cons proc args) self bound
+ (match-lambda
+ ((proc . args)
+ (values (build-cps-term
+ ($continue k src ($callk k* proc args)))
+ '())))))
+
(($ $continue k src ($ $primcall name args))
(convert-free-vars args self bound
(lambda (args)
($continue k src ($values args)))
'()))))
- (($ $continue k src ($ $prompt escape? tag handler pop))
+ (($ $continue k src ($ $prompt escape? tag handler))
(convert-free-var
tag self bound
(lambda (tag)
(values (build-cps-term
- ($continue k src ($prompt escape? tag handler pop)))
+ ($continue k src ($prompt escape? tag handler)))
'()))))
(_ (error "what" exp))))
(($ $letk conts body)
($letk ,(map visit-cont conts) ,(visit-term body)))
(($ $continue k src ($ $primcall 'free-ref (closure sym)))
- ,(let-gensyms (idx)
+ ,(let-fresh () (idx)
(build-cps-term
($letconst (('idx idx (free-index sym)))
($continue k src ($primcall 'free-ref (closure idx)))))))
(rewrite-cps-cont cont
(($ $cont sym ($ $kargs names syms body))
(sym ($kargs names syms ,(visit-term body))))
- (($ $cont sym ($ $kclause arity body))
- (sym ($kclause ,arity ,(visit-cont body))))
+ (($ $cont sym ($ $kclause arity body alternate))
+ (sym ($kclause ,arity ,(visit-cont body)
+ ,(and alternate (visit-cont alternate)))))
;; Other kinds of continuations don't bind values and don't have
;; bodies.
(($ $cont)
,cont)))
(rewrite-cps-cont body
- (($ $cont sym ($ $kentry self tail clauses))
- (sym ($kentry self ,tail ,(map visit-cont clauses))))))
+ (($ $cont sym ($ $kentry self tail clause))
+ (sym ($kentry self ,tail ,(and clause (visit-cont clause)))))))
(define (convert-closures exp)
"Convert free reference in @var{exp} to primcalls to @code{free-ref},
and allocate and initialize flat closures."
- (match exp
- (($ $fun src meta () body)
- (receive (body free) (cc body #f '())
- (unless (null? free)
- (error "Expected no free vars in toplevel thunk" exp body free))
- (build-cps-exp
- ($fun src meta free ,(convert-to-indices body free)))))))
+ (with-fresh-name-state exp
+ (match exp
+ (($ $fun src meta () body)
+ (receive (body free) (cc body #f '())
+ (unless (null? free)
+ (error "Expected no free vars in toplevel thunk" exp body free))
+ (build-cps-exp
+ ($fun src meta free ,(convert-to-indices body free))))))))