mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-09 21:40:33 +02:00
Code Activity

First-order CPS has $program and $closure forms

Browse source 
* 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 2014-04-12 11:52:38 +02:00
parent 405805fbc3
commit cf8bb03772
7 changed files with 444 additions and 422 deletions
Download patch file Download diff file Expand all files Collapse all files

94
module/language/cps.scm
View file

@ -122,7 +122,11 @@
$kif $kreceive $kargs $kfun $ktail $kclause
;; 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.
label-counter var-counter
@ -173,7 +177,7 @@
;; Terms.
(define-cps-type $letk conts body)
(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
(define-cps-type $cont k cont)
@ -188,13 +192,18 @@
(define-cps-type $void)
(define-cps-type $const val)
(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 $callk k proc args)
(define-cps-type $callk k proc args) ; First-order.
(define-cps-type $primcall name args)
(define-cps-type $values args)
(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 var-counter (make-parameter #f))
@ -257,13 +266,14 @@
(define-syntax build-cps-exp
(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)
((_ ($void)) (make-$void))
((_ ($const val)) (make-$const val))
((_ ($prim name)) (make-$prim name))
((_ ($fun free body))
(make-$fun free (build-cps-cont body)))
((_ ($fun free 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 (arg ...))) (make-$call proc (list arg ...)))
((_ ($call proc args)) (make-$call proc args))
@ -280,7 +290,7 @@
(make-$prompt escape? tag handler))))
(define-syntax build-cps-term
(syntax-rules (unquote $letk $letk* $letconst $letrec $continue)
(syntax-rules (unquote $letk $letk* $letconst $letrec $program $continue)
((_ (unquote exp))
exp)
((_ ($letk (unquote conts) body))
@ -303,6 +313,12 @@
($const val))))))
((_ ($letrec names gensyms funs 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))
(make-$continue k src (build-cps-exp exp)))))
@ -375,9 +391,13 @@
(build-cps-exp ($prim name)))
(('fun free body)
(build-cps-exp ($fun free ,(parse-cps body))))
(('closure k nfree)
(build-cps-exp ($closure k nfree)))
(('letrec ((name sym fun) ...) body)
(build-cps-term
($letrec name sym (map parse-cps fun) ,(parse-cps body))))
(('program (cont ...))
(build-cps-term ($program ,(map parse-cps cont))))
(('call proc arg ...)
(build-cps-exp ($call proc arg)))
(('callk k proc arg ...)
@ -432,11 +452,15 @@
`(prim ,name))
(($ $fun free body)
`(fun ,free ,(unparse-cps body)))
(($ $closure k nfree)
`(closure ,k ,nfree))
(($ $letrec names syms funs body)
`(letrec ,(map (lambda (name sym fun)
(list name sym (unparse-cps fun)))
names syms funs)
,(unparse-cps body)))
(($ $program conts)
`(program ,(map unparse-cps conts)))
(($ $call proc args)
`(call ,proc ,@args))
(($ $callk k proc args)
@ -541,21 +565,45 @@
(cont-folder tail seed ...))))))
(define (compute-max-label-and-var fun)
((make-global-cont-folder max-label max-var)
(lambda (label cont max-label max-var)
(values (max label max-label)
(match cont
(($ $kargs names vars body)
(let lp ((body body) (max-var (fold max max-var vars)))
(match body
(($ $letk conts body) (lp body max-var))
(($ $letrec names vars funs body)
(lp body (fold max max-var vars)))
(_ max-var))))
(($ $kfun src meta self)
(max self max-var))
(_ max-var))))
fun -1 -1))
(match fun
(($ $cont)
((make-global-cont-folder max-label max-var)
(lambda (label cont max-label max-var)
(values (max label max-label)
(match cont
(($ $kargs names vars body)
(let lp ((body body) (max-var (fold max max-var vars)))
(match body
(($ $letk conts body) (lp body max-var))
(($ $letrec names vars funs body)
(lp body (fold max max-var vars)))
(_ max-var))))
(($ $kfun src meta self)
(max self max-var))
(_ max-var))))
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)
((make-global-cont-folder seed) proc fun seed))

395
module/language/cps/closure-conversion.scm
View file

@ -34,249 +34,226 @@
#:use-module ((srfi srfi-1) #:select (fold
lset-union lset-difference
list-index))
#:use-module (ice-9 receive)
#:use-module (srfi srfi-26)
#:use-module (language cps)
#:export (convert-closures))
(define (union s1 s2)
(lset-union eq? s1 s2))
;; free := var ...
(define (difference s1 s2)
(lset-difference eq? s1 s2))
;; bound := sym ...
;; free := sym ...
(define (convert-free-var sym self bound k)
(define (convert-free-var var self free k)
"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
called with the new var. Otherwise @var{sym} is bound, so @var{k} is
called with @var{sym}.
called with the new var. Otherwise @var{var} is bound, so @var{k} is
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
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)
(define (convert-free-vars vars self free k)
"Convert a number of possibly free references to bound references.
@var{k} is called with the bound references, and should return two
values: the term and a list of additional free variables in the term."
(match syms
@var{k} is called with the bound references, and should return the
term."
(match vars
(() (k '()))
((sym . syms)
(convert-free-var sym self bound
(lambda (sym)
(convert-free-vars syms self bound
(lambda (syms)
(k (cons sym syms)))))))))
((var . vars)
(convert-free-var var self free
(lambda (var)
(convert-free-vars vars self free
(lambda (vars)
(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
@var{v}, and continue with @var{body}. @var{outer-self} must be the
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)
(let-fresh (k) (idxsym)
(let-fresh (k) (idxvar)
(build-cps-term
($letk ((k ($kargs () () ,body)))
,(convert-free-var
free outer-self outer-bound
free outer-self outer-free
(lambda (free)
(values (build-cps-term
($letconst (('idx idxsym idx))
($letconst (('idx idxvar idx))
($continue k src
($primcall 'free-set! (v idxsym free)))))
($primcall 'free-set! (v idxvar free)))))
'())))))))
body
free
(iota (length free))))
(define (cc* exps self bound)
"Convert all free references in the list of expressions @var{exps} to
bound references, and convert functions to flat closures. Returns two
values: the transformed list, and a cumulative set of free variables."
(let lp ((exps exps) (exps* '()) (free '()))
(match exps
(() (values (reverse exps*) free))
((exp . exps)
(receive (exp* free*) (cc exp self bound)
(lp exps (cons exp* exps*) (union free free*)))))))
;; Closure conversion.
(define (cc exp self bound)
"Convert all free references in @var{exp} to bound references, and
convert functions to flat closures."
(match exp
(($ $letk conts body)
(receive (conts free) (cc* conts self bound)
(receive (body free*) (cc body self bound)
(values (build-cps-term ($letk ,conts ,body))
(union free free*)))))
(($ $cont sym ($ $kargs names syms body))
(receive (body free) (cc body self (append syms bound))
(values (build-cps-cont (sym ($kargs names syms ,body)))
(define (compute-free-vars exp)
"Compute the set of free variables for all $fun instances in
@var{exp}."
(let ((table (make-hash-table)))
(define (union a b)
(lset-union eq? a b))
(define (difference a b)
(lset-difference eq? a b))
(define (visit-cont cont bound)
(match cont
(($ $cont label ($ $kargs names vars body))
(visit-term body (append vars bound)))
(($ $cont label ($ $kfun src meta self tail clause))
(let ((free (if clause
(visit-cont clause (list self))
'())))
(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)
(fold (lambda (cont free)
(union (visit-cont cont bound) free))
(visit-term body bound)
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 ($ $kfun src meta self tail clause))
(receive (clause free) (if clause
(cc clause self (list self))
(values #f '()))
(values (build-cps-cont (sym ($kfun src meta self ,tail ,clause)))
free)))
(let ((free (visit-cont exp '())))
(unless (null? free)
(error "Expected no free vars in toplevel thunk" free exp))
table)))
(($ $cont sym ($ $kclause arity body alternate))
(receive (body free) (cc body self bound)
(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
;; bodies.
(values exp '()))
;; Remove letrec.
(($ $letrec names syms funs body)
(let ((bound (append bound syms)))
(receive (body free) (cc body self bound)
(let lp ((in (map list names syms funs))
(bindings (lambda (body) body))
(body body)
(free free))
(match in
(() (values (bindings body) free))
(((name sym ($ $fun () (and fun-body
($ $cont _ ($ $kfun src))))) . in)
(receive (fun-body fun-free) (cc fun-body #f '())
(lp in
(lambda (body)
(let-fresh (k) ()
(build-cps-term
($letk ((k ($kargs (name) (sym) ,(bindings body))))
($continue k src
($fun fun-free ,fun-body))))))
(init-closure src sym fun-free self bound body)
(union free (difference fun-free bound))))))))))
(($ $continue k src
(or ($ $void)
($ $const)
($ $prim)))
(values exp '()))
(($ $continue k src ($ $fun () body))
(receive (body free) (cc body #f '())
(match free
(()
(values (build-cps-term
($continue k src ($fun free ,body)))
free))
(_
(values
(let-fresh (kinit) (v)
(build-cps-term
($letk ((kinit ($kargs (v) (v)
,(init-closure
src v free self bound
(build-cps-term
($continue k src ($values (v))))))))
($continue kinit src ($fun free ,body)))))
(difference free bound))))))
(($ $continue k src ($ $call proc args))
(convert-free-vars (cons proc args) self bound
(match-lambda
((proc . args)
(values (build-cps-term
($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)
(values (build-cps-term
($continue k src ($primcall name args)))
'()))))
(($ $continue k src ($ $values args))
(convert-free-vars args self bound
(lambda (args)
(values (build-cps-term
($continue k src ($values args)))
'()))))
(($ $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)))
'()))))
(_ (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)
(define (convert-one label table)
(match (hashq-ref table label)
((free . (and fun ($ $cont _ ($ $kfun _ _ self))))
(define (visit-cont cont)
(rewrite-cps-cont cont
(($ $cont label ($ $kargs names vars body))
(label ($kargs names vars ,(visit-term body))))
(($ $cont label ($ $kfun src meta self tail clause))
(label ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))
(($ $cont label ($ $kclause arity body alternate))
(label ($kclause ,arity ,(visit-cont body)
,(and alternate (visit-cont alternate)))))
(($ $cont) ,cont)))
(define (visit-term term)
(match term
(($ $letk conts body)
(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
($fun free ,(convert-to-indices body free))))
(($ $continue)
,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)))
($letk ,(map visit-cont conts) ,(visit-term body))))
(rewrite-cps-cont body
(($ $cont sym ($ $kfun src meta self tail clause))
(sym ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))))
;; Remove letrec.
(($ $letrec names vars funs body)
(let lp ((in (map list names vars funs))
(bindings (lambda (body) body))
(body (visit-term body)))
(match in
(() (bindings body))
(((name var ($ $fun ()
(and fun-body
($ $cont kfun ($ $kfun src))))) . in)
(match (hashq-ref table kfun)
((fun-free . _)
(lp in
(lambda (body)
(let-fresh (k) ()
(build-cps-term
($letk ((k ($kargs (name) (var) ,(bindings body))))
($continue k src
($closure kfun (length fun-free)))))))
(init-closure src var fun-free self free body))))))))
(($ $continue k src (or ($ $void) ($ $const) ($ $prim)))
term)
(($ $continue k src ($ $fun () ($ $cont kfun)))
(match (hashq-ref table kfun)
((() . _)
(build-cps-term ($continue k src ($closure kfun 0))))
((fun-free . _)
(let-fresh (kinit) (v)
(build-cps-term
($letk ((kinit ($kargs (v) (v)
,(init-closure
src v fun-free self free
(build-cps-term
($continue k src ($values (v))))))))
($continue kinit src
($closure kfun (length fun-free)))))))))
(($ $continue k src ($ $call proc args))
(convert-free-vars (cons proc args) self free
(match-lambda
((proc . args)
(build-cps-term
($continue k src ($call proc args)))))))
(($ $continue k src ($ $callk k* proc args))
(convert-free-vars (cons proc args) self free
(match-lambda
((proc . args)
(build-cps-term
($continue k src ($callk k* proc args)))))))
(($ $continue k src ($ $primcall name args))
(convert-free-vars args self free
(lambda (args)
(build-cps-term
($continue k src ($primcall name args))))))
(($ $continue k src ($ $values args))
(convert-free-vars args self free
(lambda (args)
(build-cps-term
($continue k src ($values args))))))
(($ $continue k src ($ $prompt escape? tag handler))
(convert-free-var tag self free
(lambda (tag)
(build-cps-term
($continue k src
($prompt escape? tag handler))))))))
(visit-cont fun))))
(define (convert-closures fun)
"Convert free reference in @var{exp} to primcalls to @code{free-ref},
and allocate and initialize flat closures."
(with-fresh-name-state fun
(receive (body free) (cc fun #f '())
(unless (null? free)
(error "Expected no free vars in toplevel thunk" fun body free))
(convert-to-indices body free))))
(let* ((table (compute-free-vars fun))
(labels (sort (hash-map->list (lambda (k v) k) table) <)))
(build-cps-term
($program ,(map (cut convert-one <> table) labels))))))

41
module/language/cps/compile-bytecode.scm
View file

@ -245,10 +245,10 @@
(emit-load-constant asm dst *unspecified*))
(($ $const exp)
(emit-load-constant asm dst exp))
(($ $fun () ($ $cont k))
(($ $closure k 0)
(emit-load-static-procedure asm dst k))
(($ $fun free ($ $cont k))
(emit-make-closure asm dst k (length free)))
(($ $closure k nfree)
(emit-make-closure asm dst k nfree))
(($ $primcall 'current-module)
(emit-current-module asm dst))
(($ $primcall 'cached-toplevel-box (scope name bound?))
@ -474,43 +474,18 @@
(($ $cont k ($ $kfun src meta self tail clause))
(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)
(let* ((exp (fix-arities exp))
(exp (optimize exp opts))
(exp (convert-closures exp))
;; first-order optimization should go here
(exp (reify-primitives exp))
(exp (renumber exp))
(asm (make-assembler)))
(visit-funs (lambda (fun)
(compile-fun fun asm))
exp)
(match exp
(($ $program funs)
(for-each (lambda (fun) (compile-fun fun asm))
funs)))
(values (link-assembly asm #:page-aligned? (kw-arg-ref opts #:to-file? #f))
env
env)))

2
module/language/cps/dfg.scm
View file

@ -851,7 +851,7 @@ body continuation in the prompt."
(define (use! sym)
(add-use! sym label))
(match exp
((or ($ $void) ($ $const) ($ $prim)) #f)
((or ($ $void) ($ $const) ($ $prim) ($ $closure)) #f)
(($ $call proc args)
(use! proc)
(for-each use! args))

145
module/language/cps/reify-primitives.scm
View file

@ -33,16 +33,16 @@
#:export (reify-primitives))
(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
($letconst (('module module-sym module)
('name name-sym name)
('public? public?-sym public?)
('bound? bound?-sym bound?))
($letconst (('module module-var module)
('name name-var name)
('public? public?-var public?)
('bound? bound?-var bound?))
($letk ((kbox ($kargs ('box) (box) ,(val-proc box))))
($continue kbox src
($primcall 'cached-module-box
(module-sym name-sym public?-sym bound?-sym))))))))
(module-var name-var public?-var bound?-var))))))))
(define (primitive-module name)
(case name
@ -81,11 +81,11 @@
($continue k src ($primcall 'box-ref (box)))))))
(define (builtin-ref idx k src)
(let-fresh () (idx-sym)
(let-fresh () (idx-var)
(build-cps-term
($letconst (('idx idx-sym idx))
($letconst (('idx idx-var idx))
($continue k src
($primcall 'builtin-ref (idx-sym)))))))
($primcall 'builtin-ref (idx-var)))))))
(define (reify-clause ktail)
(let-fresh (kclause kbody kthrow) (wna false str eol throw)
@ -105,63 +105,72 @@
,(primitive-ref 'throw kthrow #f)))))
,#f)))))
;; FIXME: Operate on one function at a time, for efficiency.
(define (reify-primitives fun)
(with-fresh-name-state fun
(let ((conts (build-cont-table fun)))
(define (visit-fun term)
(rewrite-cps-exp term
(($ $fun free body)
($fun free ,(visit-cont body)))))
(define (visit-cont cont)
(rewrite-cps-cont cont
(($ $cont sym ($ $kargs names syms body))
(sym ($kargs names syms ,(visit-term body))))
(($ $cont sym ($ $kfun src meta self (and tail ($ $cont ktail)) #f))
;; A case-lambda with no clauses. Reify a clause.
(sym ($kfun src meta self ,tail ,(reify-clause ktail))))
(($ $cont sym ($ $kfun src meta self tail clause))
(sym ($kfun src meta self ,tail ,(visit-cont clause))))
(($ $cont sym ($ $kclause arity body alternate))
(sym ($kclause ,arity ,(visit-cont body)
,(and alternate (visit-cont alternate)))))
(($ $cont)
,cont)))
(define (visit-term term)
(rewrite-cps-term term
(($ $letk conts body)
($letk ,(map visit-cont conts) ,(visit-term body)))
(($ $continue k src exp)
,(match exp
(($ $prim name)
(match (vector-ref conts k)
(($ $kargs (_))
(cond
((builtin-name->index name)
=> (lambda (idx)
(builtin-ref idx k src)))
(else (primitive-ref name k src))))
(_ (build-cps-term ($continue k src ($void))))))
(($ $fun)
(build-cps-term ($continue k src ,(visit-fun exp))))
(($ $primcall 'call-thunk/no-inline (proc))
(build-cps-term
($continue k src ($call proc ()))))
(($ $primcall name args)
(cond
((or (prim-instruction name) (branching-primitive? name))
;; Assume arities are correct.
term)
(else
(let-fresh (k*) (v)
(build-cps-term
($letk ((k* ($kargs (v) (v)
($continue k src ($call v args)))))
,(cond
((builtin-name->index name)
=> (lambda (idx)
(builtin-ref idx k* src)))
(else (primitive-ref name k* src)))))))))
(_ term)))))
(define (reify-primitives/1 fun single-value-conts)
(define (visit-clause cont)
(rewrite-cps-cont cont
(($ $cont label ($ $kclause arity body alternate))
(label ($kclause ,arity ,(visit-cont body)
,(and alternate (visit-clause alternate)))))))
(define (visit-cont cont)
(rewrite-cps-cont cont
(($ $cont label ($ $kargs (name) (var) body))
,(begin
(bitvector-set! single-value-conts label #t)
(build-cps-cont
(label ($kargs (name) (var) ,(visit-term body))))))
(($ $cont label ($ $kargs names vars body))
(label ($kargs names vars ,(visit-term body))))
(($ $cont)
,cont)))
(define (visit-term term)
(match term
(($ $letk conts body)
;; Visit continuations before their uses.
(let ((conts (map visit-cont conts)))
(build-cps-term
($letk ,conts ,(visit-term body)))))
(($ $continue k src exp)
(match exp
(($ $prim name)
(if (bitvector-ref single-value-conts k)
(cond
((builtin-name->index name)
=> (lambda (idx)
(builtin-ref idx k src)))
(else (primitive-ref name k src)))
(build-cps-term ($continue k src ($void)))))
(($ $primcall 'call-thunk/no-inline (proc))
(build-cps-term
($continue k src ($call proc ()))))
(($ $primcall name args)
(cond
((or (prim-instruction name) (branching-primitive? name))
;; Assume arities are correct.
term)
(else
(let-fresh (k*) (v)
(build-cps-term
($letk ((k* ($kargs (v) (v)
($continue k src ($call v args)))))
,(cond
((builtin-name->index name)
=> (lambda (idx)
(builtin-ref idx k* src)))
(else (primitive-ref name k* src)))))))))
(_ 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)))))))

187
module/language/cps/renumber.scm
View file

@ -169,99 +169,112 @@
(set! queue (cons body queue))))
(($ $continue) #f)))
(collect-conts fun)
(match fun
(($ $cont kfun)
(collect-conts fun)
(set! next-label (sort-conts kfun labels next-label))
(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)
(values labels vars next-label next-var)))))
(define (renumber fun)
(call-with-values (lambda () (compute-new-labels-and-vars fun))
(define (apply-renumbering term labels vars)
(define (relabel label) (vector-ref labels label))
(define (rename var) (vector-ref vars var))
(define (rename-kw-arity arity)
(match arity
(($ $arity req opt rest kw aok?)
(make-$arity req opt rest
(map (match-lambda
((kw kw-name kw-var)
(list kw kw-name (rename kw-var))))
kw)
aok?))))
(define (must-visit-cont cont)
(or (visit-cont cont)
(error "internal error -- failed to visit cont")))
(define (visit-conts conts)
(match conts
(() '())
((cont . conts)
(cond
((visit-cont cont)
=> (lambda (cont)
(cons cont (visit-conts conts))))
(else (visit-conts conts))))))
(define (visit-cont cont)
(match cont
(($ $cont label cont)
(let ((label (relabel label)))
(and
label
(rewrite-cps-cont cont
(($ $kargs names vars body)
(label ($kargs names (map rename vars) ,(visit-term body))))
(($ $kfun src meta self tail clause)
(label
($kfun src meta (rename self) ,(must-visit-cont tail)
,(and clause (must-visit-cont clause)))))
(($ $ktail)
(label ($ktail)))
(($ $kclause arity body alternate)
(label
($kclause ,(rename-kw-arity arity) ,(must-visit-cont body)
,(and alternate (must-visit-cont alternate)))))
(($ $kreceive ($ $arity req () rest () #f) kargs)
(label ($kreceive req rest (relabel kargs))))
(($ $kif kt kf)
(label ($kif (relabel kt) (relabel kf))))))))))
(define (visit-term term)
(rewrite-cps-term term
(($ $letk conts body)
,(match (visit-conts conts)
(() (visit-term body))
(conts (build-cps-term ($letk ,conts ,(visit-term body))))))
(($ $letrec names vars funs body)
($letrec names (map rename vars) (map visit-fun funs)
,(visit-term body)))
(($ $continue k src exp)
($continue (relabel k) src ,(visit-exp exp)))))
(define (visit-exp exp)
(match exp
((or ($ $void) ($ $const) ($ $prim))
exp)
(($ $closure k nfree)
(build-cps-exp ($closure (relabel k) nfree)))
(($ $fun)
(visit-fun exp))
(($ $values args)
(let ((args (map rename args)))
(build-cps-exp ($values args))))
(($ $call proc args)
(let ((args (map rename args)))
(build-cps-exp ($call (rename proc) args))))
(($ $callk k proc args)
(let ((args (map rename args)))
(build-cps-exp ($callk (relabel k) (rename proc) args))))
(($ $primcall name args)
(let ((args (map rename args)))
(build-cps-exp ($primcall name args))))
(($ $prompt escape? tag handler)
(build-cps-exp
($prompt escape? (rename tag) (relabel handler))))))
(define (visit-fun fun)
(rewrite-cps-exp fun
(($ $fun free body)
($fun (map rename free) ,(must-visit-cont body)))))
(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)
(define (relabel label) (vector-ref labels label))
(define (rename var) (vector-ref vars var))
(define (rename-kw-arity arity)
(match arity
(($ $arity req opt rest kw aok?)
(make-$arity req opt rest
(map (match-lambda
((kw kw-name kw-var)
(list kw kw-name (rename kw-var))))
kw)
aok?))))
(define (must-visit-cont cont)
(or (visit-cont cont)
(error "internal error -- failed to visit cont")))
(define (visit-conts conts)
(match conts
(() '())
((cont . conts)
(cond
((visit-cont cont)
=> (lambda (cont)
(cons cont (visit-conts conts))))
(else (visit-conts conts))))))
(define (visit-cont cont)
(match cont
(($ $cont label cont)
(let ((label (relabel label)))
(and
label
(rewrite-cps-cont cont
(($ $kargs names vars body)
(label ($kargs names (map rename vars) ,(visit-term body))))
(($ $kfun src meta self tail clause)
(label
($kfun src meta (rename self) ,(must-visit-cont tail)
,(and clause (must-visit-cont clause)))))
(($ $ktail)
(label ($ktail)))
(($ $kclause arity body alternate)
(label
($kclause ,(rename-kw-arity arity) ,(must-visit-cont body)
,(and alternate (must-visit-cont alternate)))))
(($ $kreceive ($ $arity req () rest () #f) kargs)
(label ($kreceive req rest (relabel kargs))))
(($ $kif kt kf)
(label ($kif (relabel kt) (relabel kf))))))))))
(define (visit-term term)
(rewrite-cps-term term
(($ $letk conts body)
,(match (visit-conts conts)
(() (visit-term body))
(conts (build-cps-term ($letk ,conts ,(visit-term body))))))
(($ $letrec names vars funs body)
($letrec names (map rename vars) (map visit-fun funs)
,(visit-term body)))
(($ $continue k src exp)
($continue (relabel k) src ,(visit-exp exp)))))
(define (visit-exp exp)
(match exp
((or ($ $void) ($ $const) ($ $prim))
exp)
(($ $fun)
(visit-fun exp))
(($ $values args)
(let ((args (map rename args)))
(build-cps-exp ($values args))))
(($ $call proc args)
(let ((args (map rename args)))
(build-cps-exp ($call (rename proc) args))))
(($ $callk k proc args)
(let ((args (map rename args)))
(build-cps-exp ($callk (relabel k) (rename proc) args))))
(($ $primcall name args)
(let ((args (map rename args)))
(build-cps-exp ($primcall name args))))
(($ $prompt escape? tag handler)
(build-cps-exp
($prompt escape? (rename tag) (relabel handler))))))
(define (visit-fun fun)
(rewrite-cps-exp fun
(($ $fun free body)
($fun (map rename free) ,(must-visit-cont body)))))
(values (must-visit-cont fun) nlabels nvars))))
(values (apply-renumbering term labels vars) nlabels nvars))))

2
module/language/cps/slot-allocation.scm
View file

@ -442,7 +442,7 @@ are comparable with eqv?. A tmp slot may be used."
;; are finished with the scan, we kill uses of the
;; terminator, but leave its definitions.
(match (find-expression body)
((or ($ $void) ($ $const) ($ $prim) ($ $fun)
((or ($ $void) ($ $const) ($ $prim) ($ $closure)
($ $primcall) ($ $prompt)
;; If $values has more than one argument, it may
;; use a temporary, which would invalidate our