mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-09 21:40:33 +02:00
First-order CPS has $program and $closure forms
* module/language/cps.scm ($closure, $program): New CPS types, part of low-level (first-order) CPS. (build-cps-exp, build-cps-term, parse-cps, unparse-cps) (compute-max-label-and-var): Update for new CPS types. * module/language/cps/closure-conversion.scm: Rewrite to produce a $program with $closures, and no $funs. * module/language/cps/reify-primitives.scm: * module/language/cps/compile-bytecode.scm (compile-fun): (compile-bytecode): Adapt to new first-order format. * module/language/cps/dfg.scm (compute-dfg): Add $closure case. * module/language/cps/renumber.scm (renumber): Allow this pass to work on either format. * module/language/cps/slot-allocation.scm (allocate-slots): Add $closure case.
This commit is contained in:
Andy Wingo
parent
405805fbc3
commit
cf8bb03772
7 changed files with 444 additions and 422 deletions
|
|
@ -122,7 +122,11 @@
|
||||||
$kif $kreceive $kargs $kfun $ktail $kclause
|
$kif $kreceive $kargs $kfun $ktail $kclause
|
||||||
|
|
||||||
;; Expressions.
|
;; Expressions.
|
||||||
$void $const $prim $fun $call $callk $primcall $values $prompt
|
$void $const $prim $fun $closure
|
||||||
|
$call $callk $primcall $values $prompt
|
||||||
|
|
||||||
|
;; First-order CPS root.
|
||||||
|
$program
|
||||||
|
|
||||||
;; Fresh names.
|
;; Fresh names.
|
||||||
label-counter var-counter
|
label-counter var-counter
|
||||||
|
|
@ -173,7 +177,7 @@
|
||||||
;; Terms.
|
;; Terms.
|
||||||
(define-cps-type $letk conts body)
|
(define-cps-type $letk conts body)
|
||||||
(define-cps-type $continue k src exp)
|
(define-cps-type $continue k src exp)
|
||||||
(define-cps-type $letrec names syms funs body)
|
(define-cps-type $letrec names syms funs body) ; Higher-order.
|
||||||
|
|
||||||
;; Continuations
|
;; Continuations
|
||||||
(define-cps-type $cont k cont)
|
(define-cps-type $cont k cont)
|
||||||
|
|
@ -188,13 +192,18 @@
|
||||||
(define-cps-type $void)
|
(define-cps-type $void)
|
||||||
(define-cps-type $const val)
|
(define-cps-type $const val)
|
||||||
(define-cps-type $prim name)
|
(define-cps-type $prim name)
|
||||||
(define-cps-type $fun free body)
|
(define-cps-type $fun free body) ; Higher-order.
|
||||||
|
(define-cps-type $closure label nfree) ; First-order.
|
||||||
(define-cps-type $call proc args)
|
(define-cps-type $call proc args)
|
||||||
(define-cps-type $callk k proc args)
|
(define-cps-type $callk k proc args) ; First-order.
|
||||||
(define-cps-type $primcall name args)
|
(define-cps-type $primcall name args)
|
||||||
(define-cps-type $values args)
|
(define-cps-type $values args)
|
||||||
(define-cps-type $prompt escape? tag handler)
|
(define-cps-type $prompt escape? tag handler)
|
||||||
|
|
||||||
|
;; The root of a higher-order CPS term is $cont containing a $kfun. The
|
||||||
|
;; root of a first-order CPS term is a $program.
|
||||||
|
(define-cps-type $program funs)
|
||||||
|
|
||||||
(define label-counter (make-parameter #f))
|
(define label-counter (make-parameter #f))
|
||||||
(define var-counter (make-parameter #f))
|
(define var-counter (make-parameter #f))
|
||||||
|
|
||||||
|
|
@ -257,13 +266,14 @@
|
||||||
|
|
||||||
(define-syntax build-cps-exp
|
(define-syntax build-cps-exp
|
||||||
(syntax-rules (unquote
|
(syntax-rules (unquote
|
||||||
$void $const $prim $fun $call $callk $primcall $values $prompt)
|
$void $const $prim $fun $closure
|
||||||
|
$call $callk $primcall $values $prompt)
|
||||||
((_ (unquote exp)) exp)
|
((_ (unquote exp)) exp)
|
||||||
((_ ($void)) (make-$void))
|
((_ ($void)) (make-$void))
|
||||||
((_ ($const val)) (make-$const val))
|
((_ ($const val)) (make-$const val))
|
||||||
((_ ($prim name)) (make-$prim name))
|
((_ ($prim name)) (make-$prim name))
|
||||||
((_ ($fun free body))
|
((_ ($fun free body)) (make-$fun free (build-cps-cont body)))
|
||||||
(make-$fun free (build-cps-cont body)))
|
((_ ($closure k nfree)) (make-$closure k nfree))
|
||||||
((_ ($call proc (unquote args))) (make-$call proc args))
|
((_ ($call proc (unquote args))) (make-$call proc args))
|
||||||
((_ ($call proc (arg ...))) (make-$call proc (list arg ...)))
|
((_ ($call proc (arg ...))) (make-$call proc (list arg ...)))
|
||||||
((_ ($call proc args)) (make-$call proc args))
|
((_ ($call proc args)) (make-$call proc args))
|
||||||
|
|
@ -280,7 +290,7 @@
|
||||||
(make-$prompt escape? tag handler))))
|
(make-$prompt escape? tag handler))))
|
||||||
|
|
||||||
(define-syntax build-cps-term
|
(define-syntax build-cps-term
|
||||||
(syntax-rules (unquote $letk $letk* $letconst $letrec $continue)
|
(syntax-rules (unquote $letk $letk* $letconst $letrec $program $continue)
|
||||||
((_ (unquote exp))
|
((_ (unquote exp))
|
||||||
exp)
|
exp)
|
||||||
((_ ($letk (unquote conts) body))
|
((_ ($letk (unquote conts) body))
|
||||||
|
|
@ -303,6 +313,12 @@
|
||||||
($const val))))))
|
($const val))))))
|
||||||
((_ ($letrec names gensyms funs body))
|
((_ ($letrec names gensyms funs body))
|
||||||
(make-$letrec names gensyms funs (build-cps-term body)))
|
(make-$letrec names gensyms funs (build-cps-term body)))
|
||||||
|
((_ ($program (unquote conts)))
|
||||||
|
(make-$program conts))
|
||||||
|
((_ ($program (cont ...)))
|
||||||
|
(make-$program (list (build-cps-cont cont) ...)))
|
||||||
|
((_ ($program conts))
|
||||||
|
(make-$program conts))
|
||||||
((_ ($continue k src exp))
|
((_ ($continue k src exp))
|
||||||
(make-$continue k src (build-cps-exp exp)))))
|
(make-$continue k src (build-cps-exp exp)))))
|
||||||
|
|
||||||
|
|
@ -375,9 +391,13 @@
|
||||||
(build-cps-exp ($prim name)))
|
(build-cps-exp ($prim name)))
|
||||||
(('fun free body)
|
(('fun free body)
|
||||||
(build-cps-exp ($fun free ,(parse-cps body))))
|
(build-cps-exp ($fun free ,(parse-cps body))))
|
||||||
|
(('closure k nfree)
|
||||||
|
(build-cps-exp ($closure k nfree)))
|
||||||
(('letrec ((name sym fun) ...) body)
|
(('letrec ((name sym fun) ...) body)
|
||||||
(build-cps-term
|
(build-cps-term
|
||||||
($letrec name sym (map parse-cps fun) ,(parse-cps body))))
|
($letrec name sym (map parse-cps fun) ,(parse-cps body))))
|
||||||
|
(('program (cont ...))
|
||||||
|
(build-cps-term ($program ,(map parse-cps cont))))
|
||||||
(('call proc arg ...)
|
(('call proc arg ...)
|
||||||
(build-cps-exp ($call proc arg)))
|
(build-cps-exp ($call proc arg)))
|
||||||
(('callk k proc arg ...)
|
(('callk k proc arg ...)
|
||||||
|
|
@ -432,11 +452,15 @@
|
||||||
`(prim ,name))
|
`(prim ,name))
|
||||||
(($ $fun free body)
|
(($ $fun free body)
|
||||||
`(fun ,free ,(unparse-cps body)))
|
`(fun ,free ,(unparse-cps body)))
|
||||||
|
(($ $closure k nfree)
|
||||||
|
`(closure ,k ,nfree))
|
||||||
(($ $letrec names syms funs body)
|
(($ $letrec names syms funs body)
|
||||||
`(letrec ,(map (lambda (name sym fun)
|
`(letrec ,(map (lambda (name sym fun)
|
||||||
(list name sym (unparse-cps fun)))
|
(list name sym (unparse-cps fun)))
|
||||||
names syms funs)
|
names syms funs)
|
||||||
,(unparse-cps body)))
|
,(unparse-cps body)))
|
||||||
|
(($ $program conts)
|
||||||
|
`(program ,(map unparse-cps conts)))
|
||||||
(($ $call proc args)
|
(($ $call proc args)
|
||||||
`(call ,proc ,@args))
|
`(call ,proc ,@args))
|
||||||
(($ $callk k proc args)
|
(($ $callk k proc args)
|
||||||
|
|
@ -541,6 +565,8 @@
|
||||||
(cont-folder tail seed ...))))))
|
(cont-folder tail seed ...))))))
|
||||||
|
|
||||||
(define (compute-max-label-and-var fun)
|
(define (compute-max-label-and-var fun)
|
||||||
|
(match fun
|
||||||
|
(($ $cont)
|
||||||
((make-global-cont-folder max-label max-var)
|
((make-global-cont-folder max-label max-var)
|
||||||
(lambda (label cont max-label max-var)
|
(lambda (label cont max-label max-var)
|
||||||
(values (max label max-label)
|
(values (max label max-label)
|
||||||
|
|
@ -556,6 +582,28 @@
|
||||||
(max self max-var))
|
(max self max-var))
|
||||||
(_ max-var))))
|
(_ max-var))))
|
||||||
fun -1 -1))
|
fun -1 -1))
|
||||||
|
(($ $program conts)
|
||||||
|
(define (fold/2 proc in s0 s1)
|
||||||
|
(if (null? in)
|
||||||
|
(values s0 s1)
|
||||||
|
(let-values (((s0 s1) (proc (car in) s0 s1)))
|
||||||
|
(fold/2 proc (cdr in) s0 s1))))
|
||||||
|
(let lp ((conts conts) (max-label -1) (max-var -1))
|
||||||
|
(if (null? conts)
|
||||||
|
(values max-label max-var)
|
||||||
|
(call-with-values (lambda ()
|
||||||
|
((make-local-cont-folder max-label max-var)
|
||||||
|
(lambda (label cont max-label max-var)
|
||||||
|
(values (max label max-label)
|
||||||
|
(match cont
|
||||||
|
(($ $kargs names vars body)
|
||||||
|
(fold max max-var vars))
|
||||||
|
(($ $kfun src meta self)
|
||||||
|
(max self max-var))
|
||||||
|
(_ max-var))))
|
||||||
|
(car conts) max-label max-var))
|
||||||
|
(lambda (max-label max-var)
|
||||||
|
(lp (cdr conts) max-label max-var))))))))
|
||||||
|
|
||||||
(define (fold-conts proc seed fun)
|
(define (fold-conts proc seed fun)
|
||||||
((make-global-cont-folder seed) proc fun seed))
|
((make-global-cont-folder seed) proc fun seed))
|
||||||
|
|
|
||||||
|
|
@ -34,249 +34,226 @@
|
||||||
#:use-module ((srfi srfi-1) #:select (fold
|
#:use-module ((srfi srfi-1) #:select (fold
|
||||||
lset-union lset-difference
|
lset-union lset-difference
|
||||||
list-index))
|
list-index))
|
||||||
#:use-module (ice-9 receive)
|
|
||||||
#:use-module (srfi srfi-26)
|
#:use-module (srfi srfi-26)
|
||||||
#:use-module (language cps)
|
#:use-module (language cps)
|
||||||
#:export (convert-closures))
|
#:export (convert-closures))
|
||||||
|
|
||||||
(define (union s1 s2)
|
;; free := var ...
|
||||||
(lset-union eq? s1 s2))
|
|
||||||
|
|
||||||
(define (difference s1 s2)
|
(define (convert-free-var var self free k)
|
||||||
(lset-difference eq? s1 s2))
|
|
||||||
|
|
||||||
;; bound := sym ...
|
|
||||||
;; free := sym ...
|
|
||||||
|
|
||||||
(define (convert-free-var sym self bound k)
|
|
||||||
"Convert one possibly free variable reference to a bound reference.
|
"Convert one possibly free variable reference to a bound reference.
|
||||||
|
|
||||||
If @var{sym} is free (i.e., not present in @var{bound},), it is replaced
|
If @var{var} is free (i.e., present in @var{free},), it is replaced
|
||||||
by a closure reference via a @code{free-ref} primcall, and @var{k} is
|
by a closure reference via a @code{free-ref} primcall, and @var{k} is
|
||||||
called with the new var. Otherwise @var{sym} is bound, so @var{k} is
|
called with the new var. Otherwise @var{var} is bound, so @var{k} is
|
||||||
called with @var{sym}.
|
called with @var{var}."
|
||||||
|
(cond
|
||||||
|
((list-index (cut eq? <> var) free)
|
||||||
|
=> (lambda (free-idx)
|
||||||
|
(let-fresh (k* kidx) (idx var*)
|
||||||
|
(build-cps-term
|
||||||
|
($letk ((kidx ($kargs ('idx) (idx)
|
||||||
|
($letk ((k* ($kargs (var*) (var*) ,(k var*))))
|
||||||
|
($continue k* #f
|
||||||
|
($primcall 'free-ref (self idx)))))))
|
||||||
|
($continue kidx #f ($const free-idx)))))))
|
||||||
|
(else (k var))))
|
||||||
|
|
||||||
@var{k} should return two values: a term and a list of additional free
|
(define (convert-free-vars vars self free k)
|
||||||
values in the term."
|
|
||||||
(if (memq sym bound)
|
|
||||||
(k sym)
|
|
||||||
(let-fresh (k*) (sym*)
|
|
||||||
(receive (exp free) (k sym*)
|
|
||||||
(values (build-cps-term
|
|
||||||
($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)
|
|
||||||
"Convert a number of possibly free references to bound references.
|
"Convert a number of possibly free references to bound references.
|
||||||
@var{k} is called with the bound references, and should return two
|
@var{k} is called with the bound references, and should return the
|
||||||
values: the term and a list of additional free variables in the term."
|
term."
|
||||||
(match syms
|
(match vars
|
||||||
(() (k '()))
|
(() (k '()))
|
||||||
((sym . syms)
|
((var . vars)
|
||||||
(convert-free-var sym self bound
|
(convert-free-var var self free
|
||||||
(lambda (sym)
|
(lambda (var)
|
||||||
(convert-free-vars syms self bound
|
(convert-free-vars vars self free
|
||||||
(lambda (syms)
|
(lambda (vars)
|
||||||
(k (cons sym syms)))))))))
|
(k (cons var vars)))))))))
|
||||||
|
|
||||||
(define (init-closure src v free outer-self outer-bound body)
|
(define (init-closure src v free outer-self outer-free body)
|
||||||
"Initialize the free variables @var{free} in a closure bound to
|
"Initialize the free variables @var{free} in a closure bound to
|
||||||
@var{v}, and continue with @var{body}. @var{outer-self} must be the
|
@var{v}, and continue with @var{body}. @var{outer-self} must be the
|
||||||
label of the outer procedure, where the initialization will be
|
label of the outer procedure, where the initialization will be
|
||||||
performed, and @var{outer-bound} is the list of bound variables there."
|
performed, and @var{outer-free} is the list of free variables there."
|
||||||
(fold (lambda (free idx body)
|
(fold (lambda (free idx body)
|
||||||
(let-fresh (k) (idxsym)
|
(let-fresh (k) (idxvar)
|
||||||
(build-cps-term
|
(build-cps-term
|
||||||
($letk ((k ($kargs () () ,body)))
|
($letk ((k ($kargs () () ,body)))
|
||||||
,(convert-free-var
|
,(convert-free-var
|
||||||
free outer-self outer-bound
|
free outer-self outer-free
|
||||||
(lambda (free)
|
(lambda (free)
|
||||||
(values (build-cps-term
|
(values (build-cps-term
|
||||||
($letconst (('idx idxsym idx))
|
($letconst (('idx idxvar idx))
|
||||||
($continue k src
|
($continue k src
|
||||||
($primcall 'free-set! (v idxsym free)))))
|
($primcall 'free-set! (v idxvar free)))))
|
||||||
'())))))))
|
'())))))))
|
||||||
body
|
body
|
||||||
free
|
free
|
||||||
(iota (length free))))
|
(iota (length free))))
|
||||||
|
|
||||||
(define (cc* exps self bound)
|
(define (compute-free-vars exp)
|
||||||
"Convert all free references in the list of expressions @var{exps} to
|
"Compute the set of free variables for all $fun instances in
|
||||||
bound references, and convert functions to flat closures. Returns two
|
@var{exp}."
|
||||||
values: the transformed list, and a cumulative set of free variables."
|
(let ((table (make-hash-table)))
|
||||||
(let lp ((exps exps) (exps* '()) (free '()))
|
(define (union a b)
|
||||||
(match exps
|
(lset-union eq? a b))
|
||||||
(() (values (reverse exps*) free))
|
(define (difference a b)
|
||||||
((exp . exps)
|
(lset-difference eq? a b))
|
||||||
(receive (exp* free*) (cc exp self bound)
|
(define (visit-cont cont bound)
|
||||||
(lp exps (cons exp* exps*) (union free free*)))))))
|
(match cont
|
||||||
|
(($ $cont label ($ $kargs names vars body))
|
||||||
;; Closure conversion.
|
(visit-term body (append vars bound)))
|
||||||
(define (cc exp self bound)
|
(($ $cont label ($ $kfun src meta self tail clause))
|
||||||
"Convert all free references in @var{exp} to bound references, and
|
(let ((free (if clause
|
||||||
convert functions to flat closures."
|
(visit-cont clause (list self))
|
||||||
(match exp
|
'())))
|
||||||
|
(hashq-set! table label (cons free cont))
|
||||||
|
(difference free bound)))
|
||||||
|
(($ $cont label ($ $kclause arity body alternate))
|
||||||
|
(let ((free (visit-cont body bound)))
|
||||||
|
(if alternate
|
||||||
|
(union (visit-cont alternate bound) free)
|
||||||
|
free)))
|
||||||
|
(($ $cont) '())))
|
||||||
|
(define (visit-term term bound)
|
||||||
|
(match term
|
||||||
(($ $letk conts body)
|
(($ $letk conts body)
|
||||||
(receive (conts free) (cc* conts self bound)
|
(fold (lambda (cont free)
|
||||||
(receive (body free*) (cc body self bound)
|
(union (visit-cont cont bound) free))
|
||||||
(values (build-cps-term ($letk ,conts ,body))
|
(visit-term body bound)
|
||||||
(union free free*)))))
|
conts))
|
||||||
|
(($ $letrec names vars (($ $fun () cont) ...) body)
|
||||||
|
(let ((bound (append vars bound)))
|
||||||
|
(fold (lambda (cont free)
|
||||||
|
(union (visit-cont cont bound) free))
|
||||||
|
(visit-term body bound)
|
||||||
|
cont)))
|
||||||
|
(($ $continue k src ($ $fun () body))
|
||||||
|
(visit-cont body bound))
|
||||||
|
(($ $continue k src exp)
|
||||||
|
(visit-exp exp bound))))
|
||||||
|
(define (visit-exp exp bound)
|
||||||
|
(define (adjoin var free)
|
||||||
|
(if (or (memq var bound) (memq var free))
|
||||||
|
free
|
||||||
|
(cons var free)))
|
||||||
|
(match exp
|
||||||
|
((or ($ $void) ($ $const) ($ $prim)) '())
|
||||||
|
(($ $call proc args)
|
||||||
|
(fold adjoin (adjoin proc '()) args))
|
||||||
|
(($ $callk k* proc args)
|
||||||
|
(fold adjoin (adjoin proc '()) args))
|
||||||
|
(($ $primcall name args)
|
||||||
|
(fold adjoin '() args))
|
||||||
|
(($ $values args)
|
||||||
|
(fold adjoin '() args))
|
||||||
|
(($ $prompt escape? tag handler)
|
||||||
|
(adjoin tag '()))))
|
||||||
|
|
||||||
(($ $cont sym ($ $kargs names syms body))
|
(let ((free (visit-cont exp '())))
|
||||||
(receive (body free) (cc body self (append syms bound))
|
(unless (null? free)
|
||||||
(values (build-cps-cont (sym ($kargs names syms ,body)))
|
(error "Expected no free vars in toplevel thunk" free exp))
|
||||||
free)))
|
table)))
|
||||||
|
|
||||||
(($ $cont sym ($ $kfun src meta self tail clause))
|
(define (convert-one label table)
|
||||||
(receive (clause free) (if clause
|
(match (hashq-ref table label)
|
||||||
(cc clause self (list self))
|
((free . (and fun ($ $cont _ ($ $kfun _ _ self))))
|
||||||
(values #f '()))
|
(define (visit-cont cont)
|
||||||
(values (build-cps-cont (sym ($kfun src meta self ,tail ,clause)))
|
(rewrite-cps-cont cont
|
||||||
free)))
|
(($ $cont label ($ $kargs names vars body))
|
||||||
|
(label ($kargs names vars ,(visit-term body))))
|
||||||
(($ $cont sym ($ $kclause arity body alternate))
|
(($ $cont label ($ $kfun src meta self tail clause))
|
||||||
(receive (body free) (cc body self bound)
|
(label ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))
|
||||||
(receive (alternate free*) (if alternate
|
(($ $cont label ($ $kclause arity body alternate))
|
||||||
(cc alternate self bound)
|
(label ($kclause ,arity ,(visit-cont body)
|
||||||
(values #f '()))
|
,(and alternate (visit-cont alternate)))))
|
||||||
(values (build-cps-cont (sym ($kclause ,arity ,body ,alternate)))
|
(($ $cont) ,cont)))
|
||||||
(union free free*)))))
|
(define (visit-term term)
|
||||||
|
(match term
|
||||||
(($ $cont)
|
(($ $letk conts body)
|
||||||
;; Other kinds of continuations don't bind values and don't have
|
(build-cps-term
|
||||||
;; bodies.
|
($letk ,(map visit-cont conts) ,(visit-term body))))
|
||||||
(values exp '()))
|
|
||||||
|
|
||||||
;; Remove letrec.
|
;; Remove letrec.
|
||||||
(($ $letrec names syms funs body)
|
(($ $letrec names vars funs body)
|
||||||
(let ((bound (append bound syms)))
|
(let lp ((in (map list names vars funs))
|
||||||
(receive (body free) (cc body self bound)
|
|
||||||
(let lp ((in (map list names syms funs))
|
|
||||||
(bindings (lambda (body) body))
|
(bindings (lambda (body) body))
|
||||||
(body body)
|
(body (visit-term body)))
|
||||||
(free free))
|
|
||||||
(match in
|
(match in
|
||||||
(() (values (bindings body) free))
|
(() (bindings body))
|
||||||
(((name sym ($ $fun () (and fun-body
|
(((name var ($ $fun ()
|
||||||
($ $cont _ ($ $kfun src))))) . in)
|
(and fun-body
|
||||||
(receive (fun-body fun-free) (cc fun-body #f '())
|
($ $cont kfun ($ $kfun src))))) . in)
|
||||||
|
(match (hashq-ref table kfun)
|
||||||
|
((fun-free . _)
|
||||||
(lp in
|
(lp in
|
||||||
(lambda (body)
|
(lambda (body)
|
||||||
(let-fresh (k) ()
|
(let-fresh (k) ()
|
||||||
(build-cps-term
|
(build-cps-term
|
||||||
($letk ((k ($kargs (name) (sym) ,(bindings body))))
|
($letk ((k ($kargs (name) (var) ,(bindings body))))
|
||||||
($continue k src
|
($continue k src
|
||||||
($fun fun-free ,fun-body))))))
|
($closure kfun (length fun-free)))))))
|
||||||
(init-closure src sym fun-free self bound body)
|
(init-closure src var fun-free self free body))))))))
|
||||||
(union free (difference fun-free bound))))))))))
|
|
||||||
|
|
||||||
(($ $continue k src
|
(($ $continue k src (or ($ $void) ($ $const) ($ $prim)))
|
||||||
(or ($ $void)
|
term)
|
||||||
($ $const)
|
|
||||||
($ $prim)))
|
|
||||||
(values exp '()))
|
|
||||||
|
|
||||||
(($ $continue k src ($ $fun () body))
|
(($ $continue k src ($ $fun () ($ $cont kfun)))
|
||||||
(receive (body free) (cc body #f '())
|
(match (hashq-ref table kfun)
|
||||||
(match free
|
((() . _)
|
||||||
(()
|
(build-cps-term ($continue k src ($closure kfun 0))))
|
||||||
(values (build-cps-term
|
((fun-free . _)
|
||||||
($continue k src ($fun free ,body)))
|
|
||||||
free))
|
|
||||||
(_
|
|
||||||
(values
|
|
||||||
(let-fresh (kinit) (v)
|
(let-fresh (kinit) (v)
|
||||||
(build-cps-term
|
(build-cps-term
|
||||||
($letk ((kinit ($kargs (v) (v)
|
($letk ((kinit ($kargs (v) (v)
|
||||||
,(init-closure
|
,(init-closure
|
||||||
src v free self bound
|
src v fun-free self free
|
||||||
(build-cps-term
|
(build-cps-term
|
||||||
($continue k src ($values (v))))))))
|
($continue k src ($values (v))))))))
|
||||||
($continue kinit src ($fun free ,body)))))
|
($continue kinit src
|
||||||
(difference free bound))))))
|
($closure kfun (length fun-free)))))))))
|
||||||
|
|
||||||
(($ $continue k src ($ $call proc args))
|
(($ $continue k src ($ $call proc args))
|
||||||
(convert-free-vars (cons proc args) self bound
|
(convert-free-vars (cons proc args) self free
|
||||||
(match-lambda
|
(match-lambda
|
||||||
((proc . args)
|
((proc . args)
|
||||||
(values (build-cps-term
|
(build-cps-term
|
||||||
($continue k src ($call proc args)))
|
($continue k src ($call proc args)))))))
|
||||||
'())))))
|
|
||||||
|
|
||||||
(($ $continue k src ($ $callk k* proc args))
|
(($ $continue k src ($ $callk k* proc args))
|
||||||
(convert-free-vars (cons proc args) self bound
|
(convert-free-vars (cons proc args) self free
|
||||||
(match-lambda
|
(match-lambda
|
||||||
((proc . args)
|
((proc . args)
|
||||||
(values (build-cps-term
|
(build-cps-term
|
||||||
($continue k src ($callk k* proc args)))
|
($continue k src ($callk k* proc args)))))))
|
||||||
'())))))
|
|
||||||
|
|
||||||
(($ $continue k src ($ $primcall name args))
|
(($ $continue k src ($ $primcall name args))
|
||||||
(convert-free-vars args self bound
|
(convert-free-vars args self free
|
||||||
(lambda (args)
|
(lambda (args)
|
||||||
(values (build-cps-term
|
(build-cps-term
|
||||||
($continue k src ($primcall name args)))
|
($continue k src ($primcall name args))))))
|
||||||
'()))))
|
|
||||||
|
|
||||||
(($ $continue k src ($ $values args))
|
(($ $continue k src ($ $values args))
|
||||||
(convert-free-vars args self bound
|
(convert-free-vars args self free
|
||||||
(lambda (args)
|
(lambda (args)
|
||||||
(values (build-cps-term
|
(build-cps-term
|
||||||
($continue k src ($values args)))
|
($continue k src ($values args))))))
|
||||||
'()))))
|
|
||||||
|
|
||||||
(($ $continue k src ($ $prompt escape? tag handler))
|
(($ $continue k src ($ $prompt escape? tag handler))
|
||||||
(convert-free-var
|
(convert-free-var tag self free
|
||||||
tag self bound
|
|
||||||
(lambda (tag)
|
(lambda (tag)
|
||||||
(values (build-cps-term
|
|
||||||
($continue k src ($prompt escape? tag handler)))
|
|
||||||
'()))))
|
|
||||||
|
|
||||||
(_ (error "what" exp))))
|
|
||||||
|
|
||||||
;; Convert the slot arguments of 'free-ref' primcalls from symbols to
|
|
||||||
;; indices.
|
|
||||||
(define (convert-to-indices body free)
|
|
||||||
(define (free-index sym)
|
|
||||||
(or (list-index (cut eq? <> sym) free)
|
|
||||||
(error "free variable not found!" sym free)))
|
|
||||||
(define (visit-term term)
|
|
||||||
(rewrite-cps-term term
|
|
||||||
(($ $letk conts body)
|
|
||||||
($letk ,(map visit-cont conts) ,(visit-term body)))
|
|
||||||
(($ $continue k src ($ $primcall 'free-ref (closure sym)))
|
|
||||||
,(let-fresh () (idx)
|
|
||||||
(build-cps-term
|
(build-cps-term
|
||||||
($letconst (('idx idx (free-index sym)))
|
|
||||||
($continue k src ($primcall 'free-ref (closure idx)))))))
|
|
||||||
(($ $continue k src ($ $fun free body))
|
|
||||||
($continue k src
|
($continue k src
|
||||||
($fun free ,(convert-to-indices body free))))
|
($prompt escape? tag handler))))))))
|
||||||
(($ $continue)
|
(visit-cont fun))))
|
||||||
,term)))
|
|
||||||
(define (visit-cont cont)
|
|
||||||
(rewrite-cps-cont cont
|
|
||||||
(($ $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 ($ $kfun src meta self tail clause))
|
|
||||||
(sym ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))))
|
|
||||||
|
|
||||||
(define (convert-closures fun)
|
(define (convert-closures fun)
|
||||||
"Convert free reference in @var{exp} to primcalls to @code{free-ref},
|
"Convert free reference in @var{exp} to primcalls to @code{free-ref},
|
||||||
and allocate and initialize flat closures."
|
and allocate and initialize flat closures."
|
||||||
(with-fresh-name-state fun
|
(with-fresh-name-state fun
|
||||||
(receive (body free) (cc fun #f '())
|
(let* ((table (compute-free-vars fun))
|
||||||
(unless (null? free)
|
(labels (sort (hash-map->list (lambda (k v) k) table) <)))
|
||||||
(error "Expected no free vars in toplevel thunk" fun body free))
|
(build-cps-term
|
||||||
(convert-to-indices body free))))
|
($program ,(map (cut convert-one <> table) labels))))))
|
||||||
|
|
|
||||||
|
|
@ -245,10 +245,10 @@
|
||||||
(emit-load-constant asm dst *unspecified*))
|
(emit-load-constant asm dst *unspecified*))
|
||||||
(($ $const exp)
|
(($ $const exp)
|
||||||
(emit-load-constant asm dst exp))
|
(emit-load-constant asm dst exp))
|
||||||
(($ $fun () ($ $cont k))
|
(($ $closure k 0)
|
||||||
(emit-load-static-procedure asm dst k))
|
(emit-load-static-procedure asm dst k))
|
||||||
(($ $fun free ($ $cont k))
|
(($ $closure k nfree)
|
||||||
(emit-make-closure asm dst k (length free)))
|
(emit-make-closure asm dst k nfree))
|
||||||
(($ $primcall 'current-module)
|
(($ $primcall 'current-module)
|
||||||
(emit-current-module asm dst))
|
(emit-current-module asm dst))
|
||||||
(($ $primcall 'cached-toplevel-box (scope name bound?))
|
(($ $primcall 'cached-toplevel-box (scope name bound?))
|
||||||
|
|
@ -474,43 +474,18 @@
|
||||||
(($ $cont k ($ $kfun src meta self tail clause))
|
(($ $cont k ($ $kfun src meta self tail clause))
|
||||||
(compile-entry)))))
|
(compile-entry)))))
|
||||||
|
|
||||||
(define (visit-funs proc exp)
|
|
||||||
(match exp
|
|
||||||
(($ $continue _ _ exp)
|
|
||||||
(visit-funs proc exp))
|
|
||||||
|
|
||||||
(($ $fun free body)
|
|
||||||
(visit-funs proc body))
|
|
||||||
|
|
||||||
(($ $letk conts body)
|
|
||||||
(visit-funs proc body)
|
|
||||||
(for-each (lambda (cont) (visit-funs proc cont)) conts))
|
|
||||||
|
|
||||||
(($ $cont sym ($ $kargs names syms body))
|
|
||||||
(visit-funs proc body))
|
|
||||||
|
|
||||||
(($ $cont sym ($ $kclause arity body alternate))
|
|
||||||
(visit-funs proc body)
|
|
||||||
(when alternate
|
|
||||||
(visit-funs proc alternate)))
|
|
||||||
|
|
||||||
(($ $cont sym ($ $kfun src meta self tail clause))
|
|
||||||
(proc exp)
|
|
||||||
(when clause
|
|
||||||
(visit-funs proc clause)))
|
|
||||||
|
|
||||||
(_ (values))))
|
|
||||||
|
|
||||||
(define (compile-bytecode exp env opts)
|
(define (compile-bytecode exp env opts)
|
||||||
(let* ((exp (fix-arities exp))
|
(let* ((exp (fix-arities exp))
|
||||||
(exp (optimize exp opts))
|
(exp (optimize exp opts))
|
||||||
(exp (convert-closures exp))
|
(exp (convert-closures exp))
|
||||||
|
;; first-order optimization should go here
|
||||||
(exp (reify-primitives exp))
|
(exp (reify-primitives exp))
|
||||||
(exp (renumber exp))
|
(exp (renumber exp))
|
||||||
(asm (make-assembler)))
|
(asm (make-assembler)))
|
||||||
(visit-funs (lambda (fun)
|
(match exp
|
||||||
(compile-fun fun asm))
|
(($ $program funs)
|
||||||
exp)
|
(for-each (lambda (fun) (compile-fun fun asm))
|
||||||
|
funs)))
|
||||||
(values (link-assembly asm #:page-aligned? (kw-arg-ref opts #:to-file? #f))
|
(values (link-assembly asm #:page-aligned? (kw-arg-ref opts #:to-file? #f))
|
||||||
env
|
env
|
||||||
env)))
|
env)))
|
||||||
|
|
|
||||||
|
|
@ -851,7 +851,7 @@ body continuation in the prompt."
|
||||||
(define (use! sym)
|
(define (use! sym)
|
||||||
(add-use! sym label))
|
(add-use! sym label))
|
||||||
(match exp
|
(match exp
|
||||||
((or ($ $void) ($ $const) ($ $prim)) #f)
|
((or ($ $void) ($ $const) ($ $prim) ($ $closure)) #f)
|
||||||
(($ $call proc args)
|
(($ $call proc args)
|
||||||
(use! proc)
|
(use! proc)
|
||||||
(for-each use! args))
|
(for-each use! args))
|
||||||
|
|
|
||||||
|
|
@ -33,16 +33,16 @@
|
||||||
#:export (reify-primitives))
|
#:export (reify-primitives))
|
||||||
|
|
||||||
(define (module-box src module name public? bound? val-proc)
|
(define (module-box src module name public? bound? val-proc)
|
||||||
(let-fresh (kbox) (module-sym name-sym public?-sym bound?-sym box)
|
(let-fresh (kbox) (module-var name-var public?-var bound?-var box)
|
||||||
(build-cps-term
|
(build-cps-term
|
||||||
($letconst (('module module-sym module)
|
($letconst (('module module-var module)
|
||||||
('name name-sym name)
|
('name name-var name)
|
||||||
('public? public?-sym public?)
|
('public? public?-var public?)
|
||||||
('bound? bound?-sym bound?))
|
('bound? bound?-var bound?))
|
||||||
($letk ((kbox ($kargs ('box) (box) ,(val-proc box))))
|
($letk ((kbox ($kargs ('box) (box) ,(val-proc box))))
|
||||||
($continue kbox src
|
($continue kbox src
|
||||||
($primcall 'cached-module-box
|
($primcall 'cached-module-box
|
||||||
(module-sym name-sym public?-sym bound?-sym))))))))
|
(module-var name-var public?-var bound?-var))))))))
|
||||||
|
|
||||||
(define (primitive-module name)
|
(define (primitive-module name)
|
||||||
(case name
|
(case name
|
||||||
|
|
@ -81,11 +81,11 @@
|
||||||
($continue k src ($primcall 'box-ref (box)))))))
|
($continue k src ($primcall 'box-ref (box)))))))
|
||||||
|
|
||||||
(define (builtin-ref idx k src)
|
(define (builtin-ref idx k src)
|
||||||
(let-fresh () (idx-sym)
|
(let-fresh () (idx-var)
|
||||||
(build-cps-term
|
(build-cps-term
|
||||||
($letconst (('idx idx-sym idx))
|
($letconst (('idx idx-var idx))
|
||||||
($continue k src
|
($continue k src
|
||||||
($primcall 'builtin-ref (idx-sym)))))))
|
($primcall 'builtin-ref (idx-var)))))))
|
||||||
|
|
||||||
(define (reify-clause ktail)
|
(define (reify-clause ktail)
|
||||||
(let-fresh (kclause kbody kthrow) (wna false str eol throw)
|
(let-fresh (kclause kbody kthrow) (wna false str eol throw)
|
||||||
|
|
@ -105,45 +105,40 @@
|
||||||
,(primitive-ref 'throw kthrow #f)))))
|
,(primitive-ref 'throw kthrow #f)))))
|
||||||
,#f)))))
|
,#f)))))
|
||||||
|
|
||||||
;; FIXME: Operate on one function at a time, for efficiency.
|
(define (reify-primitives/1 fun single-value-conts)
|
||||||
(define (reify-primitives fun)
|
(define (visit-clause cont)
|
||||||
(with-fresh-name-state fun
|
(rewrite-cps-cont cont
|
||||||
(let ((conts (build-cont-table fun)))
|
(($ $cont label ($ $kclause arity body alternate))
|
||||||
(define (visit-fun term)
|
(label ($kclause ,arity ,(visit-cont body)
|
||||||
(rewrite-cps-exp term
|
,(and alternate (visit-clause alternate)))))))
|
||||||
(($ $fun free body)
|
|
||||||
($fun free ,(visit-cont body)))))
|
|
||||||
(define (visit-cont cont)
|
(define (visit-cont cont)
|
||||||
(rewrite-cps-cont cont
|
(rewrite-cps-cont cont
|
||||||
(($ $cont sym ($ $kargs names syms body))
|
(($ $cont label ($ $kargs (name) (var) body))
|
||||||
(sym ($kargs names syms ,(visit-term body))))
|
,(begin
|
||||||
(($ $cont sym ($ $kfun src meta self (and tail ($ $cont ktail)) #f))
|
(bitvector-set! single-value-conts label #t)
|
||||||
;; A case-lambda with no clauses. Reify a clause.
|
(build-cps-cont
|
||||||
(sym ($kfun src meta self ,tail ,(reify-clause ktail))))
|
(label ($kargs (name) (var) ,(visit-term body))))))
|
||||||
(($ $cont sym ($ $kfun src meta self tail clause))
|
(($ $cont label ($ $kargs names vars body))
|
||||||
(sym ($kfun src meta self ,tail ,(visit-cont clause))))
|
(label ($kargs names vars ,(visit-term body))))
|
||||||
(($ $cont sym ($ $kclause arity body alternate))
|
|
||||||
(sym ($kclause ,arity ,(visit-cont body)
|
|
||||||
,(and alternate (visit-cont alternate)))))
|
|
||||||
(($ $cont)
|
(($ $cont)
|
||||||
,cont)))
|
,cont)))
|
||||||
(define (visit-term term)
|
(define (visit-term term)
|
||||||
(rewrite-cps-term term
|
(match term
|
||||||
(($ $letk conts body)
|
(($ $letk conts body)
|
||||||
($letk ,(map visit-cont conts) ,(visit-term body)))
|
;; Visit continuations before their uses.
|
||||||
|
(let ((conts (map visit-cont conts)))
|
||||||
|
(build-cps-term
|
||||||
|
($letk ,conts ,(visit-term body)))))
|
||||||
(($ $continue k src exp)
|
(($ $continue k src exp)
|
||||||
,(match exp
|
(match exp
|
||||||
(($ $prim name)
|
(($ $prim name)
|
||||||
(match (vector-ref conts k)
|
(if (bitvector-ref single-value-conts k)
|
||||||
(($ $kargs (_))
|
|
||||||
(cond
|
(cond
|
||||||
((builtin-name->index name)
|
((builtin-name->index name)
|
||||||
=> (lambda (idx)
|
=> (lambda (idx)
|
||||||
(builtin-ref idx k src)))
|
(builtin-ref idx k src)))
|
||||||
(else (primitive-ref name k src))))
|
(else (primitive-ref name k src)))
|
||||||
(_ (build-cps-term ($continue k src ($void))))))
|
(build-cps-term ($continue k src ($void)))))
|
||||||
(($ $fun)
|
|
||||||
(build-cps-term ($continue k src ,(visit-fun exp))))
|
|
||||||
(($ $primcall 'call-thunk/no-inline (proc))
|
(($ $primcall 'call-thunk/no-inline (proc))
|
||||||
(build-cps-term
|
(build-cps-term
|
||||||
($continue k src ($call proc ()))))
|
($continue k src ($call proc ()))))
|
||||||
|
|
@ -164,4 +159,18 @@
|
||||||
(else (primitive-ref name k* src)))))))))
|
(else (primitive-ref name k* src)))))))))
|
||||||
(_ term)))))
|
(_ term)))))
|
||||||
|
|
||||||
(visit-cont fun))))
|
(rewrite-cps-cont fun
|
||||||
|
(($ $cont label ($ $kfun src meta self (and tail ($ $cont ktail)) #f))
|
||||||
|
;; A case-lambda with no clauses. Reify a clause.
|
||||||
|
(label ($kfun src meta self ,tail ,(reify-clause ktail))))
|
||||||
|
(($ $cont label ($ $kfun src meta self tail clause))
|
||||||
|
(label ($kfun src meta self ,tail ,(visit-clause clause))))))
|
||||||
|
|
||||||
|
(define (reify-primitives term)
|
||||||
|
(with-fresh-name-state term
|
||||||
|
(let ((single-value-conts (make-bitvector (label-counter) #f)))
|
||||||
|
(rewrite-cps-term term
|
||||||
|
(($ $program procs)
|
||||||
|
($program ,(map (lambda (cont)
|
||||||
|
(reify-primitives/1 cont single-value-conts))
|
||||||
|
procs)))))))
|
||||||
|
|
|
||||||
|
|
@ -169,19 +169,19 @@
|
||||||
(set! queue (cons body queue))))
|
(set! queue (cons body queue))))
|
||||||
(($ $continue) #f)))
|
(($ $continue) #f)))
|
||||||
|
|
||||||
(collect-conts fun)
|
|
||||||
(match fun
|
(match fun
|
||||||
(($ $cont kfun)
|
(($ $cont kfun)
|
||||||
|
(collect-conts fun)
|
||||||
(set! next-label (sort-conts kfun labels next-label))
|
(set! next-label (sort-conts kfun labels next-label))
|
||||||
(visit-cont fun)
|
(visit-cont fun)
|
||||||
(for-each compute-names-in-fun (reverse queue)))))
|
(for-each compute-names-in-fun (reverse queue)))
|
||||||
|
(($ $program conts)
|
||||||
|
(for-each compute-names-in-fun conts))))
|
||||||
|
|
||||||
(compute-names-in-fun fun)
|
(compute-names-in-fun fun)
|
||||||
(values labels vars next-label next-var)))))
|
(values labels vars next-label next-var)))))
|
||||||
|
|
||||||
(define (renumber fun)
|
(define (apply-renumbering term labels vars)
|
||||||
(call-with-values (lambda () (compute-new-labels-and-vars fun))
|
|
||||||
(lambda (labels vars nlabels nvars)
|
|
||||||
(define (relabel label) (vector-ref labels label))
|
(define (relabel label) (vector-ref labels label))
|
||||||
(define (rename var) (vector-ref vars var))
|
(define (rename var) (vector-ref vars var))
|
||||||
(define (rename-kw-arity arity)
|
(define (rename-kw-arity arity)
|
||||||
|
|
@ -243,6 +243,8 @@
|
||||||
(match exp
|
(match exp
|
||||||
((or ($ $void) ($ $const) ($ $prim))
|
((or ($ $void) ($ $const) ($ $prim))
|
||||||
exp)
|
exp)
|
||||||
|
(($ $closure k nfree)
|
||||||
|
(build-cps-exp ($closure (relabel k) nfree)))
|
||||||
(($ $fun)
|
(($ $fun)
|
||||||
(visit-fun exp))
|
(visit-fun exp))
|
||||||
(($ $values args)
|
(($ $values args)
|
||||||
|
|
@ -264,4 +266,15 @@
|
||||||
(rewrite-cps-exp fun
|
(rewrite-cps-exp fun
|
||||||
(($ $fun free body)
|
(($ $fun free body)
|
||||||
($fun (map rename free) ,(must-visit-cont body)))))
|
($fun (map rename free) ,(must-visit-cont body)))))
|
||||||
(values (must-visit-cont fun) nlabels nvars))))
|
|
||||||
|
(match term
|
||||||
|
(($ $cont)
|
||||||
|
(must-visit-cont term))
|
||||||
|
(($ $program conts)
|
||||||
|
(build-cps-term
|
||||||
|
($program ,(map must-visit-cont conts))))))
|
||||||
|
|
||||||
|
(define (renumber term)
|
||||||
|
(call-with-values (lambda () (compute-new-labels-and-vars term))
|
||||||
|
(lambda (labels vars nlabels nvars)
|
||||||
|
(values (apply-renumbering term labels vars) nlabels nvars))))
|
||||||
|
|
|
||||||
|
|
@ -442,7 +442,7 @@ are comparable with eqv?. A tmp slot may be used."
|
||||||
;; are finished with the scan, we kill uses of the
|
;; are finished with the scan, we kill uses of the
|
||||||
;; terminator, but leave its definitions.
|
;; terminator, but leave its definitions.
|
||||||
(match (find-expression body)
|
(match (find-expression body)
|
||||||
((or ($ $void) ($ $const) ($ $prim) ($ $fun)
|
((or ($ $void) ($ $const) ($ $prim) ($ $closure)
|
||||||
($ $primcall) ($ $prompt)
|
($ $primcall) ($ $prompt)
|
||||||
;; If $values has more than one argument, it may
|
;; If $values has more than one argument, it may
|
||||||
;; use a temporary, which would invalidate our
|
;; use a temporary, which would invalidate our
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue