;;; 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* #f ($kargs (sym*) (sym*) ,exp)))
- ($continue k* ($primcall 'free-ref (self sym)))))
+ ($letk ((k* ($kargs (sym*) (sym*) ,exp)))
+ ($continue k* #f ($primcall 'free-ref (self sym)))))
(cons sym free))))))
(define (convert-free-vars syms self bound k)
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 src ($kargs () () ,body)))
+ ($letk ((k ($kargs () () ,body)))
,(convert-free-var
free outer-self outer-bound
(lambda (free)
(values (build-cps-term
($letconst (('idx idxsym idx))
- ($continue k
+ ($continue k src
($primcall 'free-set! (v idxsym free)))))
'())))))))
body
(values (build-cps-term ($letk ,conts ,body))
(union free free*)))))
- (($ $cont sym src ($ $kargs names syms body))
+ (($ $cont sym ($ $kargs names syms body))
(receive (body free) (cc body self (append syms bound))
- (values (build-cps-cont (sym src ($kargs names syms ,body)))
+ (values (build-cps-cont (sym ($kargs names syms ,body)))
free)))
- (($ $cont sym src ($ $kentry self tail clauses))
- (receive (clauses free) (cc* clauses self (list self))
- (values (build-cps-cont (sym src ($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 src ($ $kclause arity body))
+ (($ $cont sym ($ $kclause arity body alternate))
(receive (body free) (cc body self bound)
- (values (build-cps-cont (sym src ($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
(free free))
(match in
(() (values (bindings body) free))
- (((name sym ($ $fun meta () fun-body)) . in)
+ (((name sym ($ $fun src meta () fun-body)) . in)
(receive (fun-body fun-free) (cc fun-body #f '())
(lp in
(lambda (body)
- (let-gensyms (k)
+ (let-fresh (k) ()
(build-cps-term
- ($letk ((k #f ($kargs (name) (sym) ,(bindings body))))
- ($continue k
- ($fun meta fun-free ,fun-body))))))
- (init-closure #f sym fun-free self bound body)
+ ($letk ((k ($kargs (name) (sym) ,(bindings body))))
+ ($continue k src
+ ($fun src meta fun-free ,fun-body))))))
+ (init-closure src sym fun-free self bound body)
(union free (difference fun-free bound))))))))))
- (($ $continue k ($ $var sym))
- (convert-free-var sym self bound
- (lambda (sym)
- (values (build-cps-term ($continue k ($var sym)))
- '()))))
-
- (($ $continue k
+ (($ $continue k src
(or ($ $void)
($ $const)
($ $prim)))
(values exp '()))
- (($ $continue k ($ $fun meta () body))
+ (($ $continue k src ($ $fun src* meta () body))
(receive (body free) (cc body #f '())
(match free
(()
(values (build-cps-term
- ($continue k ($fun meta free ,body)))
+ ($continue k src ($fun src* meta free ,body)))
free))
(_
(values
- (let-gensyms (kinit v)
+ (let-fresh (kinit) (v)
(build-cps-term
- ($letk ((kinit #f ($kargs (v) (v)
- ,(init-closure #f v free self bound
- (build-cps-term
- ($continue k ($var v)))))))
- ($continue kinit ($fun meta free ,body)))))
+ ($letk ((kinit ($kargs (v) (v)
+ ,(init-closure
+ src v free self bound
+ (build-cps-term
+ ($continue k src ($values (v))))))))
+ ($continue kinit src ($fun src* meta free ,body)))))
(difference free bound))))))
- (($ $continue k ($ $call proc args))
+ (($ $continue k src ($ $call proc args))
(convert-free-vars (cons proc args) self bound
(match-lambda
((proc . args)
(values (build-cps-term
- ($continue k ($call proc args)))
+ ($continue k src ($call proc args)))
'())))))
- (($ $continue k ($ $primcall name 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)
(values (build-cps-term
- ($continue k ($primcall name args)))
+ ($continue k src ($primcall name args)))
'()))))
- (($ $continue k ($ $values args))
+ (($ $continue k src ($ $values args))
(convert-free-vars args self bound
(lambda (args)
(values (build-cps-term
- ($continue k ($values args)))
+ ($continue k src ($values args)))
'()))))
- (($ $continue k ($ $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 ($prompt escape? tag handler pop)))
+ ($continue k src ($prompt escape? tag handler)))
'()))))
(_ (error "what" exp))))
(rewrite-cps-term term
(($ $letk conts body)
($letk ,(map visit-cont conts) ,(visit-term body)))
- (($ $continue k ($ $primcall 'free-ref (closure sym)))
- ,(let-gensyms (idx)
+ (($ $continue k src ($ $primcall 'free-ref (closure sym)))
+ ,(let-fresh () (idx)
(build-cps-term
($letconst (('idx idx (free-index sym)))
- ($continue k ($primcall 'free-ref (closure idx)))))))
- (($ $continue k ($ $fun meta free body))
- ($continue k ($fun meta free ,(convert-to-indices body free))))
+ ($continue k src ($primcall 'free-ref (closure idx)))))))
+ (($ $continue k src ($ $fun src* meta free body))
+ ($continue k src
+ ($fun src* meta free ,(convert-to-indices body free))))
(($ $continue)
,term)))
(define (visit-cont cont)
(rewrite-cps-cont cont
- (($ $cont sym src ($ $kargs names syms body))
- (sym src ($kargs names syms ,(visit-term body))))
- (($ $cont sym src ($ $kclause arity body))
- (sym src ($kclause ,arity ,(visit-cont body))))
+ (($ $cont sym ($ $kargs names syms body))
+ (sym ($kargs names syms ,(visit-term 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 src ($ $kentry self tail clauses))
- (sym src ($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 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 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))))))))
HCoop / bpt / guile.git / blobdiff