[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-845-g6e5e9ff
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-845-g6e5e9ff |
|
Date: |
Mon, 31 Mar 2014 17:06:11 +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=6e5e9ffb7564501e8ef0ce21137ad450f8107761
The branch, master has been updated
via 6e5e9ffb7564501e8ef0ce21137ad450f8107761 (commit)
via 90dce16db470716e1dffbeb21ee19ab2e277bae6 (commit)
via a3a45279c0e642c657f749dc6454cc66c4f3dbe1 (commit)
via 4bf757b8106d275f6882b47a523db4aa6670dcb3 (commit)
via 4926024cfbd9d0a428880a919b6e5a394b4a304d (commit)
via de3cbadcc08f7f46bab0d91d4dcc5bac2f64613f (commit)
via 5fc403911e5c23c8f7d7cac83514e7ee0953eb36 (commit)
via 21d6d183a95103f478a8acea76bde9e2283214be (commit)
via f49e994b5291267e433cc2e29f4f35b1c197b81d (commit)
via 62b7180bfdad20ffce4497d5aa451f130b5c364a (commit)
via f05517b24e65e0b14f29c57ad0c83ade9d7f1f14 (commit)
via 98c5b69fa0bcf29592421766a50dd6ae3bdd6ae8 (commit)
via b99553301c88e87b856b11cc539a03f0fa3ac0e8 (commit)
via cec43eb8f6b12d713e6a1205a32e44a0320f4c9f (commit)
via 29619661e45c437f802811207011e86fbb0694f9 (commit)
via 5e897908967c02b0998654db2fa4af93940279d0 (commit)
via fbdb69b21c9efd9272033b6bc0397eb89e2ac9f5 (commit)
via a6f823bd027b091114eeca9fe651e1025be1e537 (commit)
via 1eda52c8adb6eef950ddd7e3ffd0606314fb0ed8 (commit)
via b9e601d20ded2d931d36a81a38a27449d8c2ae80 (commit)
via eb60b4136b96339774e2746194a778b7e1526b6a (commit)
via e6cf744ab4478de939016026ad7a4d6f48fa2592 (commit)
via 699ed8ce2903429faec45006e29481b49ef06fb5 (commit)
via ef58442a0541eb382476d833f540fff01a4e4007 (commit)
via cd72929e71e61b31d09ef8aa1a926674acf140e2 (commit)
via 39056a81fcff9ef0880ca385e87b6859acae9943 (commit)
via 828ed94469b4c8cf69db08e6aeb12b399b67ed20 (commit)
via 053473531464236f8ecf16a4038249cecfd5984c (commit)
via 9a1dfb7d2ecfea1642f14ab2baacf9efea49131a (commit)
from ecc7987427a32fb0748de05bcca0b65fb16a3b26 (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 6e5e9ffb7564501e8ef0ce21137ad450f8107761
Author: Andy Wingo <address@hidden>
Date: Mon Mar 31 18:08:11 2014 +0200
Fix analyze-control-flow to preserve order among unordered labels
* module/language/cps/dfg.scm (analyze-control-flow): Sort blocks to
preserve order among unordered successors.
(lookup-successors): Choose a more natural order, now that it doesn't
matter.
commit 90dce16db470716e1dffbeb21ee19ab2e277bae6
Author: Andy Wingo <address@hidden>
Date: Mon Mar 31 16:38:53 2014 +0200
Use Tree-IL-like case-lambda clause chaining in CPS
* module/language/cps.scm ($kclause, $kentry): Instead of having an
entry continuation contain a list of clauses, have the clauses contain
clauses (as in Tree-IL). In some ways it's not as convenient but it
does reflect the continuation tree correctly.
* 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/dce.scm:
* module/language/cps/dfg.scm:
* module/language/cps/elide-values.scm:
* module/language/cps/prune-top-level-scopes.scm:
* module/language/cps/reify-primitives.scm:
* module/language/cps/renumber.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 aaaaaaall users.
commit a3a45279c0e642c657f749dc6454cc66c4f3dbe1
Author: Andy Wingo <address@hidden>
Date: Mon Mar 31 12:10:08 2014 +0200
Rewrite control-point? to avoid consing
* module/language/cps/dfg.scm (control-point?): Rewrite to avoid consing
a successors list.
commit 4bf757b8106d275f6882b47a523db4aa6670dcb3
Author: Andy Wingo <address@hidden>
Date: Mon Mar 31 12:09:46 2014 +0200
Remove succs from DFG
* module/language/cps/dfg.scm ($dfg): Remove "succs" from DFG. Instead
we can compute the successors set on-demand.
(lookup-successors): Adapt.
commit 4926024cfbd9d0a428880a919b6e5a394b4a304d
Author: Andy Wingo <address@hidden>
Date: Sun Mar 30 22:28:07 2014 +0200
Simplify boot-9 and srfi-1 map
* module/ice-9/boot-9.scm (map):
* module/srfi/srfi-1.scm (map): Simplify the implementations to check
for list? beforehand. It's faster, and it will be needed if we decide
to go recursive.
commit de3cbadcc08f7f46bab0d91d4dcc5bac2f64613f
Author: Andy Wingo <address@hidden>
Date: Sun Mar 30 21:28:10 2014 +0200
Avoid consing in compute-label-and-var-ranges.
* module/language/cps/dfg.scm (compute-label-and-var-ranges): Avoid
consing.
commit 5fc403911e5c23c8f7d7cac83514e7ee0953eb36
Author: Andy Wingo <address@hidden>
Date: Sun Mar 30 21:14:31 2014 +0200
Scope and scope-level in DFG vector
* module/language/cps/dfg.scm ($dfg): Hoist scopes and scope levels out
of $block and into $dfg. Adapt all callers.
commit 21d6d183a95103f478a8acea76bde9e2283214be
Author: Andy Wingo <address@hidden>
Date: Sun Mar 30 20:55:57 2014 +0200
Predecessors and successors in DFG vectors
* module/language/cps/dfg.scm ($dfg, $block): Record predecessors and
successors in vectors instead of in $block data structures. Adapt
users.
commit f49e994b5291267e433cc2e29f4f35b1c197b81d
Author: Andy Wingo <address@hidden>
Date: Sun Mar 30 20:27:31 2014 +0200
DFG refactor
* module/language/cps/dfg.scm (lookup-cont, lookup-block):
(lookup-def, constant-needs-allocation?): Rework these accessors to
avoid completely destructuring the $dfg.
commit 62b7180bfdad20ffce4497d5aa451f130b5c364a
Author: Andy Wingo <address@hidden>
Date: Sun Mar 30 19:31:07 2014 +0200
Renumber functions before emitting code
* module/language/cps/compile-bytecode.scm (compile-bytecode): Renumber
a function before going to compile it, so that the vars and labels are
contiguous within each function.
commit f05517b24e65e0b14f29c57ad0c83ade9d7f1f14
Author: Andy Wingo <address@hidden>
Date: Sun Mar 30 19:09:40 2014 +0200
Add renumber module
* module/language/cps/renumber.scm: New module.
* module/Makefile.am: Add to build.
fix renumber
commit 98c5b69fa0bcf29592421766a50dd6ae3bdd6ae8
Author: Andy Wingo <address@hidden>
Date: Sun Mar 30 11:48:47 2014 +0200
Replace use-map in DFG with separate def / use vectors
* module/language/cps/dfg.scm ($dfg, $use-map): Replace use-map vector
with "defs" and "uses" vectors. Adapt callers.
commit b99553301c88e87b856b11cc539a03f0fa3ac0e8
Author: Andy Wingo <address@hidden>
Date: Sun Mar 30 11:36:59 2014 +0200
Remove "sym" from $use-map
* module/language/cps/dfg.scm ($use-map): Remove "sym" from use-map;
it's redundant. Adapt callers.
commit cec43eb8f6b12d713e6a1205a32e44a0320f4c9f
Author: Andy Wingo <address@hidden>
Date: Sun Mar 30 11:25:23 2014 +0200
$use-map no longer has name member
* module/language/cps/dfg.scm ($use-map): Remove name member. Adapt
users.
commit 29619661e45c437f802811207011e86fbb0694f9
Author: Andy Wingo <address@hidden>
Date: Sun Mar 30 11:23:51 2014 +0200
$dfa no longer includes name vector (can get that from dfg)
* module/language/cps/dfg.scm ($dfa, dfa-var-name):
(compute-live-variables, print-dfa): Remove "names" from DFAs.
commit 5e897908967c02b0998654db2fa4af93940279d0
Author: Andy Wingo <address@hidden>
Date: Sun Mar 30 11:14:45 2014 +0200
DFG stores conts, blocks, and use-maps in vectors
* module/language/cps/dfg.scm ($dfg): Change to store conts, blocks, and
use-maps as vectors. A DFG also records the minimum label, minimum
variable, and the number of labels and variables. The first entry in
one of these vectors corresponds to the minimum. This can be
optimum in the local case if the conts and variables have been renamed
appropriately.
Adapt callers.
(compute-live-variables): Adapt. This is currently suboptimal but it
works, so it's a useful base for optimization.
commit fbdb69b21c9efd9272033b6bc0397eb89e2ac9f5
Author: Andy Wingo <address@hidden>
Date: Sun Mar 30 10:41:31 2014 +0200
lookup-cont takes a DFG as its argument
* module/language/cps/dfg.scm (lookup-cont): Change to take a DFG
instead of a cont table.
(build-cont-table): Change to return a vector.
* module/language/cps/arities.scm:
* module/language/cps/contification.scm:
* module/language/cps/dce.scm:
* module/language/cps/effects-analysis.scm:
* module/language/cps/elide-values.scm:
* module/language/cps/reify-primitives.scm:
* module/language/cps/simplify.scm:
* module/language/cps/slot-allocation.scm: Adapt to lookup-cont and
build-cont-table changes.
commit a6f823bd027b091114eeca9fe651e1025be1e537
Author: Andy Wingo <address@hidden>
Date: Sat Mar 29 07:56:08 2014 +0100
Public make-cont-folder
* module/language/cps.scm (make-cont-folder): Add global? parameter, and
make public.
(fold-conts): Adapt.
(fold-local-conts): Use make-cont-folder, and take a function instead
of a continuation.
* module/language/cps/arities.scm (fix-clause-arities, fix-arities*):
* module/language/cps/compile-bytecode.scm (collect-conts):
* module/language/cps/elide-values.scm (elide-values*): Adapt to
fold-local-conts change.
commit 1eda52c8adb6eef950ddd7e3ffd0606314fb0ed8
Author: Andy Wingo <address@hidden>
Date: Fri Mar 28 22:27:48 2014 +0100
Vars and labels are separate namespaces
* module/language/cps.scm (fresh-var, with-fresh-name-state): Vars have
their own namespace.
commit b9e601d20ded2d931d36a81a38a27449d8c2ae80
Author: Andy Wingo <address@hidden>
Date: Fri Mar 28 21:55:46 2014 +0100
Prepare for decoupling of var/label name uniqueness
* module/language/cps/simplify.scm (compute-beta-reductions):
(beta-reduce): Separate state into two tables, so we can relax current
guarantee that vars and labels are mutually unique.
commit eb60b4136b96339774e2746194a778b7e1526b6a
Author: Andy Wingo <address@hidden>
Date: Fri Mar 28 21:32:26 2014 +0100
Update verify-cps
* module/language/cps/verify.scm (verify-cps): Vars should only be exact
integers now.
commit e6cf744ab4478de939016026ad7a4d6f48fa2592
Author: Andy Wingo <address@hidden>
Date: Fri Mar 28 21:30:55 2014 +0100
CPS conversion renames incoming gensyms to small integers
* module/language/tree-il/compile-cps.scm (fold-formals)
(unbound?, init-default-value, convert): Arrange to rename incoming
gensyms as small integers.
(canonicalize): Convert vector and abort here too.
commit 699ed8ce2903429faec45006e29481b49ef06fb5
Author: Andy Wingo <address@hidden>
Date: Fri Mar 28 19:17:22 2014 +0100
Less copying in tree-il pre-order / post-order.
* module/language/tree-il.scm (pre-post-order): If the pre handler
doesn't modify the components of a tree-il expression, avoid copying a
new one.
commit ef58442a0541eb382476d833f540fff01a4e4007
Author: Andy Wingo <address@hidden>
Date: Fri Mar 28 17:51:37 2014 +0100
Prompt-related refactor in compile-cps
* module/language/tree-il/compile-cps.scm (fix-prompts): New procedure.
Eta-expand prompts before compiling to ensure that they have inline
handlers.
commit cd72929e71e61b31d09ef8aa1a926674acf140e2
Author: Andy Wingo <address@hidden>
Date: Fri Mar 28 16:57:40 2014 +0100
DCE uses fresh-var instead of gensym
* module/language/cps/dce.scm (eliminate-dead-code): Use fresh-var
instead of gensym.
commit 39056a81fcff9ef0880ca385e87b6859acae9943
Author: Andy Wingo <address@hidden>
Date: Fri Mar 28 16:55:15 2014 +0100
Adapt verify-cps to CPS changes
* module/language/cps/verify.scm (verify-cps): Update to expect integer
labels, and to allow integer variables.
commit 828ed94469b4c8cf69db08e6aeb12b399b67ed20
Author: Andy Wingo <address@hidden>
Date: Fri Mar 28 16:29:16 2014 +0100
Replace all let-gensyms uses with let-fresh
* .dir-locals.el: Add with-fresh-name-state.
* module/language/cps.scm (fresh-label, fresh-var): Signal an error if
the counters are not initialized.
(with-fresh-name-state): New macro.
(make-cont-folder): New macro, generates an n-ary folder.
(compute-max-label-and-var): New function, uses make-cont-folder.
(fold-conts): Use make-cont-folder.
(let-gensyms): Remove.
* module/language/cps/arities.scm:
* module/language/cps/closure-conversion.scm:
* module/language/cps/constructors.scm:
* module/language/cps/dce.scm:
* module/language/cps/elide-values.scm:
* module/language/cps/reify-primitives.scm:
* module/language/cps/specialize-primcalls.scm: Use let-fresh instead of
let-gensyms, and wrap in a with-fresh-name-state as needed.
* module/language/tree-il/compile-cps.scm: Remove hack to avoid
importing let-gensyms from (language tree-il).
commit 053473531464236f8ecf16a4038249cecfd5984c
Author: Andy Wingo <address@hidden>
Date: Fri Mar 28 14:23:51 2014 +0100
Remove unneeded local exact-integer? definition
* module/system/vm/assembler.scm (link-debug): Remove unneeded
exact-integer? definition.
commit 9a1dfb7d2ecfea1642f14ab2baacf9efea49131a
Author: Andy Wingo <address@hidden>
Date: Fri Mar 28 14:21:06 2014 +0100
Continuation labels and variable identifiers may be integers
* module/language/cps.scm (label-counter, var-counter): New parameters,
for producing fresh label and var names.
(fresh-label, fresh-var): New procedures.
(let-fresh): New macro, will replace let-gensyms.
(build-cps-term): Use let-fresh.
* module/language/tree-il/compile-cps.scm: Use let-fresh to generate
fresh names.
* module/system/vm/assembler.scm (make-meta, begin-kw-arity): Allow
exact integers as labels.
(link-debug): Explicitly mark low-pc as being an "addr" value.
-----------------------------------------------------------------------
Summary of changes:
.dir-locals.el | 2 +
module/Makefile.am | 1 +
module/ice-9/boot-9.scm | 65 +---
module/language/cps.scm | 237 +++++++----
module/language/cps/arities.scm | 49 ++-
module/language/cps/closure-conversion.scm | 51 ++-
module/language/cps/compile-bytecode.scm | 56 ++--
module/language/cps/constructors.scm | 29 +-
module/language/cps/contification.scm | 72 ++--
module/language/cps/dce.scm | 219 +++++-----
module/language/cps/dfg.scm | 538 ++++++++++++------------
module/language/cps/effects-analysis.scm | 2 +-
module/language/cps/elide-values.scm | 136 +++---
module/language/cps/prune-top-level-scopes.scm | 18 +-
module/language/cps/reify-primitives.scm | 123 +++---
module/language/cps/renumber.scm | 184 ++++++++
module/language/cps/simplify.scm | 68 ++--
module/language/cps/slot-allocation.scm | 15 +-
module/language/cps/specialize-primcalls.scm | 154 ++++----
module/language/cps/verify.scm | 88 +++--
module/language/tree-il.scm | 205 ++++++---
module/language/tree-il/compile-cps.scm | 424 ++++++++++---------
module/srfi/srfi-1.scm | 19 +-
module/system/vm/assembler.scm | 9 +-
24 files changed, 1581 insertions(+), 1183 deletions(-)
create mode 100644 module/language/cps/renumber.scm
diff --git a/.dir-locals.el b/.dir-locals.el
index 0589229..2efca64 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -12,6 +12,8 @@
(eval . (put 'with-code-coverage 'scheme-indent-function 1))
(eval . (put 'with-statprof 'scheme-indent-function 1))
(eval . (put 'let-gensyms 'scheme-indent-function 1))
+ (eval . (put 'let-fresh 'scheme-indent-function 2))
+ (eval . (put 'with-fresh-name-state 'scheme-indent-function 1))
(eval . (put 'build-cps-term 'scheme-indent-function 0))
(eval . (put 'build-cps-exp 'scheme-indent-function 0))
(eval . (put 'build-cps-cont 'scheme-indent-function 0))
diff --git a/module/Makefile.am b/module/Makefile.am
index 42ee4b2..0e2ce6d 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -131,6 +131,7 @@ CPS_LANG_SOURCES =
\
language/cps/primitives.scm \
language/cps/prune-top-level-scopes.scm \
language/cps/reify-primitives.scm \
+ language/cps/renumber.scm \
language/cps/slot-allocation.scm \
language/cps/simplify.scm \
language/cps/spec.scm \
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 4d5d603..8bc8e53 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -837,58 +837,23 @@ for key @var{k}, then invoke @var{thunk}."
(define map
(case-lambda
((f l)
- (let map1 ((hare l) (tortoise l) (move? #f) (out '()))
- (if (pair? hare)
- (if move?
- (if (eq? tortoise hare)
- (scm-error 'wrong-type-arg "map" "Circular list: ~S"
- (list l) #f)
- (map1 (cdr hare) (cdr tortoise) #f
- (cons (f (car hare)) out)))
- (map1 (cdr hare) tortoise #t
- (cons (f (car hare)) out)))
- (if (null? hare)
- (reverse! out)
- (scm-error 'wrong-type-arg "map" "Not a list: ~S"
- (list l) #f)))))
+ (unless (list? l)
+ (scm-error 'wrong-type-arg "map" "Not a list: ~S"
+ (list l) #f))
+ (let map1 ((l l) (out '()))
+ (if (pair? l)
+ (map1 (cdr l) (cons (f (car l)) out))
+ (reverse! out))))
((f l1 l2)
- (let map2 ((h1 l1) (h2 l2) (t1 l1) (t2 l2) (move? #f) (out '()))
- (cond
- ((pair? h1)
- (cond
- ((not (pair? h2))
- (scm-error 'wrong-type-arg "map"
- (if (list? h2)
- "List of wrong length: ~S"
- "Not a list: ~S")
- (list l2) #f))
- ((not move?)
- (map2 (cdr h1) (cdr h2) t1 t2 #t
- (cons (f (car h1) (car h2)) out)))
- ((eq? t1 h1)
- (scm-error 'wrong-type-arg "map" "Circular list: ~S"
- (list l1) #f))
- ((eq? t2 h2)
- (scm-error 'wrong-type-arg "map" "Circular list: ~S"
- (list l2) #f))
- (else
- (map2 (cdr h1) (cdr h2) (cdr t1) (cdr t2) #f
- (cons (f (car h1) (car h2)) out)))))
-
- ((and (null? h1) (null? h2))
- (reverse! out))
-
- ((null? h1)
- (scm-error 'wrong-type-arg "map"
- (if (list? h2)
- "List of wrong length: ~S"
- "Not a list: ~S")
- (list l2) #f))
- (else
- (scm-error 'wrong-type-arg "map"
- "Not a list: ~S"
- (list l1) #f)))))
+ (unless (= (length l1) (length l2))
+ (scm-error 'wrong-type-arg "map" "List of wrong length: ~S"
+ (list l2) #f))
+
+ (let map2 ((l1 l1) (l2 l2) (out '()))
+ (if (pair? l1)
+ (map2 (cdr l1) (cdr l2) (cons (f (car l1) (car l2)) out))
+ (reverse! out))))
((f l1 . rest)
(let ((len (length l1)))
diff --git a/module/language/cps.scm b/module/language/cps.scm
index e0d708a..cb2cf03 100644
--- a/module/language/cps.scm
+++ b/module/language/cps.scm
@@ -61,12 +61,12 @@
;;; contains a $ktail representing the formal argument which is the
;;; function's continuation.
;;;
-;;; - $kentry also contains $kclause continuations, corresponding to
-;;; the case-lambda clauses of the function. $kclause actually
-;;; contains the clause body. This is because the $kclause
-;;; logically matches or doesn't match a given set of actual
-;;; arguments against a formal arity, then proceeds to a "body"
-;;; continuation (which is a $kargs).
+;;; - $kentry 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
+;;; a given set of actual arguments against a formal arity, then
+;;; proceeds to a "body" continuation (which is a $kargs).
;;;
;;; That's to say that a $fun can be matched like this:
;;;
@@ -74,9 +74,9 @@
;;; (($ $fun src meta free
;;; ($ $cont kentry
;;; ($ $kentry self ($ $cont ktail _ ($ $ktail))
-;;; (($ $kclause arity
-;;; ($ $cont kbody _ ($ $kargs names syms body)))
-;;; ...))))
+;;; ($ $kclause arity
+;;; ($ $cont kbody _ ($ $kargs names syms body))
+;;; alternate))))
;;; #t))
;;;
;;; A $continue to ktail is in tail position. $kentry, $kclause,
@@ -107,6 +107,7 @@
#:use-module ((srfi srfi-1) #:select (fold))
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
+ #:use-module (srfi srfi-11)
#:export (;; Helper.
$arity
make-$arity
@@ -123,14 +124,19 @@
;; Expressions.
$void $const $prim $fun $call $callk $primcall $values $prompt
+ ;; Fresh names.
+ label-counter var-counter
+ fresh-label fresh-var
+ with-fresh-name-state compute-max-label-and-var
+ let-fresh
+
;; Building macros.
- let-gensyms
build-cps-term build-cps-cont build-cps-exp
rewrite-cps-term rewrite-cps-cont rewrite-cps-exp
;; Misc.
parse-cps unparse-cps
- fold-conts fold-local-conts))
+ make-cont-folder fold-conts fold-local-conts))
;; FIXME: Use SRFI-99, when Guile adds it.
(define-syntax define-record-type*
@@ -172,9 +178,9 @@
(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 clauses)
+(define-cps-type $kentry self tail clause)
(define-cps-type $ktail)
-(define-cps-type $kclause arity cont)
+(define-cps-type $kclause arity cont alternate)
;; Expressions.
(define-cps-type $void)
@@ -187,11 +193,36 @@
(define-cps-type $values args)
(define-cps-type $prompt escape? tag handler)
-(define-syntax let-gensyms
- (syntax-rules ()
- ((_ (sym ...) body body* ...)
- (let ((sym (gensym (symbol->string 'sym))) ...)
- body body* ...))))
+(define label-counter (make-parameter #f))
+(define var-counter (make-parameter #f))
+
+(define (fresh-label)
+ (let ((count (or (label-counter)
+ (error "fresh-label outside with-fresh-name-state"))))
+ (label-counter (1+ count))
+ count))
+
+(define (fresh-var)
+ (let ((count (or (var-counter)
+ (error "fresh-var outside with-fresh-name-state"))))
+ (var-counter (1+ count))
+ count))
+
+(define-syntax-rule (let-fresh (label ...) (var ...) body ...)
+ (let ((label (fresh-label)) ...
+ (var (fresh-var)) ...)
+ body ...))
+
+(define-syntax-rule (with-fresh-name-state fun body ...)
+ (begin
+ (when (or (label-counter) (var-counter))
+ (error "with-fresh-name-state should not be called recursively"))
+ (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)))
+ body ...)))))
(define-syntax build-arity
(syntax-rules (unquote)
@@ -211,14 +242,13 @@
(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 (unquote clauses)))
- (make-$kentry self (build-cps-cont tail) clauses))
- ((_ ($kentry self tail (clause ...)))
- (make-$kentry self (build-cps-cont tail) (list (build-cps-cont clause)
...)))
+ ((_ ($kentry self tail clause))
+ (make-$kentry self (build-cps-cont tail) (build-cps-cont clause)))
((_ ($ktail))
(make-$ktail))
- ((_ ($kclause arity cont))
- (make-$kclause (build-arity arity) (build-cps-cont cont)))))
+ ((_ ($kclause arity cont alternate))
+ (make-$kclause (build-arity arity) (build-cps-cont cont)
+ (build-cps-cont alternate)))))
(define-syntax build-cps-cont
(syntax-rules (unquote)
@@ -261,7 +291,7 @@
((_ ($letconst () body))
(build-cps-term body))
((_ ($letconst ((name sym val) tail ...) body))
- (let-gensyms (kconst)
+ (let-fresh (kconst) ()
(build-cps-term
($letk ((kconst ($kargs (name) (sym) ($letconst (tail ...) body))))
($continue kconst (let ((props (source-properties val)))
@@ -310,16 +340,22 @@
(build-cont-body ($kreceive req rest k)))
(('kargs names syms body)
(build-cont-body ($kargs names syms ,(parse-cps body))))
- (('kentry self tail clauses)
+ (('kentry self tail clause)
(build-cont-body
- ($kentry self ,(parse-cps tail) ,(map parse-cps clauses))))
+ ($kentry self ,(parse-cps tail) ,(and=> clause parse-cps))))
(('ktail)
(build-cont-body
($ktail)))
(('kclause (req opt rest kw allow-other-keys?) body)
(build-cont-body
($kclause (req opt rest kw allow-other-keys?)
- ,(parse-cps body))))
+ ,(parse-cps body)
+ ,#f)))
+ (('kclause (req opt rest kw allow-other-keys?) body alternate)
+ (build-cont-body
+ ($kclause (req opt rest kw allow-other-keys?)
+ ,(parse-cps body)
+ ,(parse-cps alternate))))
(('kseq body)
(build-cont-body ($kargs () () ,(parse-cps body))))
@@ -372,12 +408,13 @@
`(kseq ,(unparse-cps body)))
(($ $kargs names syms body)
`(kargs ,names ,syms ,(unparse-cps body)))
- (($ $kentry self tail clauses)
- `(kentry ,self ,(unparse-cps tail) ,(map unparse-cps clauses)))
+ (($ $kentry self tail clause)
+ `(kentry ,self ,(unparse-cps tail) ,(unparse-cps clause)))
(($ $ktail)
`(ktail))
- (($ $kclause ($ $arity req opt rest kw allow-other-keys?) body)
- `(kclause (,req ,opt ,rest ,kw ,allow-other-keys?) ,(unparse-cps body)))
+ (($ $kclause ($ $arity req opt rest kw allow-other-keys?) body alternate)
+ `(kclause (,req ,opt ,rest ,kw ,allow-other-keys?) ,(unparse-cps body)
+ . ,(if alternate (list (unparse-cps alternate)) '())))
;; Calls.
(($ $continue k src exp)
@@ -408,67 +445,79 @@
(_
(error "unexpected cps" exp))))
-(define (fold-conts proc seed fun)
- (define (cont-folder cont seed)
- (match cont
- (($ $cont k cont)
- (let ((seed (proc k cont seed)))
- (match cont
- (($ $kargs names syms body)
- (term-folder body seed))
-
- (($ $kentry self tail clauses)
- (fold cont-folder (cont-folder tail seed) clauses))
-
- (($ $kclause arity body)
- (cont-folder body seed))
-
- (_ seed))))))
+(define-syntax-rule (make-cont-folder global? seed ...)
+ (lambda (proc fun seed ...)
+ (define (fold-values proc in seed ...)
+ (if (null? in)
+ (values seed ...)
+ (let-values (((seed ...) (proc (car in) seed ...)))
+ (fold-values proc (cdr in) seed ...))))
+
+ (define (cont-folder cont seed ...)
+ (match cont
+ (($ $cont k cont)
+ (let-values (((seed ...) (proc k cont seed ...)))
+ (match cont
+ (($ $kargs names syms body)
+ (term-folder body seed ...))
+
+ (($ $kentry self tail clause)
+ (let-values (((seed ...) (cont-folder tail seed ...)))
+ (if clause
+ (cont-folder clause seed ...)
+ (values seed ...))))
+
+ (($ $kclause arity body alternate)
+ (let-values (((seed ...) (cont-folder body seed ...)))
+ (if alternate
+ (cont-folder alternate seed ...)
+ (values seed ...))))
+
+ (_ (values seed ...)))))))
+
+ (define (fun-folder fun seed ...)
+ (match fun
+ (($ $fun src meta free body)
+ (cont-folder body seed ...))))
+
+ (define (term-folder term seed ...)
+ (match term
+ (($ $letk conts body)
+ (let-values (((seed ...) (term-folder body seed ...)))
+ (fold-values cont-folder conts seed ...)))
+
+ (($ $continue k src exp)
+ (match exp
+ (($ $fun)
+ (if global?
+ (fun-folder exp seed ...)
+ (values 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 ...))))))
+
+ (fun-folder fun 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)
+ (fold max max-var vars))
+ (($ $kentry self)
+ (max self max-var))
+ (_ max-var))))
+ fun
+ -1
+ -1))
- (define (fun-folder fun seed)
- (match fun
- (($ $fun src meta free body)
- (cont-folder body seed))))
-
- (define (term-folder term seed)
- (match term
- (($ $letk conts body)
- (fold cont-folder (term-folder body seed) conts))
-
- (($ $continue k src exp)
- (match exp
- (($ $fun) (fun-folder exp seed))
- (_ seed)))
-
- (($ $letrec names syms funs body)
- (fold fun-folder (term-folder body seed) funs))))
-
- (fun-folder fun seed))
-
-(define (fold-local-conts proc seed cont)
- (define (cont-folder cont seed)
- (match cont
- (($ $cont k cont)
- (let ((seed (proc k cont seed)))
- (match cont
- (($ $kargs names syms body)
- (term-folder body seed))
-
- (($ $kentry self tail clauses)
- (fold cont-folder (cont-folder tail seed) clauses))
-
- (($ $kclause arity body)
- (cont-folder body seed))
-
- (_ seed))))))
-
- (define (term-folder term seed)
- (match term
- (($ $letk conts body)
- (fold cont-folder (term-folder body seed) conts))
-
- (($ $continue) seed)
-
- (($ $letrec names syms funs body) (term-folder body seed))))
+(define (fold-conts proc seed fun)
+ ((make-cont-folder #t seed) proc fun seed))
- (cont-folder cont seed))
+(define (fold-local-conts proc seed fun)
+ ((make-cont-folder #f seed) proc fun seed))
diff --git a/module/language/cps/arities.scm b/module/language/cps/arities.scm
index 1cd8704..b470ba1 100644
--- a/module/language/cps/arities.scm
+++ b/module/language/cps/arities.scm
@@ -32,25 +32,25 @@
#:use-module (language cps primitives)
#:export (fix-arities))
-(define (fix-clause-arities clause)
- (let ((conts (build-local-cont-table clause))
- (ktail (match clause
+(define (fix-clause-arities clause dfg)
+ (let ((ktail (match clause
(($ $cont _ ($ $kentry _ ($ $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 fix-arities funs) ,(visit-term body)))
+ ($letrec names syms (map (cut fix-arities* <> dfg) funs)
+ ,(visit-term body)))
(($ $continue k src exp)
,(visit-exp k src exp))))
(define (adapt-exp nvals k src exp)
(match nvals
(0
- (rewrite-cps-term (lookup-cont k conts)
+ (rewrite-cps-term (lookup-cont k dfg)
(($ $ktail)
- ,(let-gensyms (kvoid kunspec unspec)
+ ,(let-fresh (kvoid kunspec) (unspec)
(build-cps-term
($letk* ((kunspec ($kargs (unspec) (unspec)
($continue k src
@@ -62,7 +62,7 @@
,(match arity
(($ $arity () () rest () #f)
(if rest
- (let-gensyms (knil)
+ (let-fresh (knil) ()
(build-cps-term
($letk ((knil ($kargs () ()
($continue kargs src ($const '())))))
@@ -70,7 +70,7 @@
(build-cps-term
($continue kargs src ,exp))))
(_
- (let-gensyms (kvoid kvalues void)
+ (let-fresh (kvoid kvalues) (void)
(build-cps-term
($letk* ((kvalues ($kargs ('void) (void)
($continue k src
@@ -82,18 +82,18 @@
(($ $kargs () () _)
($continue k src ,exp))
(_
- ,(let-gensyms (k*)
+ ,(let-fresh (k*) ()
(build-cps-term
($letk ((k* ($kargs () () ($continue k src ($void)))))
($continue k* src ,exp)))))))
(1
- (rewrite-cps-term (lookup-cont k conts)
+ (rewrite-cps-term (lookup-cont k dfg)
(($ $ktail)
,(rewrite-cps-term exp
(($values (sym))
($continue ktail src ($primcall 'return (sym))))
(_
- ,(let-gensyms (k* v)
+ ,(let-fresh (k*) (v)
(build-cps-term
($letk ((k* ($kargs (v) (v)
($continue k src
@@ -103,7 +103,7 @@
,(match arity
(($ $arity (_) () rest () #f)
(if rest
- (let-gensyms (kval val nil)
+ (let-fresh (kval) (val nil)
(build-cps-term
($letk ((kval ($kargs ('val) (val)
($letconst (('nil nil '()))
@@ -112,14 +112,14 @@
($continue kval src ,exp))))
(build-cps-term ($continue kargs src ,exp))))
(_
- (let-gensyms (kvalues value)
+ (let-fresh (kvalues) (value)
(build-cps-term
($letk ((kvalues ($kargs ('value) (value)
($continue k src
($primcall 'values (value))))))
($continue kvalues src ,exp)))))))
(($ $kargs () () _)
- ,(let-gensyms (k* drop)
+ ,(let-fresh (k*) (drop)
(build-cps-term
($letk ((k* ($kargs ('drop) (drop)
($continue k src ($values ())))))
@@ -135,7 +135,7 @@
($ $values (_)))
,(adapt-exp 1 k src exp))
(($ $fun)
- ,(adapt-exp 1 k src (fix-arities exp)))
+ ,(adapt-exp 1 k src (fix-arities* exp dfg)))
((or ($ $call) ($ $callk))
;; In general, calls have unknown return arity. For that
;; reason every non-tail call has a $kreceive continuation to
@@ -158,7 +158,7 @@
(if (and inst (not (eq? inst name)))
(build-cps-exp ($primcall inst args))
exp)))
- (let-gensyms (k* p*)
+ (let-fresh (k*) (p*)
(build-cps-term
($letk ((k* ($kargs ('prim) (p*)
($continue k src ($call p* args)))))
@@ -174,16 +174,21 @@
(rewrite-cps-cont cont
(($ $cont sym ($ $kargs names syms body))
(sym ($kargs names syms ,(visit-term body))))
- (($ $cont sym ($ $kclause arity body))
- (sym ($kclause ,arity ,(visit-cont body))))
+ (($ $cont sym ($ $kclause arity body alternate))
+ (sym ($kclause ,arity ,(visit-cont body)
+ ,(and alternate (visit-cont alternate)))))
(($ $cont)
,cont)))
(rewrite-cps-cont clause
- (($ $cont sym ($ $kentry self tail clauses))
- (sym ($kentry self ,tail ,(map visit-cont clauses)))))))
+ (($ $cont sym ($ $kentry self tail clause))
+ (sym ($kentry self ,tail ,(and clause (visit-cont clause))))))))
-(define (fix-arities fun)
+(define (fix-arities* fun dfg)
(rewrite-cps-exp fun
(($ $fun src meta free body)
- ($fun src meta free ,(fix-clause-arities body)))))
+ ($fun src meta free ,(fix-clause-arities body dfg)))))
+
+(define (fix-arities fun)
+ (with-fresh-name-state fun
+ (fix-arities* fun (compute-dfg fun))))
diff --git a/module/language/cps/closure-conversion.scm
b/module/language/cps/closure-conversion.scm
index c03b409..89c491f 100644
--- a/module/language/cps/closure-conversion.scm
+++ b/module/language/cps/closure-conversion.scm
@@ -60,7 +60,7 @@ called with @var{sym}.
values in the term."
(if (memq sym bound)
(k sym)
- (let-gensyms (k* sym*)
+ (let-fresh (k*) (sym*)
(receive (exp free) (k sym*)
(values (build-cps-term
($letk ((k* ($kargs (sym*) (sym*) ,exp)))
@@ -86,7 +86,7 @@ values: the term and a list of additional free variables in
the term."
label of the outer procedure, where the initialization will be
performed, and @var{outer-bound} is the list of bound variables there."
(fold (lambda (free idx body)
- (let-gensyms (k idxsym)
+ (let-fresh (k) (idxsym)
(build-cps-term
($letk ((k ($kargs () () ,body)))
,(convert-free-var
@@ -128,15 +128,20 @@ convert functions to flat closures."
(values (build-cps-cont (sym ($kargs names syms ,body)))
free)))
- (($ $cont sym ($ $kentry self tail clauses))
- (receive (clauses free) (cc* clauses self (list self))
- (values (build-cps-cont (sym ($kentry self ,tail ,clauses)))
+ (($ $cont sym ($ $kentry self tail clause))
+ (receive (clause free) (if clause
+ (cc clause self (list self))
+ (values #f '()))
+ (values (build-cps-cont (sym ($kentry self ,tail ,clause)))
free)))
- (($ $cont sym ($ $kclause arity body))
+ (($ $cont sym ($ $kclause arity body alternate))
(receive (body free) (cc body self bound)
- (values (build-cps-cont (sym ($kclause ,arity ,body)))
- free)))
+ (receive (alternate free*) (if alternate
+ (cc alternate self bound)
+ (values #f '()))
+ (values (build-cps-cont (sym ($kclause ,arity ,body ,alternate)))
+ (union free free*)))))
(($ $cont)
;; Other kinds of continuations don't bind values and don't have
@@ -157,7 +162,7 @@ convert functions to flat closures."
(receive (fun-body fun-free) (cc fun-body #f '())
(lp in
(lambda (body)
- (let-gensyms (k)
+ (let-fresh (k) ()
(build-cps-term
($letk ((k ($kargs (name) (sym) ,(bindings body))))
($continue k src
@@ -180,7 +185,7 @@ convert functions to flat closures."
free))
(_
(values
- (let-gensyms (kinit v)
+ (let-fresh (kinit) (v)
(build-cps-term
($letk ((kinit ($kargs (v) (v)
,(init-closure
@@ -241,7 +246,7 @@ convert functions to flat closures."
(($ $letk conts body)
($letk ,(map visit-cont conts) ,(visit-term body)))
(($ $continue k src ($ $primcall 'free-ref (closure sym)))
- ,(let-gensyms (idx)
+ ,(let-fresh () (idx)
(build-cps-term
($letconst (('idx idx (free-index sym)))
($continue k src ($primcall 'free-ref (closure idx)))))))
@@ -254,24 +259,26 @@ convert functions to flat closures."
(rewrite-cps-cont cont
(($ $cont sym ($ $kargs names syms body))
(sym ($kargs names syms ,(visit-term body))))
- (($ $cont sym ($ $kclause arity body))
- (sym ($kclause ,arity ,(visit-cont 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 clauses))
- (sym ($kentry self ,tail ,(map visit-cont clauses))))))
+ (($ $cont sym ($ $kentry self tail clause))
+ (sym ($kentry self ,tail ,(and clause (visit-cont clause)))))))
(define (convert-closures exp)
"Convert free reference in @var{exp} to primcalls to @code{free-ref},
and allocate and initialize flat closures."
- (match exp
- (($ $fun 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)))))))
+ (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))))))))
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index 0aa8d11..3026e59 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -37,6 +37,7 @@
#:use-module (language cps primitives)
#:use-module (language cps prune-top-level-scopes)
#:use-module (language cps reify-primitives)
+ #:use-module (language cps renumber)
#:use-module (language cps simplify)
#:use-module (language cps slot-allocation)
#:use-module (language cps specialize-primcalls)
@@ -91,9 +92,7 @@
(when idx
(vector-set! contv idx cont))))
'()
- (match f
- (($ $fun src meta free entry)
- entry)))
+ f)
contv))
(define (compile-fun f asm)
@@ -128,24 +127,15 @@
(define (compile-entry meta)
(match (vector-ref contv 0)
- (($ $kentry self tail clauses)
+ (($ $kentry self tail clause)
(emit-begin-program asm (cfa-k-sym cfa 0) meta)
- (let lp ((n 1)
- (ks (map (match-lambda (($ $cont k) k)) clauses)))
- (match ks
- (()
- (unless (= n (vector-length contv))
- (error "unexpected end of clauses"))
- (emit-end-program asm))
- ((k . ks)
- (unless (eq? (cfa-k-sym cfa n) k)
- (error "unexpected k" k))
- (lp (compile-clause n (and (pair? ks) (car ks)))
- ks)))))))
-
- (define (compile-clause n alternate)
+ (compile-clause 1)
+ (emit-end-program asm))))
+
+ (define (compile-clause n)
(match (vector-ref contv n)
- (($ $kclause ($ $arity req opt rest kw allow-other-keys?))
+ (($ $kclause ($ $arity req opt rest kw allow-other-keys?)
+ body alternate)
(let* ((kw-indices (map (match-lambda
((key name sym)
(cons key (lookup-slot sym allocation))))
@@ -153,11 +143,19 @@
(k (cfa-k-sym cfa n))
(nlocals (lookup-nlocals k allocation)))
(emit-label asm k)
- (emit-begin-kw-arity asm req opt rest kw-indices
- allow-other-keys? nlocals alternate)
+ (emit-begin-kw-arity asm req opt rest kw-indices allow-other-keys?
+ nlocals
+ (match alternate (#f #f) (($ $cont alt) alt)))
(let ((next (compile-body (1+ n) nlocals)))
(emit-end-arity asm)
- next)))))
+ (match alternate
+ (($ $cont alt)
+ (unless (eq? (cfa-k-sym cfa next) alt)
+ (error "unexpected k" alt))
+ (compile-clause next))
+ (#f
+ (unless (= next (vector-length contv))
+ (error "unexpected end of clauses")))))))))
(define (compile-body n nlocals)
(let compile-cont ((n n))
@@ -492,7 +490,7 @@
(emit-call-label asm proc-slot nargs k))))))
(match f
- (($ $fun src meta free ($ $cont k ($ $kentry self tail clauses)))
+ (($ $fun src meta free ($ $cont k ($ $kentry self tail clause)))
;; FIXME: src on kentry instead?
(when src
(emit-source asm src))
@@ -514,11 +512,14 @@
(($ $cont sym ($ $kargs names syms body))
(visit-funs proc body))
- (($ $cont sym ($ $kclause arity 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 clauses))
- (for-each (lambda (clause) (visit-funs proc clause)) clauses))
+ (($ $cont sym ($ $kentry self tail clause))
+ (when clause
+ (visit-funs proc clause)))
(_ (values))))
@@ -527,6 +528,7 @@
(exp (optimize exp opts))
(exp (convert-closures exp))
(exp (reify-primitives exp))
+ (exp (renumber exp))
(asm (make-assembler)))
(visit-funs (lambda (fun)
(compile-fun fun asm))
diff --git a/module/language/cps/constructors.scm
b/module/language/cps/constructors.scm
index d7ff0ab..4bb8670 100644
--- a/module/language/cps/constructors.scm
+++ b/module/language/cps/constructors.scm
@@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -29,15 +29,16 @@
#:use-module (language cps)
#:export (inline-constructors))
-(define (inline-constructors fun)
+(define (inline-constructors* fun)
(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 tail clauses))
- (sym ($kentry self ,tail ,(map visit-cont clauses))))
- (($ $cont sym ($ $kclause arity body))
- (sym ($kclause ,arity ,(visit-cont body))))
+ (($ $cont sym ($ $kentry self tail clause))
+ (sym ($kentry self ,tail ,(and clause (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)
@@ -46,10 +47,10 @@
($letk ,(map visit-cont conts)
,(visit-term body)))
(($ $letrec names syms funs body)
- ($letrec names syms (map inline-constructors funs)
+ ($letrec names syms (map inline-constructors* funs)
,(visit-term body)))
(($ $continue k src ($ $primcall 'list args))
- ,(let-gensyms (kvalues val)
+ ,(let-fresh (kvalues) (val)
(build-cps-term
($letk ((kvalues ($kargs ('val) (val)
($continue k src
@@ -60,21 +61,21 @@
(build-cps-term
($continue k src ($const '()))))
((arg . args)
- (let-gensyms (ktail tail)
+ (let-fresh (ktail) (tail)
(build-cps-term
($letk ((ktail ($kargs ('tail) (tail)
($continue k src
($primcall 'cons (arg tail))))))
,(lp args ktail)))))))))))
(($ $continue k src ($ $primcall 'vector args))
- ,(let-gensyms (kalloc vec len init)
+ ,(let-fresh (kalloc) (vec len init)
(define (initialize args n)
(match args
(()
(build-cps-term
($continue k src ($primcall 'values (vec)))))
((arg . args)
- (let-gensyms (knext idx)
+ (let-fresh (knext) (idx)
(build-cps-term
($letk ((knext ($kargs () ()
,(initialize args (1+ n)))))
@@ -89,10 +90,14 @@
($continue kalloc src
($primcall 'make-vector (len init))))))))
(($ $continue k src (and fun ($ $fun)))
- ($continue k src ,(inline-constructors fun)))
+ ($continue k src ,(inline-constructors* fun)))
(($ $continue)
,term)))
(rewrite-cps-exp fun
(($ $fun src meta free body)
($fun src meta free ,(visit-cont body)))))
+
+(define (inline-constructors fun)
+ (with-fresh-name-state fun
+ (inline-constructors* fun)))
diff --git a/module/language/cps/contification.scm
b/module/language/cps/contification.scm
index fe0a3ad..a7e3d36 100644
--- a/module/language/cps/contification.scm
+++ b/module/language/cps/contification.scm
@@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -40,7 +40,6 @@
(define (compute-contification fun)
(let* ((dfg (compute-dfg fun))
- (cont-table (dfg-cont-table dfg))
(scope-table (make-hash-table))
(call-substs '())
(cont-substs '())
@@ -67,7 +66,7 @@
;; If K is a continuation that binds one variable, and it has only
;; one predecessor, return that variable.
(define (bound-symbol k)
- (match (lookup-cont k cont-table)
+ (match (lookup-cont k dfg)
(($ $kargs (_) (sym))
(match (lookup-predecessors k dfg)
((_)
@@ -76,6 +75,17 @@
(_ #f)))
(_ #f)))
+ (define (extract-arities clause)
+ (match clause
+ (($ $cont _ ($ $kclause arity body alternate))
+ (cons arity (extract-arities alternate)))
+ (#f '())))
+ (define (extract-bodies clause)
+ (match clause
+ (($ $cont _ ($ $kclause arity body alternate))
+ (cons body (extract-bodies alternate)))
+ (#f '())))
+
(define (contify-fun term-k sym self tail arities bodies)
(contify-funs term-k
(list sym) (list self) (list tail)
@@ -107,7 +117,7 @@
;; is compatible with one of the procedure's arities, return the
;; target continuation. Otherwise return #f.
(define (call-target use proc)
- (match (find-call (lookup-cont use cont-table))
+ (match (find-call (lookup-cont use dfg))
(($ $continue k src ($ $call proc* args))
(and (eq? proc proc*) (not (memq proc args)) (applicable? proc args)
;; Converge more quickly by resolving already-contified
@@ -176,13 +186,13 @@
(let ((k-scope (continuation-scope k)))
(if (scope-contains? k-scope term-k)
term-k
- (match (lookup-cont k-scope cont-table)
- (($ $kentry self tail clauses)
+ (match (lookup-cont k-scope dfg)
+ (($ $kentry self tail clause)
;; K is the tail of some function. If that function
;; has just one clause, return that clause. Otherwise
;; bail.
- (match clauses
- ((($ $cont _ ($ $kclause arity ($ $cont kargs))))
+ (match clause
+ (($ $cont _ ($ $kclause arity ($ $cont kargs) #f))
kargs)
(_ #f)))
(_ k-scope)))))
@@ -215,10 +225,11 @@
(match cont
(($ $cont sym ($ $kargs _ _ body))
(visit-term body sym))
- (($ $cont sym ($ $kentry self tail clauses))
- (for-each visit-cont clauses))
- (($ $cont sym ($ $kclause arity body))
- (visit-cont body))
+ (($ $cont sym ($ $kentry self tail clause))
+ (when clause (visit-cont clause)))
+ (($ $cont sym ($ $kclause arity body alternate))
+ (visit-cont body)
+ (when alternate (visit-cont alternate)))
(($ $cont)
#t)))
(define (visit-term term term-k)
@@ -245,20 +256,22 @@
(if (recursive? kentry)
(lp nsf (cons elt rec))
(cons (list elt) (lp nsf rec)))))))
+ (define (extract-arities+bodies clauses)
+ (values (map extract-arities clauses)
+ (map extract-bodies clauses)))
(define (visit-component component)
(match component
(((name sym fun) ...)
(match fun
((($ $fun src meta free
($ $cont fun-k
- ($ $kentry self
- ($ $cont tail-k ($ $ktail))
- (($ $cont _ ($ $kclause arity body))
- ...))))
+ ($ $kentry self ($ $cont tail-k ($ $ktail)) clause)))
...)
- (if (contify-funs term-k sym self tail-k arity body)
- (for-each (cut for-each visit-cont <>) body)
- (for-each visit-fun fun)))))))
+ (call-with-values (lambda () (extract-arities+bodies clause))
+ (lambda (arities bodies)
+ (if (contify-funs term-k sym self tail-k arities bodies)
+ (for-each (cut for-each visit-cont <>) bodies)
+ (for-each visit-fun fun)))))))))
(visit-term body term-k)
(for-each visit-component
(split-components (map list names syms funs))))
@@ -266,15 +279,15 @@
(match exp
(($ $fun src meta free
($ $cont fun-k
- ($ $kentry self
- ($ $cont tail-k ($ $ktail))
- (($ $cont _ ($ $kclause arity body)) ...))))
+ ($ $kentry self ($ $cont tail-k ($ $ktail)) clause)))
(if (and=> (bound-symbol k)
(lambda (sym)
- (contify-fun term-k sym self tail-k arity body)))
+ (contify-fun term-k sym self tail-k
+ (extract-arities clause)
+ (extract-bodies clause))))
(begin
- (elide-function! k (lookup-cont k cont-table))
- (for-each visit-cont body))
+ (elide-function! k (lookup-cont k dfg))
+ (for-each visit-cont (extract-bodies clause)))
(visit-fun exp)))
(_ #t)))))
@@ -336,10 +349,11 @@
,#f)
(($ $cont sym ($ $kargs names syms body))
(sym ($kargs names syms ,(visit-term body sym))))
- (($ $cont sym ($ $kentry self tail clauses))
- (sym ($kentry self ,tail ,(map visit-cont clauses))))
- (($ $cont sym ($ $kclause arity body))
- (sym ($kclause ,arity ,(visit-cont body))))
+ (($ $cont sym ($ $kentry self tail clause))
+ (sym ($kentry self ,tail ,(and clause (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 term-k)
diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm
index 8b16bd1..20fc9cd 100644
--- a/module/language/cps/dce.scm
+++ b/module/language/cps/dce.scm
@@ -50,11 +50,11 @@
(live-conts fun-data-live-conts)
(defs fun-data-defs))
-(define (compute-cont-vector cfa cont-table)
+(define (compute-cont-vector cfa dfg)
(let ((v (make-vector (cfa-k-count cfa) #f)))
(let lp ((n 0))
(when (< n (vector-length v))
- (vector-set! v n (lookup-cont (cfa-k-sym cfa n) cont-table))
+ (vector-set! v n (lookup-cont (cfa-k-sym cfa n) dfg))
(lp (1+ n))))
v))
@@ -98,7 +98,7 @@
(or (hashq-ref fun-data-table fun)
(let* ((cfa (analyze-control-flow fun dfg))
(effects (compute-effects cfa dfg))
- (contv (compute-cont-vector cfa (dfg-cont-table dfg)))
+ (contv (compute-cont-vector cfa dfg))
(live-conts (make-bitvector (cfa-k-count cfa) #f))
(defs (compute-defs cfa contv))
(fun-data (make-fun-data cfa effects contv live-conts defs)))
@@ -163,7 +163,7 @@
(($ $kif) #f)
(($ $kclause arity ($ $cont kargs ($ $kargs names syms body)))
(for-each mark-live! syms))
- (($ $kentry self tail clauses)
+ (($ $kentry self)
(mark-live! self))
(($ $ktail) #f))
(lp (1- n))))))))
@@ -174,108 +174,111 @@
(values fun-data-table live-vars)))
(define (eliminate-dead-code fun)
- (call-with-values (lambda () (compute-live-code fun))
- (lambda (fun-data-table live-vars)
- (define (value-live? sym)
- (hashq-ref live-vars sym))
- (define (make-adaptor name k defs)
- (let* ((names (map (lambda (_) 'tmp) defs))
- (syms (map (lambda (_) (gensym "tmp")) defs))
- (live (filter-map (lambda (def sym)
- (and (value-live? def)
- sym))
- defs syms)))
- (build-cps-cont
- (name ($kargs names syms
- ($continue k #f ($values live)))))))
- (define (visit-fun fun)
- (match (hashq-ref fun-data-table fun)
- (($ $fun-data cfa effects contv live-conts defs)
- (define (must-visit-cont cont)
- (match (visit-cont cont)
- ((cont) cont)
- (conts (error "cont must be reachable" cont conts))))
- (define (visit-cont cont)
- (match cont
- (($ $cont sym cont)
- (match (cfa-k-idx cfa sym #:default (lambda (k) #f))
- (#f '())
- (n
- (match cont
- (($ $kargs names syms body)
- (match (filter-map (lambda (name sym)
- (and (value-live? sym)
- (cons name sym)))
- names syms)
- (((names . syms) ...)
- (list
- (build-cps-cont
- (sym ($kargs names syms
- ,(visit-term body n))))))))
- (($ $kentry self tail clauses)
- (list
- (build-cps-cont
- (sym ($kentry self ,tail
- ,(visit-conts clauses))))))
- (($ $kclause arity body)
- (list
- (build-cps-cont
- (sym ($kclause ,arity
- ,(must-visit-cont body))))))
- (($ $kreceive ($ $arity req () rest () #f) kargs)
- (let ((defs (vector-ref defs n)))
- (if (and-map value-live? defs)
- (list (build-cps-cont (sym ,cont)))
- (let-gensyms (adapt)
- (list (make-adaptor adapt kargs defs)
- (build-cps-cont
- (sym ($kreceive req rest adapt))))))))
- (_ (list (build-cps-cont (sym ,cont))))))))))
- (define (visit-conts conts)
- (append-map visit-cont conts))
- (define (visit-term term term-k-idx)
- (match term
- (($ $letk conts body)
- (let ((body (visit-term body term-k-idx)))
- (match (visit-conts conts)
- (() body)
- (conts (build-cps-term ($letk ,conts ,body))))))
- (($ $letrec names syms funs body)
- (let ((body (visit-term body term-k-idx)))
- (match (filter-map
- (lambda (name sym fun)
- (and (value-live? sym)
- (list name sym (visit-fun fun))))
- names syms funs)
- (() body)
- (((names syms funs) ...)
- (build-cps-term
- ($letrec names syms funs ,body))))))
- (($ $continue k src ($ $values args))
- (match (vector-ref defs term-k-idx)
- (#f term)
- (defs
- (let ((args (filter-map (lambda (use def)
- (and (value-live? def) use))
- args defs)))
- (build-cps-term
- ($continue k src ($values args)))))))
- (($ $continue k src exp)
- (if (bitvector-ref live-conts term-k-idx)
- (rewrite-cps-term exp
- (($ $fun) ($continue k src ,(visit-fun exp)))
- (_
- ,(match (vector-ref defs term-k-idx)
- ((or #f ((? value-live?) ...))
- (build-cps-term
- ($continue k src ,exp)))
- (syms
- (let-gensyms (adapt)
+ (with-fresh-name-state fun
+ (call-with-values (lambda () (compute-live-code fun))
+ (lambda (fun-data-table live-vars)
+ (define (value-live? sym)
+ (hashq-ref live-vars sym))
+ (define (make-adaptor name k defs)
+ (let* ((names (map (lambda (_) 'tmp) defs))
+ (syms (map (lambda (_) (fresh-var)) defs))
+ (live (filter-map (lambda (def sym)
+ (and (value-live? def)
+ sym))
+ defs syms)))
+ (build-cps-cont
+ (name ($kargs names syms
+ ($continue k #f ($values live)))))))
+ (define (visit-fun fun)
+ (match (hashq-ref fun-data-table fun)
+ (($ $fun-data cfa effects contv live-conts defs)
+ (define (must-visit-cont cont)
+ (match (visit-cont cont)
+ ((cont) cont)
+ (conts (error "cont must be reachable" cont conts))))
+ (define (visit-cont cont)
+ (match cont
+ (($ $cont sym cont)
+ (match (cfa-k-idx cfa sym #:default (lambda (k) #f))
+ (#f '())
+ (n
+ (match cont
+ (($ $kargs names syms body)
+ (match (filter-map (lambda (name sym)
+ (and (value-live? sym)
+ (cons name sym)))
+ names syms)
+ (((names . syms) ...)
+ (list
+ (build-cps-cont
+ (sym ($kargs names syms
+ ,(visit-term body n))))))))
+ (($ $kentry self tail clause)
+ (list
+ (build-cps-cont
+ (sym ($kentry self ,tail
+ ,(and clause (must-visit-cont clause)))))))
+ (($ $kclause arity body alternate)
+ (list
+ (build-cps-cont
+ (sym ($kclause ,arity
+ ,(must-visit-cont body)
+ ,(and alternate
+ (must-visit-cont alternate)))))))
+ (($ $kreceive ($ $arity req () rest () #f) kargs)
+ (let ((defs (vector-ref defs n)))
+ (if (and-map value-live? defs)
+ (list (build-cps-cont (sym ,cont)))
+ (let-fresh (adapt) ()
+ (list (make-adaptor adapt kargs defs)
+ (build-cps-cont
+ (sym ($kreceive req rest adapt))))))))
+ (_ (list (build-cps-cont (sym ,cont))))))))))
+ (define (visit-conts conts)
+ (append-map visit-cont conts))
+ (define (visit-term term term-k-idx)
+ (match term
+ (($ $letk conts body)
+ (let ((body (visit-term body term-k-idx)))
+ (match (visit-conts conts)
+ (() body)
+ (conts (build-cps-term ($letk ,conts ,body))))))
+ (($ $letrec names syms funs body)
+ (let ((body (visit-term body term-k-idx)))
+ (match (filter-map
+ (lambda (name sym fun)
+ (and (value-live? sym)
+ (list name sym (visit-fun fun))))
+ names syms funs)
+ (() body)
+ (((names syms funs) ...)
+ (build-cps-term
+ ($letrec names syms funs ,body))))))
+ (($ $continue k src ($ $values args))
+ (match (vector-ref defs term-k-idx)
+ (#f term)
+ (defs
+ (let ((args (filter-map (lambda (use def)
+ (and (value-live? def) use))
+ args defs)))
+ (build-cps-term
+ ($continue k src ($values args)))))))
+ (($ $continue k src exp)
+ (if (bitvector-ref live-conts term-k-idx)
+ (rewrite-cps-term exp
+ (($ $fun) ($continue k src ,(visit-fun exp)))
+ (_
+ ,(match (vector-ref defs term-k-idx)
+ ((or #f ((? value-live?) ...))
(build-cps-term
- ($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 ,(must-visit-cont body)))))))
- (visit-fun fun))))
+ ($continue k src ,exp)))
+ (syms
+ (let-fresh (adapt) ()
+ (build-cps-term
+ ($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 ,(must-visit-cont body)))))))
+ (visit-fun fun)))))
diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm
index c1e670a..768dcab 100644
--- a/module/language/cps/dfg.scm
+++ b/module/language/cps/dfg.scm
@@ -41,7 +41,6 @@
#:use-module (srfi srfi-26)
#:use-module (language cps)
#:export (build-cont-table
- build-local-cont-table
lookup-cont
compute-dfg
@@ -69,7 +68,7 @@
;; Data flow analysis.
compute-live-variables
dfa-k-idx dfa-k-sym dfa-k-count dfa-k-in dfa-k-out
- dfa-var-idx dfa-var-name dfa-var-sym dfa-var-count
+ dfa-var-idx dfa-var-sym dfa-var-count
print-dfa))
;; These definitions are here because currently we don't do cross-module
@@ -92,54 +91,36 @@
(for-each2 (cdr l1) (cdr l2)))))
(define (build-cont-table fun)
- (fold-conts (lambda (k cont table)
- (hashq-set! table k cont)
- table)
- (make-hash-table)
- fun))
-
-(define (build-local-cont-table cont)
- (fold-local-conts (lambda (k cont table)
- (hashq-set! table k cont)
- table)
- (make-hash-table)
- cont))
-
-(define (lookup-cont sym conts)
- (let ((res (hashq-ref conts sym)))
- (unless res
- (error "Unknown continuation!" sym (hash-fold acons '() conts)))
- res))
+ (let ((max-k (fold-conts (lambda (k cont max-k) (max k max-k))
+ -1 fun)))
+ (fold-conts (lambda (k cont table)
+ (vector-set! table k cont)
+ table)
+ (make-vector (1+ max-k) #f)
+ fun)))
;; Data-flow graph for CPS: both for values and continuations.
(define-record-type $dfg
- (make-dfg conts blocks use-maps)
+ (make-dfg conts preds defs uses scopes scope-levels
+ min-label nlabels min-var nvars)
dfg?
- ;; hash table of sym -> $kif, $kargs, etc
+ ;; vector of label -> $kif, $kargs, etc
(conts dfg-cont-table)
- ;; hash table of sym -> $block
- (blocks dfg-blocks)
- ;; hash table of sym -> $use-map
- (use-maps dfg-use-maps))
-
-(define-record-type $use-map
- (make-use-map name sym def uses)
- use-map?
- (name use-map-name)
- (sym use-map-sym)
- (def use-map-def)
- (uses use-map-uses set-use-map-uses!))
-
-(define-record-type $block
- (%make-block scope scope-level preds succs)
- block?
- (scope block-scope set-block-scope!)
- (scope-level block-scope-level set-block-scope-level!)
- (preds block-preds set-block-preds!)
- (succs block-succs set-block-succs!))
-
-(define (make-block scope scope-level)
- (%make-block scope scope-level '() '()))
+ ;; vector of label -> (pred-label ...)
+ (preds dfg-preds)
+ ;; vector of var -> def-label
+ (defs dfg-defs)
+ ;; vector of var -> (use-label ...)
+ (uses dfg-uses)
+ ;; vector of label -> label
+ (scopes dfg-scopes)
+ ;; vector of label -> int
+ (scope-levels dfg-scope-levels)
+
+ (min-label dfg-min-label)
+ (nlabels dfg-nlabels)
+ (min-var dfg-min-var)
+ (nvars dfg-nvars))
;; Some analyses assume that the only relevant set of nodes is the set
;; that is reachable from some start node. Others need to include nodes
@@ -237,8 +218,7 @@ for quickest convergence."
(when (< n k-count)
(for-each (lambda (succ)
(vector-push! succs n (cfa-k-idx cfa succ)))
- (block-succs (lookup-block (cfa-k-sym cfa n)
- (dfg-blocks dfg))))
+ (lookup-successors (cfa-k-sym cfa n) dfg))
(lp (1+ n))))
;; Iterate cfa backwards, to converge quickly.
@@ -272,7 +252,7 @@ HANDLER-INDEX pairs."
((= n (cfa-k-count cfa))
(reverse prompts))
(else
- (match (lookup-cont (cfa-k-sym cfa n) (dfg-cont-table dfg))
+ (match (lookup-cont (cfa-k-sym cfa n) dfg)
(($ $kargs names syms body)
(match (find-expression body)
(($ $prompt escape? tag handler)
@@ -338,8 +318,7 @@ BODY for each body continuation in the prompt."
(let ((succ (cfa-k-idx cfa succ)))
(or (not (bitvector-ref body succ))
(<= succ n))))
- (block-succs (lookup-block (cfa-k-sym cfa n)
- (dfg-blocks dfg)))))
+ (lookup-successors (cfa-k-sym cfa n) dfg)))
(let lp ((n 0))
(let ((n (bit-position #t body n)))
(when n
@@ -349,19 +328,24 @@ BODY for each body continuation in the prompt."
(find-prompt-bodies cfa dfg)))
(define* (analyze-control-flow fun dfg #:key reverse? add-handler-preds?)
- (define (build-cfa kentry block-succs block-preds forward-cfa)
- (define (block-accessor accessor)
- (lambda (k)
- (accessor (lookup-block k (dfg-blocks dfg)))))
- (define (reachable-preds mapping accessor)
+ (define (build-cfa kentry lookup-succs lookup-preds forward-cfa)
+ (define (reachable-preds mapping)
;; It's possible for a predecessor to not be in the mapping, if
;; the predecessor is not reachable from the entry node.
(lambda (k)
- (filter-map (cut hashq-ref mapping <>)
- ((block-accessor accessor) k))))
+ (filter-map (cut hashq-ref mapping <>) (lookup-preds k dfg))))
(let* ((order (reverse-post-order
kentry
- (block-accessor block-succs)
+ (lambda (k)
+ ;; RPO numbering is going to visit this list of
+ ;; successors in the order that we give it. Sort
+ ;; it so that all things being equal, we preserve
+ ;; the existing numbering order. This also has the
+ ;; effect of preserving clause order.
+ (let ((succs (lookup-succs k dfg)))
+ (if (or (null? succs) (null? (cdr succs)))
+ succs
+ (sort succs >))))
(if forward-cfa
(lambda (f seed)
(let lp ((n (cfa-k-count forward-cfa)) (seed seed))
@@ -371,8 +355,7 @@ BODY for each body continuation in the prompt."
(f (cfa-k-sym forward-cfa (1- n)) seed)))))
(lambda (f seed) seed))))
(k-map (make-block-mapping order))
- (preds (convert-predecessors order
- (reachable-preds k-map block-preds)))
+ (preds (convert-predecessors order (reachable-preds k-map)))
(cfa (make-cfa k-map order preds)))
(when add-handler-preds?
;; Any expression in the prompt body could cause an abort to the
@@ -397,13 +380,12 @@ BODY for each body continuation in the prompt."
(match fun
(($ $fun src meta free
($ $cont kentry
- (and entry
- ($ $kentry self ($ $cont ktail tail) clauses))))
+ (and entry ($ $kentry self ($ $cont ktail tail)))))
(if reverse?
- (build-cfa ktail block-preds block-succs
+ (build-cfa ktail lookup-predecessors lookup-successors
(analyze-control-flow fun dfg #:reverse? #f
#:add-handler-preds? #f))
- (build-cfa kentry block-succs block-preds #f)))))
+ (build-cfa kentry lookup-successors lookup-predecessors #f)))))
;; Dominator analysis.
(define-record-type $dominator-analysis
@@ -673,14 +655,12 @@ BODY for each body continuation in the prompt."
;; Data-flow analysis.
(define-record-type $dfa
- (make-dfa cfa var-map names syms in out)
+ (make-dfa cfa var-map syms in out)
dfa?
;; CFA, for its reverse-post-order numbering
(cfa dfa-cfa)
;; Hash table mapping var-sym -> var-idx
(var-map dfa-var-map)
- ;; Vector of var-idx -> name
- (names dfa-names)
;; Vector of var-idx -> var-sym
(syms dfa-syms)
;; Vector of k-idx -> bitvector
@@ -701,9 +681,6 @@ BODY for each body continuation in the prompt."
(or (hashq-ref (dfa-var-map dfa) var)
(error "unknown var" var)))
-(define (dfa-var-name dfa idx)
- (vector-ref (dfa-names dfa) idx))
-
(define (dfa-var-sym dfa idx)
(vector-ref (dfa-syms dfa) idx))
@@ -717,61 +694,59 @@ BODY for each body continuation in the prompt."
(vector-ref (dfa-out dfa) idx))
(define (compute-live-variables fun dfg)
- (define (make-variable-mapping use-maps)
- (let ((mapping (make-hash-table))
- (n 0))
- (hash-for-each (lambda (sym use-map)
- (hashq-set! mapping sym n)
- (set! n (1+ n)))
- use-maps)
- (values mapping n)))
- (call-with-values (lambda () (make-variable-mapping (dfg-use-maps dfg)))
- (lambda (var-map nvars)
- (let* ((cfa (analyze-control-flow fun dfg #:reverse? #t
- #:add-handler-preds? #t))
- (syms (make-vector nvars #f))
- (names (make-vector nvars #f))
- (usev (make-vector (cfa-k-count cfa) '()))
- (defv (make-vector (cfa-k-count cfa) '()))
- (live-in (make-vector (cfa-k-count cfa) #f))
- (live-out (make-vector (cfa-k-count cfa) #f)))
- ;; Initialize syms, names, defv, and usev.
- (hash-for-each
- (lambda (sym use-map)
- (match use-map
- (($ $use-map name sym def uses)
- (let ((v (or (hashq-ref var-map sym)
- (error "unknown var" sym))))
- (vector-set! syms v sym)
- (vector-set! names v name)
+ (let* ((var-map (make-hash-table))
+ (min-var (dfg-min-var dfg))
+ (nvars (dfg-nvars dfg))
+ (cfa (analyze-control-flow fun dfg #:reverse? #t
+ #:add-handler-preds? #t))
+ (syms (make-vector nvars #f))
+ (usev (make-vector (cfa-k-count cfa) '()))
+ (defv (make-vector (cfa-k-count cfa) '()))
+ (live-in (make-vector (cfa-k-count cfa) #f))
+ (live-out (make-vector (cfa-k-count cfa) #f)))
+ ;; Initialize syms, defv, and usev.
+ (let ((defs (dfg-defs dfg))
+ (uses (dfg-uses dfg))
+ (counter 0))
+ (define (counter++)
+ (let ((res counter))
+ (set! counter (1+ counter))
+ res))
+ (let lp ((n 0))
+ (when (< n (vector-length defs))
+ (let ((def (vector-ref defs n)))
+ (when def
+ (let ((v (counter++)))
+ (hashq-set! var-map (+ n min-var) v)
+ (vector-set! syms v (+ n min-var))
(for-each (lambda (def)
(vector-push! defv (cfa-k-idx cfa def) v))
- (block-preds (lookup-block def (dfg-blocks dfg))))
+ (lookup-predecessors def dfg))
(for-each (lambda (use)
(vector-push! usev (cfa-k-idx cfa use) v))
- uses)))))
- (dfg-use-maps dfg))
-
- ;; Initialize live-in and live-out sets.
- (let lp ((n 0))
- (when (< n (vector-length live-out))
- (vector-set! live-in n (make-bitvector nvars #f))
- (vector-set! live-out n (make-bitvector nvars #f))
- (lp (1+ n))))
-
- ;; Liveness is a reverse data-flow problem, so we give
- ;; compute-maximum-fixed-point a reversed graph, swapping in
- ;; for out, and usev for defv. Note that since we are using
- ;; a reverse CFA, cfa-preds are actually successors, and
- ;; continuation 0 is ktail.
- (compute-maximum-fixed-point (cfa-preds cfa)
- live-out live-in defv usev #t)
-
- (make-dfa cfa var-map names syms live-in live-out)))))
+ (vector-ref uses n)))))
+ (lp (1+ n)))))
+
+ ;; Initialize live-in and live-out sets.
+ (let lp ((n 0))
+ (when (< n (vector-length live-out))
+ (vector-set! live-in n (make-bitvector nvars #f))
+ (vector-set! live-out n (make-bitvector nvars #f))
+ (lp (1+ n))))
+
+ ;; Liveness is a reverse data-flow problem, so we give
+ ;; compute-maximum-fixed-point a reversed graph, swapping in
+ ;; for out, and usev for defv. Note that since we are using
+ ;; a reverse CFA, cfa-preds are actually successors, and
+ ;; continuation 0 is ktail.
+ (compute-maximum-fixed-point (cfa-preds cfa)
+ live-out live-in defv usev #t)
+
+ (make-dfa cfa var-map syms live-in live-out)))
(define (print-dfa dfa)
(match dfa
- (($ $dfa cfa var-map names syms in out)
+ (($ $dfa cfa var-map syms in out)
(define (print-var-set bv)
(let lp ((n 0))
(let ((n (bit-position #t bv n)))
@@ -789,35 +764,29 @@ BODY for each body continuation in the prompt."
(newline)
(lp (1+ n)))))))
-(define (visit-fun fun conts blocks use-maps global?)
- (define (add-def! name sym def-k)
- (unless def-k
- (error "Term outside labelled continuation?"))
- (hashq-set! use-maps sym (make-use-map name sym def-k '())))
+(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! sym use-k)
- (match (hashq-ref use-maps sym)
- (#f (error "Symbol out of scope?" sym))
- ((and use-map ($ $use-map name sym def uses))
- (set-use-map-uses! use-map (cons use-k uses)))))
+ (define (add-use! var use-k)
+ (vector-push! uses (- var min-var) use-k))
(define* (declare-block! label cont parent
#:optional (level
- (1+ (lookup-scope-level parent
blocks))))
- (hashq-set! conts label cont)
- (hashq-set! blocks label (make-block parent 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)
- (let ((pred-block (hashq-ref blocks pred))
- (succ-block (hashq-ref blocks succ)))
- (unless (and pred-block succ-block)
- (error "internal error" pred-block succ-block))
- (set-block-succs! pred-block (cons succ (block-succs pred-block)))
- (set-block-preds! succ-block (cons pred (block-preds succ-block)))))
+ (vector-push! preds (- succ min-label) pred))
(define (visit exp exp-k)
- (define (def! name sym)
- (add-def! name sym exp-k))
+ (define (def! sym)
+ (add-def! sym exp-k))
(define (use! sym)
(add-use! sym exp-k))
(define (use-k! k)
@@ -834,7 +803,7 @@ BODY for each body continuation in the prompt."
(recur body))
(($ $kargs names syms body)
- (for-each/2 def! names syms)
+ (for-each def! syms)
(recur body))
(($ $kif kt kf)
@@ -847,8 +816,11 @@ BODY for each body continuation in the prompt."
(($ $letrec names syms funs body)
(unless global?
(error "$letrec should not be present when building a local DFG"))
- (for-each/2 def! names syms)
- (for-each (cut visit-fun <> conts blocks use-maps global?) funs)
+ (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)
@@ -874,7 +846,8 @@ BODY for each body continuation in the prompt."
(($ $fun)
(when global?
- (visit-fun exp conts blocks use-maps global?)))
+ (visit-fun exp conts preds defs uses scopes scope-levels
+ min-label min-var global?)))
(_ #f)))))
@@ -882,77 +855,123 @@ BODY for each body continuation in the prompt."
(($ $fun src meta free
($ $cont kentry
(and entry
- ($ $kentry self ($ $cont ktail tail) clauses))))
+ ($ $kentry self ($ $cont ktail tail) clause))))
(declare-block! kentry entry #f 0)
- (add-def! #f self kentry)
+ (add-def! self kentry)
(declare-block! ktail tail kentry)
- (for-each
- (match-lambda
- (($ $cont kclause
- (and clause ($ $kclause arity ($ $cont kbody body))))
- (declare-block! kclause clause kentry)
- (link-blocks! kentry kclause)
-
- (declare-block! kbody body kclause)
- (link-blocks! kclause kbody)
-
- (visit body kbody)))
- clauses))))
+ (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))
+ ((make-cont-folder global?
+ min-label max-label label-count
+ min-var max-var var-count)
+ (lambda (label cont
+ min-label max-label label-count
+ min-var max-var var-count)
+ (let ((min-label (min* label min-label))
+ (max-label (max label max-label)))
+ (match cont
+ (($ $kargs names vars)
+ (values min-label max-label (1+ label-count)
+ (cond (min-var (fold min min-var vars))
+ ((pair? vars) (fold min (car vars) (cdr vars)))
+ (else min-var))
+ (fold max max-var vars)
+ (+ var-count (length vars))))
+ (($ $kentry 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)
+ min-var max-var var-count)))))
+ fun
+ #f -1 0 #f -1 0))
(define* (compute-dfg fun #:key (global? #t))
- (let* ((conts (make-hash-table))
- (blocks (make-hash-table))
- (use-maps (make-hash-table)))
- (visit-fun fun conts blocks use-maps global?)
- (make-dfg conts blocks use-maps)))
-
-(define (lookup-block k blocks)
- (let ((res (hashq-ref blocks k)))
+ (call-with-values (lambda () (compute-label-and-var-ranges fun global?))
+ (lambda (min-label max-label label-count min-var max-var var-count)
+ (when (or (zero? label-count) (zero? var-count))
+ (error "internal error (no vars or labels for fun?)"))
+ (let* ((nlabels (- (1+ max-label) min-label))
+ (nvars (- (1+ max-var) min-var))
+ (conts (make-vector nlabels #f))
+ (preds (make-vector nlabels '()))
+ (defs (make-vector nvars #f))
+ (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?)
+ (make-dfg conts preds defs uses scopes scope-levels
+ min-label label-count min-var var-count)))))
+
+(define (lookup-cont label dfg)
+ (let ((res (vector-ref (dfg-cont-table dfg) (- label (dfg-min-label dfg)))))
(unless res
- (error "Unknown continuation!" k (hash-fold acons '() blocks)))
+ (error "Unknown continuation!" label))
res))
-(define (lookup-scope-level k blocks)
- (match (lookup-block k blocks)
- (($ $block _ scope-level) scope-level)))
+(define (lookup-predecessors k dfg)
+ (vector-ref (dfg-preds dfg) (- k (dfg-min-label dfg))))
-(define (lookup-use-map sym use-maps)
- (let ((res (hashq-ref use-maps sym)))
- (unless res
- (error "Unknown lexical!" sym (hash-fold acons '() use-maps)))
- res))
+(define (lookup-successors k dfg)
+ (match (vector-ref (dfg-cont-table dfg) (- k (dfg-min-label dfg)))
+ (($ $kargs names syms body)
+ (let lp ((body body))
+ (match body
+ (($ $letk conts body) (lp body))
+ (($ $letrec names vars funs body) (lp body))
+ (($ $continue k src exp)
+ (match exp
+ (($ $prompt escape? tag handler) (list k handler))
+ (_ (list k)))))))
-(define (lookup-def sym dfg)
- (match dfg
- (($ $dfg conts blocks use-maps)
- (match (lookup-use-map sym use-maps)
- (($ $use-map name sym def uses)
- def)))))
+ (($ $kif kt kf) (list kt kf))
-(define (lookup-uses sym dfg)
- (match dfg
- (($ $dfg conts blocks use-maps)
- (match (lookup-use-map sym use-maps)
- (($ $use-map name sym def uses)
- uses)))))
+ (($ $kreceive arity k) (list k))
-(define (lookup-block-scope k dfg)
- (block-scope (lookup-block k (dfg-blocks dfg))))
+ (($ $kclause arity ($ $cont kbody) #f) (list kbody))
-(define (lookup-predecessors k dfg)
- (match (lookup-block k (dfg-blocks dfg))
- (($ $block _ _ preds succs) preds)))
+ (($ $kclause arity ($ $cont kbody) ($ $cont kalt)) (list kbody kalt))
-(define (lookup-successors k dfg)
- (match (lookup-block k (dfg-blocks dfg))
- (($ $block _ _ preds succs) succs)))
+ (($ $kentry self tail ($ $cont clause)) (list clause))
+
+ (($ $kentry self tail #f) '())
+
+ (($ $ktail) '())))
+
+(define (lookup-def var dfg)
+ (vector-ref (dfg-defs dfg) (- var (dfg-min-var dfg))))
+
+(define (lookup-uses var dfg)
+ (vector-ref (dfg-uses dfg) (- var (dfg-min-var dfg))))
+
+(define (lookup-block-scope k dfg)
+ (vector-ref (dfg-scopes dfg) (- k (dfg-min-label dfg))))
+
+(define (lookup-scope-level k dfg)
+ (vector-ref (dfg-scope-levels dfg) (- k (dfg-min-label dfg))))
(define (find-defining-term sym dfg)
(match (lookup-predecessors (lookup-def sym dfg) dfg)
((def-exp-k)
- (lookup-cont def-exp-k (dfg-cont-table dfg)))
+ (lookup-cont def-exp-k dfg))
(else #f)))
(define (find-call term)
@@ -994,83 +1013,80 @@ BODY for each body continuation in the prompt."
(($ $kargs names syms body) (find-exp body))
(($ $letk conts body) (find-exp body))
(else term)))
- (match dfg
- (($ $dfg conts blocks use-maps)
- (match (lookup-use-map sym use-maps)
- (($ $use-map _ _ def uses)
- (or-map
- (lambda (use)
- (match (find-expression (lookup-cont use conts))
- (($ $call) #f)
- (($ $callk) #f)
- (($ $values) #f)
- (($ $primcall 'free-ref (closure slot))
- (not (eq? sym slot)))
- (($ $primcall 'free-set! (closure slot value))
- (not (eq? sym slot)))
- (($ $primcall 'cache-current-module! (mod . _))
- (eq? sym mod))
- (($ $primcall 'cached-toplevel-box _)
- #f)
- (($ $primcall 'cached-module-box _)
- #f)
- (($ $primcall 'resolve (name bound?))
- (eq? sym name))
- (($ $primcall 'make-vector/immediate (len init))
- (not (eq? sym len)))
- (($ $primcall 'vector-ref/immediate (v i))
- (not (eq? sym i)))
- (($ $primcall 'vector-set!/immediate (v i x))
- (not (eq? sym i)))
- (($ $primcall 'allocate-struct/immediate (vtable nfields))
- (not (eq? sym nfields)))
- (($ $primcall 'struct-ref/immediate (s n))
- (not (eq? sym n)))
- (($ $primcall 'struct-set!/immediate (s n x))
- (not (eq? sym n)))
- (($ $primcall 'builtin-ref (idx))
- #f)
- (_ #t)))
- uses))))))
-
-(define (continuation-scope-contains? scope-k k blocks)
- (let ((scope-level (lookup-scope-level scope-k blocks)))
+
+ (or-map
+ (lambda (use)
+ (match (find-expression (lookup-cont use dfg))
+ (($ $call) #f)
+ (($ $callk) #f)
+ (($ $values) #f)
+ (($ $primcall 'free-ref (closure slot))
+ (not (eq? sym slot)))
+ (($ $primcall 'free-set! (closure slot value))
+ (not (eq? sym slot)))
+ (($ $primcall 'cache-current-module! (mod . _))
+ (eq? sym mod))
+ (($ $primcall 'cached-toplevel-box _)
+ #f)
+ (($ $primcall 'cached-module-box _)
+ #f)
+ (($ $primcall 'resolve (name bound?))
+ (eq? sym name))
+ (($ $primcall 'make-vector/immediate (len init))
+ (not (eq? sym len)))
+ (($ $primcall 'vector-ref/immediate (v i))
+ (not (eq? sym i)))
+ (($ $primcall 'vector-set!/immediate (v i x))
+ (not (eq? sym i)))
+ (($ $primcall 'allocate-struct/immediate (vtable nfields))
+ (not (eq? sym nfields)))
+ (($ $primcall 'struct-ref/immediate (s n))
+ (not (eq? sym n)))
+ (($ $primcall 'struct-set!/immediate (s n x))
+ (not (eq? sym n)))
+ (($ $primcall 'builtin-ref (idx))
+ #f)
+ (_ #t)))
+ (vector-ref (dfg-uses dfg) (- sym (dfg-min-var dfg)))))
+
+(define (continuation-scope-contains? scope-k k dfg)
+ (let ((scope-level (lookup-scope-level scope-k dfg)))
(let lp ((k k))
(or (eq? scope-k k)
- (match (lookup-block k blocks)
- (($ $block scope level)
- (and (< scope-level level)
- (lp scope))))))))
+ (and (< scope-level (lookup-scope-level k dfg))
+ (lp (lookup-block-scope k dfg)))))))
(define (continuation-bound-in? k use-k dfg)
- (match dfg
- (($ $dfg conts blocks use-maps)
- (match (lookup-block k blocks)
- (($ $block def-k)
- (continuation-scope-contains? def-k use-k blocks))))))
+ (continuation-scope-contains? (lookup-block-scope k dfg) use-k dfg))
(define (variable-free-in? var k dfg)
- (match dfg
- (($ $dfg conts blocks use-maps)
- (or-map (lambda (use)
- (continuation-scope-contains? k use blocks))
- (match (lookup-use-map var use-maps)
- (($ $use-map name sym def uses)
- uses))))))
+ (or-map (lambda (use)
+ (continuation-scope-contains? k use dfg))
+ (lookup-uses var dfg)))
;; A continuation is a control point if it has multiple predecessors, or
-;; if its single predecessor has multiple successors.
+;; if its single predecessor does not have a single successor.
(define (control-point? k dfg)
(match (lookup-predecessors k dfg)
((pred)
- (match (lookup-successors pred dfg)
- ((_) #f)
- (_ #t)))
+ (match (vector-ref (dfg-cont-table dfg) (- pred (dfg-min-label dfg)))
+ (($ $kargs names syms body)
+ (let lp ((body body))
+ (match body
+ (($ $letk conts body) (lp body))
+ (($ $letrec names vars funs body) (lp body))
+ (($ $continue k src exp)
+ (match exp
+ (($ $prompt) #t)
+ (_ #f))))))
+ (($ $kif) #t)
+ (($ $kreceive) #f)
+ (($ $kclause) #f)
+ (($ $kentry) #f)
+ (($ $ktail) #t)))
(_ #t)))
(define (lookup-bound-syms k dfg)
- (match dfg
- (($ $dfg conts blocks use-maps)
- (match (lookup-cont k conts)
- (($ $kargs names syms body)
- syms)))))
+ (match (lookup-cont k dfg)
+ (($ $kargs names syms body)
+ syms)))
diff --git a/module/language/cps/effects-analysis.scm
b/module/language/cps/effects-analysis.scm
index 3c2b5da..87eed03 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -467,7 +467,7 @@
(vector-set!
effects
n
- (match (lookup-cont (cfa-k-sym cfa n) (dfg-cont-table dfg))
+ (match (lookup-cont (cfa-k-sym cfa n) dfg)
(($ $kargs names syms body)
(expression-effects (find-expression body) dfg))
(($ $kreceive arity kargs)
diff --git a/module/language/cps/elide-values.scm
b/module/language/cps/elide-values.scm
index d6590aa..c770f88 100644
--- a/module/language/cps/elide-values.scm
+++ b/module/language/cps/elide-values.scm
@@ -35,70 +35,74 @@
#:use-module (language cps dfg)
#:export (elide-values))
-(define (elide-values fun)
- (let ((conts (build-local-cont-table
- (match fun (($ $fun src meta free body) 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 tail clauses))
- (sym ($kentry self ,tail ,(map visit-cont clauses))))
- (($ $cont sym ($ $kclause arity body))
- (sym ($kclause ,arity ,(visit-cont body))))
- (($ $cont)
- ,cont)))
- (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 elide-values funs)
- ,(visit-term body)))
- (($ $continue k src ($ $primcall 'values vals))
- ,(rewrite-cps-term (lookup-cont k conts)
- (($ $ktail)
- ($continue k src ($values vals)))
- (($ $kreceive ($ $arity req () rest () #f) kargs)
- ,(cond
- ((and (not rest) (= (length vals) (length req)))
- (build-cps-term
- ($continue kargs src ($values vals))))
- ((and rest (>= (length vals) (length req)))
- (let-gensyms (krest rest)
- (let ((vals* (append (list-head vals (length req))
- (list rest))))
- (build-cps-term
- ($letk ((krest ($kargs ('rest) (rest)
- ($continue kargs src
- ($values vals*)))))
- ,(let lp ((tail (list-tail vals (length req)))
- (k krest))
- (match tail
- (()
- (build-cps-term ($continue k src
- ($const '()))))
- ((v . tail)
- (let-gensyms (krest rest)
- (build-cps-term
- ($letk ((krest ($kargs ('rest) (rest)
- ($continue k src
- ($primcall 'cons
- (v rest))))))
- ,(lp tail krest))))))))))))
- (else term)))
- (($ $kargs args)
- ,(if (< (length vals) (length args))
- term
- (let ((vals (list-head vals (length args))))
- (build-cps-term
- ($continue k src ($values vals))))))))
- (($ $continue k src (and fun ($ $fun)))
- ($continue k src ,(elide-values fun)))
- (($ $continue)
- ,term)))
+(define (elide-values* fun conts)
+ (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 tail clause))
+ (sym ($kentry self ,tail ,(and clause (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)))
+ (($ $letrec names syms funs body)
+ ($letrec names syms (map (cut elide-values* <> conts) funs)
+ ,(visit-term body)))
+ (($ $continue k src ($ $primcall 'values vals))
+ ,(rewrite-cps-term (vector-ref conts k)
+ (($ $ktail)
+ ($continue k src ($values vals)))
+ (($ $kreceive ($ $arity req () rest () #f) kargs)
+ ,(cond
+ ((and (not rest) (= (length vals) (length req)))
+ (build-cps-term
+ ($continue kargs src ($values vals))))
+ ((and rest (>= (length vals) (length req)))
+ (let-fresh (krest) (rest)
+ (let ((vals* (append (list-head vals (length req))
+ (list rest))))
+ (build-cps-term
+ ($letk ((krest ($kargs ('rest) (rest)
+ ($continue kargs src
+ ($values vals*)))))
+ ,(let lp ((tail (list-tail vals (length req)))
+ (k krest))
+ (match tail
+ (()
+ (build-cps-term ($continue k src
+ ($const '()))))
+ ((v . tail)
+ (let-fresh (krest) (rest)
+ (build-cps-term
+ ($letk ((krest ($kargs ('rest) (rest)
+ ($continue k src
+ ($primcall 'cons
+ (v rest))))))
+ ,(lp tail krest))))))))))))
+ (else term)))
+ (($ $kargs args)
+ ,(if (< (length vals) (length args))
+ term
+ (let ((vals (list-head vals (length args))))
+ (build-cps-term
+ ($continue k src ($values vals))))))))
+ (($ $continue k src (and fun ($ $fun)))
+ ($continue k src ,(elide-values* fun conts)))
+ (($ $continue)
+ ,term)))
+
+ (rewrite-cps-exp fun
+ (($ $fun src meta free body)
+ ($fun src meta free ,(visit-cont body)))))
- (rewrite-cps-exp fun
- (($ $fun src meta free body)
- ($fun src meta free ,(visit-cont body))))))
+(define (elide-values fun)
+ (with-fresh-name-state fun
+ (let ((conts (build-cont-table fun)))
+ (elide-values* fun conts))))
diff --git a/module/language/cps/prune-top-level-scopes.scm
b/module/language/cps/prune-top-level-scopes.scm
index fc337c1..7ee7972 100644
--- a/module/language/cps/prune-top-level-scopes.scm
+++ b/module/language/cps/prune-top-level-scopes.scm
@@ -37,10 +37,11 @@
(hashq-set! refs k sym)))
(($ $cont k ($ $kargs names syms body))
(visit-term body))
- (($ $cont k ($ $kentry self tail clauses))
- (for-each visit-cont clauses))
- (($ $cont k ($ $kclause arity body))
- (visit-cont body))
+ (($ $cont k ($ $kentry self tail clause))
+ (when clause (visit-cont clause)))
+ (($ $cont k ($ $kclause arity body alternate))
+ (visit-cont body)
+ (when alternate (visit-cont alternate)))
(($ $cont k (or ($ $kreceive) ($ $kif)))
#t)))
(define (visit-term term)
@@ -89,10 +90,11 @@
(rewrite-cps-cont cont
(($ $cont sym ($ $kargs names syms body))
(sym ($kargs names syms ,(visit-term body))))
- (($ $cont sym ($ $kentry self tail clauses))
- (sym ($kentry self ,tail ,(map visit-cont clauses))))
- (($ $cont sym ($ $kclause arity body))
- (sym ($kclause ,arity ,(visit-cont body))))
+ (($ $cont sym ($ $kentry self tail clause))
+ (sym ($kentry self ,tail ,(and clause (visit-cont clause)))))
+ (($ $cont sym ($ $kclause arity body alternate))
+ (sym ($kclause ,arity ,(visit-cont body)
+ ,(and alternate (visit-cont alternate)))))
(($ $cont sym (or ($ $kreceive) ($ $kif)))
,cont)))
(define (visit-term term)
diff --git a/module/language/cps/reify-primitives.scm
b/module/language/cps/reify-primitives.scm
index e165798..e6d3736 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -33,7 +33,7 @@
#:export (reify-primitives))
(define (module-box src module name public? bound? val-proc)
- (let-gensyms (module-sym name-sym public?-sym bound?-sym kbox box)
+ (let-fresh (kbox) (module-sym name-sym public?-sym bound?-sym box)
(build-cps-term
($letconst (('module module-sym module)
('name name-sym name)
@@ -81,14 +81,14 @@
($continue k src ($primcall 'box-ref (box)))))))
(define (builtin-ref idx k src)
- (let-gensyms (idx-sym)
+ (let-fresh () (idx-sym)
(build-cps-term
($letconst (('idx idx-sym idx))
($continue k src
($primcall 'builtin-ref (idx-sym)))))))
(define (reify-clause ktail)
- (let-gensyms (kclause kbody wna false str eol kthrow throw)
+ (let-fresh (kclause kbody kthrow) (wna false str eol throw)
(build-cps-cont
(kclause ($kclause ('() '() #f '() #f)
(kbody
@@ -102,63 +102,66 @@
($continue ktail #f
($call throw
(wna false str eol false))))))
- ,(primitive-ref 'throw kthrow #f))))))))))
+ ,(primitive-ref 'throw kthrow #f)))))
+ ,#f)))))
;; FIXME: Operate on one function at a time, for efficiency.
(define (reify-primitives 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)) ()))
- ;; A case-lambda with no clauses. Reify a clause.
- (sym ($kentry self ,tail (,(reify-clause ktail)))))
- (($ $cont sym ($ $kentry self tail clauses))
- (sym ($kentry self ,tail ,(map visit-cont clauses))))
- (($ $cont sym ($ $kclause arity body))
- (sym ($kclause ,arity ,(visit-cont body))))
- (($ $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 (lookup-cont k conts)
- (($ $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-gensyms (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)))
+ (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))))
diff --git a/module/language/cps/renumber.scm b/module/language/cps/renumber.scm
new file mode 100644
index 0000000..056b1ad
--- /dev/null
+++ b/module/language/cps/renumber.scm
@@ -0,0 +1,184 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2014 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+;;; Commentary:
+;;;
+;;; A pass to renumber variables and continuation labels so that they
+;;; are contiguous within each function.
+;;;
+;;; Code:
+
+(define-module (language cps renumber)
+ #:use-module (ice-9 match)
+ #:use-module (language cps)
+ #:export (renumber))
+
+(define (visit-funs proc fun)
+ (define (visit-cont cont)
+ (match cont
+ (($ $cont label cont)
+ (match cont
+ (($ $kargs names vars body)
+ (visit-term body))
+ (($ $kentry self tail clause)
+ (when clause
+ (visit-cont clause)))
+ (($ $kclause arity body alternate)
+ (visit-cont body)
+ (when alternate
+ (visit-cont alternate)))
+ ((or ($ $kreceive) ($ $kif))
+ #f)))))
+ (define (visit-term term)
+ (match term
+ (($ $letk conts body)
+ (for-each visit-cont conts)
+ (visit-term body))
+ (($ $letrec names syms funs body)
+ (for-each visit-fun funs)
+ (visit-term body))
+ (($ $continue k src (and fun ($ $fun)))
+ (visit-fun fun))
+ (($ $continue k src _)
+ #f)))
+ (define (visit-fun fun)
+ (proc fun)
+ (match fun
+ (($ $fun src meta free body)
+ (visit-cont body))))
+ (visit-fun fun))
+
+(define (compute-new-labels-and-vars fun)
+ (call-with-values (lambda () (compute-max-label-and-var fun))
+ (lambda (max-label max-var)
+ (let ((labels (make-vector (1+ max-label)))
+ (next-label 0)
+ (vars (make-vector (1+ max-var)))
+ (next-var 0))
+ (define (relabel! label)
+ (vector-set! labels label next-label)
+ (set! next-label (1+ next-label)))
+ (define (rename! var)
+ (vector-set! vars var next-var)
+ (set! next-var (1+ next-var)))
+ (define (compute-names-in-fun fun)
+ (define (visit-cont cont)
+ (match cont
+ (($ $cont label cont)
+ (relabel! label)
+ (match cont
+ (($ $kargs names vars body)
+ (for-each rename! vars)
+ (visit-term body))
+ (($ $kentry self tail clause)
+ (rename! self)
+ (visit-cont tail)
+ (when clause
+ (visit-cont clause)))
+ (($ $kclause arity body alternate)
+ (visit-cont body)
+ (when alternate
+ (visit-cont alternate)))
+ ((or ($ $ktail) ($ $kreceive) ($ $kif))
+ #f)))))
+ (define (visit-term term)
+ (match term
+ (($ $letk conts body)
+ (for-each visit-cont conts)
+ (visit-term body))
+ (($ $letrec names syms funs body)
+ (for-each rename! syms)
+ (visit-term body))
+ (($ $continue k src _)
+ #f)))
+ (match fun
+ (($ $fun src meta free body)
+ (visit-cont body))))
+
+ (visit-funs compute-names-in-fun fun)
+ (values labels vars)))))
+
+(define (renumber fun)
+ (call-with-values (lambda () (compute-new-labels-and-vars fun))
+ (lambda (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 (visit-cont cont)
+ (rewrite-cps-cont cont
+ (($ $cont label ($ $kargs names vars body))
+ ((relabel label)
+ ($kargs names (map rename vars) ,(visit-term body))))
+ (($ $cont label ($ $kentry self tail clause))
+ ((relabel label)
+ ($kentry (rename self) ,(visit-cont tail)
+ ,(and clause (visit-cont clause)))))
+ (($ $cont label ($ $ktail))
+ ((relabel label) ($ktail)))
+ (($ $cont label ($ $kclause arity body alternate))
+ ((relabel label)
+ ($kclause ,(rename-kw-arity arity) ,(visit-cont body)
+ ,(and alternate (visit-cont alternate)))))
+ (($ $cont label ($ $kreceive ($ $arity req () rest () #f) kargs))
+ ((relabel label) ($kreceive req rest (relabel kargs))))
+ (($ $cont label ($ $kif kt kf))
+ ((relabel label) ($kif (relabel kt) (relabel kf))))))
+ (define (visit-term term)
+ (rewrite-cps-term term
+ (($ $letk conts body)
+ ($letk ,(map visit-cont 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) ,(visit-cont body)))))
+ (visit-fun fun))))
diff --git a/module/language/cps/simplify.scm b/module/language/cps/simplify.scm
index 98788b7..c30ba76 100644
--- a/module/language/cps/simplify.scm
+++ b/module/language/cps/simplify.scm
@@ -26,6 +26,7 @@
(define-module (language cps simplify)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (language cps)
#:use-module (language cps dfg)
@@ -52,10 +53,11 @@
(rewrite-cps-cont cont
(($ $kargs names syms body)
(sym ($kargs names syms ,(visit-term body))))
- (($ $kentry self tail clauses)
- (sym ($kentry self ,tail ,(visit-conts clauses))))
- (($ $kclause arity body)
- (sym ($kclause ,arity ,(must-visit-cont body))))
+ (($ $kentry self tail clause)
+ (sym ($kentry self ,tail ,(and clause (visit-cont clause)))))
+ (($ $kclause arity body alternate)
+ (sym ($kclause ,arity ,(must-visit-cont body)
+ ,(and alternate (visit-cont alternate)))))
((or ($ $kreceive) ($ $kif))
(sym ,cont)))))))
(define (visit-conts conts)
@@ -86,10 +88,11 @@
(match cont
(($ $cont sym ($ $kargs names syms body))
(visit-term body sym syms))
- (($ $cont sym ($ $kentry self tail clauses))
- (for-each visit-cont clauses))
- (($ $cont sym ($ $kclause arity body))
- (visit-cont body))
+ (($ $cont sym ($ $kentry self tail clause))
+ (when clause (visit-cont clause)))
+ (($ $cont sym ($ $kclause arity body alternate))
+ (visit-cont body)
+ (when alternate (visit-cont alternate)))
(($ $cont sym _) #f)))
(define (visit-term term term-k term-args)
(match term
@@ -122,7 +125,7 @@
(k*
(if (and (continuation-bound-in? k* scope dfg)
(or values?
- (match (lookup-cont k* (dfg-cont-table dfg))
+ (match (lookup-cont k* dfg)
(($ $kargs) #t)
(_ #f))))
(reduce* k* scope values?)
@@ -135,10 +138,11 @@
(rewrite-cps-cont cont
(($ $cont sym ($ $kargs names syms body))
(sym ($kargs names syms ,(visit-term body sym))))
- (($ $cont sym ($ $kentry self tail clauses))
- (sym ($kentry self ,tail ,(map (cut visit-cont <> sym) clauses))))
- (($ $cont sym ($ $kclause arity body))
- (sym ($kclause ,arity ,(visit-cont body sym))))
+ (($ $cont sym ($ $kentry self tail clause))
+ (sym ($kentry 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)))))
(($ $cont sym ($ $kreceive ($ $arity req () rest () #f) kargs))
(sym ($kreceive req rest (reduce kargs scope))))
(($ $cont sym ($ $kif kt kf))
@@ -167,16 +171,18 @@
;; A continuation's body can be inlined in place of a $values
;; expression if the continuation is a $kargs. It should only be
;; inlined if it is used only once, and not recursively.
- (let ((table (make-hash-table))
+ (let ((var-table (make-hash-table))
+ (k-table (make-hash-table))
(dfg (compute-dfg fun)))
(define (visit-cont cont)
(match cont
(($ $cont sym ($ $kargs names syms body))
(visit-term body))
- (($ $cont sym ($ $kentry self tail clauses))
- (for-each visit-cont clauses))
- (($ $cont sym ($ $kclause arity body))
- (visit-cont body))
+ (($ $cont sym ($ $kentry self tail clause))
+ (when clause (visit-cont clause)))
+ (($ $cont sym ($ $kclause arity body alternate))
+ (visit-cont body)
+ (when alternate (visit-cont alternate)))
(($ $cont sym (or ($ $ktail) ($ $kreceive) ($ $kif)))
#f)))
(define (visit-term term)
@@ -188,7 +194,7 @@
(for-each visit-fun funs)
(visit-term body))
(($ $continue k src ($ $values args))
- (match (lookup-cont k (dfg-cont-table dfg))
+ (match (lookup-cont k dfg)
(($ $kargs names syms body)
(match (lookup-predecessors k dfg)
((_)
@@ -198,8 +204,8 @@
;; -> body mapping in the table. Also store the
;; substitutions for the variables bound by the inlined
;; continuation.
- (for-each (cut hashq-set! table <> <>) syms args)
- (hashq-set! table k body))
+ (for-each (cut hashq-set! var-table <> <>) syms args)
+ (hashq-set! k-table k body))
(_ #f)))
(_ #f)))
(($ $continue k src (and fun ($ $fun)))
@@ -211,12 +217,12 @@
(($ $fun src meta free body)
(visit-cont body))))
(visit-fun fun)
- table))
+ (values var-table k-table)))
(define (beta-reduce fun)
- (let ((table (compute-beta-reductions fun)))
+ (let-values (((var-table k-table) (compute-beta-reductions fun)))
(define (subst var)
- (cond ((hashq-ref table var) => subst)
+ (cond ((hashq-ref var-table var) => subst)
(else var)))
(define (must-visit-cont cont)
(or (visit-cont cont)
@@ -224,14 +230,16 @@
(define (visit-cont cont)
(match cont
(($ $cont sym cont)
- (and (not (hashq-ref table sym))
+ (and (not (hashq-ref k-table sym))
(rewrite-cps-cont cont
(($ $kargs names syms body)
(sym ($kargs names syms ,(visit-term body))))
- (($ $kentry self tail clauses)
- (sym ($kentry self ,tail ,(map must-visit-cont clauses))))
- (($ $kclause arity body)
- (sym ($kclause ,arity ,(must-visit-cont body))))
+ (($ $kentry self tail clause)
+ (sym ($kentry self ,tail
+ ,(and clause (must-visit-cont clause)))))
+ (($ $kclause arity body alternate)
+ (sym ($kclause ,arity ,(must-visit-cont body)
+ ,(and alternate (must-visit-cont alternate)))))
((or ($ $kreceive) ($ $kif))
(sym ,cont)))))))
(define (visit-term term)
@@ -247,7 +255,7 @@
,(visit-term body))))
(($ $continue k src exp)
(cond
- ((hashq-ref table k) => visit-term)
+ ((hashq-ref k-table k) => visit-term)
(else
(build-cps-term
($continue k src
diff --git a/module/language/cps/slot-allocation.scm
b/module/language/cps/slot-allocation.scm
index 24a6d5f..96a577b 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -331,11 +331,10 @@ are comparable with eqv?. A tmp slot may be used."
;; Transform the DFG's continuation table to a vector, for easy
;; access.
(define (compute-conts!)
- (let ((cont-table (dfg-cont-table dfg)))
- (let lp ((n 0))
- (when (< n (vector-length contv))
- (vector-set! contv n (lookup-cont (cfa-k-sym cfa n) cont-table))
- (lp (1+ n))))))
+ (let lp ((n 0))
+ (when (< n (vector-length contv))
+ (vector-set! contv n (lookup-cont (cfa-k-sym cfa n) dfg))
+ (lp (1+ n)))))
;; Record uses and defs, as lists of variable indexes, indexed by
;; CFA continuation index.
@@ -660,7 +659,7 @@ are comparable with eqv?. A tmp slot may be used."
(error "Unexpected clause live set"))
(set! nlocals 1)
(match (vector-ref contv n)
- (($ $kclause arity ($ $cont kbody ($ $kargs names)))
+ (($ $kclause arity ($ $cont kbody ($ $kargs names)) alternate)
(unless (eq? (cfa-k-sym cfa (1+ n)) kbody)
(error "Unexpected CFA order"))
(let* ((nargs (length names))
@@ -671,6 +670,10 @@ are comparable with eqv?. A tmp slot may be used."
(cdr (iota (1+ nargs)))))))
(hashq-set! nlocals-table (cfa-k-sym cfa n) nlocals)
(when (< next (cfa-k-count cfa))
+ (match alternate
+ (($ $cont kalt)
+ (unless (eq? kalt (cfa-k-sym cfa next))
+ (error "Unexpected clause order"))))
(visit-clauses next live))))))
(match (vector-ref contv 0)
(($ $kentry self)
diff --git a/module/language/cps/specialize-primcalls.scm
b/module/language/cps/specialize-primcalls.scm
index f5d61bd..6372026 100644
--- a/module/language/cps/specialize-primcalls.scm
+++ b/module/language/cps/specialize-primcalls.scm
@@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -31,81 +31,83 @@
#:export (specialize-primcalls))
(define (specialize-primcalls fun)
- (let ((dfg (compute-dfg fun #:global? #t)))
- (define (immediate-u8? sym)
- (call-with-values (lambda () (find-constant-value sym dfg))
- (lambda (has-const? val)
- (and has-const? (integer? val) (exact? val) (<= 0 val 255)))))
- (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 tail clauses))
- (sym ($kentry self ,tail ,(map visit-cont clauses))))
- (($ $cont sym ($ $kclause arity body))
- (sym ($kclause ,arity ,(visit-cont body))))
- (($ $cont)
- ,cont)))
- (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 visit-fun funs)
- ,(visit-term body)))
- (($ $continue k src (and fun ($ $fun)))
- ($continue k src ,(visit-fun fun)))
- (($ $continue k src ($ $primcall name args))
- ,(visit-primcall k src name args))
- (($ $continue)
- ,term)))
- (define (visit-primcall k src name args)
- ;; If we introduce a VM op from a primcall without a VM op, we
- ;; will need to ensure that the return arity matches. Rely on the
- ;; elide-values pass to clean up.
- (define-syntax-rule (adapt-void exp)
- (let-gensyms (k* val kvoid)
- (build-cps-term
- ($letk ((k* ($kargs ('val) (val)
- ($continue k src ($primcall 'values (val)))))
- (kvoid ($kargs () ()
- ($continue k* src ($void)))))
- ($continue kvoid src exp)))))
- (define-syntax-rule (adapt-val exp)
- (let-gensyms (k* val)
- (build-cps-term
- ($letk ((k* ($kargs ('val) (val)
- ($continue k src ($primcall 'values (val))))))
- ($continue k* src exp)))))
- (match (cons name args)
- (('make-vector (? immediate-u8? n) init)
- (adapt-val ($primcall 'make-vector/immediate (n init))))
- (('vector-ref v (? immediate-u8? n))
- (build-cps-term
- ($continue k src ($primcall 'vector-ref/immediate (v n)))))
- (('vector-set! v (? immediate-u8? n) x)
- (build-cps-term
- ($continue k src ($primcall 'vector-set!/immediate (v n x)))))
- (('allocate-struct v (? immediate-u8? n))
- (adapt-val ($primcall 'allocate-struct/immediate (v n))))
- (('struct-ref s (? immediate-u8? n))
- (adapt-val ($primcall 'struct-ref/immediate (s n))))
- (('struct-set! s (? immediate-u8? n) x)
- ;; Unhappily, and undocumentedly, struct-set! returns the value
- ;; that was set. There is code that relies on this. Hackety
- ;; hack...
- (let-gensyms (k*)
+ (with-fresh-name-state fun
+ (let ((dfg (compute-dfg fun #:global? #t)))
+ (define (immediate-u8? sym)
+ (call-with-values (lambda () (find-constant-value sym dfg))
+ (lambda (has-const? val)
+ (and has-const? (integer? val) (exact? val) (<= 0 val 255)))))
+ (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 tail clause))
+ (sym ($kentry self ,tail ,(and clause (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)))
+ (($ $letrec names syms funs body)
+ ($letrec names syms (map visit-fun funs)
+ ,(visit-term body)))
+ (($ $continue k src (and fun ($ $fun)))
+ ($continue k src ,(visit-fun fun)))
+ (($ $continue k src ($ $primcall name args))
+ ,(visit-primcall k src name args))
+ (($ $continue)
+ ,term)))
+ (define (visit-primcall k src name args)
+ ;; If we introduce a VM op from a primcall without a VM op, we
+ ;; will need to ensure that the return arity matches. Rely on the
+ ;; elide-values pass to clean up.
+ (define-syntax-rule (adapt-void exp)
+ (let-fresh (k* kvoid) (val)
+ (build-cps-term
+ ($letk ((k* ($kargs ('val) (val)
+ ($continue k src ($primcall 'values (val)))))
+ (kvoid ($kargs () ()
+ ($continue k* src ($void)))))
+ ($continue kvoid src exp)))))
+ (define-syntax-rule (adapt-val exp)
+ (let-fresh (k*) (val)
+ (build-cps-term
+ ($letk ((k* ($kargs ('val) (val)
+ ($continue k src ($primcall 'values (val))))))
+ ($continue k* src exp)))))
+ (match (cons name args)
+ (('make-vector (? immediate-u8? n) init)
+ (adapt-val ($primcall 'make-vector/immediate (n init))))
+ (('vector-ref v (? immediate-u8? n))
(build-cps-term
- ($letk ((k* ($kargs () ()
- ($continue k src ($primcall 'values (x))))))
- ($continue k* src ($primcall 'struct-set!/immediate (s n
x)))))))
- (_
- (build-cps-term ($continue k src ($primcall name args))))))
+ ($continue k src ($primcall 'vector-ref/immediate (v n)))))
+ (('vector-set! v (? immediate-u8? n) x)
+ (build-cps-term
+ ($continue k src ($primcall 'vector-set!/immediate (v n x)))))
+ (('allocate-struct v (? immediate-u8? n))
+ (adapt-val ($primcall 'allocate-struct/immediate (v n))))
+ (('struct-ref s (? immediate-u8? n))
+ (adapt-val ($primcall 'struct-ref/immediate (s n))))
+ (('struct-set! s (? immediate-u8? n) x)
+ ;; Unhappily, and undocumentedly, struct-set! returns the value
+ ;; that was set. There is code that relies on this. Hackety
+ ;; hack...
+ (let-fresh (k*) ()
+ (build-cps-term
+ ($letk ((k* ($kargs () ()
+ ($continue k src ($primcall 'values (x))))))
+ ($continue k* src ($primcall 'struct-set!/immediate (s n
x)))))))
+ (_
+ (build-cps-term ($continue k src ($primcall name args))))))
- (define (visit-fun fun)
- (rewrite-cps-exp fun
- (($ $fun src meta free body)
- ($fun src meta free ,(visit-cont body)))))
+ (define (visit-fun fun)
+ (rewrite-cps-exp fun
+ (($ $fun src meta free body)
+ ($fun src meta free ,(visit-cont body)))))
- (visit-fun fun)))
+ (visit-fun fun))))
diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm
index 10cb748..9bc082b 100644
--- a/module/language/cps/verify.scm
+++ b/module/language/cps/verify.scm
@@ -28,27 +28,43 @@
#:export (verify-cps))
(define (verify-cps fun)
- (define seen-gensyms (make-hash-table))
+ (define seen-labels (make-hash-table))
+ (define seen-vars (make-hash-table))
- (define (add sym env)
- (if (hashq-ref seen-gensyms sym)
- (error "duplicate gensym" sym)
- (begin
- (hashq-set! seen-gensyms sym #t)
- (cons sym env))))
+ (define (add sym seen env)
+ (when (hashq-ref seen sym)
+ (error "duplicate gensym" sym))
+ (hashq-set! seen sym #t)
+ (cons sym env))
- (define (add-env new env)
+ (define (add-env new seen env)
(if (null? new)
env
- (add-env (cdr new) (add (car new) env))))
+ (add-env (cdr new) seen (add (car new) seen env))))
- (define (check-var sym env)
+ (define (add-vars new env)
+ (unless (and-map exact-integer? new)
+ (error "bad vars" new))
+ (add-env new seen-vars env))
+
+ (define (add-labels new env)
+ (unless (and-map exact-integer? new)
+ (error "bad labels" new))
+ (add-env new seen-labels env))
+
+ (define (check-ref sym seen env)
(cond
- ((not (hashq-ref seen-gensyms sym))
+ ((not (hashq-ref seen sym))
(error "unbound lexical" sym))
((not (memq sym env))
(error "displaced lexical" sym))))
+ (define (check-label sym env)
+ (check-ref sym seen-labels env))
+
+ (define (check-var sym env)
+ (check-ref sym seen-vars env))
+
(define (check-src src)
(if (and src (not (and (list? src) (and-map pair? src)
(and-map symbol? (map car src)))))
@@ -57,14 +73,14 @@
(define (visit-cont-body cont k-env v-env)
(match cont
(($ $kif kt kf)
- (check-var kt k-env)
- (check-var kf k-env))
+ (check-label kt k-env)
+ (check-label kf k-env))
(($ $kreceive ($ $arity ((? symbol?) ...) () (or #f (? symbol?)) () #f)
k)
- (check-var k k-env))
- (($ $kargs ((? symbol? name) ...) ((? symbol? sym) ...) body)
+ (check-label k k-env))
+ (($ $kargs ((? symbol? name) ...) (sym ...) body)
(unless (= (length name) (length sym))
(error "name and sym lengths don't match" name sym))
- (visit-term body k-env (add-env sym v-env)))
+ (visit-term body k-env (add-vars sym v-env)))
(_
;; $kclause, $kentry, and $ktail are only ever seen in $fun.
(error "unexpected cont body" cont))))
@@ -79,7 +95,8 @@
(and rest (or #f (? symbol?)))
(((? keyword? kw) (? symbol? kwname) (? symbol? kwsym)) ...)
(or #f #t))
- ($ $cont kbody (and body ($ $kargs names syms _)))))
+ ($ $cont kbody (and body ($ $kargs names syms _)))
+ alternate))
(for-each (lambda (sym)
(unless (memq sym syms)
(error "bad keyword sym" sym)))
@@ -89,25 +106,28 @@
(unless (equal? (append req opt (if rest (list rest) '()) kwname)
names)
(error "clause body names do not match arity names" exp))
- (let ((k-env (add-env (list kclause kbody) k-env)))
- (visit-cont-body body k-env v-env)))
+ (let ((k-env (add-labels (list kclause kbody) k-env)))
+ (visit-cont-body body k-env v-env))
+ (when alternate
+ (visit-clause alternate k-env v-env)))
(_
(error "unexpected clause" clause))))
(define (visit-fun fun k-env v-env)
(match fun
- (($ $fun src meta ((? symbol? free) ...)
+ (($ $fun src meta (free ...)
($ $cont kbody
- ($ $kentry (? symbol? self) ($ $cont ktail ($ $ktail)) clauses)))
+ ($ $kentry 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)
(check-src src)
;; Reset the continuation environment, because Guile's
;; continuations are local.
- (let ((v-env (add-env (list self) v-env))
- (k-env (add-env (list ktail) '())))
- (for-each (cut visit-clause <> k-env v-env) clauses)))
+ (let ((v-env (add-vars (list self) v-env))
+ (k-env (add-labels (list ktail) '())))
+ (when clause
+ (visit-clause clause k-env v-env))))
(_
(error "unexpected $fun" fun))))
@@ -121,43 +141,43 @@
#t)
(($ $fun)
(visit-fun exp k-env v-env))
- (($ $call (? symbol? proc) ((? symbol? arg) ...))
+ (($ $call (? symbol? proc) (arg ...))
(check-var proc v-env)
(for-each (cut check-var <> v-env) arg))
- (($ $callk (? symbol? k*) (? symbol? proc) ((? symbol? arg) ...))
+ (($ $callk k* proc (arg ...))
;; We don't check that k* is in scope; it's actually inside some
;; other function, probably. We rely on the transformation that
;; introduces the $callk to be correct, and the linker to resolve
;; the reference.
(check-var proc v-env)
(for-each (cut check-var <> v-env) arg))
- (($ $primcall (? symbol? name) ((? symbol? arg) ...))
+ (($ $primcall (? symbol? name) (arg ...))
(for-each (cut check-var <> v-env) arg))
- (($ $values ((? symbol? arg) ...))
+ (($ $values (arg ...))
(for-each (cut check-var <> v-env) arg))
(($ $prompt escape? tag handler)
(unless (boolean? escape?) (error "escape? should be boolean" escape?))
(check-var tag v-env)
- (check-var handler k-env))
+ (check-label handler k-env))
(_
(error "unexpected expression" exp))))
(define (visit-term term k-env v-env)
(match term
- (($ $letk (($ $cont (? symbol? k) cont) ...) body)
- (let ((k-env (add-env k k-env)))
+ (($ $letk (($ $cont k cont) ...) body)
+ (let ((k-env (add-labels k k-env)))
(for-each (cut visit-cont-body <> k-env v-env) cont)
(visit-term body k-env v-env)))
- (($ $letrec ((? symbol? name) ...) ((? symbol? sym) ...) (fun ...) body)
+ (($ $letrec ((? symbol? name) ...) (sym ...) (fun ...) body)
(unless (= (length name) (length sym) (length fun))
(error "letrec syms, names, and funs not same length" term))
- (let ((v-env (add-env sym v-env)))
+ (let ((v-env (add-vars sym v-env)))
(for-each (cut visit-fun <> k-env v-env) fun)
(visit-term body k-env v-env)))
(($ $continue k src exp)
- (check-var k k-env)
+ (check-label k k-env)
(check-src src)
(visit-expression exp k-env v-env))
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 4ae1484..dcd0346 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -1,4 +1,4 @@
-;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation,
Inc.
+;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014 Free Software
Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -418,75 +418,146 @@ This is an implementation of `foldts' as described by
Andy Wingo in
((make-tree-il-folder tree) tree down up seed))
(define (pre-post-order pre post x)
+ (define (elts-eq? a b)
+ (or (null? a)
+ (and (eq? (car a) (car b))
+ (elts-eq? (cdr a) (cdr b)))))
(let lp ((x x))
(post
- (match (pre x)
- (($ <void> src)
- (make-void src))
-
- (($ <const> src exp)
- (make-const src exp))
-
- (($ <primitive-ref> src name)
- (make-primitive-ref src name))
-
- (($ <lexical-ref> src name gensym)
- (make-lexical-ref src name gensym))
-
- (($ <lexical-set> src name gensym exp)
- (make-lexical-set src name gensym (lp exp)))
-
- (($ <module-ref> src mod name public?)
- (make-module-ref src mod name public?))
-
- (($ <module-set> src mod name public? exp)
- (make-module-set src mod name public? (lp exp)))
-
- (($ <toplevel-ref> src name)
- (make-toplevel-ref src name))
-
- (($ <toplevel-set> src name exp)
- (make-toplevel-set src name (lp exp)))
-
- (($ <toplevel-define> src name exp)
- (make-toplevel-define src name (lp exp)))
-
- (($ <conditional> src test consequent alternate)
- (make-conditional src (lp test) (lp consequent) (lp alternate)))
-
- (($ <call> src proc args)
- (make-call src (lp proc) (map lp args)))
-
- (($ <primcall> src name args)
- (make-primcall src name (map lp args)))
-
- (($ <seq> src head tail)
- (make-seq src (lp head) (lp tail)))
+ (let ((x (pre x)))
+ (match x
+ ((or ($ <void>)
+ ($ <const>)
+ ($ <primitive-ref>)
+ ($ <lexical-ref>)
+ ($ <module-ref>)
+ ($ <toplevel-ref>))
+ x)
+
+ (($ <lexical-set> src name gensym exp)
+ (let ((exp* (lp exp)))
+ (if (eq? exp exp*)
+ x
+ (make-lexical-set src name gensym exp*))))
+
+ (($ <module-set> src mod name public? exp)
+ (let ((exp* (lp exp)))
+ (if (eq? exp exp*)
+ x
+ (make-module-set src mod name public? exp*))))
+
+ (($ <toplevel-set> src name exp)
+ (let ((exp* (lp exp)))
+ (if (eq? exp exp*)
+ x
+ (make-toplevel-set src name exp*))))
+
+ (($ <toplevel-define> src name exp)
+ (let ((exp* (lp exp)))
+ (if (eq? exp exp*)
+ x
+ (make-toplevel-define src name exp*))))
+
+ (($ <conditional> src test consequent alternate)
+ (let ((test* (lp test))
+ (consequent* (lp consequent))
+ (alternate* (lp alternate)))
+ (if (and (eq? test test*)
+ (eq? consequent consequent*)
+ (eq? alternate alternate*))
+ x
+ (make-conditional src test* consequent* alternate*))))
+
+ (($ <call> src proc args)
+ (let ((proc* (lp proc))
+ (args* (map lp args)))
+ (if (and (eq? proc proc*)
+ (elts-eq? args args*))
+ x
+ (make-call src proc* args*))))
+
+ (($ <primcall> src name args)
+ (let ((args* (map lp args)))
+ (if (elts-eq? args args*)
+ x
+ (make-primcall src name args*))))
+
+ (($ <seq> src head tail)
+ (let ((head* (lp head))
+ (tail* (lp tail)))
+ (if (and (eq? head head*)
+ (eq? tail tail*))
+ x
+ (make-seq src head* tail*))))
- (($ <lambda> src meta body)
- (make-lambda src meta (and body (lp body))))
-
- (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
- (make-lambda-case src req opt rest kw (map lp inits) gensyms (lp body)
- (and alternate (lp alternate))))
-
- (($ <let> src names gensyms vals body)
- (make-let src names gensyms (map lp vals) (lp body)))
-
- (($ <letrec> src in-order? names gensyms vals body)
- (make-letrec src in-order? names gensyms (map lp vals) (lp body)))
-
- (($ <fix> src names gensyms vals body)
- (make-fix src names gensyms (map lp vals) (lp body)))
-
- (($ <let-values> src exp body)
- (make-let-values src (lp exp) (lp body)))
-
- (($ <prompt> src escape-only? tag body handler)
- (make-prompt src escape-only? (lp tag) (lp body) (lp handler)))
-
- (($ <abort> src tag args tail)
- (make-abort src (lp tag) (map lp args) (lp tail)))))))
+ (($ <lambda> src meta body)
+ (let ((body* (and body (lp body))))
+ (if (eq? body body*)
+ x
+ (make-lambda src meta body*))))
+
+ (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
+ (let ((inits* (map lp inits))
+ (body* (lp body))
+ (alternate* (and alternate (lp alternate))))
+ (if (and (elts-eq? inits inits*)
+ (eq? body body*)
+ (eq? alternate alternate*))
+ x
+ (make-lambda-case src req opt rest kw inits* gensyms body*
+ alternate*))))
+
+ (($ <let> src names gensyms vals body)
+ (let ((vals* (map lp vals))
+ (body* (lp body)))
+ (if (and (elts-eq? vals vals*)
+ (eq? body body*))
+ x
+ (make-let src names gensyms vals* body*))))
+
+ (($ <letrec> src in-order? names gensyms vals body)
+ (let ((vals* (map lp vals))
+ (body* (lp body)))
+ (if (and (elts-eq? vals vals*)
+ (eq? body body*))
+ x
+ (make-letrec src in-order? names gensyms vals* body*))))
+
+ (($ <fix> src names gensyms vals body)
+ (let ((vals* (map lp vals))
+ (body* (lp body)))
+ (if (and (elts-eq? vals vals*)
+ (eq? body body*))
+ x
+ (make-fix src names gensyms vals* body*))))
+
+ (($ <let-values> src exp body)
+ (let ((exp* (lp exp))
+ (body* (lp body)))
+ (if (and (eq? exp exp*)
+ (eq? body body*))
+ x
+ (make-let-values src exp* body*))))
+
+ (($ <prompt> src escape-only? tag body handler)
+ (let ((tag* (lp tag))
+ (body* (lp body))
+ (handler* (lp handler)))
+ (if (and (eq? tag tag*)
+ (eq? body body*)
+ (eq? handler handler*))
+ x
+ (make-prompt src escape-only? tag* body* handler*))))
+
+ (($ <abort> src tag args tail)
+ (let ((tag* (lp tag))
+ (args* (map lp args))
+ (tail* (lp tail)))
+ (if (and (eq? tag tag*)
+ (elts-eq? args args*)
+ (eq? tail tail*))
+ x
+ (make-abort src tag* args* tail*)))))))))
(define (post-order f x)
(pre-post-order (lambda (x) x) f x))
diff --git a/module/language/tree-il/compile-cps.scm
b/module/language/tree-il/compile-cps.scm
index 6e987a3..0c0085d 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -58,7 +58,7 @@
#:use-module (language cps primitives)
#:use-module (language tree-il analyze)
#:use-module (language tree-il optimize)
- #:use-module ((language tree-il) #:hide (let-gensyms))
+ #:use-module (language tree-il)
#:export (compile-cps))
;;; Guile's semantics are that a toplevel lambda captures a reference on
@@ -77,7 +77,7 @@
(define current-topbox-scope (make-parameter #f))
(define (toplevel-box src name bound? val-proc)
- (let-gensyms (name-sym bound?-sym kbox box)
+ (let-fresh (kbox) (name-sym bound?-sym box)
(build-cps-term
($letconst (('name name-sym name)
('bound? bound?-sym bound?))
@@ -89,7 +89,7 @@
($primcall 'resolve
(name-sym bound?-sym)))))
(scope
- (let-gensyms (scope-sym)
+ (let-fresh () (scope-sym)
(build-cps-term
($letconst (('scope scope-sym scope))
($continue kbox src
@@ -97,7 +97,7 @@
(scope-sym name-sym bound?-sym)))))))))))))
(define (module-box src module name public? bound? val-proc)
- (let-gensyms (module-sym name-sym public?-sym bound?-sym kbox box)
+ (let-fresh (kbox) (module-sym name-sym public?-sym bound?-sym box)
(build-cps-term
($letconst (('module module-sym module)
('name name-sym name)
@@ -109,7 +109,7 @@
(module-sym name-sym public?-sym bound?-sym))))))))
(define (capture-toplevel-scope src scope k)
- (let-gensyms (module scope-sym kmodule)
+ (let-fresh (kmodule) (module scope-sym)
(build-cps-term
($letconst (('scope scope-sym scope))
($letk ((kmodule ($kargs ('module) (module)
@@ -149,50 +149,53 @@
(error "too many inits"))
seed)
(((key name var) . kw)
- (unless (eq? var (car gensyms))
- (error "unexpected keyword arg order"))
- (proc name var (car inits)
+ ;; Could be that var is not a gensym any more.
+ (when (symbol? var)
+ (unless (eq? var (car gensyms))
+ (error "unexpected keyword arg order")))
+ (proc name (car gensyms) (car inits)
(fold-kw kw (cdr gensyms) (cdr inits) seed)))))
(fold-req req gensyms seed)))))
-(define (unbound? src sym kt kf)
+(define (unbound? src var kt kf)
(define tc8-iflag 4)
(define unbound-val 9)
(define unbound-bits (logior (ash unbound-val 8) tc8-iflag))
- (let-gensyms (unbound ktest)
+ (let-fresh (ktest) (unbound)
(build-cps-term
- ($letconst (('unbound unbound (pointer->scm (make-pointer
unbound-bits))))
+ ($letconst (('unbound unbound
+ (pointer->scm (make-pointer unbound-bits))))
($letk ((ktest ($kif kt kf)))
($continue ktest src
- ($primcall 'eq? (sym unbound))))))))
+ ($primcall 'eq? (var unbound))))))))
(define (init-default-value name sym subst init body)
- (match (assq-ref subst sym)
- ((subst-sym box?)
+ (match (hashq-ref subst sym)
+ ((orig-var subst-var box?)
(let ((src (tree-il-src init)))
(define (maybe-box k make-body)
(if box?
- (let-gensyms (kbox phi)
+ (let-fresh (kbox) (phi)
(build-cps-term
($letk ((kbox ($kargs (name) (phi)
($continue k src ($primcall 'box (phi))))))
,(make-body kbox))))
(make-body k)))
- (let-gensyms (knext kbound kunbound kreceive krest val rest)
+ (let-fresh (knext kbound kunbound kreceive krest) (val rest)
(build-cps-term
- ($letk ((knext ($kargs (name) (subst-sym) ,body)))
+ ($letk ((knext ($kargs (name) (subst-var) ,body)))
,(maybe-box
knext
(lambda (k)
(build-cps-term
($letk ((kbound ($kargs () () ($continue k src
- ($values (sym)))))
+ ($values (orig-var)))))
(krest ($kargs (name 'rest) (val rest)
($continue k src ($values (val)))))
(kreceive ($kreceive (list name) 'rest krest))
(kunbound ($kargs () ()
,(convert init kreceive subst))))
- ,(unbound? src sym kunbound kbound))))))))))))
+ ,(unbound? src orig-var kunbound kbound))))))))))))
;; exp k-name alist -> term
(define (convert exp k subst)
@@ -200,16 +203,16 @@
(define (convert-arg exp k)
(match exp
(($ <lexical-ref> src name sym)
- (match (assq-ref subst sym)
- ((box #t)
- (let-gensyms (kunboxed unboxed)
+ (match (hashq-ref subst sym)
+ ((orig-var box #t)
+ (let-fresh (kunboxed) (unboxed)
(build-cps-term
($letk ((kunboxed ($kargs ('unboxed) (unboxed) ,(k unboxed))))
($continue kunboxed src ($primcall 'box-ref (box)))))))
- ((subst #f) (k subst))
- (#f (k sym))))
+ ((orig-var subst-var #f) (k subst-var))
+ (var (k var))))
(else
- (let-gensyms (kreceive karg arg rest)
+ (let-fresh (kreceive karg) (arg rest)
(build-cps-term
($letk ((karg ($kargs ('arg 'rest) (arg rest) ,(k arg)))
(kreceive ($kreceive '(arg) 'rest karg)))
@@ -225,20 +228,24 @@
(lambda (names)
(k (cons name names)))))))))
(define (box-bound-var name sym body)
- (match (assq-ref subst sym)
- ((box #t)
- (let-gensyms (k)
+ (match (hashq-ref subst sym)
+ ((orig-var subst-var #t)
+ (let-fresh (k) ()
(build-cps-term
- ($letk ((k ($kargs (name) (box) ,body)))
- ($continue k #f ($primcall 'box (sym)))))))
+ ($letk ((k ($kargs (name) (subst-var) ,body)))
+ ($continue k #f ($primcall 'box (orig-var)))))))
(else body)))
+ (define (bound-var sym)
+ (match (hashq-ref subst sym)
+ ((var . _) var)
+ ((? exact-integer? var) var)))
(match exp
(($ <lexical-ref> src name sym)
- (match (assq-ref subst sym)
- ((box #t) (build-cps-term ($continue k src ($primcall 'box-ref (box)))))
- ((subst #f) (build-cps-term ($continue k src ($values (subst)))))
- (#f (build-cps-term ($continue k src ($values (sym)))))))
+ (rewrite-cps-term (hashq-ref subst sym)
+ ((orig-var box #t) ($continue k src ($primcall 'box-ref (box))))
+ ((orig-var subst-var #f) ($continue k src ($values (subst-var))))
+ (var ($continue k src ($values (var))))))
(($ <void> src)
(build-cps-term ($continue k src ($void))))
@@ -253,37 +260,41 @@
(let ()
(define (convert-clauses body ktail)
(match body
- (#f '())
+ (#f #f)
(($ <lambda-case> src req opt rest kw inits gensyms body alternate)
(let* ((arity (make-$arity req (or opt '()) rest
- (if kw (cdr kw) '()) (and kw (car kw))))
+ (map (match-lambda
+ ((kw name sym)
+ (list kw name (bound-var sym))))
+ (if kw (cdr kw) '()))
+ (and kw (car kw))))
(names (fold-formals (lambda (name sym init names)
(cons name names))
'()
arity gensyms inits)))
- (cons
- (let-gensyms (kclause kargs)
- (build-cps-cont
- (kclause
- ($kclause ,arity
- (kargs
- ($kargs names gensyms
- ,(fold-formals
- (lambda (name sym init body)
- (if init
- (init-default-value name sym subst init body)
- (box-bound-var name sym body)))
- (convert body ktail subst)
- arity gensyms inits)))))))
- (convert-clauses alternate ktail))))))
+ (let ((bound-vars (map bound-var gensyms)))
+ (let-fresh (kclause kargs) ()
+ (build-cps-cont
+ (kclause
+ ($kclause ,arity
+ (kargs
+ ($kargs names bound-vars
+ ,(fold-formals
+ (lambda (name sym init body)
+ (if init
+ (init-default-value name sym subst init body)
+ (box-bound-var name sym body)))
+ (convert body ktail subst)
+ arity gensyms inits)))
+ ,(convert-clauses alternate ktail))))))))))
(if (current-topbox-scope)
- (let-gensyms (kentry self ktail)
+ (let-fresh (kentry ktail) (self)
(build-cps-term
($continue k fun-src
($fun fun-src meta '()
(kentry ($kentry self (ktail ($ktail))
,(convert-clauses body ktail)))))))
- (let-gensyms (scope kscope)
+ (let-fresh (kscope) (scope)
(build-cps-term
($letk ((kscope ($kargs () ()
,(parameterize ((current-topbox-scope scope))
@@ -323,7 +334,7 @@
(($ <toplevel-define> src name exp)
(convert-arg exp
(lambda (val)
- (let-gensyms (kname name-sym)
+ (let-fresh (kname) (name-sym)
(build-cps-term
($letconst (('name name-sym name))
($continue k src ($primcall 'define! (name-sym val)))))))))
@@ -337,48 +348,14 @@
(($ <primcall> src name args)
(cond
((branching-primitive? name)
- (convert (make-conditional src exp (make-const #f #t)
- (make-const #f #f))
- k subst))
- ((and (eq? name 'vector)
- (and-map (match-lambda
- ((or ($ <const>)
- ($ <void>)
- ($ <lambda>)
- ($ <lexical-ref>)) #t)
- (_ #f))
- args))
- ;; Some macros generate calls to "vector" with like 300
- ;; arguments. Since we eventually compile to make-vector and
- ;; vector-set!, it reduces live variable pressure to allocate the
- ;; vector first, then set values as they are produced, if we can
- ;; prove that no value can capture the continuation. (More on
- ;; that caveat here:
- ;; http://wingolog.org/archives/2013/11/02/scheme-quiz-time).
- ;;
- ;; Normally we would do this transformation in the compiler, but
- ;; it's quite tricky there and quite easy here, so hold your nose
- ;; while we drop some smelly code.
- (convert (let ((len (length args)))
- (let-gensyms (v)
- (make-let src
- (list 'v)
- (list v)
- (list (make-primcall src 'make-vector
- (list (make-const #f len)
- (make-const #f #f))))
- (fold (lambda (arg n tail)
- (make-seq
- src
- (make-primcall
- src 'vector-set!
- (list (make-lexical-ref src 'v v)
- (make-const #f n)
- arg))
- tail))
- (make-lexical-ref src 'v v)
- (reverse args) (reverse (iota len))))))
- k subst))
+ (convert-args args
+ (lambda (args)
+ (let-fresh (kt kf kif) ()
+ (build-cps-term
+ ($letk ((kt ($kargs () () ($continue k src ($const #t))))
+ (kf ($kargs () () ($continue k src ($const #f))))
+ (kif ($kif kt kf)))
+ ($continue kif src ($primcall name args))))))))
((and (eq? name 'list)
(and-map (match-lambda
((or ($ <const>)
@@ -387,14 +364,15 @@
($ <lexical-ref>)) #t)
(_ #f))
args))
- ;; The same situation occurs with "list".
+ ;; See note below in `canonicalize' about `vector'. The same
+ ;; thing applies to `list'.
(let lp ((args args) (k k))
(match args
(()
(build-cps-term
($continue k src ($const '()))))
((arg . args)
- (let-gensyms (ktail tail)
+ (let-fresh (ktail) (tail)
(build-cps-term
($letk ((ktail ($kargs ('tail) (tail)
,(convert-arg arg
@@ -426,11 +404,12 @@
;; Otherwise we do a no-inline call to body, continuing to krest.
(convert-arg tag
(lambda (tag)
- (let ((hnames (append hreq (if hrest (list hrest) '()))))
- (let-gensyms (khargs khbody kret kprim prim kpop krest vals kbody)
+ (let ((hnames (append hreq (if hrest (list hrest) '())))
+ (bound-vars (map bound-var hsyms)))
+ (let-fresh (khargs khbody kret kprim kpop krest kbody) (prim vals)
(build-cps-term
;; FIXME: Attach hsrc to $kreceive.
- ($letk* ((khbody ($kargs hnames hsyms
+ ($letk* ((khbody ($kargs hnames bound-vars
,(fold box-bound-var
(convert hbody k subst)
hnames hsyms)))
@@ -463,40 +442,6 @@
($continue kbody (tree-il-src body)
($prompt #f tag khargs))))))))))))))
- ;; Eta-convert prompts without inline handlers.
- (($ <prompt> src escape-only? tag body handler)
- (let-gensyms (h args)
- (convert
- (make-let
- src (list 'h) (list h) (list handler)
- (make-seq
- src
- (make-conditional
- src
- (make-primcall src 'procedure? (list (make-lexical-ref #f 'h h)))
- (make-void src)
- (make-primcall
- src 'scm-error
- (list
- (make-const #f 'wrong-type-arg)
- (make-const #f "call-with-prompt")
- (make-const #f "Wrong type (expecting procedure): ~S")
- (make-primcall #f 'list (list (make-lexical-ref #f 'h h)))
- (make-primcall #f 'list (list (make-lexical-ref #f 'h h))))))
- (make-prompt
- src escape-only? tag body
- (make-lambda
- src '()
- (make-lambda-case
- src '() #f 'args #f '() (list args)
- (make-primcall
- src 'apply
- (list (make-lexical-ref #f 'h h)
- (make-lexical-ref #f 'args args)))
- #f)))))
- k
- subst)))
-
(($ <abort> src tag args ($ <const> _ ()))
(convert-args (cons tag args)
(lambda (args*)
@@ -514,7 +459,7 @@
($continue k src ($primcall 'apply args*))))))
(($ <conditional> src test consequent alternate)
- (let-gensyms (kif kt kf)
+ (let-fresh (kif kt kf) ()
(build-cps-term
($letk* ((kt ($kargs () () ,(convert consequent k subst)))
(kf ($kargs () () ,(convert alternate k subst)))
@@ -533,13 +478,13 @@
(($ <lexical-set> src name gensym exp)
(convert-arg exp
(lambda (exp)
- (match (assq-ref subst gensym)
- ((box #t)
+ (match (hashq-ref subst gensym)
+ ((orig-var box #t)
(build-cps-term
($continue k src ($primcall 'box-set! (box exp)))))))))
(($ <seq> src head tail)
- (let-gensyms (kreceive kseq vals)
+ (let-fresh (kreceive kseq) (vals)
(build-cps-term
($letk* ((kseq ($kargs ('vals) (vals)
,(convert tail k subst)))
@@ -551,9 +496,9 @@
(match (list names syms vals)
((() () ()) (convert body k subst))
(((name . names) (sym . syms) (val . vals))
- (let-gensyms (kreceive klet rest)
+ (let-fresh (kreceive klet) (rest)
(build-cps-term
- ($letk* ((klet ($kargs (name 'rest) (sym rest)
+ ($letk* ((klet ($kargs (name 'rest) ((bound-var sym) rest)
,(box-bound-var name sym
(lp names syms vals))))
(kreceive ($kreceive (list name) 'rest klet)))
@@ -562,17 +507,17 @@
(($ <fix> src names gensyms funs body)
;; Some letrecs can be contified; that happens later.
(if (current-topbox-scope)
- (let-gensyms (self)
+ (let-fresh () (self)
(build-cps-term
($letrec names
- gensyms
+ (map bound-var gensyms)
(map (lambda (fun)
(match (convert fun k subst)
(($ $continue _ _ (and fun ($ $fun)))
fun)))
funs)
,(convert body k subst))))
- (let-gensyms (scope kscope)
+ (let-fresh (kscope) (scope)
(build-cps-term
($letk ((kscope ($kargs () ()
,(parameterize ((current-topbox-scope scope))
@@ -581,10 +526,11 @@
(($ <let-values> src exp
($ <lambda-case> lsrc req #f rest #f () syms body #f))
- (let ((names (append req (if rest (list rest) '()))))
- (let-gensyms (kreceive kargs)
+ (let ((names (append req (if rest (list rest) '())))
+ (bound-vars (map bound-var syms)))
+ (let-fresh (kreceive kargs) ()
(build-cps-term
- ($letk* ((kargs ($kargs names syms
+ ($letk* ((kargs ($kargs names bound-vars
,(fold box-bound-var
(convert body k subst)
names syms)))
@@ -592,50 +538,69 @@
,(convert exp kreceive subst))))))))
(define (build-subst exp)
- "Compute a mapping from lexical gensyms to substituted gensyms. The
-usual reason to replace one variable by another is assignment
-conversion. Default argument values is the other reason.
-
-Returns a list of (ORIG-SYM SUBST-SYM BOXED?). A true value for BOXED?
-indicates that the replacement variable is in a box."
- (define (box-set-vars exp subst)
- (match exp
- (($ <lexical-set> src name sym exp)
- (if (assq sym subst)
- subst
- (cons (list sym (gensym "b") #t) subst)))
- (_ subst)))
- (define (default-args exp subst)
- (match exp
- (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
- (fold-formals (lambda (name sym init subst)
- (if init
- (let ((box? (match (assq-ref subst sym)
- ((box #t) #t)
- (#f #f)))
- (subst-sym (gensym (symbol->string name))))
- (cons (list sym subst-sym box?) subst))
- subst))
- subst
- (make-$arity req (or opt '()) rest
- (if kw (cdr kw) '()) (and kw (car kw)))
- gensyms
- inits))
- (_ subst)))
- (tree-il-fold box-set-vars default-args '() exp))
+ "Compute a mapping from lexical gensyms to CPS variable indexes. CPS
+uses small integers to identify variables, instead of gensyms.
+
+This subst table serves an additional purpose of mapping variables to
+replacements. The usual reason to replace one variable by another is
+assignment conversion. Default argument values is the other reason.
+
+The result is a hash table mapping symbols to substitutions (in the case
+that a variable is substituted) or to indexes. A substitution is a list
+of the form:
+
+ (ORIG-INDEX SUBST-INDEX BOXED?)
+
+A true value for BOXED? indicates that the replacement variable is in a
+box. If a variable is not substituted, the mapped value is a small
+integer."
+ (let ((table (make-hash-table)))
+ (define (down exp)
+ (match exp
+ (($ <lexical-set> src name sym exp)
+ (match (hashq-ref table sym)
+ ((orig subst #t) #t)
+ ((orig subst #f) (hashq-set! table sym (list orig subst #t)))
+ ((? number? idx) (hashq-set! table sym (list idx (fresh-var) #t)))))
+ (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
+ (fold-formals (lambda (name sym init seed)
+ (hashq-set! table sym
+ (if init
+ (list (fresh-var) (fresh-var) #f)
+ (fresh-var))))
+ #f
+ (make-$arity req (or opt '()) rest
+ (if kw (cdr kw) '()) (and kw (car kw)))
+ gensyms
+ inits))
+ (($ <let> src names gensyms vals body)
+ (for-each (lambda (sym)
+ (hashq-set! table sym (fresh-var)))
+ gensyms))
+ (($ <fix> src names gensyms vals body)
+ (for-each (lambda (sym)
+ (hashq-set! table sym (fresh-var)))
+ gensyms))
+ (_ #t))
+ (values))
+ (define (up exp) (values))
+ ((make-tree-il-folder) exp down up)
+ table))
(define (cps-convert/thunk exp)
- (let ((src (tree-il-src exp)))
- (let-gensyms (kinit init ktail kclause kbody)
- (build-cps-exp
- ($fun src '() '()
- (kinit ($kentry init
- (ktail ($ktail))
- ((kclause
- ($kclause ('() '() #f '() #f)
- (kbody ($kargs () ()
- ,(convert exp ktail
- (build-subst exp))))))))))))))
+ (parameterize ((label-counter 0)
+ (var-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))))))))))
(define *comp-module* (make-fluid))
@@ -659,8 +624,87 @@ indicates that the replacement variable is in a box."
(optimize x e opts))
+(define (canonicalize exp)
+ (post-order
+ (lambda (exp)
+ (match exp
+ (($ <primcall> src 'vector
+ (and args
+ ((or ($ <const>) ($ <void>) ($ <lambda>) ($ <lexical-ref>))
+ ...)))
+ ;; Some macros generate calls to "vector" with like 300
+ ;; arguments. Since we eventually compile to make-vector and
+ ;; vector-set!, it reduces live variable pressure to allocate the
+ ;; vector first, then set values as they are produced, if we can
+ ;; prove that no value can capture the continuation. (More on
+ ;; that caveat here:
+ ;; http://wingolog.org/archives/2013/11/02/scheme-quiz-time).
+ ;;
+ ;; Normally we would do this transformation in the compiler, but
+ ;; it's quite tricky there and quite easy here, so hold your nose
+ ;; while we drop some smelly code.
+ (let ((len (length args))
+ (v (gensym "v ")))
+ (make-let src
+ (list 'v)
+ (list v)
+ (list (make-primcall src 'make-vector
+ (list (make-const #f len)
+ (make-const #f #f))))
+ (fold (lambda (arg n tail)
+ (make-seq
+ src
+ (make-primcall
+ src 'vector-set!
+ (list (make-lexical-ref src 'v v)
+ (make-const #f n)
+ arg))
+ tail))
+ (make-lexical-ref src 'v v)
+ (reverse args) (reverse (iota len))))))
+
+ (($ <prompt> src escape-only? tag body
+ ($ <lambda> hsrc hmeta
+ ($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f)))
+ exp)
+
+ ;; Eta-convert prompts without inline handlers.
+ (($ <prompt> src escape-only? tag body handler)
+ (let ((h (gensym "h "))
+ (args (gensym "args ")))
+ (make-let
+ src (list 'h) (list h) (list handler)
+ (make-seq
+ src
+ (make-conditional
+ src
+ (make-primcall src 'procedure? (list (make-lexical-ref #f 'h h)))
+ (make-void src)
+ (make-primcall
+ src 'scm-error
+ (list
+ (make-const #f 'wrong-type-arg)
+ (make-const #f "call-with-prompt")
+ (make-const #f "Wrong type (expecting procedure): ~S")
+ (make-primcall #f 'list (list (make-lexical-ref #f 'h h)))
+ (make-primcall #f 'list (list (make-lexical-ref #f 'h h))))))
+ (make-prompt
+ src escape-only? tag body
+ (make-lambda
+ src '()
+ (make-lambda-case
+ src '() #f 'args #f '() (list args)
+ (make-primcall
+ src 'apply
+ (list (make-lexical-ref #f 'h h)
+ (make-lexical-ref #f 'args args)))
+ #f)))))))
+ (_ exp)))
+ exp))
+
(define (compile-cps exp env opts)
- (values (cps-convert/thunk (optimize-tree-il exp env opts))
+ (values (cps-convert/thunk
+ (canonicalize (optimize-tree-il exp env opts)))
env
env))
diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm
index c7c1f8d..919d512 100644
--- a/module/srfi/srfi-1.scm
+++ b/module/srfi/srfi-1.scm
@@ -566,20 +566,11 @@ has just one element then that's the return value."
(case-lambda
((f l)
(check-arg procedure? f map)
- (let map1 ((hare l) (tortoise l) (move? #f) (out '()))
- (if (pair? hare)
- (if move?
- (if (eq? tortoise hare)
- (scm-error 'wrong-type-arg "map" "Circular list: ~S"
- (list l) #f)
- (map1 (cdr hare) (cdr tortoise) #f
- (cons (f (car hare)) out)))
- (map1 (cdr hare) tortoise #t
- (cons (f (car hare)) out)))
- (if (null? hare)
- (reverse! out)
- (scm-error 'wrong-type-arg "map" "Not a list: ~S"
- (list l) #f)))))
+ (check-arg list? l map)
+ (let map1 ((in l) (out '()))
+ (if (pair? in)
+ (map1 (cdr in) (cons (f (car in)) out))
+ (reverse! out))))
((f l1 . rest)
(check-arg procedure? f map)
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 597d878..7f4b1bd 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -153,7 +153,7 @@
(arities meta-arities set-meta-arities!))
(define (make-meta label properties low-pc)
- (assert-match label (? symbol?) "symbol")
+ (assert-match label (or (? exact-integer?) (? symbol?)) "symbol")
(assert-match properties (((? symbol?) . _) ...) "alist with symbolic keys")
(%make-meta label properties low-pc #f '()))
@@ -750,7 +750,7 @@ returned instead."
"alist of keyword -> integer")
(assert-match allow-other-keys? (? boolean?) "boolean")
(assert-match nlocals (? integer?) "integer")
- (assert-match alternate (or #f (? symbol?)) "#f or symbol")
+ (assert-match alternate (or #f (? exact-integer?) (? symbol?)) "#f or
symbol")
(let* ((meta (car (asm-meta asm)))
(arity (make-arity req opt rest kw-indices allow-other-keys?
(asm-start asm) #f))
@@ -1954,13 +1954,11 @@ procedure with label @var{rw-init}. @var{rw-init} may
be false. If
('language (language-name->code val))
('stmt-list val)))
- (define (exact-integer? val)
- (and (number? val) (integer? val) (exact? val)))
-
(define (choose-form attr val code)
(cond
((string? val) 'strp)
((eq? attr 'stmt-list) 'sec-offset)
+ ((eq? attr 'low-pc) 'addr)
((exact-integer? code)
(cond
((< code 0) 'sleb128)
@@ -1969,7 +1967,6 @@ procedure with label @var{rw-init}. @var{rw-init} may be
false. If
((<= code #xffffffff) 'data4)
((<= code #xffffffffffffffff) 'data8)
(else 'uleb128)))
- ((symbol? val) 'addr)
(else (error "unhandled case" attr val code))))
(define (add-die-relocation! kind sym)
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-845-g6e5e9ff,
Andy Wingo <=