[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-579-g3108664
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-579-g3108664 |
|
Date: |
Sat, 11 Jan 2014 15:21:47 +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=310866418b17cc4b340d325c960a4fb9f7b7d629
The branch, master has been updated
via 310866418b17cc4b340d325c960a4fb9f7b7d629 (commit)
via 22a79b55b8c3f7b5ad9a6190cc7f1e8f187f2df7 (commit)
via 305cccb43c7ba81388f42fb809c1c3f8946fc572 (commit)
via ad4f6be137a3a2fabcbba54f1419a26f41626881 (commit)
via 8a2d420f7476ddbf6fd32e9d070ff633ada2b852 (commit)
via c79f873eb15d727986405563c64650e901119c70 (commit)
via f409295892e8eb28e9df2e934badc1fcf4aa5e72 (commit)
via e4fa7d403aa010dda326167f460a128a12e7a8d4 (commit)
via 4dfcb360068552a95280a7a91baea9f0354230db (commit)
via 7ab76a830bfbc7fcd45ec4780ba661e0c61bacd6 (commit)
via 146ce52d2169a5002a0509cb4a21d3203d554a55 (commit)
via 9002277d0f41bab8bb8197048ea86986aa343d07 (commit)
via f235f926d13ce758cfa4e2633e2a56bc37f18943 (commit)
via 6eb0296027ef60c80c9f52d7717c5782640af5c4 (commit)
via 58ef5f07128204f333357879125a831e90e0ea27 (commit)
via d20b4a1cd25571966b749053e0cbcd1cb66124a0 (commit)
via d59060ce9999b1c1d0b63aa0319da110d3eae3f8 (commit)
from 1df515a077f26d59510e48fad3d45a33d2c90e0f (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 310866418b17cc4b340d325c960a4fb9f7b7d629
Author: Andy Wingo <address@hidden>
Date: Fri Jan 10 17:44:10 2014 +0100
Insert explicit $ktrunc nodes everywhere that truncates multiple values
* module/language/tree-il/compile-cps.scm (init-default-value, convert):
Explicitly insert $ktrunc nodes on all places that can truncate to
single values.
commit 22a79b55b8c3f7b5ad9a6190cc7f1e8f187f2df7
Author: Andy Wingo <address@hidden>
Date: Fri Jan 10 22:50:12 2014 +0100
Add simplification pass
* module/Makefile.am:
* module/language/cps/compile-bytecode.scm:
* module/language/cps/simplify.scm: New pass.
commit 305cccb43c7ba81388f42fb809c1c3f8946fc572
Author: Andy Wingo <address@hidden>
Date: Wed Dec 11 11:07:33 2013 +0100
Add DCE pass.
* module/language/cps/dce.scm: New pass.
* module/Makefile.am:
* module/language/cps/compile-bytecode.scm: Wire up the new pass.
commit ad4f6be137a3a2fabcbba54f1419a26f41626881
Author: Andy Wingo <address@hidden>
Date: Fri Jan 10 20:42:50 2014 +0100
Shuffle the first return value from truncating calls
* module/language/cps/slot-allocation.scm (allocate-slots): For
truncating calls, shuffle the first return value (if any). Avoids
frame size growth due to sparse locals, pegged where they were left by
procedure call returns. With this patch, eval with $ktrunc nodes goes
from 31 locals to 18 (similar to the size before adding $ktrunc
nodes).
commit 8a2d420f7476ddbf6fd32e9d070ff633ada2b852
Author: Andy Wingo <address@hidden>
Date: Fri Jan 10 17:42:10 2014 +0100
All $values expressions go through allocate-values
* module/language/cps/slot-allocation.scm (allocate-slots): Make all
$values expressions go through allocate-values, and refactor
allocate-values.
commit c79f873eb15d727986405563c64650e901119c70
Author: Andy Wingo <address@hidden>
Date: Fri Jan 10 16:40:24 2014 +0100
Fix allocate-slots bug
* module/language/cps/slot-allocation.scm (allocate-slots): Fix bug in
allocate!, whereby a previously hinted allocation would not be added
to the live set if a hint was not given later.
commit f409295892e8eb28e9df2e934badc1fcf4aa5e72
Author: Andy Wingo <address@hidden>
Date: Fri Jan 10 14:48:24 2014 +0100
More robust compute-hints
* module/language/cps/slot-allocation.scm (allocate-slots): Allow the
compute-hints pass to traverse through $values with 0 or 1 value.
commit e4fa7d403aa010dda326167f460a128a12e7a8d4
Author: Andy Wingo <address@hidden>
Date: Sun Dec 22 11:14:13 2013 -0500
Prefer "receive" over "receive-values"+"reset-frame"
* module/language/cps/compile-bytecode.scm (compile-fun): Attempt to
emit "receive" instead of "receive-values"+"reset-frame" where
possible.
commit 4dfcb360068552a95280a7a91baea9f0354230db
Author: Andy Wingo <address@hidden>
Date: Sun Dec 22 10:37:27 2013 -0500
Only emit receive-values if it is needed
* module/language/cps/compile-bytecode.scm (compile-fun): Don't emit
receive-values unless there is a minimum or maximum number of values.
commit 7ab76a830bfbc7fcd45ec4780ba661e0c61bacd6
Author: Andy Wingo <address@hidden>
Date: Thu Jan 9 19:52:58 2014 +0100
Remove "pop" from $prompt
* module/language/cps.scm:
* module/language/cps/closure-conversion.scm:
* module/language/cps/compile-bytecode.scm:
* module/language/cps/dfg.scm:
* module/language/cps/slot-allocation.scm:
* module/language/cps/verify.scm:
* module/language/tree-il/compile-cps.scm: Remove "pop" member from
$prompt data type, as it is no longer used.
commit 146ce52d2169a5002a0509cb4a21d3203d554a55
Author: Andy Wingo <address@hidden>
Date: Thu Jan 9 19:23:03 2014 +0100
Enable prompt analysis
* module/language/cps/dfg.scm (compute-live-variables, visit-fun):
Use the new prompt analysis pass in analyze-control-flow instead of
always adding a link in the DFG. Avoids problems if there are
parts of the prompt body that have no path to the pop.
commit 9002277d0f41bab8bb8197048ea86986aa343d07
Author: Andy Wingo <address@hidden>
Date: Thu Jan 9 16:18:16 2014 +0100
Add prompt analysis to the DFG's analyze-control-flow
* module/language/cps/dfg.scm (compute-reachable, find-prompts)
(compute-interval, find-prompt-bodies, visit-prompt-control-flow): New
helpers.
(analyze-control-flow): Add a mode that adds on CFA edges
corresponding to non-local control flow in a prompt.
commit f235f926d13ce758cfa4e2633e2a56bc37f18943
Author: Andy Wingo <address@hidden>
Date: Thu Jan 9 10:56:22 2014 +0100
compute-live-variables uses CFA analysis
* module/language/cps/dfg.scm ($dfa): Store a CFA instead of a separate
k-map and order.
(dfa-k-idx, dfa-k-sym, dfa-k-count): Adapt.
(compute-live-variables): Use analyze-control-flow instead of rolling
out own RPO numbering. Will allow us to fix some prompt-related
things in a central place.
commit 6eb0296027ef60c80c9f52d7717c5782640af5c4
Author: Andy Wingo <address@hidden>
Date: Thu Jan 9 10:21:17 2014 +0100
Internal analyze-control-flow refactor
* module/language/cps/dfg.scm (reverse-post-order): Fold-all-conts is
now a required arg.
(analyze-control-flow): Reverse CFA adds forward-reachable
continuations to the numbering.
commit 58ef5f07128204f333357879125a831e90e0ea27
Author: Andy Wingo <address@hidden>
Date: Mon Dec 16 13:48:59 2013 +0100
Fix constant-needs-allocation? for $values uses
* module/language/cps/dfg.scm (constant-needs-allocation?): Use of a
constant in a $values expression of any arity does not cause slot
allocation.
* module/language/cps/compile-bytecode.scm (compile-fun): Allow $values
with a constant value to be compiled in test context. Really we
should fold these in a previous pass!
commit d20b4a1cd25571966b749053e0cbcd1cb66124a0
Author: Andy Wingo <address@hidden>
Date: Sat Dec 7 19:58:08 2013 +0100
Add effects analysis pass on CPS
* module/Makefile.am:
* module/language/cps/effects-analysis.scm: New helper module.
commit d59060ce9999b1c1d0b63aa0319da110d3eae3f8
Author: Andy Wingo <address@hidden>
Date: Sat Dec 7 19:41:59 2013 +0100
Fix prim -> VM op mapping for u8/s8 bytevector ops
* module/language/cps/primitives.scm (*instruction-aliases*): Fix
aliases for bytevector u8 / s8 operations.
* module/language/cps/compile-bytecode.scm (compile-fun): Fix s8
operations.
-----------------------------------------------------------------------
Summary of changes:
module/Makefile.am | 5 +-
module/language/cps.scm | 19 +-
module/language/cps/closure-conversion.scm | 6 +-
module/language/cps/compile-bytecode.scm | 77 +++--
module/language/cps/dce.scm | 278 ++++++++++++++++
module/language/cps/dfg.scm | 343 ++++++++++++++------
module/language/cps/effects-analysis.scm | 480 ++++++++++++++++++++++++++++
module/language/cps/primitives.scm | 8 +-
module/language/cps/simplify.scm | 273 ++++++++++++++++
module/language/cps/slot-allocation.scm | 80 +++--
module/language/cps/verify.scm | 7 +-
module/language/tree-il/compile-cps.scm | 38 ++-
12 files changed, 1422 insertions(+), 192 deletions(-)
create mode 100644 module/language/cps/dce.scm
create mode 100644 module/language/cps/effects-analysis.scm
create mode 100644 module/language/cps/simplify.scm
diff --git a/module/Makefile.am b/module/Makefile.am
index 95dd236..4c75221 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -1,6 +1,6 @@
## Process this file with automake to produce Makefile.in.
##
-## Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation,
Inc.
+## Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014 Free Software
Foundation, Inc.
##
## This file is part of GUILE.
##
@@ -123,11 +123,14 @@ CPS_LANG_SOURCES =
\
language/cps/compile-bytecode.scm \
language/cps/constructors.scm \
language/cps/contification.scm \
+ language/cps/dce.scm \
language/cps/dfg.scm \
+ language/cps/effects-analysis.scm \
language/cps/elide-values.scm \
language/cps/primitives.scm \
language/cps/reify-primitives.scm \
language/cps/slot-allocation.scm \
+ language/cps/simplify.scm \
language/cps/spec.scm \
language/cps/specialize-primcalls.scm \
language/cps/verify.scm
diff --git a/module/language/cps.scm b/module/language/cps.scm
index 57d95d4..8aac42b 100644
--- a/module/language/cps.scm
+++ b/module/language/cps.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
@@ -85,8 +85,7 @@
;;; - $prompt continues to the body of the prompt, having pushed on a
;;; prompt whose handler will continue at its "handler"
;;; continuation. The continuation of the prompt is responsible for
-;;; popping the prompt. A $prompt also records the continuation
-;;; that pops the prompt, to make various static analyses easier.
+;;; popping the prompt.
;;;
;;; In summary:
;;;
@@ -185,7 +184,7 @@
(define-cps-type $call proc args)
(define-cps-type $primcall name args)
(define-cps-type $values args)
-(define-cps-type $prompt escape? tag handler pop)
+(define-cps-type $prompt escape? tag handler)
(define-syntax let-gensyms
(syntax-rules ()
@@ -240,8 +239,8 @@
((_ ($primcall name args)) (make-$primcall name args))
((_ ($values (arg ...))) (make-$values (list arg ...)))
((_ ($values args)) (make-$values args))
- ((_ ($prompt escape? tag handler pop))
- (make-$prompt escape? tag handler pop))))
+ ((_ ($prompt escape? tag handler))
+ (make-$prompt escape? tag handler))))
(define-syntax build-cps-term
(syntax-rules (unquote $letk $letk* $letconst $letrec $continue)
@@ -341,8 +340,8 @@
(build-cps-exp ($primcall name arg)))
(('values arg ...)
(build-cps-exp ($values arg)))
- (('prompt escape? tag handler pop)
- (build-cps-exp ($prompt escape? tag handler pop)))
+ (('prompt escape? tag handler)
+ (build-cps-exp ($prompt escape? tag handler)))
(_
(error "unexpected cps" exp))))
@@ -397,8 +396,8 @@
`(primcall ,name ,@args))
(($ $values args)
`(values ,@args))
- (($ $prompt escape? tag handler pop)
- `(prompt ,escape? ,tag ,handler ,pop))
+ (($ $prompt escape? tag handler)
+ `(prompt ,escape? ,tag ,handler))
(_
(error "unexpected cps" exp))))
diff --git a/module/language/cps/closure-conversion.scm
b/module/language/cps/closure-conversion.scm
index 11d388b..4221cb8 100644
--- a/module/language/cps/closure-conversion.scm
+++ b/module/language/cps/closure-conversion.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
@@ -212,12 +212,12 @@ convert functions to flat closures."
($continue k src ($values args)))
'()))))
- (($ $continue k src ($ $prompt escape? tag handler pop))
+ (($ $continue k src ($ $prompt escape? tag handler))
(convert-free-var
tag self bound
(lambda (tag)
(values (build-cps-term
- ($continue k src ($prompt escape? tag handler pop)))
+ ($continue k src ($prompt escape? tag handler)))
'()))))
(_ (error "what" exp))))
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index 216fca6..5b03f6d 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.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,10 +31,12 @@
#:use-module (language cps closure-conversion)
#:use-module (language cps contification)
#:use-module (language cps constructors)
+ #:use-module (language cps dce)
#:use-module (language cps dfg)
#:use-module (language cps elide-values)
#:use-module (language cps primitives)
#:use-module (language cps reify-primitives)
+ #:use-module (language cps simplify)
#:use-module (language cps slot-allocation)
#:use-module (language cps specialize-primcalls)
#:use-module (system vm assembler)
@@ -53,27 +55,29 @@
(pass exp)
exp))
- ;; Calls to source-to-source optimization passes go here.
- (let* ((exp (run-pass exp contify #:contify? #t))
+ ;; The first DCE pass is mainly to eliminate functions that aren't
+ ;; called. The last is mainly to eliminate rest parameters that
+ ;; aren't used, and thus shouldn't be consed.
+
+ (let* ((exp (run-pass exp eliminate-dead-code #:eliminate-dead-code? #t))
+ (exp (run-pass exp simplify #:simplify? #t))
+ (exp (run-pass exp contify #:contify? #t))
(exp (run-pass exp inline-constructors #:inline-constructors? #t))
(exp (run-pass exp specialize-primcalls #:specialize-primcalls? #t))
- (exp (run-pass exp elide-values #:elide-values? #t)))
+ (exp (run-pass exp elide-values #:elide-values? #t))
+ (exp (run-pass exp eliminate-dead-code #:eliminate-dead-code? #t))
+ (exp (run-pass exp simplify #:simplify? #t)))
;; Passes that are needed:
;;
;; * Abort contification: turning abort primcalls into continuation
;; calls, and eliding prompts if possible.
;;
- ;; * Common subexpression elimination. Desperately needed. Requires
- ;; effects analysis.
+ ;; * Common subexpression elimination. Desperately needed.
;;
;; * Loop peeling. Unrolls the first round through a loop if the
;; loop has effects that CSE can work on. Requires effects
;; analysis. When run before CSE, loop peeling is the equivalent
;; of loop-invariant code motion (LICM).
- ;;
- ;; * Generic simplification pass, to be run as needed. Used to
- ;; "clean up", both on the original raw input and after specific
- ;; optimization passes.
exp))
@@ -299,6 +303,8 @@
(emit-builtin-ref asm dst (constant name)))
(($ $primcall 'bv-u8-ref (bv idx))
(emit-bv-u8-ref asm dst (slot bv) (slot idx)))
+ (($ $primcall 'bv-s8-ref (bv idx))
+ (emit-bv-s8-ref asm dst (slot bv) (slot idx)))
(($ $primcall 'bv-u16-ref (bv idx))
(emit-bv-u16-ref asm dst (slot bv) (slot idx)))
(($ $primcall 'bv-s16-ref (bv idx))
@@ -323,7 +329,7 @@
(define (compile-effect label exp k nlocals)
(match exp
(($ $values ()) #f)
- (($ $prompt escape? tag handler pop)
+ (($ $prompt escape? tag handler)
(match (lookup-cont handler)
(($ $ktrunc ($ $arity req () rest () #f) khandler-body)
(let ((receive-args (gensym "handler"))
@@ -332,7 +338,8 @@
(emit-prompt asm (slot tag) escape? proc-slot receive-args)
(emit-br asm k)
(emit-label asm receive-args)
- (emit-receive-values asm proc-slot (->bool rest) nreq)
+ (unless (and rest (zero? nreq))
+ (emit-receive-values asm proc-slot (->bool rest) nreq))
(when (and rest
(match (vector-ref contv (cfa-k-idx cfa
khandler-body))
(($ $kargs names (_ ... rest))
@@ -372,6 +379,8 @@
(emit-wind asm (slot winder) (slot unwinder)))
(($ $primcall 'bv-u8-set! (bv idx val))
(emit-bv-u8-set! asm (slot bv) (slot idx) (slot val)))
+ (($ $primcall 'bv-s8-set! (bv idx val))
+ (emit-bv-s8-set! asm (slot bv) (slot idx) (slot val)))
(($ $primcall 'bv-u16-set! (bv idx val))
(emit-bv-u16-set! asm (slot bv) (slot idx) (slot val)))
(($ $primcall 'bv-s16-set! (bv idx val))
@@ -417,7 +426,17 @@
(unless (eq? kf next-label)
(emit-br asm kf)))))
(match exp
- (($ $values (sym)) (unary emit-br-if-true sym))
+ (($ $values (sym))
+ (call-with-values (lambda ()
+ (lookup-maybe-constant-value sym allocation))
+ (lambda (has-const? val)
+ (if has-const?
+ (if val
+ (unless (eq? kt next-label)
+ (emit-br asm kt))
+ (unless (eq? kf next-label)
+ (emit-br asm kf)))
+ (unary emit-br-if-true sym)))))
(($ $primcall 'null? (a)) (unary emit-br-if-null a))
(($ $primcall 'nil? (a)) (unary emit-br-if-nil a))
(($ $primcall 'pair? (a)) (unary emit-br-if-pair a))
@@ -451,16 +470,28 @@
(lookup-parallel-moves label allocation))
(for-each maybe-load-constant arg-slots (cons proc args))
(emit-call asm proc-slot nargs)
- ;; FIXME: Only allow more values if there is a rest arg.
- ;; Express values truncation by the presence of an
- ;; unused rest arg instead of implicitly.
- (emit-receive-values asm proc-slot #t nreq)
- (when (and rest-var (maybe-slot rest-var))
- (emit-bind-rest asm (+ proc-slot 1 nreq)))
- (for-each (match-lambda
- ((src . dst) (emit-mov asm dst src)))
- (lookup-parallel-moves k allocation))
- (emit-reset-frame asm nlocals)))))
+ (cond
+ ((and (= 1 nreq) (and rest-var) (not (maybe-slot rest-var))
+ (match (lookup-parallel-moves k allocation)
+ ((((? (lambda (src) (= src (1+ proc-slot))) src)
+ . dst)) dst)
+ (_ #f)))
+ ;; The usual case: one required live return value, ignoring
+ ;; any additional values.
+ => (lambda (dst)
+ (emit-receive asm dst proc-slot nlocals)))
+ (else
+ ;; FIXME: Only allow more values if there is a rest arg.
+ ;; Express values truncation by the presence of an unused
+ ;; rest arg instead of implicitly.
+ (unless (zero? nreq)
+ (emit-receive-values asm proc-slot #t nreq))
+ (when (and rest-var (maybe-slot rest-var))
+ (emit-bind-rest asm (+ proc-slot 1 nreq)))
+ (for-each (match-lambda
+ ((src . dst) (emit-mov asm dst src)))
+ (lookup-parallel-moves k allocation))
+ (emit-reset-frame asm nlocals)))))))
(match f
(($ $fun src meta free ($ $cont k ($ $kentry self tail clauses)))
diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm
new file mode 100644
index 0000000..b32dea0
--- /dev/null
+++ b/module/language/cps/dce.scm
@@ -0,0 +1,278 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; 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
+;;;; 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:
+;;;
+;;; Various optimizations can inline calls from one continuation to some
+;;; other continuation, usually in response to information about the
+;;; return arity of the call. That leaves us with dangling
+;;; continuations that aren't reachable any more from the procedure
+;;; entry. This pass will remove them.
+;;;
+;;; This pass also kills dead expressions: code that has no side
+;;; effects, and whose value is unused. It does so by marking all live
+;;; values, and then discarding other values as dead. This happens
+;;; recursively through procedures, so it should be possible to elide
+;;; dead procedures as well.
+;;;
+;;; Code:
+
+(define-module (language cps dce)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (language cps)
+ #:use-module (language cps dfg)
+ #:use-module (language cps effects-analysis)
+ #:export (eliminate-dead-code))
+
+(define-record-type $fun-data
+ (make-fun-data cfa effects conts live-conts defs)
+ fun-data?
+ (cfa fun-data-cfa)
+ (effects fun-data-effects)
+ (conts fun-data-conts)
+ (live-conts fun-data-live-conts)
+ (defs fun-data-defs))
+
+(define (compute-cont-vector cfa cont-table)
+ (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))
+ (lp (1+ n))))
+ v))
+
+(define (compute-defs cfa contv)
+ (define (cont-defs k)
+ (match (vector-ref contv (cfa-k-idx cfa k))
+ (($ $kargs names syms) syms)
+ (_ #f)))
+ (let ((defs (make-vector (vector-length contv) #f)))
+ (let lp ((n 0))
+ (when (< n (vector-length contv))
+ (vector-set!
+ defs
+ n
+ (match (vector-ref contv n)
+ (($ $kargs _ _ body)
+ (match (find-call body)
+ (($ $continue k) (cont-defs k))))
+ (($ $ktrunc arity kargs)
+ (cont-defs kargs))
+ (($ $kclause arity ($ $cont kargs ($ $kargs names syms)))
+ syms)
+ (($ $kif) #f)
+ (($ $kentry self) (list self))
+ (($ $ktail) #f)))
+ (lp (1+ n))))
+ defs))
+
+(define (compute-live-code fun)
+ (let ((fun-data-table (make-hash-table))
+ (live-vars (make-hash-table))
+ (dfg (compute-dfg fun #:global? #t))
+ (changed? #f))
+ (define (mark-live! sym)
+ (unless (value-live? sym)
+ (set! changed? #t)
+ (hashq-set! live-vars sym #t)))
+ (define (value-live? sym)
+ (hashq-ref live-vars sym))
+ (define (ensure-fun-data fun)
+ (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)))
+ (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)))
+ (hashq-set! fun-data-table fun fun-data)
+ (set! changed? #t)
+ fun-data)))
+ (define (visit-fun fun)
+ (match (ensure-fun-data fun)
+ (($ $fun-data cfa effects contv live-conts defs)
+ (define (visit-grey-exp n)
+ (let ((defs (vector-ref defs n)))
+ (cond
+ ((not defs) #t)
+ ((not (effect-free? (exclude-effects (vector-ref effects n)
+ &allocation)))
+ #t)
+ (else
+ (or-map value-live? defs)))))
+ (let lp ((n (1- (cfa-k-count cfa))))
+ (unless (< n 0)
+ (let ((cont (vector-ref contv n)))
+ (match cont
+ (($ $kargs _ _ body)
+ (let lp ((body body))
+ (match body
+ (($ $letk conts body) (lp body))
+ (($ $letrec names syms funs body)
+ (lp body)
+ (for-each (lambda (sym fun)
+ (when (value-live? sym)
+ (visit-fun fun)))
+ syms funs))
+ (($ $continue k src exp)
+ (unless (bitvector-ref live-conts n)
+ (when (visit-grey-exp n)
+ (set! changed? #t)
+ (bitvector-set! live-conts n #t)))
+ (when (bitvector-ref live-conts n)
+ (match exp
+ ((or ($ $void) ($ $const) ($ $prim))
+ #f)
+ ((and fun ($ $fun))
+ (visit-fun fun))
+ (($ $prompt escape? tag handler)
+ (mark-live! tag))
+ (($ $call proc args)
+ (mark-live! proc)
+ (for-each mark-live! args))
+ (($ $primcall name args)
+ (for-each mark-live! args))
+ (($ $values args)
+ (match (vector-ref defs n)
+ (#f (for-each mark-live! args))
+ (defs (for-each (lambda (use def)
+ (when (value-live? def)
+ (mark-live! use)))
+ args defs))))))))))
+ (($ $ktrunc arity kargs) #f)
+ (($ $kif) #f)
+ (($ $kclause arity ($ $cont kargs ($ $kargs names syms body)))
+ (for-each mark-live! syms))
+ (($ $kentry self tail clauses)
+ (mark-live! self))
+ (($ $ktail) #f))
+ (lp (1- n))))))))
+ (let lp ()
+ (set! changed? #f)
+ (visit-fun fun)
+ (when changed? (lp)))
+ (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))))))
+ (($ $ktrunc ($ $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 ($ktrunc 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)
+ (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 d6cfcf3..59e61e5 100644
--- a/module/language/cps/dfg.scm
+++ b/module/language/cps/dfg.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
@@ -126,9 +126,8 @@
;; that is reachable from some start node. Others need to include nodes
;; that are reachable from an end node as well, or all nodes in a
;; function. In that case pass an appropriate implementation of
-;; fold-all-conts, as compute-live-variables does.
-(define* (reverse-post-order k0 get-successors #:optional
- (fold-all-conts (lambda (f seed) seed)))
+;; fold-all-conts, as analyze-control-flow does.
+(define (reverse-post-order k0 get-successors fold-all-conts)
(let ((order '())
(visited? (make-hash-table)))
(let visit ((k k0))
@@ -189,8 +188,149 @@
(define (cfa-predecessors cfa n)
(vector-ref (cfa-preds cfa) n))
-(define* (analyze-control-flow fun dfg #:key reverse?)
- (define (build-cfa kentry block-succs block-preds)
+(define-inlinable (vector-push! vec idx val)
+ (let ((v vec) (i idx))
+ (vector-set! v i (cons val (vector-ref v i)))))
+
+(define (compute-reachable cfa dfg)
+ "Given the forward control-flow analysis in CFA, compute and return
+the continuations that may be reached if flow reaches a continuation N.
+Returns a vector of bitvectors. The given CFA should be a forward CFA,
+for quickest convergence."
+ (let* ((k-count (cfa-k-count cfa))
+ ;; Vector of bitvectors, indicating that continuation N can
+ ;; reach a set M...
+ (reachable (make-vector k-count #f))
+ ;; Vector of lists, indicating that continuation N can directly
+ ;; reach continuations M...
+ (succs (make-vector k-count '())))
+
+ ;; All continuations are reachable from themselves.
+ (let lp ((n 0))
+ (when (< n k-count)
+ (let ((bv (make-bitvector k-count #f)))
+ (bitvector-set! bv n #t)
+ (vector-set! reachable n bv)
+ (lp (1+ n)))))
+
+ ;; Initialize successor lists.
+ (let lp ((n 0))
+ (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))))
+ (lp (1+ n))))
+
+ ;; Iterate cfa backwards, to converge quickly.
+ (let ((tmp (make-bitvector k-count #f)))
+ (let lp ((n k-count) (changed? #f))
+ (cond
+ ((zero? n)
+ (if changed?
+ (lp 0 #f)
+ reachable))
+ (else
+ (let ((n (1- n)))
+ (bitvector-fill! tmp #f)
+ (for-each (lambda (succ)
+ (bit-set*! tmp (vector-ref reachable succ) #t))
+ (vector-ref succs n))
+ (bitvector-set! tmp n #t)
+ (bit-set*! tmp (vector-ref reachable n) #f)
+ (cond
+ ((bit-position #t tmp 0)
+ (bit-set*! (vector-ref reachable n) tmp #t)
+ (lp n #t))
+ (else
+ (lp n changed?))))))))))
+
+(define (find-prompts cfa dfg)
+ "Find the prompts in CFA, and return them as a list of PROMPT-INDEX,
+HANDLER-INDEX pairs."
+ (let lp ((n 0) (prompts '()))
+ (cond
+ ((= n (cfa-k-count cfa))
+ (reverse prompts))
+ (else
+ (match (lookup-cont (cfa-k-sym cfa n) (dfg-cont-table dfg))
+ (($ $kargs names syms body)
+ (match (find-expression body)
+ (($ $prompt escape? tag handler)
+ (lp (1+ n) (acons n (cfa-k-idx cfa handler) prompts)))
+ (_ (lp (1+ n) prompts))))
+ (_ (lp (1+ n) prompts)))))))
+
+(define (compute-interval cfa dfg reachable start end)
+ "Compute and return the set of continuations that may be reached from
+START, inclusive, but not reached by END, exclusive. Returns a
+bitvector."
+ (let ((body (make-bitvector (cfa-k-count cfa) #f)))
+ (bit-set*! body (vector-ref reachable start) #t)
+ (bit-set*! body (vector-ref reachable end) #f)
+ body))
+
+(define (find-prompt-bodies cfa dfg)
+ "Find all the prompts in CFA, and compute the set of continuations
+that is reachable from the prompt bodies but not from the corresponding
+handler. Returns a list of PROMPT, HANDLER, BODY lists, where the BODY
+is a bitvector."
+ (match (find-prompts cfa dfg)
+ (() '())
+ (((prompt . handler) ...)
+ (let ((reachable (compute-reachable cfa dfg)))
+ (map (lambda (prompt handler)
+ ;; FIXME: It isn't correct to use all continuations
+ ;; reachable from the prompt, because that includes
+ ;; continuations outside the prompt body. This point is
+ ;; moot if the handler's control flow joins with the the
+ ;; body, as is usually but not always the case.
+ ;;
+ ;; One counter-example is when the handler contifies an
+ ;; infinite loop; in that case we compute a too-large
+ ;; prompt body. This error is currently innocuous, but
+ ;; we should fix it at some point.
+ ;;
+ ;; The fix is to end the body at the corresponding "pop"
+ ;; primcall, if any.
+ (let ((body (compute-interval cfa dfg reachable prompt handler)))
+ (list prompt handler body)))
+ prompt handler)))))
+
+(define* (visit-prompt-control-flow cfa dfg f #:key complete?)
+ "For all prompts in CFA, invoke F with arguments PROMPT, HANDLER, and
+BODY for each body continuation in the prompt."
+ (for-each
+ (match-lambda
+ ((prompt handler body)
+ (define (out-or-back-edge? n)
+ ;; Most uses of visit-prompt-control-flow don't need every body
+ ;; continuation, and would be happy getting called only for
+ ;; continuations that postdominate the rest of the body. Unless
+ ;; you pass #:complete? #t, we only invoke F on continuations
+ ;; that can leave the body, or on back-edges in loops.
+ ;;
+ ;; You would think that looking for the final "pop" primcall
+ ;; would be sufficient, but that is incorrect; it's possible for
+ ;; a loop in the prompt body to be contified, and that loop need
+ ;; not continue to the pop if it never terminates. The pop could
+ ;; even be removed by DCE, in that case.
+ (or-map (lambda (succ)
+ (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)))))
+ (let lp ((n 0))
+ (let ((n (bit-position #t body n)))
+ (when n
+ (when (or complete? (out-or-back-edge? n))
+ (f prompt handler n))
+ (lp (1+ n)))))))
+ (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)))))
@@ -200,19 +340,51 @@
(lambda (k)
(filter-map (cut hashq-ref mapping <>)
((block-accessor accessor) k))))
- (let* ((order (reverse-post-order kentry (block-accessor block-succs)))
+ (let* ((order (reverse-post-order
+ kentry
+ (block-accessor block-succs)
+ (if forward-cfa
+ (lambda (f seed)
+ (let lp ((n (cfa-k-count forward-cfa)) (seed seed))
+ (if (zero? n)
+ seed
+ (lp (1- n)
+ (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))))
- (make-cfa k-map order preds)))
+ (reachable-preds k-map block-preds)))
+ (cfa (make-cfa k-map order preds)))
+ (when add-handler-preds?
+ ;; Any expression in the prompt body could cause an abort to the
+ ;; handler. This code adds links from every block in the prompt
+ ;; body to the handler. This causes all values used by the
+ ;; handler to be seen as live in the prompt body, as indeed they
+ ;; are.
+ (let ((forward-cfa (or forward-cfa cfa)))
+ (visit-prompt-control-flow
+ forward-cfa dfg
+ (lambda (prompt handler body)
+ (define (renumber n)
+ (if (eq? forward-cfa cfa)
+ n
+ (cfa-k-idx cfa (cfa-k-sym forward-cfa n))))
+ (let ((handler (renumber handler))
+ (body (renumber body)))
+ (if reverse?
+ (vector-push! preds body handler)
+ (vector-push! preds handler body)))))))
+ cfa))
(match fun
(($ $fun src meta free
($ $cont kentry
(and entry
($ $kentry self ($ $cont ktail tail) clauses))))
(if reverse?
- (build-cfa ktail block-preds block-succs)
- (build-cfa kentry block-succs block-preds)))))
+ (build-cfa ktail block-preds block-succs
+ (analyze-control-flow fun dfg #:reverse? #f
+ #:add-handler-preds? #f))
+ (build-cfa kentry block-succs block-preds #f)))))
;; Dominator analysis.
(define-record-type $dominator-analysis
@@ -281,10 +453,6 @@
(iterate 0 #f))
(else idoms)))))
-(define-inlinable (vector-push! vec idx val)
- (let ((v vec) (i idx))
- (vector-set! v i (cons val (vector-ref v i)))))
-
;; Compute a vector containing, for each node, a list of the nodes that
;; it immediately dominates. These are the "D" edges in the DJ tree.
(define (compute-dom-edges idoms)
@@ -486,12 +654,10 @@
;; Data-flow analysis.
(define-record-type $dfa
- (make-dfa k-map order var-map names syms in out)
+ (make-dfa cfa var-map names syms in out)
dfa?
- ;; Hash table mapping k-sym -> k-idx
- (k-map dfa-k-map)
- ;; Vector of k-idx -> k-sym
- (order dfa-order)
+ ;; 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
@@ -504,14 +670,13 @@
(out dfa-out))
(define (dfa-k-idx dfa k)
- (or (hashq-ref (dfa-k-map dfa) k)
- (error "unknown k" k)))
+ (cfa-k-idx (dfa-cfa dfa) k))
(define (dfa-k-sym dfa idx)
- (vector-ref (dfa-order dfa) idx))
+ (cfa-k-sym (dfa-cfa dfa) idx))
(define (dfa-k-count dfa)
- (vector-length (dfa-order dfa)))
+ (cfa-k-count (dfa-cfa dfa)))
(define (dfa-var-idx dfa var)
(or (hashq-ref (dfa-var-map dfa) var)
@@ -541,74 +706,53 @@
(set! n (1+ n)))
use-maps)
(values mapping n)))
- (define (block-accessor blocks accessor)
- (lambda (k)
- (accessor (lookup-block k blocks))))
- (define (renumbering-accessor mapping blocks accessor)
- (lambda (k)
- (map (cut hashq-ref mapping <>)
- ((block-accessor blocks accessor) k))))
- (match fun
- (($ $fun src meta free
- (and entry
- ($ $cont kentry ($ $kentry self ($ $cont ktail tail)))))
- (call-with-values (lambda () (make-variable-mapping (dfg-use-maps dfg)))
- (lambda (var-map nvars)
- (define (fold-all-conts f seed)
- (fold-local-conts (lambda (k cont seed) (f k seed))
- seed entry))
- (let* ((blocks (dfg-blocks dfg))
- (order (reverse-post-order ktail
- (block-accessor blocks block-preds)
- fold-all-conts))
- (k-map (make-block-mapping order))
- (succs (convert-predecessors
- order
- (renumbering-accessor k-map blocks block-succs)))
- (syms (make-vector nvars #f))
- (names (make-vector nvars #f))
- (usev (make-vector (vector-length order) '()))
- (defv (make-vector (vector-length order) '()))
- (live-in (make-vector (vector-length order) #f))
- (live-out (make-vector (vector-length order) #f)))
- (define (k->idx k)
- (or (hashq-ref k-map k) (error "unknown k" k)))
- ;; 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)
- (for-each (lambda (def)
- (vector-push! defv (k->idx def) v))
- ((block-accessor blocks block-preds) def))
- (for-each (lambda (use)
- (vector-push! usev (k->idx 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
- ;; and out, usev and defv, using successors instead of
- ;; predecessors, and starting with ktail instead of the
- ;; entry.
- (compute-maximum-fixed-point succs live-out live-in defv usev #t)
-
- (make-dfa k-map order var-map names syms live-in live-out)))))))
+ (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)
+ (for-each (lambda (def)
+ (vector-push! defv (cfa-k-idx cfa def) v))
+ (block-preds (lookup-block def (dfg-blocks 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)))))
(define (print-dfa dfa)
(match dfa
- (($ $dfa k-map order var-map names syms in out)
+ (($ $dfa cfa var-map names syms in out)
(define (print-var-set bv)
(let lp ((n 0))
(let ((n (bit-position #t bv n)))
@@ -616,8 +760,8 @@
(format #t " ~A" (vector-ref syms n))
(lp (1+ n))))))
(let lp ((n 0))
- (when (< n (vector-length order))
- (format #t "~A:\n" (vector-ref order n))
+ (when (< n (cfa-k-count cfa))
+ (format #t "~A:\n" (cfa-k-sym cfa n))
(format #t " in:")
(print-var-set (vector-ref in n))
(newline)
@@ -701,20 +845,9 @@
(($ $values args)
(for-each use! args))
- (($ $prompt escape? tag handler pop)
+ (($ $prompt escape? tag handler)
(use! tag)
- (use-k! handler)
- ;; Any continuation in the prompt body could cause an abort to
- ;; the handler, so in theory we could register the handler as
- ;; a successor of any block in the prompt body. That would be
- ;; inefficient, though, besides being a hack. Instead we take
- ;; advantage of the fact that pop continuation post-dominates
- ;; the prompt body, so we add a link from there to the
- ;; handler. This creates a primcall node with multiple
- ;; successors, which is not quite correct, but it does reflect
- ;; control flow. It is necessary to ensure that the live
- ;; variables in the handler are seen as live in the body.
- (link-blocks! pop handler))
+ (use-k! handler))
(($ $fun)
(when global?
@@ -846,7 +979,7 @@
(lambda (use)
(match (find-expression (lookup-cont use conts))
(($ $call) #f)
- (($ $values (_ _ . _)) #f)
+ (($ $values) #f)
(($ $primcall 'free-ref (closure slot))
(not (eq? sym slot)))
(($ $primcall 'free-set! (closure slot value))
diff --git a/module/language/cps/effects-analysis.scm
b/module/language/cps/effects-analysis.scm
new file mode 100644
index 0000000..9db88b7
--- /dev/null
+++ b/module/language/cps/effects-analysis.scm
@@ -0,0 +1,480 @@
+;;; Effects analysis on CPS
+
+;; Copyright (C) 2011, 2012, 2013 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 helper module to compute the set of effects that an expression
+;;; depends on and causes. This information is useful when writing
+;;; algorithms that move code around, while preserving the semantics of
+;;; an input program.
+;;;
+;;; The effects set is represented by a bitfield, as a fixnum. The set
+;;; of possible effects is modelled rather coarsely. For example, a
+;;; "car" call modelled as depending on the &car effect, and causing a
+;;; &type-check effect. If any intervening code sets the car of any
+;;; pair, that will block motion of the "car" call.
+;;;
+;;; For each effect, two bits are reserved: one to indicate that an
+;;; expression depends on the effect, and the other to indicate that an
+;;; expression causes the effect.
+;;;
+;;; Since we have more bits in a fixnum on 64-bit systems, we can be
+;;; more precise without losing efficiency. On a 32-bit system, some of
+;;; the more precise effects map to fewer bits.
+;;;
+;;; Code:
+
+(define-module (language cps effects-analysis)
+ #:use-module (language cps)
+ #:use-module (language cps dfg)
+ #:use-module (ice-9 match)
+ #:export (expression-effects
+ compute-effects
+
+ &fluid
+ &prompt
+ &definite-bailout
+ &possible-bailout
+ &allocation
+ &car
+ &cdr
+ &vector
+ &box
+ &module
+ &struct
+ &string
+ &bytevector
+ &type-check
+
+ &no-effects
+ &all-effects
+ &all-effects-but-bailout
+
+ effects-commute?
+ exclude-effects
+ effect-free?
+ constant?
+ depends-on-effects?
+ causes-effects?))
+
+(define-syntax define-effects
+ (lambda (x)
+ (syntax-case x ()
+ ((_ all name ...)
+ (with-syntax (((n ...) (iota (length #'(name ...)))))
+ #'(begin
+ (define-syntax name (identifier-syntax (ash 1 (* n 2))))
+ ...
+ (define-syntax all (identifier-syntax (logior name ...)))))))))
+
+(define-syntax compile-time-cond
+ (lambda (x)
+ (syntax-case x (else)
+ ((_ (else body ...))
+ #'(begin body ...))
+ ((_ (exp body ...) clause ...)
+ (if (eval (syntax->datum #'exp) (current-module))
+ #'(begin body ...)
+ #'(compile-time-cond clause ...))))))
+
+;; Here we define the effects, indicating the meaning of the effect.
+;;
+;; Effects that are described in a "depends on" sense can also be used
+;; in the "causes" sense.
+;;
+;; Effects that are described as causing an effect are not usually used
+;; in a "depends-on" sense. Although the "depends-on" sense is used
+;; when checking for the existence of the "causes" effect, the effects
+;; analyzer will not associate the "depends-on" sense of these effects
+;; with any expression.
+;;
+(compile-time-cond
+ ((>= (logcount most-positive-fixnum) 60)
+ (define-effects &all-effects
+ ;; Indicates that an expression depends on the value of a fluid
+ ;; variable.
+ &fluid
+
+ ;; Indicates that an expression depends on the current prompt
+ ;; stack.
+ &prompt
+
+ ;; Indicates that an expression definitely causes a non-local,
+ ;; non-resumable exit -- a bailout. Only used in the "changes" sense.
+ &definite-bailout
+
+ ;; Indicates that an expression may cause a bailout.
+ &possible-bailout
+
+ ;; Indicates that an expression may return a fresh object -- a
+ ;; "causes" effect.
+ &allocation
+
+ ;; Indicates that an expression depends on the value of the car of a
+ ;; pair.
+ &car
+
+ ;; Indicates that an expression depends on the value of the cdr of a
+ ;; pair.
+ &cdr
+
+ ;; Indicates that an expression depends on the value of a vector
+ ;; field. We cannot be more precise, as vectors may alias other
+ ;; vectors.
+ &vector
+
+ ;; Indicates that an expression depends on the value of a variable
+ ;; cell.
+ &box
+
+ ;; Indicates that an expression depends on the current module.
+ &module
+
+ ;; Indicates that an expression depends on the value of a particular
+ ;; struct field.
+ &struct-0 &struct-1 &struct-2 &struct-3 &struct-4 &struct-5 &struct-6+
+
+ ;; Indicates that an expression depends on the contents of a string.
+ &string
+
+ ;; Indicates that an expression depends on the contents of a
+ ;; bytevector. We cannot be more precise, as bytevectors may alias
+ ;; other bytevectors.
+ &bytevector
+
+ ;; Indicates that an expression may cause a type check. A type check,
+ ;; for the purposes of this analysis, is the possibility of throwing
+ ;; an exception the first time an expression is evaluated. If the
+ ;; expression did not cause an exception to be thrown, users can
+ ;; assume that evaluating the expression again will not cause an
+ ;; exception to be thrown.
+ ;;
+ ;; For example, (+ x y) might throw if X or Y are not numbers. But if
+ ;; it doesn't throw, it should be safe to elide a dominated, common
+ ;; subexpression (+ x y).
+ &type-check)
+
+ ;; Indicates that an expression depends on the contents of an unknown
+ ;; struct field.
+ (define-syntax &struct
+ (identifier-syntax
+ (logior &struct-1 &struct-2 &struct-3 &struct-4 &struct-5 &struct-6+))))
+
+ (else
+ ;; For systems with smaller fixnums, be less precise regarding struct
+ ;; fields.
+ (define-effects &all-effects
+ &fluid
+ &prompt
+ &definite-bailout
+ &possible-bailout
+ &allocation
+ &car
+ &cdr
+ &vector
+ &box
+ &module
+ &struct
+ &string
+ &bytevector
+ &type-check)
+ (define-syntax &struct-0 (identifier-syntax &struct))
+ (define-syntax &struct-1 (identifier-syntax &struct))
+ (define-syntax &struct-2 (identifier-syntax &struct))
+ (define-syntax &struct-3 (identifier-syntax &struct))
+ (define-syntax &struct-4 (identifier-syntax &struct))
+ (define-syntax &struct-5 (identifier-syntax &struct))
+ (define-syntax &struct-6+ (identifier-syntax &struct))))
+
+(define-syntax &no-effects (identifier-syntax 0))
+
+;; Definite bailout is an oddball effect. Since it indicates that an
+;; expression definitely causes bailout, it's not in the set of effects
+;; of a call to an unknown procedure. At the same time, it's also
+;; special in that a definite bailout in a subexpression doesn't always
+;; cause an outer expression to include &definite-bailout in its
+;; effects. For that reason we have to treat it specially.
+;;
+(define-syntax &all-effects-but-bailout
+ (identifier-syntax
+ (logand &all-effects (lognot &definite-bailout))))
+
+(define-inlinable (cause effect)
+ (ash effect 1))
+
+(define-inlinable (&depends-on a)
+ (logand a &all-effects))
+(define-inlinable (&causes a)
+ (logand a (cause &all-effects)))
+
+(define (exclude-effects effects exclude)
+ (logand effects (lognot (cause exclude))))
+(define (effect-free? effects)
+ (zero? (&causes effects)))
+(define (constant? effects)
+ (zero? effects))
+
+(define-inlinable (depends-on-effects? x effects)
+ (not (zero? (logand (&depends-on x) effects))))
+(define-inlinable (causes-effects? x effects)
+ (not (zero? (logand (&causes x) (cause effects)))))
+
+(define-inlinable (effects-commute? a b)
+ (and (not (causes-effects? a (&depends-on b)))
+ (not (causes-effects? b (&depends-on a)))))
+
+(define (lookup-constant-index sym dfg)
+ (call-with-values (lambda () (find-constant-value sym dfg))
+ (lambda (has-const? val)
+ (and has-const? (integer? val) (exact? val) (<= 0 val) val))))
+
+(define *primitive-effects* (make-hash-table))
+
+(define-syntax-rule (define-primitive-effects* dfg ((name . args) effects) ...)
+ (begin
+ (hashq-set! *primitive-effects* 'name
+ (case-lambda* ((dfg . args) effects)
+ (_ (logior (cause &possible-bailout)
+ (cause &definite-bailout)))))
+ ...))
+
+(define-syntax-rule (define-primitive-effects ((name . args) effects) ...)
+ (define-primitive-effects* dfg ((name . args) effects) ...))
+
+;; Miscellaneous.
+(define-primitive-effects
+ ((values . _) &no-effects)
+ ((not arg) &no-effects))
+
+;; Generic predicates.
+(define-primitive-effects
+ ((eq? . _) &no-effects)
+ ((eqv? . _) &no-effects)
+ ((equal? . _) &no-effects)
+ ((pair? arg) &no-effects)
+ ((null? arg) &no-effects)
+ ((nil? arg ) &no-effects)
+ ((list? arg) &no-effects)
+ ((symbol? arg) &no-effects)
+ ((variable? arg) &no-effects)
+ ((vector? arg) &no-effects)
+ ((struct? arg) &no-effects)
+ ((string? arg) &no-effects)
+ ((number? arg) &no-effects)
+ ((char? arg) &no-effects)
+ ((procedure? arg) &no-effects)
+ ((thunk? arg) &no-effects))
+
+;; Fluids.
+(define-primitive-effects
+ ((fluid-ref f) (logior (cause &type-check) &fluid))
+ ((fluid-set! f v) (logior (cause &type-check) (cause &fluid)))
+ ((push-fluid f v) (logior (cause &type-check) (cause &fluid)))
+ ((pop-fluid) (logior (cause &fluid))))
+
+;; Prompts.
+(define-primitive-effects
+ ((make-prompt-tag #:optional arg) (cause &allocation)))
+
+;; Bailout.
+(define-primitive-effects
+ ((error . _) (logior (cause &definite-bailout) (cause &possible-bailout)))
+ ((scm-error . _) (logior (cause &definite-bailout) (cause
&possible-bailout)))
+ ((throw . _) (logior (cause &definite-bailout) (cause &possible-bailout))))
+
+;; Pairs.
+(define-primitive-effects
+ ((cons a b) (cause &allocation))
+ ((list . _) (cause &allocation))
+ ((car x) (logior (cause &type-check) &car))
+ ((set-car! x y) (logior (cause &type-check) (cause &car)))
+ ((cdr x) (logior (cause &type-check) &cdr))
+ ((set-cdr! x y) (logior (cause &type-check) (cause &cdr)))
+ ((memq x y) (logior (cause &type-check) &car &cdr))
+ ((memv x y) (logior (cause &type-check) &car &cdr))
+ ((length l) (logior (cause &type-check) &car &cdr)))
+
+;; Vectors.
+(define-primitive-effects
+ ((vector . _) (cause &allocation))
+ ((vector-ref v n) (logior (cause &type-check) &vector))
+ ((vector-set! v n x) (logior (cause &type-check) (cause &vector)))
+ ((vector-length v) (cause &type-check)))
+
+;; Variables.
+(define-primitive-effects
+ ((box v) (cause &allocation))
+ ((box-ref v) (logior (cause &type-check) &box))
+ ((box-set! v x) (logior (cause &type-check) (cause &box))))
+
+;; Structs.
+(define-primitive-effects* dfg
+ ((allocate-struct vtable nfields) (logior (cause &type-check)
+ (cause &allocation)))
+ ((make-struct vtable ntail . args) (logior (cause &type-check)
+ (cause &allocation)))
+ ((make-struct/no-tail vtable . args) (logior (cause &type-check)
+ (cause &allocation)))
+ ((struct-ref s n)
+ (logior (cause &type-check)
+ (match (lookup-constant-index n dfg)
+ (#f &struct)
+ (0 &struct-0)
+ (1 &struct-1)
+ (2 &struct-2)
+ (3 &struct-3)
+ (4 &struct-4)
+ (5 &struct-5)
+ (_ &struct-6+))))
+ ((struct-set! s n x)
+ (logior (cause &type-check)
+ (match (lookup-constant-index n dfg)
+ (#f (cause &struct))
+ (0 (cause &struct-0))
+ (1 (cause &struct-1))
+ (2 (cause &struct-2))
+ (3 (cause &struct-3))
+ (4 (cause &struct-4))
+ (5 (cause &struct-5))
+ (_ (cause &struct-6+)))))
+ ((struct-vtable s) (cause &type-check)))
+
+;; Strings.
+(define-primitive-effects
+ ((string-ref s n) (logior (cause &type-check) &string))
+ ((string-set! s n c) (logior (cause &type-check) (cause &string)))
+ ((number->string _) (cause &type-check))
+ ((string->number _) (logior (cause &type-check) &string))
+ ((string-length s) (cause &type-check)))
+
+;; Bytevectors.
+(define-primitive-effects
+ ((bv-u8-ref bv n) (logior (cause &type-check) &bytevector))
+ ((bv-s8-ref bv n) (logior (cause &type-check) &bytevector))
+ ((bv-u16-ref bv n) (logior (cause &type-check) &bytevector))
+ ((bv-s16-ref bv n) (logior (cause &type-check) &bytevector))
+ ((bv-u32-ref bv n) (logior (cause &type-check) &bytevector))
+ ((bv-s32-ref bv n) (logior (cause &type-check) &bytevector))
+ ((bv-u64-ref bv n) (logior (cause &type-check) &bytevector))
+ ((bv-s64-ref bv n) (logior (cause &type-check) &bytevector))
+ ((bv-f32-ref bv n) (logior (cause &type-check) &bytevector))
+ ((bv-f64-ref bv n) (logior (cause &type-check) &bytevector))
+
+ ((bv-u8-set! bv n x) (logior (cause &type-check) (cause &bytevector)))
+ ((bv-s8-set! bv n x) (logior (cause &type-check) (cause &bytevector)))
+ ((bv-u16-set! bv n x) (logior (cause &type-check) (cause &bytevector)))
+ ((bv-s16-set! bv n x) (logior (cause &type-check) (cause &bytevector)))
+ ((bv-u32-set! bv n x) (logior (cause &type-check) (cause &bytevector)))
+ ((bv-s32-set! bv n x) (logior (cause &type-check) (cause &bytevector)))
+ ((bv-u64-set! bv n x) (logior (cause &type-check) (cause &bytevector)))
+ ((bv-s64-set! bv n x) (logior (cause &type-check) (cause &bytevector)))
+ ((bv-f32-set! bv n x) (logior (cause &type-check) (cause &bytevector)))
+ ((bv-f64-set! bv n x) (logior (cause &type-check) (cause &bytevector))))
+
+;; Numbers.
+(define-primitive-effects
+ ((= . _) (cause &type-check))
+ ((< . _) (cause &type-check))
+ ((> . _) (cause &type-check))
+ ((<= . _) (cause &type-check))
+ ((>= . _) (cause &type-check))
+ ((zero? . _) (cause &type-check))
+ ((add . _) (cause &type-check))
+ ((mul . _) (cause &type-check))
+ ((sub . _) (cause &type-check))
+ ((div . _) (cause &type-check))
+ ((sub1 . _) (cause &type-check))
+ ((add1 . _) (cause &type-check))
+ ((quo . _) (cause &type-check))
+ ((rem . _) (cause &type-check))
+ ((mod . _) (cause &type-check))
+ ((complex? _) (cause &type-check))
+ ((real? _) (cause &type-check))
+ ((rational? _) (cause &type-check))
+ ((inf? _) (cause &type-check))
+ ((nan? _) (cause &type-check))
+ ((integer? _) (cause &type-check))
+ ((exact? _) (cause &type-check))
+ ((inexact? _) (cause &type-check))
+ ((even? _) (cause &type-check))
+ ((odd? _) (cause &type-check))
+ ((ash n m) (cause &type-check))
+ ((logand . _) (cause &type-check))
+ ((logior . _) (cause &type-check))
+ ((logior . _) (cause &type-check))
+ ((lognot . _) (cause &type-check)))
+
+;; Characters.
+(define-primitive-effects
+ ((char<? . _) (cause &type-check))
+ ((char<=? . _) (cause &type-check))
+ ((char>=? . _) (cause &type-check))
+ ((char>? . _) (cause &type-check))
+ ((integer->char _) (cause &type-check))
+ ((char->integer _) (cause &type-check)))
+
+;; Modules.
+(define-primitive-effects
+ ((current-module) &module)
+ ((cache-current-module! mod scope) (cause &box))
+ ((resolve name bound?) (logior &box &module (cause &type-check)))
+ ((cached-toplevel-box scope name bound?) (logior &box (cause &type-check)))
+ ((cached-module-box scope name bound?) (logior &box (cause &type-check)))
+ ((define! name val) (logior &module (cause &box))))
+
+(define (primitive-effects dfg name args)
+ (let ((proc (hashq-ref *primitive-effects* name)))
+ (if proc
+ (apply proc dfg args)
+ (logior &all-effects-but-bailout (cause &all-effects-but-bailout)))))
+
+(define (expression-effects exp dfg)
+ (match exp
+ ((or ($ $void) ($ $const) ($ $prim) ($ $values))
+ &no-effects)
+ (($ $fun)
+ (cause &allocation))
+ (($ $prompt)
+ (cause &prompt))
+ (($ $call)
+ (logior &all-effects-but-bailout (cause &all-effects-but-bailout)))
+ (($ $primcall name args)
+ (primitive-effects dfg name args))))
+
+(define (compute-effects cfa dfg)
+ (let ((effects (make-vector (cfa-k-count cfa) &no-effects)))
+ (let lp ((n 0))
+ (when (< n (vector-length effects))
+ (vector-set!
+ effects
+ n
+ (match (lookup-cont (cfa-k-sym cfa n) (dfg-cont-table dfg))
+ (($ $kargs names syms body)
+ (expression-effects (find-expression body) dfg))
+ (($ $ktrunc arity kargs)
+ (match arity
+ (($ $arity _ () #f () #f) (cause &type-check))
+ (($ $arity () () _ () #f) (cause &allocation))
+ (($ $arity _ () _ () #f) (logior (cause &allocation)
+ (cause &type-check)))))
+ (($ $kif) &no-effects)
+ (($ $kentry) &type-check)
+ (($ $kclause) &type-check)
+ (($ $ktail) &no-effects)))
+ (lp (1+ n))))
+ effects))
diff --git a/module/language/cps/primitives.scm
b/module/language/cps/primitives.scm
index 58506a5..d85492f 100644
--- a/module/language/cps/primitives.scm
+++ b/module/language/cps/primitives.scm
@@ -40,21 +40,21 @@
(modulo . mod)
(variable-ref . box-ref)
(variable-set! . box-set!)
- (bytevector-u8-native-ref . bv-u8-ref)
+ (bytevector-u8-ref . bv-u8-ref)
(bytevector-u16-native-ref . bv-u16-ref)
(bytevector-u32-native-ref . bv-u32-ref)
(bytevector-u64-native-ref . bv-u64-ref)
- (bytevector-s8-native-ref . bv-s8-ref)
+ (bytevector-s8-ref . bv-s8-ref)
(bytevector-s16-native-ref . bv-s16-ref)
(bytevector-s32-native-ref . bv-s32-ref)
(bytevector-s64-native-ref . bv-s64-ref)
(bytevector-f32-native-ref . bv-f32-ref)
(bytevector-f64-native-ref . bv-f64-ref)
- (bytevector-u8-native-set! . bv-u8-set!)
+ (bytevector-u8-set! . bv-u8-set!)
(bytevector-u16-native-set! . bv-u16-set!)
(bytevector-u32-native-set! . bv-u32-set!)
(bytevector-u64-native-set! . bv-u64-set!)
- (bytevector-s8-native-set! . bv-s8-set!)
+ (bytevector-s8-set! . bv-s8-set!)
(bytevector-s16-native-set! . bv-s16-set!)
(bytevector-s32-native-set! . bv-s32-set!)
(bytevector-s64-native-set! . bv-s64-set!)
diff --git a/module/language/cps/simplify.scm b/module/language/cps/simplify.scm
new file mode 100644
index 0000000..904ec0b
--- /dev/null
+++ b/module/language/cps/simplify.scm
@@ -0,0 +1,273 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; 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
+;;;; 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:
+;;;
+;;; The fundamental lambda calculus reductions, like beta and eta
+;;; reduction and so on. Pretty lame currently.
+;;;
+;;; Code:
+
+(define-module (language cps simplify)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (language cps)
+ #:use-module (language cps dfg)
+ #:export (simplify))
+
+;; Currently we just try to bypass all $values nodes that we can. This
+;; is eta-reduction on continuations. Then we prune unused
+;; continuations. Note that this pruning is just a quick clean-up; for
+;; a real fixed-point pass that can eliminate unused loops, the
+;; dead-code elimination pass is there for you. But DCE introduces new
+;; nullary $values nodes (as replacements for expressions whose values
+;; aren't used), making it useful for this pass to include its own
+;; little pruner.
+
+(define (compute-eta-reductions fun)
+ (let ((table (make-hash-table)))
+ (define (visit-cont cont)
+ (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 _) #f)))
+ (define (visit-term term term-k term-args)
+ (match term
+ (($ $letk conts body)
+ (for-each visit-cont conts)
+ (visit-term body term-k term-args))
+ (($ $letrec names syms funs body)
+ (for-each visit-fun funs)
+ (visit-term body term-k term-args))
+ (($ $continue k src ($ $values args))
+ (when (equal? term-args args)
+ (hashq-set! table term-k k)))
+ (($ $continue k src (and fun ($ $fun)))
+ (visit-fun fun))
+ (($ $continue k src _)
+ #f)))
+ (define (visit-fun fun)
+ (match fun
+ (($ $fun src meta free body)
+ (visit-cont body))))
+ (visit-fun fun)
+ table))
+
+(define (locally-prune-continuations fun dfg)
+ (let ((cfa (analyze-control-flow fun dfg)))
+ (define (must-visit-cont cont)
+ (or (visit-cont cont)
+ (error "cont must be reachable" cont)))
+ (define (visit-cont cont)
+ (match cont
+ (($ $cont sym cont)
+ (and (cfa-k-idx cfa sym #:default (lambda (k) #f))
+ (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))))
+ ((or ($ $ktrunc) ($ $kif))
+ (sym ,cont)))))))
+ (define (visit-conts conts)
+ (filter-map visit-cont conts))
+ (define (visit-term term)
+ (match term
+ (($ $letk conts body)
+ (let ((body (visit-term body)))
+ (match (visit-conts conts)
+ (() body)
+ (conts (build-cps-term ($letk ,conts ,body))))))
+ (($ $letrec names syms funs body)
+ (build-cps-term
+ ($letrec names syms funs ,(visit-term body))))
+ (($ $continue k src exp)
+ term)))
+ (rewrite-cps-exp fun
+ (($ $fun src meta free body)
+ ($fun src meta free ,(must-visit-cont body))))))
+
+(define (eta-reduce fun)
+ (let ((table (compute-eta-reductions fun))
+ (dfg (compute-dfg fun)))
+ (define (reduce* k scope values?)
+ (match (hashq-ref table k)
+ (#f k)
+ (k*
+ (if (and (continuation-bound-in? k* scope dfg)
+ (or values?
+ (match (lookup-cont k* (dfg-cont-table dfg))
+ (($ $kargs) #t)
+ (_ #f))))
+ (reduce* k* scope values?)
+ k))))
+ (define (reduce k scope)
+ (reduce* k scope #f))
+ (define (reduce-values k scope)
+ (reduce* k scope #t))
+ (define (visit-cont cont scope)
+ (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 ($ $ktrunc ($ $arity req () rest () #f) kargs))
+ (sym ($ktrunc req rest (reduce kargs scope))))
+ (($ $cont sym ($ $kif kt kf))
+ (sym ($kif (reduce kt scope) (reduce kf scope))))))
+ (define (visit-term term scope)
+ (rewrite-cps-term term
+ (($ $letk conts body)
+ ($letk ,(map (cut visit-cont <> scope) conts)
+ ,(visit-term body scope)))
+ (($ $letrec names syms funs body)
+ ($letrec names syms (map visit-fun funs)
+ ,(visit-term body scope)))
+ (($ $continue k src ($ $values args))
+ ($continue (reduce-values k scope) src ($values args)))
+ (($ $continue k src (and fun ($ $fun)))
+ ($continue (reduce k scope) src ,(visit-fun fun)))
+ (($ $continue k src exp)
+ ($continue (reduce k scope) src ,exp))))
+ (define (visit-fun fun)
+ (locally-prune-continuations
+ (rewrite-cps-exp fun
+ (($ $fun src meta free body)
+ ($fun src meta free ,(visit-cont body #f))))
+ dfg))
+ (visit-fun fun)))
+
+(define (compute-beta-reductions fun)
+ ;; 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))
+ (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 (or ($ $ktail) ($ $ktrunc) ($ $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 ($ $values args))
+ (match (lookup-cont k (dfg-cont-table dfg))
+ (($ $kargs names syms body)
+ (match (lookup-predecessors k dfg)
+ ((_)
+ ;; There is only one use, and it is this use. We assume
+ ;; it's not recursive, as there would to be some other
+ ;; use for control flow to reach this loop. Store the k
+ ;; -> 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))
+ (_ #f)))
+ (_ #f)))
+ (($ $continue k src (and fun ($ $fun)))
+ (visit-fun fun))
+ (($ $continue k src _)
+ #f)))
+ (define (visit-fun fun)
+ (match fun
+ (($ $fun src meta free body)
+ (visit-cont body))))
+ (visit-fun fun)
+ table))
+
+(define (beta-reduce fun)
+ (let ((table (compute-beta-reductions fun)))
+ (define (subst var)
+ (cond ((hashq-ref table var) => subst)
+ (else var)))
+ (define (must-visit-cont cont)
+ (or (visit-cont cont)
+ (error "continuation must not be inlined" cont)))
+ (define (visit-cont cont)
+ (match cont
+ (($ $cont sym cont)
+ (and (not (hashq-ref 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))))
+ ((or ($ $ktrunc) ($ $kif))
+ (sym ,cont)))))))
+ (define (visit-term term)
+ (match term
+ (($ $letk conts body)
+ (match (filter-map visit-cont conts)
+ (() (visit-term body))
+ (conts (build-cps-term
+ ($letk ,conts ,(visit-term body))))))
+ (($ $letrec names syms funs body)
+ (build-cps-term
+ ($letrec names syms (map visit-fun funs)
+ ,(visit-term body))))
+ (($ $continue k src exp)
+ (cond
+ ((hashq-ref table k) => visit-term)
+ (else
+ (build-cps-term
+ ($continue k src
+ ,(match exp
+ ((or ($ $void) ($ $const) ($ $prim)) exp)
+ (($ $fun) (visit-fun exp))
+ (($ $call proc args)
+ (let ((args (map subst args)))
+ (build-cps-exp ($call (subst proc) args))))
+ (($ $primcall name args)
+ (let ((args (map subst args)))
+ (build-cps-exp ($primcall name args))))
+ (($ $values args)
+ (let ((args (map subst args)))
+ (build-cps-exp ($values args))))
+ (($ $prompt escape? tag handler)
+ (build-cps-exp ($prompt escape? (subst tag)
handler)))))))))))
+ (define (visit-fun fun)
+ (rewrite-cps-exp fun
+ (($ $fun src meta free body)
+ ($fun src meta (map subst free) ,(must-visit-cont body)))))
+ (visit-fun fun)))
+
+(define (simplify fun)
+ (eta-reduce (beta-reduce fun)))
diff --git a/module/language/cps/slot-allocation.scm
b/module/language/cps/slot-allocation.scm
index d1d02dd..5e92a6a 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.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
@@ -278,8 +278,8 @@ are comparable with eqv?. A tmp slot may be used."
(define* (allocate! var-idx hint live)
(cond
((not (bitvector-ref needs-slotv var-idx)) live)
- ((and (not hint) (bitvector-ref needs-hintv var-idx)) live)
((vector-ref slots var-idx) => (cut add-live-slot <> live))
+ ((and (not hint) (bitvector-ref needs-hintv var-idx)) live)
(else
(let ((slot (compute-slot live hint)))
(bump-nlocals! (1+ slot))
@@ -348,7 +348,7 @@ are comparable with eqv?. A tmp slot may be used."
args)
(($ $values args)
args)
- (($ $prompt escape? tag handler pop)
+ (($ $prompt escape? tag handler)
(list tag))
(_ '())))))
(_ #f))
@@ -439,7 +439,12 @@ are comparable with eqv?. A tmp slot may be used."
;; terminator, but leave its definitions.
(match (find-expression body)
((or ($ $void) ($ $const) ($ $prim) ($ $fun)
- ($ $primcall) ($ $prompt))
+ ($ $primcall) ($ $prompt)
+ ;; If $values has more than one argument, it may
+ ;; use a temporary, which would invalidate our
+ ;; assumptions that slots not allocated are not
+ ;; used.
+ ($ $values (or () (_))))
(let ((dead (make-bitvector (bitvector-length args) #f)))
(bit-set*! dead (live-before n) #t)
(bit-set*! dead (live-after n) #f)
@@ -492,8 +497,17 @@ are comparable with eqv?. A tmp slot may be used."
(result-vars (vector-ref defv (cfa-k-idx cfa kargs)))
(value-slots (map (cut + proc-slot 1 <>)
(iota (length result-vars))))
- (result-live (fold allocate!
- post-live result-vars value-slots))
+ ;; Shuffle the first result down to the lowest slot, and
+ ;; leave any remaining results where they are. This
+ ;; strikes a balance between avoiding shuffling,
+ ;; especially for unused extra values, and avoiding
+ ;; frame size growth due to sparse locals.
+ (result-live (match (cons result-vars value-slots)
+ ((() . ()) post-live)
+ (((var . vars) . (slot . slots))
+ (fold allocate!
+ (allocate! var #f post-live)
+ vars slots))))
(result-slots (map (cut vector-ref slots <>) result-vars))
;; Filter out unused results.
(value-slots (filter-map (lambda (val result) (and result val))
@@ -522,21 +536,38 @@ are comparable with eqv?. A tmp slot may be used."
(make-call-allocation proc-slot arg-moves))))))
(define (allocate-values label k uses pre-live post-live)
- (let* ((src-slots (map (cut vector-ref slots <>) uses))
- (dst-slots (match (vector-ref contv (cfa-k-idx cfa k))
- (($ $ktail)
- (let ((tail-nlocals (1+ (length uses))))
- (bump-nlocals! tail-nlocals)
- (cdr (iota tail-nlocals))))
- (_
- (let ((dst-vars (vector-ref defv (cfa-k-idx cfa
k))))
- (fold allocate! post-live dst-vars src-slots)
- (map (cut vector-ref slots <>) dst-vars)))))
- (moves (parallel-move src-slots
- dst-slots
- (compute-tmp-slot pre-live dst-slots))))
- (hashq-set! call-allocations label
- (make-call-allocation #f moves))))
+ (match (vector-ref contv (cfa-k-idx cfa k))
+ (($ $ktail)
+ (let* ((src-slots (map (cut vector-ref slots <>) uses))
+ (tail-nlocals (1+ (length uses)))
+ (dst-slots (cdr (iota tail-nlocals)))
+ (moves (parallel-move src-slots dst-slots
+ (compute-tmp-slot pre-live dst-slots))))
+ (bump-nlocals! tail-nlocals)
+ (hashq-set! call-allocations label
+ (make-call-allocation #f moves))))
+ (($ $kargs (_) (_))
+ ;; When there is only one value in play, we allow the dst to be
+ ;; hinted (see scan-for-hints). If the src doesn't have a
+ ;; slot, then the actual slot for the dst would end up being
+ ;; decided by the call that uses it. Because we don't know the
+ ;; slot, we can't really compute the parallel moves in that
+ ;; case, so just bail and rely on the bytecode emitter to
+ ;; handle the one-value case specially.
+ (match (cons uses (vector-ref defv (cfa-k-idx cfa k)))
+ (((src) . (dst))
+ (allocate! dst (vector-ref slots src) post-live))))
+ (($ $kargs)
+ (let* ((src-slots (map (cut vector-ref slots <>) uses))
+ (dst-vars (vector-ref defv (cfa-k-idx cfa k)))
+ (result-live (fold allocate! post-live dst-vars src-slots))
+ (dst-slots (map (cut vector-ref slots <>) dst-vars))
+ (moves (parallel-move src-slots dst-slots
+ (compute-tmp-slot (logior pre-live
result-live)
+ '()))))
+ (hashq-set! call-allocations label
+ (make-call-allocation #f moves))))
+ (($ $kif) #f)))
(define (allocate-prompt label k handler nargs)
(match (vector-ref contv (cfa-k-idx cfa handler))
@@ -602,12 +633,9 @@ are comparable with eqv?. A tmp slot may be used."
(($ $continue k src ($ $call))
(allocate-call label k uses live post-live))
(($ $continue k src ($ $primcall)) #t)
- ;; We only need to make a call allocation if there
- ;; are two or more values.
- (($ $continue k src ($ $values (_ _ . _)))
+ (($ $continue k src ($ $values))
(allocate-values label k uses live post-live))
- (($ $continue k src ($ $values)) #t)
- (($ $continue k src ($ $prompt escape? tag handler pop))
+ (($ $continue k src ($ $prompt escape? tag handler))
(allocate-prompt label k handler nargs))
(_ #f)))
(lp (1+ n) post-live))
diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm
index ff23aa3..94c111e 100644
--- a/module/language/cps/verify.scm
+++ b/module/language/cps/verify.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
@@ -128,11 +128,10 @@
(for-each (cut check-var <> v-env) arg))
(($ $values ((? symbol? arg) ...))
(for-each (cut check-var <> v-env) arg))
- (($ $prompt escape? tag handler pop)
+ (($ $prompt escape? tag handler)
(unless (boolean? escape?) (error "escape? should be boolean" escape?))
(check-var tag v-env)
- (check-var handler k-env)
- (check-var pop k-env))
+ (check-var handler k-env))
(_
(error "unexpected expression" exp))))
diff --git a/module/language/tree-il/compile-cps.scm
b/module/language/tree-il/compile-cps.scm
index 6375118..1960023 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.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
@@ -178,7 +178,7 @@
($continue k src ($primcall 'box (phi))))))
,(make-body kbox))))
(make-body k)))
- (let-gensyms (knext kbound kunbound)
+ (let-gensyms (knext kbound kunbound ktrunc krest val rest)
(build-cps-term
($letk ((knext ($kargs (name) (subst-sym) ,body)))
,(maybe-box
@@ -187,7 +187,11 @@
(build-cps-term
($letk ((kbound ($kargs () () ($continue k src
($values (sym)))))
- (kunbound ($kargs () () ,(convert init k subst))))
+ (krest ($kargs (name 'rest) (val rest)
+ ($continue k src ($values (val)))))
+ (ktrunc ($ktrunc (list name) 'rest krest))
+ (kunbound ($kargs () ()
+ ,(convert init ktrunc subst))))
,(unbound? src sym kunbound kbound))))))))))))
;; exp k-name alist -> term
@@ -205,10 +209,11 @@
((subst #f) (k subst))
(#f (k sym))))
(else
- (let-gensyms (karg arg)
+ (let-gensyms (ktrunc karg arg rest)
(build-cps-term
- ($letk ((karg ($kargs ('arg) (arg) ,(k arg))))
- ,(convert exp karg subst)))))))
+ ($letk ((karg ($kargs ('arg 'rest) (arg rest) ,(k arg)))
+ (ktrunc ($ktrunc '(arg) 'rest karg)))
+ ,(convert exp ktrunc subst)))))))
;; (exp ...) ((v-name ...) -> term) -> term
(define (convert-args exps k)
(match exps
@@ -447,7 +452,7 @@
(build-cps-term
($letk ((kbody ($kargs () ()
,(convert body krest subst))))
- ($continue kbody src ($prompt #t tag khargs kpop))))
+ ($continue kbody src ($prompt #t tag khargs))))
(convert-arg body
(lambda (thunk)
(build-cps-term
@@ -456,7 +461,7 @@
($primcall 'call-thunk/no-inline
(thunk))))))
($continue kbody (tree-il-src body)
- ($prompt #f tag khargs kpop))))))))))))))
+ ($prompt #f tag khargs))))))))))))))
;; Eta-convert prompts without inline handlers.
(($ <prompt> src escape-only? tag body handler)
@@ -534,11 +539,11 @@
($continue k src ($primcall 'box-set! (box exp)))))))))
(($ <seq> src head tail)
- (let-gensyms (ktrunc kseq)
+ (let-gensyms (ktrunc kseq vals)
(build-cps-term
- ($letk* ((kseq ($kargs () ()
+ ($letk* ((kseq ($kargs ('vals) (vals)
,(convert tail k subst)))
- (ktrunc ($ktrunc '() #f kseq)))
+ (ktrunc ($ktrunc '() 'vals kseq)))
,(convert head ktrunc subst)))))
(($ <let> src names syms vals body)
@@ -546,12 +551,13 @@
(match (list names syms vals)
((() () ()) (convert body k subst))
(((name . names) (sym . syms) (val . vals))
- (let-gensyms (klet)
+ (let-gensyms (ktrunc klet rest)
(build-cps-term
- ($letk ((klet ($kargs (name) (sym)
- ,(box-bound-var name sym
- (lp names syms vals)))))
- ,(convert val klet subst))))))))
+ ($letk* ((klet ($kargs (name 'rest) (sym rest)
+ ,(box-bound-var name sym
+ (lp names syms vals))))
+ (ktrunc ($ktrunc (list name) 'rest klet)))
+ ,(convert val ktrunc subst))))))))
(($ <fix> src names gensyms funs body)
;; Some letrecs can be contified; that happens later.
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-579-g3108664,
Andy Wingo <=