mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-23 21:10:29 +02:00
Refactor to closure-conversion
* module/language/cps/closure-conversion.scm (convert-one): Refactor to pull in helpers locally, as they will need more state.
This commit is contained in:
Andy Wingo
parent
1487367e21
commit
2920554a1e
1 changed files with 181 additions and 186 deletions
|
|
@ -42,154 +42,6 @@
|
||||||
|
|
||||||
;; free := var ...
|
;; free := var ...
|
||||||
|
|
||||||
(define (convert-free-var var self self-known? free k)
|
|
||||||
"Convert one possibly free variable reference to a bound reference.
|
|
||||||
|
|
||||||
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{var} is bound, so @var{k} is
|
|
||||||
called with @var{var}."
|
|
||||||
(cond
|
|
||||||
((list-index (cut eq? <> var) free)
|
|
||||||
=> (lambda (free-idx)
|
|
||||||
(match (cons self-known? free)
|
|
||||||
;; A reference to the one free var of a well-known function.
|
|
||||||
((#t _) (k self))
|
|
||||||
;; A reference to one of the two free vars in a well-known
|
|
||||||
;; function.
|
|
||||||
((#t _ _)
|
|
||||||
(let-fresh (k*) (var*)
|
|
||||||
(build-cps-term
|
|
||||||
($letk ((k* ($kargs (var*) (var*) ,(k var*))))
|
|
||||||
($continue k* #f
|
|
||||||
($primcall (match free-idx (0 'car) (1 'cdr)) (self)))))))
|
|
||||||
(_
|
|
||||||
(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
|
|
||||||
(cond
|
|
||||||
((not self-known?) 'free-ref)
|
|
||||||
((<= free-idx #xff) 'vector-ref/immediate)
|
|
||||||
(else 'vector-ref))
|
|
||||||
(self idx)))))))
|
|
||||||
($continue kidx #f ($const free-idx)))))))))
|
|
||||||
(else (k var))))
|
|
||||||
|
|
||||||
(define (convert-free-vars vars self self-known? free k)
|
|
||||||
"Convert a number of possibly free references to bound references.
|
|
||||||
@var{k} is called with the bound references, and should return the
|
|
||||||
term."
|
|
||||||
(match vars
|
|
||||||
(() (k '()))
|
|
||||||
((var . vars)
|
|
||||||
(convert-free-var var self self-known? free
|
|
||||||
(lambda (var)
|
|
||||||
(convert-free-vars vars self self-known? free
|
|
||||||
(lambda (vars)
|
|
||||||
(k (cons var vars)))))))))
|
|
||||||
|
|
||||||
(define (allocate-closure src name var label known? free body)
|
|
||||||
"Allocate a new closure."
|
|
||||||
(match (cons known? free)
|
|
||||||
((#f . _)
|
|
||||||
(let-fresh (k*) ()
|
|
||||||
(build-cps-term
|
|
||||||
($letk ((k* ($kargs (name) (var) ,body)))
|
|
||||||
($continue k* src
|
|
||||||
($closure label (length free)))))))
|
|
||||||
((#t)
|
|
||||||
;; Well-known closure with no free variables; elide the
|
|
||||||
;; binding entirely.
|
|
||||||
body)
|
|
||||||
((#t _)
|
|
||||||
;; Well-known closure with one free variable; the free var is the
|
|
||||||
;; closure, and no new binding need be made.
|
|
||||||
body)
|
|
||||||
((#t _ _)
|
|
||||||
;; Well-known closure with two free variables; the closure is a
|
|
||||||
;; pair.
|
|
||||||
(let-fresh (kinit kfalse) (false)
|
|
||||||
(build-cps-term
|
|
||||||
($letk ((kinit ($kargs (name) (var)
|
|
||||||
,body))
|
|
||||||
(kfalse ($kargs ('false) (false)
|
|
||||||
($continue kinit src
|
|
||||||
($primcall 'cons (false false))))))
|
|
||||||
($continue kfalse src ($const #f))))))
|
|
||||||
;; Well-known callee with more than two free variables; the closure
|
|
||||||
;; is a vector.
|
|
||||||
((#t . _)
|
|
||||||
(let ((nfree (length free)))
|
|
||||||
(let-fresh (kinit klen kfalse) (false len-var)
|
|
||||||
(build-cps-term
|
|
||||||
($letk ((kinit ($kargs (name) (var) ,body))
|
|
||||||
(kfalse ($kargs ('false) (false)
|
|
||||||
($letk ((klen
|
|
||||||
($kargs ('len) (len-var)
|
|
||||||
($continue kinit src
|
|
||||||
($primcall (if (<= nfree #xff)
|
|
||||||
'make-vector/immediate
|
|
||||||
'make-vector)
|
|
||||||
(len-var false))))))
|
|
||||||
($continue klen src ($const nfree))))))
|
|
||||||
($continue kfalse src ($const #f)))))))))
|
|
||||||
|
|
||||||
(define (init-closure src var known? free
|
|
||||||
outer-self outer-known? outer-free body)
|
|
||||||
"Initialize the free variables @var{free} in a closure bound to
|
|
||||||
@var{var}, 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-free} is the list of free variables there."
|
|
||||||
(match (cons known? free)
|
|
||||||
;; Well-known callee with no free variables; no initialization
|
|
||||||
;; necessary.
|
|
||||||
((#t) body)
|
|
||||||
;; Well-known callee with one free variable; no initialization
|
|
||||||
;; necessary.
|
|
||||||
((#t _) body)
|
|
||||||
;; Well-known callee with two free variables; do a set-car! and
|
|
||||||
;; set-cdr!.
|
|
||||||
((#t v0 v1)
|
|
||||||
(let-fresh (kcar kcdr) ()
|
|
||||||
(convert-free-var
|
|
||||||
v0 outer-self outer-known? outer-free
|
|
||||||
(lambda (v0)
|
|
||||||
(build-cps-term
|
|
||||||
($letk ((kcar ($kargs () ()
|
|
||||||
,(convert-free-var
|
|
||||||
v1 outer-self outer-known? outer-free
|
|
||||||
(lambda (v1)
|
|
||||||
(build-cps-term
|
|
||||||
($letk ((kcdr ($kargs () () ,body)))
|
|
||||||
($continue kcdr src
|
|
||||||
($primcall 'set-cdr! (var v1))))))))))
|
|
||||||
($continue kcar src
|
|
||||||
($primcall 'set-car! (var v0)))))))))
|
|
||||||
;; Otherwise residualize a sequence of vector-set! or free-set!,
|
|
||||||
;; depending on whether the callee is well-known or not.
|
|
||||||
(_
|
|
||||||
(fold (lambda (free idx body)
|
|
||||||
(let-fresh (k) (idxvar)
|
|
||||||
(build-cps-term
|
|
||||||
($letk ((k ($kargs () () ,body)))
|
|
||||||
,(convert-free-var
|
|
||||||
free outer-self outer-known? outer-free
|
|
||||||
(lambda (free)
|
|
||||||
(build-cps-term
|
|
||||||
($letconst (('idx idxvar idx))
|
|
||||||
($continue k src
|
|
||||||
($primcall (cond
|
|
||||||
((not known?) 'free-set!)
|
|
||||||
((<= idx #xff) 'vector-set!/immediate)
|
|
||||||
(else 'vector-set!))
|
|
||||||
(var idxvar free)))))))))))
|
|
||||||
body
|
|
||||||
free
|
|
||||||
(iota (length free))))))
|
|
||||||
|
|
||||||
(define (analyze-closures exp dfg)
|
(define (analyze-closures exp dfg)
|
||||||
"Compute the set of free variables for all $fun instances in
|
"Compute the set of free variables for all $fun instances in
|
||||||
@var{exp}."
|
@var{exp}."
|
||||||
|
|
@ -371,38 +223,183 @@ performed, and @var{outer-free} is the list of free variables there."
|
||||||
(define (well-known? label)
|
(define (well-known? label)
|
||||||
(bitvector-ref well-known label))
|
(bitvector-ref well-known label))
|
||||||
|
|
||||||
;; Load the closure for a known call. The callee may or may not be
|
|
||||||
;; known at all call sites.
|
|
||||||
(define (convert-known-proc-call var label self self-known? free k)
|
|
||||||
;; Well-known closures with one free variable are replaced at their
|
|
||||||
;; use sites by uses of the one free variable. The use sites of a
|
|
||||||
;; well-known closures are only in well-known proc calls, and in
|
|
||||||
;; free lists of other closures. Here we handle the call case; the
|
|
||||||
;; free list case is handled by prune-free-vars.
|
|
||||||
(define (rename var)
|
|
||||||
(let ((var* (vector-ref aliases var)))
|
|
||||||
(if var*
|
|
||||||
(rename var*)
|
|
||||||
var)))
|
|
||||||
(match (cons (well-known? label)
|
|
||||||
(hashq-ref free-vars label))
|
|
||||||
((#t)
|
|
||||||
;; Calling a well-known procedure with no free variables; pass #f
|
|
||||||
;; as the closure.
|
|
||||||
(let-fresh (k*) (v*)
|
|
||||||
(build-cps-term
|
|
||||||
($letk ((k* ($kargs (v*) (v*) ,(k v*))))
|
|
||||||
($continue k* #f ($const #f))))))
|
|
||||||
((#t _)
|
|
||||||
;; Calling a well-known procedure with one free variable; pass
|
|
||||||
;; the free variable as the closure.
|
|
||||||
(convert-free-var (rename var) self self-known? free k))
|
|
||||||
(_
|
|
||||||
(convert-free-var var self self-known? free k))))
|
|
||||||
|
|
||||||
(let ((free (hashq-ref free-vars label))
|
(let ((free (hashq-ref free-vars label))
|
||||||
(self-known? (well-known? label))
|
(self-known? (well-known? label))
|
||||||
(self (match fun (($ $kfun _ _ self) self))))
|
(self (match fun (($ $kfun _ _ self) self))))
|
||||||
|
(define (convert-free-var var k)
|
||||||
|
"Convert one possibly free variable reference to a bound reference.
|
||||||
|
|
||||||
|
If @var{var} is 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{var} is bound, so @var{k} is called with @var{var}."
|
||||||
|
(cond
|
||||||
|
((list-index (cut eq? <> var) free)
|
||||||
|
=> (lambda (free-idx)
|
||||||
|
(match (cons self-known? free)
|
||||||
|
;; A reference to the one free var of a well-known function.
|
||||||
|
((#t _) (k self))
|
||||||
|
;; A reference to one of the two free vars in a well-known
|
||||||
|
;; function.
|
||||||
|
((#t _ _)
|
||||||
|
(let-fresh (k*) (var*)
|
||||||
|
(build-cps-term
|
||||||
|
($letk ((k* ($kargs (var*) (var*) ,(k var*))))
|
||||||
|
($continue k* #f
|
||||||
|
($primcall (match free-idx (0 'car) (1 'cdr)) (self)))))))
|
||||||
|
(_
|
||||||
|
(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
|
||||||
|
(cond
|
||||||
|
((not self-known?) 'free-ref)
|
||||||
|
((<= free-idx #xff) 'vector-ref/immediate)
|
||||||
|
(else 'vector-ref))
|
||||||
|
(self idx)))))))
|
||||||
|
($continue kidx #f ($const free-idx)))))))))
|
||||||
|
(else (k var))))
|
||||||
|
|
||||||
|
(define (convert-free-vars vars k)
|
||||||
|
"Convert a number of possibly free references to bound references.
|
||||||
|
@var{k} is called with the bound references, and should return the
|
||||||
|
term."
|
||||||
|
(match vars
|
||||||
|
(() (k '()))
|
||||||
|
((var . vars)
|
||||||
|
(convert-free-var var
|
||||||
|
(lambda (var)
|
||||||
|
(convert-free-vars vars
|
||||||
|
(lambda (vars)
|
||||||
|
(k (cons var vars)))))))))
|
||||||
|
|
||||||
|
(define (allocate-closure src name var label known? free body)
|
||||||
|
"Allocate a new closure."
|
||||||
|
(match (cons known? free)
|
||||||
|
((#f . _)
|
||||||
|
(let-fresh (k*) ()
|
||||||
|
(build-cps-term
|
||||||
|
($letk ((k* ($kargs (name) (var) ,body)))
|
||||||
|
($continue k* src
|
||||||
|
($closure label (length free)))))))
|
||||||
|
((#t)
|
||||||
|
;; Well-known closure with no free variables; elide the
|
||||||
|
;; binding entirely.
|
||||||
|
body)
|
||||||
|
((#t _)
|
||||||
|
;; Well-known closure with one free variable; the free var is the
|
||||||
|
;; closure, and no new binding need be made.
|
||||||
|
body)
|
||||||
|
((#t _ _)
|
||||||
|
;; Well-known closure with two free variables; the closure is a
|
||||||
|
;; pair.
|
||||||
|
(let-fresh (kinit kfalse) (false)
|
||||||
|
(build-cps-term
|
||||||
|
($letk ((kinit ($kargs (name) (var)
|
||||||
|
,body))
|
||||||
|
(kfalse ($kargs ('false) (false)
|
||||||
|
($continue kinit src
|
||||||
|
($primcall 'cons (false false))))))
|
||||||
|
($continue kfalse src ($const #f))))))
|
||||||
|
;; Well-known callee with more than two free variables; the closure
|
||||||
|
;; is a vector.
|
||||||
|
((#t . _)
|
||||||
|
(let ((nfree (length free)))
|
||||||
|
(let-fresh (kinit klen kfalse) (false len-var)
|
||||||
|
(build-cps-term
|
||||||
|
($letk ((kinit ($kargs (name) (var) ,body))
|
||||||
|
(kfalse
|
||||||
|
($kargs ('false) (false)
|
||||||
|
($letk ((klen
|
||||||
|
($kargs ('len) (len-var)
|
||||||
|
($continue kinit src
|
||||||
|
($primcall (if (<= nfree #xff)
|
||||||
|
'make-vector/immediate
|
||||||
|
'make-vector)
|
||||||
|
(len-var false))))))
|
||||||
|
($continue klen src ($const nfree))))))
|
||||||
|
($continue kfalse src ($const #f)))))))))
|
||||||
|
|
||||||
|
(define (init-closure src var known? closure-free body)
|
||||||
|
"Initialize the free variables @var{closure-free} in a closure
|
||||||
|
bound to @var{var}, and continue with @var{body}."
|
||||||
|
(match (cons known? closure-free)
|
||||||
|
;; Well-known callee with no free variables; no initialization
|
||||||
|
;; necessary.
|
||||||
|
((#t) body)
|
||||||
|
;; Well-known callee with one free variable; no initialization
|
||||||
|
;; necessary.
|
||||||
|
((#t _) body)
|
||||||
|
;; Well-known callee with two free variables; do a set-car! and
|
||||||
|
;; set-cdr!.
|
||||||
|
((#t v0 v1)
|
||||||
|
(let-fresh (kcar kcdr) ()
|
||||||
|
(convert-free-var
|
||||||
|
v0
|
||||||
|
(lambda (v0)
|
||||||
|
(build-cps-term
|
||||||
|
($letk ((kcar ($kargs () ()
|
||||||
|
,(convert-free-var
|
||||||
|
v1
|
||||||
|
(lambda (v1)
|
||||||
|
(build-cps-term
|
||||||
|
($letk ((kcdr ($kargs () () ,body)))
|
||||||
|
($continue kcdr src
|
||||||
|
($primcall 'set-cdr! (var v1))))))))))
|
||||||
|
($continue kcar src
|
||||||
|
($primcall 'set-car! (var v0)))))))))
|
||||||
|
;; Otherwise residualize a sequence of vector-set! or free-set!,
|
||||||
|
;; depending on whether the callee is well-known or not.
|
||||||
|
(_
|
||||||
|
(fold (lambda (free idx body)
|
||||||
|
(let-fresh (k) (idxvar)
|
||||||
|
(build-cps-term
|
||||||
|
($letk ((k ($kargs () () ,body)))
|
||||||
|
,(convert-free-var
|
||||||
|
free
|
||||||
|
(lambda (free)
|
||||||
|
(build-cps-term
|
||||||
|
($letconst (('idx idxvar idx))
|
||||||
|
($continue k src
|
||||||
|
($primcall (cond
|
||||||
|
((not known?) 'free-set!)
|
||||||
|
((<= idx #xff) 'vector-set!/immediate)
|
||||||
|
(else 'vector-set!))
|
||||||
|
(var idxvar free)))))))))))
|
||||||
|
body
|
||||||
|
closure-free
|
||||||
|
(iota (length closure-free))))))
|
||||||
|
|
||||||
|
;; Load the closure for a known call. The callee may or may not be
|
||||||
|
;; known at all call sites.
|
||||||
|
(define (convert-known-proc-call var label self self-known? free k)
|
||||||
|
;; Well-known closures with one free variable are replaced at their
|
||||||
|
;; use sites by uses of the one free variable. The use sites of a
|
||||||
|
;; well-known closures are only in well-known proc calls, and in
|
||||||
|
;; free lists of other closures. Here we handle the call case; the
|
||||||
|
;; free list case is handled by prune-free-vars.
|
||||||
|
(define (rename var)
|
||||||
|
(let ((var* (vector-ref aliases var)))
|
||||||
|
(if var*
|
||||||
|
(rename var*)
|
||||||
|
var)))
|
||||||
|
(match (cons (well-known? label)
|
||||||
|
(hashq-ref free-vars label))
|
||||||
|
((#t)
|
||||||
|
;; Calling a well-known procedure with no free variables; pass #f
|
||||||
|
;; as the closure.
|
||||||
|
(let-fresh (k*) (v*)
|
||||||
|
(build-cps-term
|
||||||
|
($letk ((k* ($kargs (v*) (v*) ,(k v*))))
|
||||||
|
($continue k* #f ($const #f))))))
|
||||||
|
((#t _)
|
||||||
|
;; Calling a well-known procedure with one free variable; pass
|
||||||
|
;; the free variable as the closure.
|
||||||
|
(convert-free-var (rename var) k))
|
||||||
|
(_
|
||||||
|
(convert-free-var var k))))
|
||||||
|
|
||||||
(define (visit-cont cont)
|
(define (visit-cont cont)
|
||||||
(rewrite-cps-cont cont
|
(rewrite-cps-cont cont
|
||||||
(($ $cont label ($ $kargs names vars body))
|
(($ $cont label ($ $kargs names vars body))
|
||||||
|
|
@ -437,8 +434,7 @@ performed, and @var{outer-free} is the list of free variables there."
|
||||||
src name var kfun (well-known? kfun) fun-free
|
src name var kfun (well-known? kfun) fun-free
|
||||||
(bindings body)))
|
(bindings body)))
|
||||||
(init-closure
|
(init-closure
|
||||||
src var
|
src var (well-known? kfun) fun-free
|
||||||
(well-known? kfun) fun-free self self-known? free
|
|
||||||
body)))))))
|
body)))))))
|
||||||
|
|
||||||
(($ $continue k src (or ($ $void) ($ $const) ($ $prim)))
|
(($ $continue k src (or ($ $void) ($ $const) ($ $prim)))
|
||||||
|
|
@ -465,8 +461,7 @@ performed, and @var{outer-free} is the list of free variables there."
|
||||||
(allocate-closure
|
(allocate-closure
|
||||||
src #f var kfun (well-known? kfun) fun-free
|
src #f var kfun (well-known? kfun) fun-free
|
||||||
(init-closure
|
(init-closure
|
||||||
src var
|
src var (well-known? kfun) fun-free
|
||||||
(well-known? kfun) fun-free self self-known? free
|
|
||||||
(build-cps-term ($continue k src ($values (var)))))))))))
|
(build-cps-term ($continue k src ($values (var)))))))))))
|
||||||
|
|
||||||
(($ $continue k src ($ $call proc args))
|
(($ $continue k src ($ $call proc args))
|
||||||
|
|
@ -475,13 +470,13 @@ performed, and @var{outer-free} is the list of free variables there."
|
||||||
(convert-known-proc-call
|
(convert-known-proc-call
|
||||||
proc kfun self self-known? free
|
proc kfun self self-known? free
|
||||||
(lambda (proc)
|
(lambda (proc)
|
||||||
(convert-free-vars args self self-known? free
|
(convert-free-vars args
|
||||||
(lambda (args)
|
(lambda (args)
|
||||||
(build-cps-term
|
(build-cps-term
|
||||||
($continue k src
|
($continue k src
|
||||||
($callk kfun proc args))))))))
|
($callk kfun proc args))))))))
|
||||||
(#f
|
(#f
|
||||||
(convert-free-vars (cons proc args) self self-known? free
|
(convert-free-vars (cons proc args)
|
||||||
(match-lambda
|
(match-lambda
|
||||||
((proc . args)
|
((proc . args)
|
||||||
(build-cps-term
|
(build-cps-term
|
||||||
|
|
@ -489,19 +484,19 @@ performed, and @var{outer-free} is the list of free variables there."
|
||||||
($call proc args)))))))))
|
($call proc args)))))))))
|
||||||
|
|
||||||
(($ $continue k src ($ $primcall name args))
|
(($ $continue k src ($ $primcall name args))
|
||||||
(convert-free-vars args self self-known? free
|
(convert-free-vars args
|
||||||
(lambda (args)
|
(lambda (args)
|
||||||
(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 self-known? free
|
(convert-free-vars args
|
||||||
(lambda (args)
|
(lambda (args)
|
||||||
(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 tag self self-known? free
|
(convert-free-var tag
|
||||||
(lambda (tag)
|
(lambda (tag)
|
||||||
(build-cps-term
|
(build-cps-term
|
||||||
($continue k src
|
($continue k src
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue