[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-908-g983413a
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-908-g983413a |
|
Date: |
Sat, 12 Apr 2014 14:34:20 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=983413a1d9164501cd6c76aa10bf7e7f5b5c3319
The branch, master has been updated
via 983413a1d9164501cd6c76aa10bf7e7f5b5c3319 (commit)
via 8b1a4b23fde4b7b90ff98d14fcf027f8ef9fc4f2 (commit)
via cf8bb03772e9f868ef0cb269624c6642722d60cf (commit)
via 405805fbc3abab129750dc2c0da7be9ea609c34a (commit)
via a0329d01095d6ddaa42449ec18a4fb2bc83db16e (commit)
via b85f5f851fce230d16f3c13c371839f7e619059f (commit)
via 6bc36ca55e76fa595ce5263cc6e701620643e2ab (commit)
via a16af113200d2ccb9c3d060d69f3cd30b961e075 (commit)
via d3dbf75ab38e16d59575dfd49c9c99b01c5bbc12 (commit)
via 686a6490f4cfa368be13b4ca7d4661ae1577384a (commit)
via 8320f50431de0cbbdb091c9f53245236f504f7be (commit)
via 24b611e81ce18b1e311c66d849524b4a1f0f571c (commit)
from 1e91d95704b9e59fc948c07e70082dd18806b2b4 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 983413a1d9164501cd6c76aa10bf7e7f5b5c3319
Author: Andy Wingo <address@hidden>
Date: Sat Apr 12 16:12:33 2014 +0200
Hard-wire calls to known procedures
* module/language/cps/closure-conversion.scm (analyze-closures):
(convert-one, convert-closures): Hard-wire calls to known procedures
by transforming $call to $callk.
commit 8b1a4b23fde4b7b90ff98d14fcf027f8ef9fc4f2
Author: Andy Wingo <address@hidden>
Date: Sat Apr 12 15:53:58 2014 +0200
closure conversion computes well-known functions
* module/language/cps/closure-conversion.scm (analyze-closures)
(convert-closures, convert-one): Adapt to compute well-known
functions. We don't yet produce $callk though.
commit cf8bb03772e9f868ef0cb269624c6642722d60cf
Author: Andy Wingo <address@hidden>
Date: Sat Apr 12 11:52:38 2014 +0200
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.
commit 405805fbc3abab129750dc2c0da7be9ea609c34a
Author: Andy Wingo <address@hidden>
Date: Fri Apr 11 18:01:23 2014 +0200
Separate make-cont-folder into global and local variants
* module/language/cps.scm (make-global-cont-folder)
(make-local-cont-folder): Separate this macro in two. It's hot and
the difference can be important for perf.
* module/language/cps/dfg.scm (compute-label-and-var-ranges):
* module/language/cps/cse.scm (compute-label-and-var-ranges):
* module/language/cps/dce.scm (compute-live-code): Adapt.
commit a0329d01095d6ddaa42449ec18a4fb2bc83db16e
Author: Andy Wingo <address@hidden>
Date: Fri Apr 11 14:01:27 2014 +0200
Root higher-order CPS term is always $kfun $cont
* module/language/cps/arities.scm:
* module/language/cps/closure-conversion.scm:
* module/language/cps/compile-bytecode.scm:
* module/language/cps/constructors.scm:
* module/language/cps/contification.scm:
* module/language/cps/cse.scm:
* module/language/cps/dce.scm:
* module/language/cps/elide-values.scm:
* module/language/cps/prune-bailouts.scm:
* module/language/cps/prune-top-level-scopes.scm:
* module/language/cps/renumber.scm:
* module/language/cps/self-references.scm:
* module/language/cps/simplify.scm:
* module/language/cps/specialize-primcalls.scm:
* module/language/tree-il/compile-cps.scm: Adapt to produce and consume
raw $kfun $cont instances.
* .dir-locals.el: Update $letrec indentation.
commit b85f5f851fce230d16f3c13c371839f7e619059f
Author: Andy Wingo <address@hidden>
Date: Fri Apr 11 11:51:34 2014 +0200
Closure conversion, reify-primitives use $kfun $cont
* module/language/cps/closure-conversion.scm: Produce a $kfun $cont.
* module/language/cps/reify-primitives.scm: Produce and consume $kfun
$cont.
* module/language/cps/compile-bytecode.scm: Adapt.
commit 6bc36ca55e76fa595ce5263cc6e701620643e2ab
Author: Andy Wingo <address@hidden>
Date: Fri Apr 11 11:34:50 2014 +0200
Preparation for compile-bytecode to work on $kfun $conts
* module/language/cps/compile-bytecode.scm (compile-fun): Change to take
a $kfun $cont instead of a $fun.
(visit-funs): Change likewise, and call the proc on $kfun $cont's, not
$fun's.
(compile-bytecode): Adapt.
* module/language/cps/dfg.scm (analyze-reverse-control-flow): Adapt to
expect a $kfun $cont.
commit a16af113200d2ccb9c3d060d69f3cd30b961e075
Author: Andy Wingo <address@hidden>
Date: Fri Apr 11 11:22:06 2014 +0200
compute-dfg takes a $kfun $cont, not a $fun
* module/language/cps/dfg.scm (compute-dfg): Take a $kfun $cont instead
of a $fun.
* module/language/cps/arities.scm:
* module/language/cps/compile-bytecode.scm:
* module/language/cps/contification.scm:
* module/language/cps/cse.scm:
* module/language/cps/dce.scm:
* module/language/cps/simplify.scm:
* module/language/cps/specialize-primcalls.scm: Adapt callers.
commit d3dbf75ab38e16d59575dfd49c9c99b01c5bbc12
Author: Andy Wingo <address@hidden>
Date: Fri Apr 11 10:21:04 2014 +0200
with-fresh-name-state takes a cont, not a $fun
* module/language/cps.scm (with-fresh-name-state): Take a cont instead
of a fun.
* module/language/cps/closure-conversion.scm:
* module/language/cps/constructors.scm:
* module/language/cps/elide-values.scm:
* module/language/cps/prune-bailouts.scm:
* module/language/cps/reify-primitives.scm: Adapt.
commit 686a6490f4cfa368be13b4ca7d4661ae1577384a
Author: Andy Wingo <address@hidden>
Date: Fri Apr 11 10:12:37 2014 +0200
Function defined by make-cont-folder takes a cont, not a $fun
* module/language/cps.scm (make-cont-folder): Take a cont instead of a
$fun.
(with-fresh-name-state): Adapt.
* module/language/cps/cse.scm (compute-label-and-var-ranges):
* module/language/cps/dce.scm (compute-live-code):
* module/language/cps/dfg.scm (compute-dfg):
* module/language/cps/elide-values.scm (elide-values):
* module/language/cps/reify-primitives.scm (reify-primitives):
* module/language/cps/renumber.scm (compute-new-labels-and-vars):
(renumber): Adapt.
commit 8320f50431de0cbbdb091c9f53245236f504f7be
Author: Andy Wingo <address@hidden>
Date: Thu Apr 10 12:11:35 2014 +0200
Rename $kentry to $kfun
* module/language/cps.scm ($kfun): Rename from $kentry.
* module/language/cps/arities.scm:
* module/language/cps/closure-conversion.scm:
* module/language/cps/compile-bytecode.scm:
* module/language/cps/constructors.scm:
* module/language/cps/contification.scm:
* module/language/cps/cse.scm:
* module/language/cps/dce.scm:
* module/language/cps/dfg.scm:
* module/language/cps/effects-analysis.scm:
* module/language/cps/elide-values.scm:
* module/language/cps/prune-bailouts.scm:
* module/language/cps/prune-top-level-scopes.scm:
* module/language/cps/reify-primitives.scm:
* module/language/cps/renumber.scm:
* module/language/cps/self-references.scm:
* module/language/cps/simplify.scm:
* module/language/cps/slot-allocation.scm:
* module/language/cps/specialize-primcalls.scm:
* module/language/cps/verify.scm:
* module/language/tree-il/compile-cps.scm: Adapt users.
commit 24b611e81ce18b1e311c66d849524b4a1f0f571c
Author: Andy Wingo <address@hidden>
Date: Thu Apr 10 10:50:17 2014 +0200
src and meta are fields of $kentry, not $fun
* module/language/cps.scm ($kentry, $fun): Attach "src" and "meta" on
the $kentry, not the $fun. This prepares us for $callk to $kentry
continuations that have no corresponding $fun.
* module/language/cps/arities.scm:
* module/language/cps/closure-conversion.scm:
* module/language/cps/compile-bytecode.scm:
* module/language/cps/constructors.scm:
* module/language/cps/contification.scm:
* module/language/cps/cse.scm:
* module/language/cps/dce.scm:
* module/language/cps/dfg.scm:
* module/language/cps/elide-values.scm:
* module/language/cps/prune-bailouts.scm:
* module/language/cps/prune-top-level-scopes.scm:
* module/language/cps/reify-primitives.scm:
* module/language/cps/renumber.scm:
* module/language/cps/self-references.scm:
* module/language/cps/simplify.scm:
* module/language/cps/slot-allocation.scm:
* module/language/cps/specialize-primcalls.scm:
* module/language/cps/verify.scm:
* module/language/tree-il/compile-cps.scm: Adapt.
-----------------------------------------------------------------------
Summary of changes:
.dir-locals.el | 5 +-
module/language/cps.scm | 208 ++++++++----
module/language/cps/arities.scm | 27 +-
module/language/cps/closure-conversion.scm | 418 ++++++++++++------------
module/language/cps/compile-bytecode.scm | 54 +---
module/language/cps/constructors.scm | 18 +-
module/language/cps/contification.scm | 31 +-
module/language/cps/cse.scm | 41 ++-
module/language/cps/dce.scm | 32 +-
module/language/cps/dfg.scm | 231 ++++++-------
module/language/cps/effects-analysis.scm | 2 +-
module/language/cps/elide-values.scm | 18 +-
module/language/cps/prune-bailouts.scm | 24 +-
module/language/cps/prune-top-level-scopes.scm | 14 +-
module/language/cps/reify-primitives.scm | 147 +++++----
module/language/cps/renumber.scm | 212 +++++++------
module/language/cps/self-references.scm | 19 +-
module/language/cps/simplify.scm | 33 +-
module/language/cps/slot-allocation.scm | 6 +-
module/language/cps/specialize-primcalls.scm | 11 +-
module/language/cps/verify.scm | 6 +-
module/language/tree-il/compile-cps.scm | 25 +-
22 files changed, 836 insertions(+), 746 deletions(-)
diff --git a/.dir-locals.el b/.dir-locals.el
index 597f741..0a2a266 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -26,9 +26,10 @@
(eval . (put '$letconst 'scheme-indent-function 1))
(eval . (put '$continue 'scheme-indent-function 2))
(eval . (put '$kargs 'scheme-indent-function 2))
- (eval . (put '$kentry 'scheme-indent-function 2))
+ (eval . (put '$kfun 'scheme-indent-function 4))
+ (eval . (put '$letrec 'scheme-indent-function 3))
(eval . (put '$kclause 'scheme-indent-function 1))
- (eval . (put '$fun 'scheme-indent-function 2))))
+ (eval . (put '$fun 'scheme-indent-function 1))))
(emacs-lisp-mode . ((indent-tabs-mode . nil)))
(texinfo-mode . ((indent-tabs-mode . nil)
(fill-column . 72))))
diff --git a/module/language/cps.scm b/module/language/cps.scm
index f546628..86cdec5 100644
--- a/module/language/cps.scm
+++ b/module/language/cps.scm
@@ -57,11 +57,11 @@
;;; but which truncates them to some number of required values,
;;; possibly with a rest list.
;;;
-;;; - $kentry labels an entry point for a $fun (a function), and
+;;; - $kfun labels an entry point for a $fun (a function), and
;;; contains a $ktail representing the formal argument which is the
;;; function's continuation.
;;;
-;;; - $kentry also contain a $kclause continuation, corresponding to
+;;; - $kfun also contain a $kclause continuation, corresponding to
;;; the first case-lambda clause of the function. $kclause actually
;;; contains the clause body, and the subsequent clause (if any).
;;; This is because the $kclause logically matches or doesn't match
@@ -71,15 +71,15 @@
;;; That's to say that a $fun can be matched like this:
;;;
;;; (match f
-;;; (($ $fun src meta free
-;;; ($ $cont kentry
-;;; ($ $kentry self ($ $cont ktail _ ($ $ktail))
+;;; (($ $fun free
+;;; ($ $cont kfun
+;;; ($ $kfun src meta self ($ $cont ktail ($ $ktail))
;;; ($ $kclause arity
-;;; ($ $cont kbody _ ($ $kargs names syms body))
+;;; ($ $cont kbody ($ $kargs names syms body))
;;; alternate))))
;;; #t))
;;;
-;;; A $continue to ktail is in tail position. $kentry, $kclause,
+;;; A $continue to ktail is in tail position. $kfun, $kclause,
;;; and $ktail will never be seen elsewhere in a CPS term.
;;;
;;; - $prompt continues to the body of the prompt, having pushed on a
@@ -119,10 +119,14 @@
$cont
;; Continuation bodies.
- $kif $kreceive $kargs $kentry $ktail $kclause
+ $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
@@ -136,7 +140,8 @@
;; Misc.
parse-cps unparse-cps
- make-cont-folder fold-conts fold-local-conts
+ make-global-cont-folder make-local-cont-folder
+ fold-conts fold-local-conts
visit-cont-successors))
;; FIXME: Use SRFI-99, when Guile adds it.
@@ -172,14 +177,14 @@
;; 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)
(define-cps-type $kif kt kf)
(define-cps-type $kreceive arity k)
(define-cps-type $kargs names syms body)
-(define-cps-type $kentry self tail clause)
+(define-cps-type $kfun src meta self tail clause)
(define-cps-type $ktail)
(define-cps-type $kclause arity cont alternate)
@@ -187,13 +192,18 @@
(define-cps-type $void)
(define-cps-type $const val)
(define-cps-type $prim name)
-(define-cps-type $fun src meta 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))
@@ -215,8 +225,7 @@
body ...))
(define-syntax-rule (with-fresh-name-state fun body ...)
- (call-with-values (lambda ()
- (compute-max-label-and-var fun))
+ (call-with-values (lambda () (compute-max-label-and-var fun))
(lambda (max-label max-var)
(parameterize ((label-counter (1+ max-label))
(var-counter (1+ max-var)))
@@ -229,7 +238,7 @@
(make-$arity req opt rest kw allow-other-keys?))))
(define-syntax build-cont-body
- (syntax-rules (unquote $kif $kreceive $kargs $kentry $ktail $kclause)
+ (syntax-rules (unquote $kif $kreceive $kargs $kfun $ktail $kclause)
((_ (unquote exp))
exp)
((_ ($kif kt kf))
@@ -242,8 +251,8 @@
(make-$kargs (list name ...) (list sym ...) (build-cps-term body)))
((_ ($kargs names syms body))
(make-$kargs names syms (build-cps-term body)))
- ((_ ($kentry self tail clause))
- (make-$kentry self (build-cps-cont tail) (build-cps-cont clause)))
+ ((_ ($kfun src meta self tail clause))
+ (make-$kfun src meta self (build-cps-cont tail) (build-cps-cont clause)))
((_ ($ktail))
(make-$ktail))
((_ ($kclause arity cont alternate))
@@ -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 src meta free body))
- (make-$fun src meta 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)))))
@@ -344,9 +360,10 @@
(build-cont-body ($kreceive req rest k)))
(('kargs names syms body)
(build-cont-body ($kargs names syms ,(parse-cps body))))
- (('kentry self tail clause)
+ (('kfun src meta self tail clause)
(build-cont-body
- ($kentry self ,(parse-cps tail) ,(and=> clause parse-cps))))
+ ($kfun (src exp) meta self ,(parse-cps tail)
+ ,(and=> clause parse-cps))))
(('ktail)
(build-cont-body
($ktail)))
@@ -372,11 +389,15 @@
(build-cps-exp ($const exp)))
(('prim name)
(build-cps-exp ($prim name)))
- (('fun meta free body)
- (build-cps-exp ($fun (src exp) meta free ,(parse-cps body))))
+ (('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 ...)
@@ -412,8 +433,8 @@
`(kseq ,(unparse-cps body)))
(($ $kargs names syms body)
`(kargs ,names ,syms ,(unparse-cps body)))
- (($ $kentry self tail clause)
- `(kentry ,self ,(unparse-cps tail) ,(unparse-cps clause)))
+ (($ $kfun src meta self tail clause)
+ `(kfun ,meta ,self ,(unparse-cps tail) ,(unparse-cps clause)))
(($ $ktail)
`(ktail))
(($ $kclause ($ $arity req opt rest kw allow-other-keys?) body alternate)
@@ -429,13 +450,17 @@
`(const ,val))
(($ $prim name)
`(prim ,name))
- (($ $fun src meta free body)
- `(fun ,meta ,free ,(unparse-cps body)))
+ (($ $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)
@@ -449,8 +474,8 @@
(_
(error "unexpected cps" exp))))
-(define-syntax-rule (make-cont-folder global? seed ...)
- (lambda (proc fun seed ...)
+(define-syntax-rule (make-global-cont-folder seed ...)
+ (lambda (proc cont seed ...)
(define (fold-values proc in seed ...)
(if (null? in)
(values seed ...)
@@ -465,7 +490,7 @@
(($ $kargs names syms body)
(term-folder body seed ...))
- (($ $kentry self tail clause)
+ (($ $kfun src meta self tail clause)
(let-values (((seed ...) (cont-folder tail seed ...)))
(if clause
(cont-folder clause seed ...)
@@ -481,7 +506,7 @@
(define (fun-folder fun seed ...)
(match fun
- (($ $fun src meta free body)
+ (($ $fun free body)
(cont-folder body seed ...))))
(define (term-folder term seed ...)
@@ -492,44 +517,99 @@
(($ $continue k src exp)
(match exp
- (($ $fun)
- (if global?
- (fun-folder exp seed ...)
- (values seed ...)))
+ (($ $fun) (fun-folder exp seed ...))
(_ (values seed ...))))
(($ $letrec names syms funs body)
(let-values (((seed ...) (term-folder body seed ...)))
- (if global?
- (fold-values fun-folder funs seed ...)
- (values seed ...))))))
+ (fold-values fun-folder funs seed ...)))))
- (fun-folder fun seed ...)))
+ (cont-folder cont seed ...)))
+
+(define-syntax-rule (make-local-cont-folder seed ...)
+ (lambda (proc cont seed ...)
+ (define (cont-folder cont seed ...)
+ (match cont
+ (($ $cont k (and cont ($ $kargs names syms body)))
+ (let-values (((seed ...) (proc k cont seed ...)))
+ (term-folder body seed ...)))
+ (($ $cont k cont)
+ (proc k cont seed ...))))
+ (define (term-folder term seed ...)
+ (match term
+ (($ $letk conts body)
+ (let-values (((seed ...) (term-folder body seed ...)))
+ (let lp ((conts conts) (seed seed) ...)
+ (match conts
+ (() (values seed ...))
+ ((cont) (cont-folder cont seed ...))
+ ((cont . conts)
+ (let-values (((seed ...) (cont-folder cont seed ...)))
+ (lp conts seed ...)))))))
+ (($ $letrec names syms funs body) (term-folder body seed ...))
+ (_ (values seed ...))))
+ (define (clause-folder clause seed ...)
+ (match clause
+ (($ $cont k (and cont ($ $kclause arity body alternate)))
+ (let-values (((seed ...) (proc k cont seed ...)))
+ (if alternate
+ (let-values (((seed ...) (cont-folder body seed ...)))
+ (clause-folder alternate seed ...))
+ (cont-folder body seed ...))))))
+ (match cont
+ (($ $cont k (and cont ($ $kfun src meta self tail clause)))
+ (let*-values (((seed ...) (proc k cont seed ...))
+ ((seed ...) (if clause
+ (clause-folder clause seed ...)
+ (values seed ...))))
+ (cont-folder tail seed ...))))))
(define (compute-max-label-and-var fun)
- ((make-cont-folder #t 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))))
- (($ $kentry 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-cont-folder #t seed) proc fun seed))
+ ((make-global-cont-folder seed) proc fun seed))
(define (fold-local-conts proc seed fun)
- ((make-cont-folder #f seed) proc fun seed))
+ ((make-local-cont-folder seed) proc fun seed))
(define (visit-cont-successors proc cont)
(match cont
@@ -551,8 +631,8 @@
(($ $kclause arity ($ $cont kbody) ($ $cont kalt)) (proc kbody kalt))
- (($ $kentry self tail ($ $cont clause)) (proc clause))
+ (($ $kfun src meta self tail ($ $cont clause)) (proc clause))
- (($ $kentry self tail #f) (proc))
+ (($ $kfun src meta self tail #f) (proc))
(($ $ktail) (proc))))
diff --git a/module/language/cps/arities.scm b/module/language/cps/arities.scm
index 8b9ce41..c189558 100644
--- a/module/language/cps/arities.scm
+++ b/module/language/cps/arities.scm
@@ -32,16 +32,21 @@
#:use-module (language cps primitives)
#:export (fix-arities))
-(define (fix-clause-arities clause dfg)
+(define (fix-arities* clause dfg)
(let ((ktail (match clause
- (($ $cont _ ($ $kentry _ ($ $cont ktail) _)) ktail))))
+ (($ $cont _
+ ($ $kfun src meta _ ($ $cont ktail) _)) ktail))))
(define (visit-term term)
(rewrite-cps-term term
(($ $letk conts body)
($letk ,(map visit-cont conts) ,(visit-term body)))
(($ $letrec names syms funs body)
- ($letrec names syms (map (cut fix-arities* <> dfg) funs)
- ,(visit-term body)))
+ ($letrec names syms (map (lambda (fun)
+ (rewrite-cps-exp fun
+ (($ $fun free body)
+ ($fun free ,(fix-arities* body dfg)))))
+ funs)
+ ,(visit-term body)))
(($ $continue k src exp)
,(visit-exp k src exp))))
@@ -134,8 +139,9 @@
($ $prim)
($ $values (_)))
,(adapt-exp 1 k src exp))
- (($ $fun)
- ,(adapt-exp 1 k src (fix-arities* exp dfg)))
+ (($ $fun free body)
+ ,(adapt-exp 1 k src (build-cps-exp
+ ($fun free ,(fix-arities* body dfg)))))
((or ($ $call) ($ $callk))
;; In general, calls have unknown return arity. For that
;; reason every non-tail call has a $kreceive continuation to
@@ -181,13 +187,8 @@
,cont)))
(rewrite-cps-cont clause
- (($ $cont sym ($ $kentry self tail clause))
- (sym ($kentry self ,tail ,(and clause (visit-cont clause))))))))
-
-(define (fix-arities* fun dfg)
- (rewrite-cps-exp fun
- (($ $fun src meta free body)
- ($fun src meta free ,(fix-clause-arities body dfg)))))
+ (($ $cont sym ($ $kfun src meta self tail clause))
+ (sym ($kfun src meta self ,tail ,(and clause (visit-cont clause))))))))
(define (fix-arities fun)
(let ((dfg (compute-dfg fun)))
diff --git a/module/language/cps/closure-conversion.scm
b/module/language/cps/closure-conversion.scm
index 89c491f..3c30649 100644
--- a/module/language/cps/closure-conversion.scm
+++ b/module/language/cps/closure-conversion.scm
@@ -34,251 +34,255 @@
#:use-module ((srfi srfi-1) #:select (fold
lset-union lset-difference
list-index))
- #:use-module (ice-9 receive)
+ #:use-module (srfi srfi-9)
#:use-module (srfi srfi-26)
#:use-module (language cps)
+ #:use-module (language cps dfg)
#: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}.
-
address@hidden 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))))))
+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))))
-(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.
address@hidden 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
address@hidden 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)))
- free)))
-
- (($ $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)))
+(define (analyze-closures exp dfg)
+ "Compute the set of free variables for all $fun instances in
address@hidden"
+ (let ((free-vars (make-hash-table))
+ (named-funs (make-hash-table))
+ (well-known (make-bitvector (var-counter) #t)))
+ (define (add-named-fun! var cont)
+ (hashq-set! named-funs var cont))
+ (define (clear-well-known! var)
+ (bitvector-set! well-known var #f))
+ (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))
+ (add-named-fun! self cont)
+ (let ((free (if clause
+ (visit-cont clause (list self))
+ '())))
+ (hashq-set! free-vars 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)))
+ (for-each add-named-fun! vars cont)
+ (fold (lambda (cont free)
+ (union (visit-cont cont bound) free))
+ (visit-term body bound)
+ cont)))
+ (($ $continue k src ($ $fun () body))
+ (match (lookup-predecessors k dfg)
+ ((_) (match (lookup-cont k dfg)
+ (($ $kargs (name) (var))
+ (add-named-fun! var body))))
+ (_ #f))
+ (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)
+ (for-each clear-well-known! args)
+ (fold adjoin (adjoin proc '()) args))
+ (($ $primcall name args)
+ (for-each clear-well-known! args)
+ (fold adjoin '() args))
+ (($ $values args)
+ (for-each clear-well-known! args)
+ (fold adjoin '() args))
+ (($ $prompt escape? tag handler)
+ (clear-well-known! tag)
+ (adjoin tag '()))))
- (($ $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*)))))
+ (let ((free (visit-cont exp '())))
+ (unless (null? free)
+ (error "Expected no free vars in toplevel thunk" free exp))
+ (values free-vars named-funs well-known))))
- (($ $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 src meta () fun-body)) . 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 src meta 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 '()))
+(define (convert-one label free-vars named-funs well-known)
+ (match (hashq-ref free-vars 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
+ ($letk ,(map visit-cont conts) ,(visit-term body))))
- (($ $continue k src ($ $fun src* meta () body))
- (receive (body free) (cc body #f '())
- (match free
- (()
- (values (build-cps-term
- ($continue k src ($fun src* meta 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 src* meta free ,body)))))
- (difference free bound))))))
+ ;; 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 free-vars 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 ($ $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 (or ($ $void) ($ $const) ($ $prim)))
+ term)
- (($ $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 ($ $fun () ($ $cont kfun)))
+ (match (hashq-ref free-vars 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 ($ $primcall name args))
- (convert-free-vars args self bound
- (lambda (args)
- (values (build-cps-term
- ($continue k src ($primcall name args)))
- '()))))
+ (($ $continue k src ($ $call proc args))
+ (let ((def (hashq-ref named-funs proc))
+ (known? (bitvector-ref well-known proc)))
+ (convert-free-vars (cons proc args) self free
+ (match-lambda
+ ((proc . args)
+ (rewrite-cps-term def
+ (($ $cont label)
+ ($continue k src
+ ($callk label proc args)))
+ (#f
+ ($continue k src
+ ($call proc 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 ($ $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 ($ $prompt escape? tag handler))
- (convert-free-var
- tag self bound
- (lambda (tag)
- (values (build-cps-term
- ($continue k src ($prompt escape? tag handler)))
- '()))))
+ (($ $continue k src ($ $primcall name args))
+ (convert-free-vars args self free
+ (lambda (args)
+ (build-cps-term
+ ($continue k src ($primcall name args))))))
- (_ (error "what" exp))))
+ (($ $continue k src ($ $values args))
+ (convert-free-vars args self free
+ (lambda (args)
+ (build-cps-term
+ ($continue k src ($values args))))))
-;; 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
- ($letconst (('idx idx (free-index sym)))
- ($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 ($ $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 ($ $kentry self tail clause))
- (sym ($kentry self ,tail ,(and clause (visit-cont clause)))))))
+ (($ $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 exp)
+(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 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))))))))
+ (let ((dfg (compute-dfg fun)))
+ (with-fresh-name-state-from-dfg dfg
+ (call-with-values (lambda () (analyze-closures fun dfg))
+ (lambda (free-vars named-funs well-known)
+ (let ((labels (sort (hash-map->list (lambda (k v) k) free-vars) <)))
+ (build-cps-term
+ ($program
+ ,(map (cut convert-one <> free-vars named-funs well-known)
+ labels)))))))))
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index bf87f2c..e3e31a0 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -113,10 +113,12 @@
(emit-load-constant asm slot val)
#t)))))
- (define (compile-entry meta)
+ (define (compile-entry)
(let ((label (dfg-min-label dfg)))
(match (lookup-cont label dfg)
- (($ $kentry self tail clause)
+ (($ $kfun src meta self tail clause)
+ (when src
+ (emit-source asm src))
(emit-begin-program asm label meta)
(compile-clause (1+ label))
(emit-end-program asm)))))
@@ -243,10 +245,10 @@
(emit-load-constant asm dst *unspecified*))
(($ $const exp)
(emit-load-constant asm dst exp))
- (($ $fun src meta () ($ $cont k))
+ (($ $closure k 0)
(emit-load-static-procedure asm dst k))
- (($ $fun src meta 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?))
@@ -469,49 +471,21 @@
(emit-call-label asm proc-slot nargs k))))))
(match f
- (($ $fun src meta free ($ $cont k ($ $kentry self tail clause)))
- ;; FIXME: src on kentry instead?
- (when src
- (emit-source asm src))
- (compile-entry (or meta '()))))))
-
-(define (visit-funs proc exp)
- (match exp
- (($ $continue _ _ exp)
- (visit-funs proc exp))
-
- (($ $fun src meta free body)
- (proc exp)
- (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 ($ $kentry self tail clause))
- (when clause
- (visit-funs proc clause)))
-
- (_ (values))))
+ (($ $cont k ($ $kfun src meta self tail clause))
+ (compile-entry)))))
(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)))
diff --git a/module/language/cps/constructors.scm
b/module/language/cps/constructors.scm
index 4bb8670..16de825 100644
--- a/module/language/cps/constructors.scm
+++ b/module/language/cps/constructors.scm
@@ -34,8 +34,8 @@
(rewrite-cps-cont cont
(($ $cont sym ($ $kargs names syms body))
(sym ($kargs names syms ,(visit-term body))))
- (($ $cont sym ($ $kentry self tail clause))
- (sym ($kentry self ,tail ,(and clause (visit-cont clause)))))
+ (($ $cont sym ($ $kfun src meta self tail clause))
+ (sym ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))
(($ $cont sym ($ $kclause arity body alternate))
(sym ($kclause ,arity ,(visit-cont body)
,(and alternate (visit-cont alternate)))))
@@ -47,8 +47,8 @@
($letk ,(map visit-cont conts)
,(visit-term body)))
(($ $letrec names syms funs body)
- ($letrec names syms (map inline-constructors* funs)
- ,(visit-term body)))
+ ($letrec names syms (map visit-fun funs)
+ ,(visit-term body)))
(($ $continue k src ($ $primcall 'list args))
,(let-fresh (kvalues) (val)
(build-cps-term
@@ -90,13 +90,15 @@
($continue kalloc src
($primcall 'make-vector (len init))))))))
(($ $continue k src (and fun ($ $fun)))
- ($continue k src ,(inline-constructors* fun)))
+ ($continue k src ,(visit-fun fun)))
(($ $continue)
,term)))
+ (define (visit-fun fun)
+ (rewrite-cps-exp fun
+ (($ $fun free body)
+ ($fun free ,(inline-constructors* body)))))
- (rewrite-cps-exp fun
- (($ $fun src meta free body)
- ($fun src meta free ,(visit-cont body)))))
+ (visit-cont fun))
(define (inline-constructors fun)
(with-fresh-name-state fun
diff --git a/module/language/cps/contification.scm
b/module/language/cps/contification.scm
index a7e3d36..dc832c3 100644
--- a/module/language/cps/contification.scm
+++ b/module/language/cps/contification.scm
@@ -187,7 +187,7 @@
(if (scope-contains? k-scope term-k)
term-k
(match (lookup-cont k-scope dfg)
- (($ $kentry self tail clause)
+ (($ $kfun src meta self tail clause)
;; K is the tail of some function. If that function
;; has just one clause, return that clause. Otherwise
;; bail.
@@ -219,13 +219,13 @@
(define (visit-fun term)
(match term
- (($ $fun src meta free body)
+ (($ $fun free body)
(visit-cont body))))
(define (visit-cont cont)
(match cont
(($ $cont sym ($ $kargs _ _ body))
(visit-term body sym))
- (($ $cont sym ($ $kentry self tail clause))
+ (($ $cont sym ($ $kfun src meta self tail clause))
(when clause (visit-cont clause)))
(($ $cont sym ($ $kclause arity body alternate))
(visit-cont body)
@@ -251,9 +251,9 @@
(if (null? rec)
'()
(list rec)))
- (((and elt (n s ($ $fun src meta free ($ $cont kentry))))
+ (((and elt (n s ($ $fun free ($ $cont kfun))))
. nsf)
- (if (recursive? kentry)
+ (if (recursive? kfun)
(lp nsf (cons elt rec))
(cons (list elt) (lp nsf rec)))))))
(define (extract-arities+bodies clauses)
@@ -263,9 +263,10 @@
(match component
(((name sym fun) ...)
(match fun
- ((($ $fun src meta free
+ ((($ $fun free
($ $cont fun-k
- ($ $kentry self ($ $cont tail-k ($ $ktail)) clause)))
+ ($ $kfun src meta self ($ $cont tail-k ($ $ktail))
+ clause)))
...)
(call-with-values (lambda () (extract-arities+bodies clause))
(lambda (arities bodies)
@@ -277,9 +278,9 @@
(split-components (map list names syms funs))))
(($ $continue k src exp)
(match exp
- (($ $fun src meta free
+ (($ $fun free
($ $cont fun-k
- ($ $kentry self ($ $cont tail-k ($ $ktail)) clause)))
+ ($ $kfun src meta self ($ $cont tail-k ($ $ktail)) clause)))
(if (and=> (bound-symbol k)
(lambda (sym)
(contify-fun term-k sym self tail-k
@@ -291,7 +292,7 @@
(visit-fun exp)))
(_ #t)))))
- (visit-fun fun)
+ (visit-cont fun)
(values call-substs cont-substs fun-elisions cont-splices)))
(define (apply-contification fun call-substs cont-substs fun-elisions
cont-splices)
@@ -340,8 +341,8 @@
,body)))))))
(define (visit-fun term)
(rewrite-cps-exp term
- (($ $fun src meta free body)
- ($fun src meta free ,(visit-cont body)))))
+ (($ $fun free body)
+ ($fun free ,(visit-cont body)))))
(define (visit-cont cont)
(rewrite-cps-cont cont
(($ $cont (? (cut assq <> fun-elisions)))
@@ -349,8 +350,8 @@
,#f)
(($ $cont sym ($ $kargs names syms body))
(sym ($kargs names syms ,(visit-term body sym))))
- (($ $cont sym ($ $kentry self tail clause))
- (sym ($kentry self ,tail ,(and clause (visit-cont clause)))))
+ (($ $cont sym ($ $kfun src meta self tail clause))
+ (sym ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))
(($ $cont sym ($ $kclause arity body alternate))
(sym ($kclause ,arity ,(visit-cont body)
,(and alternate (visit-cont alternate)))))
@@ -398,7 +399,7 @@
(or (contify-call src proc args)
(continue k src exp)))
(_ (continue k src exp)))))))
- (visit-fun fun))
+ (visit-cont fun))
(define (contify fun)
(call-with-values (lambda () (compute-contification fun))
diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
index a0dea1a..5ca0bb5 100644
--- a/module/language/cps/cse.scm
+++ b/module/language/cps/cse.scm
@@ -222,15 +222,15 @@ be that both true and false proofs are available."
(($ $kclause arity ($ $cont kargs ($ $kargs names syms)))
syms)
(($ $kif) '())
- (($ $kentry self) (list self))
+ (($ $kfun src meta self) (list self))
(($ $ktail) '())))
(lp (1+ n))))
defs))
(define (compute-label-and-var-ranges fun)
(match fun
- (($ $fun src meta free ($ $cont kentry ($ $kentry self)))
- ((make-cont-folder #f min-label label-count min-var var-count)
+ (($ $cont kfun ($ $kfun src meta self))
+ ((make-local-cont-folder min-label label-count min-var var-count)
(lambda (k cont min-label label-count min-var var-count)
(let ((min-label (min k min-label))
(label-count (1+ label-count)))
@@ -246,11 +246,11 @@ be that both true and false proofs are available."
(+ var-count (length vars))))
(($ $letk conts body) (lp body min-var var-count))
(_ (values min-label label-count min-var var-count)))))
- (($ $kentry self)
+ (($ $kfun src meta self)
(values min-label label-count (min self min-var) (1+ var-count)))
(_
(values min-label label-count min-var var-count)))))
- fun kentry 0 self 0))))
+ fun kfun 0 self 0))))
(define (compute-idoms dfg min-label label-count)
(define (label->idx label) (- label min-label))
@@ -349,7 +349,7 @@ be that both true and false proofs are available."
(($ $void) 'void)
(($ $const val) (cons 'const val))
(($ $prim name) (cons 'prim name))
- (($ $fun src meta free body) #f)
+ (($ $fun free body) #f)
(($ $call proc args) #f)
(($ $callk k proc args) #f)
(($ $primcall name args)
@@ -423,16 +423,16 @@ be that both true and false proofs are available."
(vector-ref var-substs idx)
var)))
- (define (visit-entry-cont cont)
+ (define (visit-fun-cont cont)
(rewrite-cps-cont cont
(($ $cont label ($ $kargs names vars body))
(label ($kargs names vars ,(visit-term body label))))
- (($ $cont label ($ $kentry self tail clause))
- (label ($kentry self ,tail
- ,(and clause (visit-entry-cont clause)))))
+ (($ $cont label ($ $kfun src meta self tail clause))
+ (label ($kfun src meta self ,tail
+ ,(and clause (visit-fun-cont clause)))))
(($ $cont label ($ $kclause arity ($ $cont kbody body) alternate))
(label ($kclause ,arity ,(visit-cont kbody body)
- ,(and alternate (visit-entry-cont alternate)))))))
+ ,(and alternate (visit-fun-cont alternate)))))))
(define (visit-cont label cont)
(rewrite-cps-cont cont
@@ -458,8 +458,10 @@ be that both true and false proofs are available."
(define (visit-exp* k src exp)
(match exp
- ((and fun ($ $fun))
- (build-cps-term ($continue k src ,(cse fun dfg))))
+ (($ $fun free body)
+ (build-cps-term
+ ($continue k src
+ ($fun (map subst-var free) ,(cse body dfg)))))
(_
(cond
((vector-ref equiv-labels (label->idx label))
@@ -501,8 +503,13 @@ be that both true and false proofs are available."
(($ $letk conts body)
,(visit-term body label))
(($ $letrec names syms funs body)
- ($letrec names syms (map (lambda (fun) (cse fun dfg)) funs)
- ,(visit-term body label)))
+ ($letrec names syms
+ (map (lambda (fun)
+ (rewrite-cps-exp fun
+ (($ $fun free body)
+ ($fun (map subst-var free) ,(cse body dfg)))))
+ funs)
+ ,(visit-term body label)))
(($ $continue k src exp)
,(let ((conts (append-map visit-dom-conts
(vector-ref doms (label->idx label)))))
@@ -511,9 +518,7 @@ be that both true and false proofs are available."
(build-cps-term
($letk ,conts ,(visit-exp* k src exp))))))))
- (rewrite-cps-exp fun
- (($ $fun src meta free body)
- ($fun src meta (map subst-var free) ,(visit-entry-cont body)))))
+ (visit-fun-cont fun))
(define (cse fun dfg)
(call-with-values (lambda () (compute-equivalent-subexpressions fun dfg))
diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm
index 0aa08f7..9100b93 100644
--- a/module/language/cps/dce.scm
+++ b/module/language/cps/dce.scm
@@ -71,7 +71,7 @@
(($ $kclause arity ($ $cont kargs ($ $kargs names syms)))
syms)
(($ $kif) #f)
- (($ $kentry self) (list self))
+ (($ $kfun src meta self) (list self))
(($ $ktail) #f)))
(lp (1+ n))))
defs))
@@ -90,7 +90,7 @@
(define (ensure-fun-data fun)
(or (hashq-ref fun-data-table fun)
(call-with-values (lambda ()
- ((make-cont-folder #f label-count max-label)
+ ((make-local-cont-folder label-count max-label)
(lambda (k cont label-count max-label)
(values (1+ label-count) (max k max-label)))
fun 0 -1))
@@ -129,7 +129,9 @@
(lp body)
(for-each (lambda (sym fun)
(when (value-live? sym)
- (visit-fun fun)))
+ (match fun
+ (($ $fun free body)
+ (visit-fun body)))))
syms funs))
(($ $continue k src exp)
(unless (bitvector-ref live-conts n)
@@ -140,8 +142,8 @@
(match exp
((or ($ $void) ($ $const) ($ $prim))
#f)
- ((and fun ($ $fun))
- (visit-fun fun))
+ (($ $fun free body)
+ (visit-fun body))
(($ $prompt escape? tag handler)
(mark-live! tag))
(($ $call proc args)
@@ -163,7 +165,7 @@
(($ $kif) #f)
(($ $kclause arity ($ $cont kargs ($ $kargs names syms body)))
(for-each mark-live! syms))
- (($ $kentry self)
+ (($ $kfun src meta self)
(mark-live! self))
(($ $ktail) #f))
(lp (1- n))))))))
@@ -209,10 +211,10 @@
(build-cps-cont
(label ($kargs names syms
,(visit-term body label))))))))
- (($ $kentry self tail clause)
+ (($ $kfun src meta self tail clause)
(list
(build-cps-cont
- (label ($kentry self ,tail
+ (label ($kfun src meta self ,tail
,(and clause (visit-cont clause)))))))
(($ $kclause arity body alternate)
(list
@@ -244,7 +246,12 @@
(match (filter-map
(lambda (name sym fun)
(and (value-live? sym)
- (list name sym (visit-fun fun))))
+ (match fun
+ (($ $fun free body)
+ (list name
+ sym
+ (build-cps-exp
+ ($fun free ,(visit-fun body))))))))
names syms funs)
(() body)
(((names syms funs) ...)
@@ -262,7 +269,8 @@
(($ $continue k src exp)
(if (bitvector-ref live-conts (label->idx term-k))
(rewrite-cps-term exp
- (($ $fun) ($continue k src ,(visit-fun exp)))
+ (($ $fun free body)
+ ($continue k src ($fun free ,(visit-fun body))))
(_
,(match (vector-ref defs (label->idx term-k))
((or #f ((? value-live?) ...))
@@ -274,9 +282,7 @@
($letk (,(make-adaptor adapt k syms))
($continue adapt src ,exp))))))))
(build-cps-term ($continue k src ($values ())))))))
- (rewrite-cps-exp fun
- (($ $fun src meta free body)
- ($fun src meta free ,(visit-cont body)))))))
+ (visit-cont fun))))
(visit-fun fun))
(define (eliminate-dead-code fun)
diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm
index 3180e3d..6bc8d5a 100644
--- a/module/language/cps/dfg.scm
+++ b/module/language/cps/dfg.scm
@@ -325,8 +325,7 @@ body continuation in the prompt."
succs))
(match fun
- (($ $fun src meta free
- ($ $cont kentry ($ $kentry self ($ $cont ktail tail))))
+ (($ $cont kfun ($ $kfun src meta self ($ $cont ktail tail)))
(call-with-values
(lambda ()
(compute-reverse-control-flow-order ktail dfg))
@@ -733,124 +732,11 @@ body continuation in the prompt."
(newline)
(lp (1+ n)))))))
-(define (visit-fun fun conts preds defs uses scopes scope-levels
- min-label min-var global?)
- (define (add-def! var def-k)
- (vector-set! defs (- var min-var) def-k))
-
- (define (add-use! var use-k)
- (vector-push! uses (- var min-var) use-k))
-
- (define* (declare-block! label cont parent
- #:optional (level
- (1+ (vector-ref
- scope-levels
- (- parent min-label)))))
- (vector-set! conts (- label min-label) cont)
- (vector-set! scopes (- label min-label) parent)
- (vector-set! scope-levels (- label min-label) level))
-
- (define (link-blocks! pred succ)
- (vector-push! preds (- succ min-label) pred))
-
- (define (visit exp exp-k)
- (define (def! sym)
- (add-def! sym exp-k))
- (define (use! sym)
- (add-use! sym exp-k))
- (define (use-k! k)
- (link-blocks! exp-k k))
- (define (recur exp)
- (visit exp exp-k))
- (match exp
- (($ $letk (($ $cont k cont) ...) body)
- ;; Set up recursive environment before visiting cont bodies.
- (for-each/2 (lambda (cont k)
- (declare-block! k cont exp-k))
- cont k)
- (for-each/2 visit cont k)
- (recur body))
-
- (($ $kargs names syms body)
- (for-each def! syms)
- (recur body))
-
- (($ $kif kt kf)
- (use-k! kt)
- (use-k! kf))
-
- (($ $kreceive arity k)
- (use-k! k))
-
- (($ $letrec names syms funs body)
- (unless global?
- (error "$letrec should not be present when building a local DFG"))
- (for-each def! syms)
- (for-each
- (cut visit-fun <> conts preds defs uses scopes scope-levels
- min-label min-var global?)
- funs)
- (visit body exp-k))
-
- (($ $continue k src exp)
- (use-k! k)
- (match exp
- (($ $call proc args)
- (use! proc)
- (for-each use! args))
-
- (($ $callk k proc args)
- (use! proc)
- (for-each use! args))
-
- (($ $primcall name args)
- (for-each use! args))
-
- (($ $values args)
- (for-each use! args))
-
- (($ $prompt escape? tag handler)
- (use! tag)
- (use-k! handler))
-
- (($ $fun)
- (when global?
- (visit-fun exp conts preds defs uses scopes scope-levels
- min-label min-var global?)))
-
- (_ #f)))))
-
- (match fun
- (($ $fun src meta free
- ($ $cont kentry
- (and entry
- ($ $kentry self ($ $cont ktail tail) clause))))
- (declare-block! kentry entry #f 0)
- (add-def! self kentry)
-
- (declare-block! ktail tail kentry)
-
- (let lp ((clause clause))
- (match clause
- (#f #t)
- (($ $cont kclause
- (and clause ($ $kclause arity ($ $cont kbody body)
- alternate)))
- (declare-block! kclause clause kentry)
- (link-blocks! kentry kclause)
-
- (declare-block! kbody body kclause)
- (link-blocks! kclause kbody)
-
- (visit body kbody)
- (lp alternate)))))))
-
(define (compute-label-and-var-ranges fun global?)
(define (min* a b)
(if b (min a b) a))
- (define-syntax-rule (do-fold global?)
- ((make-cont-folder global?
- min-label max-label label-count
+ (define-syntax-rule (do-fold make-cont-folder)
+ ((make-cont-folder min-label max-label label-count
min-var max-var var-count)
(lambda (label cont
min-label max-label label-count
@@ -883,7 +769,7 @@ body continuation in the prompt."
(else min-var))
(fold max max-var vars)
(+ var-count (length vars))))))
- (($ $kentry self)
+ (($ $kfun src meta self)
(values min-label max-label (1+ label-count)
(min* self min-var) (max self max-var) (1+ var-count)))
(_ (values min-label max-label (1+ label-count)
@@ -891,8 +777,8 @@ body continuation in the prompt."
fun
#f -1 0 #f -1 0))
(if global?
- (do-fold #t)
- (do-fold #f)))
+ (do-fold make-global-cont-folder)
+ (do-fold make-local-cont-folder)))
(define* (compute-dfg fun #:key (global? #t))
(call-with-values (lambda () (compute-label-and-var-ranges fun global?))
@@ -907,8 +793,109 @@ body continuation in the prompt."
(uses (make-vector nvars '()))
(scopes (make-vector nlabels #f))
(scope-levels (make-vector nlabels #f)))
- (visit-fun fun conts preds defs uses scopes scope-levels
- min-label min-var global?)
+ (define (var->idx var) (- var min-var))
+ (define (label->idx label) (- label min-label))
+
+ (define (add-def! var def-k)
+ (vector-set! defs (var->idx var) def-k))
+ (define (add-use! var use-k)
+ (vector-push! uses (var->idx var) use-k))
+
+ (define* (declare-block! label cont parent
+ #:optional (level
+ (1+ (vector-ref
+ scope-levels
+ (label->idx parent)))))
+ (vector-set! conts (label->idx label) cont)
+ (vector-set! scopes (label->idx label) parent)
+ (vector-set! scope-levels (label->idx label) level))
+
+ (define (link-blocks! pred succ)
+ (vector-push! preds (label->idx succ) pred))
+
+ (define (visit-cont cont label)
+ (match cont
+ (($ $kargs names syms body)
+ (for-each (cut add-def! <> label) syms)
+ (visit-term body label))
+ (($ $kif kt kf)
+ (link-blocks! label kt)
+ (link-blocks! label kf))
+ (($ $kreceive arity k)
+ (link-blocks! label k))))
+
+ (define (visit-term term label)
+ (match term
+ (($ $letk (($ $cont k cont) ...) body)
+ ;; Set up recursive environment before visiting cont bodies.
+ (for-each/2 (lambda (cont k)
+ (declare-block! k cont label))
+ cont k)
+ (for-each/2 visit-cont cont k)
+ (visit-term body label))
+ (($ $letrec names syms funs body)
+ (unless global?
+ (error "$letrec should not be present when building a local
DFG"))
+ (for-each (cut add-def! <> label) syms)
+ (for-each (lambda (fun)
+ (match fun
+ (($ $fun free body)
+ (visit-fun body))))
+ funs)
+ (visit-term body label))
+ (($ $continue k src exp)
+ (link-blocks! label k)
+ (visit-exp exp label))))
+
+ (define (visit-exp exp label)
+ (define (use! sym)
+ (add-use! sym label))
+ (match exp
+ ((or ($ $void) ($ $const) ($ $prim) ($ $closure)) #f)
+ (($ $call proc args)
+ (use! proc)
+ (for-each use! args))
+ (($ $callk k proc args)
+ (use! proc)
+ (for-each use! args))
+ (($ $primcall name args)
+ (for-each use! args))
+ (($ $values args)
+ (for-each use! args))
+ (($ $prompt escape? tag handler)
+ (use! tag)
+ (link-blocks! label handler))
+ (($ $fun free body)
+ (when global?
+ (visit-fun body)))))
+
+ (define (visit-clause clause kfun)
+ (match clause
+ (#f #t)
+ (($ $cont kclause
+ (and clause ($ $kclause arity ($ $cont kbody body)
+ alternate)))
+ (declare-block! kclause clause kfun)
+ (link-blocks! kfun kclause)
+
+ (declare-block! kbody body kclause)
+ (link-blocks! kclause kbody)
+
+ (visit-cont body kbody)
+ (visit-clause alternate kfun))))
+
+ (define (visit-fun fun)
+ (match fun
+ (($ $cont kfun
+ (and cont
+ ($ $kfun src meta self ($ $cont ktail tail) clause)))
+ (declare-block! kfun cont #f 0)
+ (add-def! self kfun)
+ (declare-block! ktail tail kfun)
+ (visit-clause clause kfun))))
+
+ (visit-fun fun)
+
(make-dfg conts preds defs uses scopes scope-levels
min-label max-label label-count
min-var max-var var-count)))))
diff --git a/module/language/cps/effects-analysis.scm
b/module/language/cps/effects-analysis.scm
index a8e7cb2..49b4088 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -487,7 +487,7 @@
(($ $arity _ () _ () #f) (logior (cause &allocation)
(cause &type-check)))))
(($ $kif) &no-effects)
- (($ $kentry) (cause &type-check))
+ (($ $kfun) (cause &type-check))
(($ $kclause) (cause &type-check))
(($ $ktail) &no-effects)))
(lp (1+ n))))
diff --git a/module/language/cps/elide-values.scm
b/module/language/cps/elide-values.scm
index c770f88..6823deb 100644
--- a/module/language/cps/elide-values.scm
+++ b/module/language/cps/elide-values.scm
@@ -40,8 +40,8 @@
(rewrite-cps-cont cont
(($ $cont sym ($ $kargs names syms body))
(sym ($kargs names syms ,(visit-term body))))
- (($ $cont sym ($ $kentry self tail clause))
- (sym ($kentry self ,tail ,(and clause (visit-cont clause)))))
+ (($ $cont sym ($ $kfun src meta self tail clause))
+ (sym ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))
(($ $cont sym ($ $kclause arity body alternate))
(sym ($kclause ,arity ,(visit-cont body)
,(and alternate (visit-cont alternate)))))
@@ -53,8 +53,8 @@
($letk ,(map visit-cont conts)
,(visit-term body)))
(($ $letrec names syms funs body)
- ($letrec names syms (map (cut elide-values* <> conts) funs)
- ,(visit-term body)))
+ ($letrec names syms (map visit-fun funs)
+ ,(visit-term body)))
(($ $continue k src ($ $primcall 'values vals))
,(rewrite-cps-term (vector-ref conts k)
(($ $ktail)
@@ -94,13 +94,15 @@
(build-cps-term
($continue k src ($values vals))))))))
(($ $continue k src (and fun ($ $fun)))
- ($continue k src ,(elide-values* fun conts)))
+ ($continue k src ,(visit-fun fun)))
(($ $continue)
,term)))
+ (define (visit-fun fun)
+ (rewrite-cps-exp fun
+ (($ $fun free cont)
+ ($fun free ,(visit-cont cont)))))
- (rewrite-cps-exp fun
- (($ $fun src meta free body)
- ($fun src meta free ,(visit-cont body)))))
+ (visit-cont fun))
(define (elide-values fun)
(with-fresh-name-state fun
diff --git a/module/language/cps/prune-bailouts.scm
b/module/language/cps/prune-bailouts.scm
index 91afc18..3ba28d9 100644
--- a/module/language/cps/prune-bailouts.scm
+++ b/module/language/cps/prune-bailouts.scm
@@ -50,8 +50,8 @@
(rewrite-cps-cont cont
(($ $cont label ($ $kargs names vars body))
(label ($kargs names vars ,(visit-term body ktail))))
- (($ $cont label ($ $kentry self tail clause))
- (label ($kentry self ,tail
+ (($ $cont label ($ $kfun src meta self tail clause))
+ (label ($kfun src meta self ,tail
,(and clause (visit-cont clause ktail)))))
(($ $cont label ($ $kclause arity body alternate))
(label ($kclause ,arity ,(visit-cont body ktail)
@@ -61,7 +61,7 @@
(define (visit-term term ktail)
(rewrite-cps-term term
(($ $letrec names vars funs body)
- ($letrec names vars (map prune-bailouts* funs)
+ ($letrec names vars (map visit-fun funs)
,(visit-term body ktail)))
(($ $letk conts body)
($letk ,(map (lambda (cont) (visit-cont cont ktail)) conts)
@@ -71,7 +71,7 @@
(define (visit-exp k src exp ktail)
(rewrite-cps-term exp
- (($ $fun) ($continue k src ,(prune-bailouts* exp)))
+ (($ $fun) ($continue k src ,(visit-fun exp)))
(($ $primcall (and name (or 'error 'scm-error 'throw)) args)
,(if (eq? k ktail)
(build-cps-term ($continue k src ,exp))
@@ -86,12 +86,16 @@
,(primitive-ref name kprim src))))))
(_ ($continue k src ,exp))))
- (rewrite-cps-exp fun
- (($ $fun src meta free
- ($ $cont kentry ($ $kentry self ($ $cont ktail ($ $ktail)) clause)))
- ($fun src meta free
- (kentry ($kentry self (ktail ($ktail))
- ,(and clause (visit-cont clause ktail))))))))
+ (define (visit-fun fun)
+ (rewrite-cps-exp fun
+ (($ $fun free body)
+ ($fun free ,(prune-bailouts* body)))))
+
+ (rewrite-cps-cont fun
+ (($ $cont kfun
+ ($ $kfun src meta self ($ $cont ktail ($ $ktail)) clause))
+ (kfun ($kfun src meta self (ktail ($ktail))
+ ,(and clause (visit-cont clause ktail)))))))
(define (prune-bailouts fun)
(with-fresh-name-state fun
diff --git a/module/language/cps/prune-top-level-scopes.scm
b/module/language/cps/prune-top-level-scopes.scm
index 84f3730..2330d31 100644
--- a/module/language/cps/prune-top-level-scopes.scm
+++ b/module/language/cps/prune-top-level-scopes.scm
@@ -41,7 +41,7 @@
(hashq-set! k->scope-var k var)))
(($ $cont k ($ $kargs names syms body))
(visit-term body))
- (($ $cont k ($ $kentry self tail clause))
+ (($ $cont k ($ $kfun src meta self tail clause))
(when clause (visit-cont clause)))
(($ $cont k ($ $kclause arity body alternate))
(visit-cont body)
@@ -82,10 +82,10 @@
(_ #t)))))
(define (visit-fun fun)
(match fun
- (($ $fun src meta free body)
+ (($ $fun free body)
(visit-cont body))))
- (visit-fun fun)
+ (visit-cont fun)
scope-var->used?))
(define (prune-top-level-scopes fun)
@@ -94,8 +94,8 @@
(rewrite-cps-cont cont
(($ $cont sym ($ $kargs names syms body))
(sym ($kargs names syms ,(visit-term body))))
- (($ $cont sym ($ $kentry self tail clause))
- (sym ($kentry self ,tail ,(and clause (visit-cont clause)))))
+ (($ $cont sym ($ $kfun src meta self tail clause))
+ (sym ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))
(($ $cont sym ($ $kclause arity body alternate))
(sym ($kclause ,arity ,(visit-cont body)
,(and alternate (visit-cont alternate)))))
@@ -114,6 +114,4 @@
($continue k src ($primcall 'values ())))
(($ $continue)
,term)))
- (rewrite-cps-exp fun
- (($ $fun src meta free body)
- ($fun src meta free ,(visit-cont body))))))
+ (visit-cont fun)))
diff --git a/module/language/cps/reify-primitives.scm
b/module/language/cps/reify-primitives.scm
index e6d3736..a4d7099 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -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 src meta free body)
- ($fun src meta 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 ($ $kentry self (and tail ($ $cont ktail)) #f))
- ;; A case-lambda with no clauses. Reify a clause.
- (sym ($kentry self ,tail ,(reify-clause ktail))))
- (($ $cont sym ($ $kentry self tail clause))
- (sym ($kentry 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)))))
-
- (visit-fun fun))))
+(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)))))
+
+ (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)))))))
diff --git a/module/language/cps/renumber.scm b/module/language/cps/renumber.scm
index 9136247..ab27653 100644
--- a/module/language/cps/renumber.scm
+++ b/module/language/cps/renumber.scm
@@ -92,7 +92,7 @@
(match cont
(($ $kargs names vars body)
(visit-term body))
- (($ $kentry self tail clause)
+ (($ $kfun src meta self tail clause)
(visit-cont tail)
(when clause
(visit-cont clause)))
@@ -110,9 +110,7 @@
(($ $letrec names syms funs body)
(visit-term body))
(($ $continue k src _) #f)))
- (match fun
- (($ $fun src meta free body)
- (visit-cont body))))
+ (visit-cont fun))
(define (compute-names-in-fun fun)
(define queue '())
@@ -131,7 +129,7 @@
(when reachable?
(for-each rename! vars))
(visit-term body reachable?))
- (($ $kentry self tail clause)
+ (($ $kfun src meta self tail clause)
(unless reachable? (error "entry should be reachable"))
(rename! self)
(visit-cont tail)
@@ -159,106 +157,124 @@
(($ $letrec names syms funs body)
(when reachable?
(for-each rename! syms)
- (set! queue (fold cons queue funs)))
+ (set! queue (fold (lambda (fun queue)
+ (match fun
+ (($ $fun free body)
+ (cons body queue))))
+ queue
+ funs)))
(visit-term body reachable?))
- (($ $continue k src (and fun ($ $fun)))
+ (($ $continue k src ($ $fun free body))
(when reachable?
- (set! queue (cons fun queue))))
+ (set! queue (cons body queue))))
(($ $continue) #f)))
- (collect-conts fun)
(match fun
- (($ $fun src meta free (and entry ($ $cont kentry)))
- (set! next-label (sort-conts kentry labels next-label))
- (visit-cont entry)
- (for-each compute-names-in-fun (reverse queue)))))
+ (($ $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)))
+ (($ $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))))
- (($ $kentry self tail clause)
- (label
- ($kentry (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 src meta free body)
- ($fun src meta (map rename free) ,(must-visit-cont body)))))
- (values (visit-fun fun) nlabels nvars))))
+ (values (apply-renumbering term labels vars) nlabels nvars))))
diff --git a/module/language/cps/self-references.scm
b/module/language/cps/self-references.scm
index bde37a6..6911320 100644
--- a/module/language/cps/self-references.scm
+++ b/module/language/cps/self-references.scm
@@ -35,8 +35,8 @@
(rewrite-cps-cont cont
(($ $cont label ($ $kargs names vars body))
(label ($kargs names vars ,(visit-term body))))
- (($ $cont label ($ $kentry self tail clause))
- (label ($kentry self ,tail
+ (($ $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)
@@ -47,7 +47,7 @@
(rewrite-cps-term term
(($ $letrec names vars funs body)
($letrec names vars (map visit-recursive-fun funs vars)
- ,(visit-term body)))
+ ,(visit-term body)))
(($ $letk conts body)
($letk ,(map visit-cont conts)
,(visit-term body)))
@@ -57,7 +57,8 @@
(define (visit-exp exp)
(rewrite-cps-exp exp
((or ($ $void) ($ $const) ($ $prim)) ,exp)
- (($ $fun) ,(resolve-self-references exp env))
+ (($ $fun free body)
+ ($fun free ,(resolve-self-references body env)))
(($ $call proc args)
($call (subst proc) ,(map subst args)))
(($ $callk k proc args)
@@ -70,10 +71,8 @@
($prompt escape? (subst tag) handler))))
(define (visit-recursive-fun fun var)
- (match fun
- (($ $fun src meta free (and cont ($ $cont _ ($ $kentry self))))
- (resolve-self-references fun (acons var self env)))))
+ (rewrite-cps-exp fun
+ (($ $fun free (and cont ($ $cont _ ($ $kfun src meta self))))
+ ($fun free ,(resolve-self-references cont (acons var self env))))))
- (rewrite-cps-exp fun
- (($ $fun src meta free cont)
- ($fun src meta (map subst free) ,(visit-cont cont)))))
+ (visit-cont fun))
diff --git a/module/language/cps/simplify.scm b/module/language/cps/simplify.scm
index 8c7b898..0dd98e2 100644
--- a/module/language/cps/simplify.scm
+++ b/module/language/cps/simplify.scm
@@ -39,7 +39,7 @@
(match cont
(($ $cont sym ($ $kargs names syms body))
(visit-term body sym syms))
- (($ $cont sym ($ $kentry self tail clause))
+ (($ $cont sym ($ $kfun src meta self tail clause))
(when clause (visit-cont clause)))
(($ $cont sym ($ $kclause arity body alternate))
(visit-cont body)
@@ -62,9 +62,9 @@
#f)))
(define (visit-fun fun)
(match fun
- (($ $fun src meta free body)
+ (($ $fun free body)
(visit-cont body))))
- (visit-fun fun)
+ (visit-cont fun)
table))
(define (eta-reduce fun)
@@ -89,8 +89,9 @@
(rewrite-cps-cont cont
(($ $cont sym ($ $kargs names syms body))
(sym ($kargs names syms ,(visit-term body sym))))
- (($ $cont sym ($ $kentry self tail clause))
- (sym ($kentry self ,tail ,(and clause (visit-cont clause sym)))))
+ (($ $cont sym ($ $kfun src meta self tail clause))
+ (sym ($kfun src meta self ,tail
+ ,(and clause (visit-cont clause sym)))))
(($ $cont sym ($ $kclause arity body alternate))
(sym ($kclause ,arity ,(visit-cont body sym)
,(and alternate (visit-cont alternate sym)))))
@@ -114,9 +115,9 @@
($continue (reduce k scope) src ,exp))))
(define (visit-fun fun)
(rewrite-cps-exp fun
- (($ $fun src meta free body)
- ($fun src meta free ,(visit-cont body #f)))))
- (visit-fun fun)))
+ (($ $fun free body)
+ ($fun free ,(visit-cont body #f)))))
+ (visit-cont fun #f)))
(define (compute-beta-reductions fun)
;; A continuation's body can be inlined in place of a $values
@@ -129,7 +130,7 @@
(match cont
(($ $cont sym ($ $kargs names syms body))
(visit-term body))
- (($ $cont sym ($ $kentry self tail clause))
+ (($ $cont sym ($ $kfun src meta self tail clause))
(when clause (visit-cont clause)))
(($ $cont sym ($ $kclause arity body alternate))
(visit-cont body)
@@ -165,9 +166,9 @@
#f)))
(define (visit-fun fun)
(match fun
- (($ $fun src meta free body)
+ (($ $fun free body)
(visit-cont body))))
- (visit-fun fun)
+ (visit-cont fun)
(values var-table k-table)))
(define (beta-reduce fun)
@@ -185,8 +186,8 @@
(rewrite-cps-cont cont
(($ $kargs names syms body)
(sym ($kargs names syms ,(visit-term body))))
- (($ $kentry self tail clause)
- (sym ($kentry self ,tail
+ (($ $kfun src meta self tail clause)
+ (sym ($kfun src meta self ,tail
,(and clause (must-visit-cont clause)))))
(($ $kclause arity body alternate)
(sym ($kclause ,arity ,(must-visit-cont body)
@@ -229,9 +230,9 @@
(build-cps-exp ($prompt escape? (subst tag)
handler)))))))))))
(define (visit-fun fun)
(rewrite-cps-exp fun
- (($ $fun src meta free body)
- ($fun src meta (map subst free) ,(must-visit-cont body)))))
- (visit-fun fun)))
+ (($ $fun free body)
+ ($fun (map subst free) ,(must-visit-cont body)))))
+ (must-visit-cont fun)))
(define (simplify fun)
;; Renumbering prunes continuations that are made unreachable by
diff --git a/module/language/cps/slot-allocation.scm
b/module/language/cps/slot-allocation.scm
index e5f3117..47e6284 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -337,7 +337,7 @@ are comparable with eqv?. A tmp slot may be used."
(let lp ((n 0))
(when (< n (vector-length usev))
(match (lookup-cont (idx->label n) dfg)
- (($ $kentry self)
+ (($ $kfun src meta self)
(vector-set! defv n (list (dfa-var-idx dfa self))))
(($ $kargs names syms body)
(vector-set! defv n (map (cut dfa-var-idx dfa <>) syms))
@@ -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
@@ -671,7 +671,7 @@ are comparable with eqv?. A tmp slot may be used."
(error "Unexpected clause order"))))
(visit-clauses next live))))))
(match (lookup-cont (idx->label 0) dfg)
- (($ $kentry self)
+ (($ $kfun src meta self)
(visit-clauses 1 (allocate-defs! 0 (empty-live-slots))))))
(compute-constants!)
diff --git a/module/language/cps/specialize-primcalls.scm
b/module/language/cps/specialize-primcalls.scm
index e1283e4..e03eb62 100644
--- a/module/language/cps/specialize-primcalls.scm
+++ b/module/language/cps/specialize-primcalls.scm
@@ -41,8 +41,9 @@
(rewrite-cps-cont cont
(($ $cont sym ($ $kargs names syms body))
(sym ($kargs names syms ,(visit-term body))))
- (($ $cont sym ($ $kentry self tail clause))
- (sym ($kentry self ,tail ,(and clause (visit-cont clause)))))
+ (($ $cont sym ($ $kfun src meta self tail clause))
+ (sym ($kfun src meta self ,tail
+ ,(and clause (visit-cont clause)))))
(($ $cont sym ($ $kclause arity body alternate))
(sym ($kclause ,arity ,(visit-cont body)
,(and alternate (visit-cont alternate)))))
@@ -107,7 +108,7 @@
(define (visit-fun fun)
(rewrite-cps-exp fun
- (($ $fun src meta free body)
- ($fun src meta free ,(visit-cont body)))))
+ (($ $fun free body)
+ ($fun free ,(visit-cont body)))))
- (visit-fun fun))))
+ (visit-cont fun))))
diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm
index d521351..4352f20 100644
--- a/module/language/cps/verify.scm
+++ b/module/language/cps/verify.scm
@@ -82,7 +82,7 @@
(error "name and sym lengths don't match" name sym))
(visit-term body k-env (add-vars sym v-env)))
(_
- ;; $kclause, $kentry, and $ktail are only ever seen in $fun.
+ ;; $kclause, $kfun, and $ktail are only ever seen in $fun.
(error "unexpected cont body" cont))))
(define (visit-clause clause k-env v-env)
@@ -115,9 +115,9 @@
(define (visit-fun fun k-env v-env)
(match fun
- (($ $fun src meta (free ...)
+ (($ $fun (free ...)
($ $cont kbody
- ($ $kentry self ($ $cont ktail ($ $ktail)) clause)))
+ ($ $kfun src meta self ($ $cont ktail ($ $ktail)) clause)))
(when (and meta (not (and (list? meta) (and-map pair? meta))))
(error "meta should be alist" meta))
(for-each (cut check-var <> v-env) free)
diff --git a/module/language/tree-il/compile-cps.scm
b/module/language/tree-il/compile-cps.scm
index 5e7e66f..96f27cd 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -294,12 +294,12 @@
arity gensyms inits)))
,(convert-clauses alternate ktail))))))))))
(if (current-topbox-scope)
- (let-fresh (kentry ktail) (self)
+ (let-fresh (kfun ktail) (self)
(build-cps-term
($continue k fun-src
- ($fun fun-src meta '()
- (kentry ($kentry self (ktail ($ktail))
- ,(convert-clauses body ktail)))))))
+ ($fun '()
+ (kfun ($kfun fun-src meta self (ktail ($ktail))
+ ,(convert-clauses body ktail)))))))
(let ((scope-id (fresh-scope-id)))
(let-fresh (kscope) ()
(build-cps-term
@@ -603,15 +603,14 @@ integer."
(scope-counter 0))
(let ((src (tree-il-src exp)))
(let-fresh (kinit ktail kclause kbody) (init)
- (build-cps-exp
- ($fun src '() '()
- (kinit ($kentry init (ktail ($ktail))
- (kclause
- ($kclause ('() '() #f '() #f)
- (kbody ($kargs () ()
- ,(convert exp ktail
- (build-subst exp))))
- ,#f))))))))))
+ (build-cps-cont
+ (kinit ($kfun src '() init (ktail ($ktail))
+ (kclause
+ ($kclause ('() '() #f '() #f)
+ (kbody ($kargs () ()
+ ,(convert exp ktail
+ (build-subst exp))))
+ ,#f)))))))))
(define *comp-module* (make-fluid))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-908-g983413a,
Andy Wingo <=