[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-239-g9d8a10a
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-239-g9d8a10a |
|
Date: |
Thu, 26 Apr 2012 21:41:06 +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=9d8a10a94c022e5fe4b58aa4b586eda514b1189f
The branch, master has been updated
via 9d8a10a94c022e5fe4b58aa4b586eda514b1189f (commit)
via 0ea5ba9ab9e749ccb19ec12129045d0753844338 (commit)
via 79d29f96c7c4631ec8096d88cbd86498f004162f (commit)
via c46e0a8a598a16b8f68b5492a13e4032b93f21f9 (commit)
via e7501d4a682cc2b430514280834dfc68b97f2be2 (commit)
via 4bd53c1ba39ba1c2d51ff895104f27cf4bb69e4e (commit)
via 985702f7131e11c7c13aa75db19d10525c34fecd (commit)
via f6a554a6aa0832432cec9c9c18b99fad56008997 (commit)
via 299ce911f986c7f9a6a4887ca3b72e5748e126f7 (commit)
via f66cbb99ee096186837536885d3436bb334df34d (commit)
via 1cd63115be7a25d0ea18aaa0e1eff5658d8db77a (commit)
via 73001b06f60206edfa4ae4ec6a8b5c8f65d272c2 (commit)
via a36e7870c31322fd300c7478df24dbf559a0d67b (commit)
via 3db8f60977e966522e3c05cc554c99382c968b55 (commit)
via 036c366dc2fbbeeb04d8984bb0819df28d9d455f (commit)
via b3f25e62695315ab632d2e3a66d31bb490c82100 (commit)
via f7d8efc630ce45f5d82aae5b2682d261e5541d5f (commit)
via 9068f4f52772397c5d4408f585ccdf1017869a3e (commit)
via da9b2b71f76644abcc2eec2cc1478379df1e9025 (commit)
via de1eb420a5a95b17e85b19c4d98c869036e9ecb0 (commit)
via 5deea34d0eb3d2ec5db421eb79516e747eed5841 (commit)
via d10f7b572c0ca1ccef87f9c46069daa30946e0cf (commit)
via 7e822b32d2a165a027fd1de4d59fdfae568599bf (commit)
via b064d565141ca777778fa38e0fe98c0aed834eb9 (commit)
via 7a4188c4492736f7afd7304a01eaebc3474ccdee (commit)
via 398446c7428b3d98d168fcc3ff170829d3e09f9a (commit)
via fd07759b7d4c9d631090b04855ab81b6a2109e9e (commit)
via d8fe367a31d15ea64c43c80c4e4819ef393696ef (commit)
via 0f6dd25023da59bcfefb080c66a2d2650d955ffa (commit)
via 5ef102cc93a4f2eba0f5dad94a7306085b353000 (commit)
via bbb9f000ad52282ee1a0518b65437baf20c3d17c (commit)
via 51853eee69ca5811ae0661eb91868121c6ad1d74 (commit)
via e26da7a24e79cf3a9d3052e78228a9dfed3c4f3d (commit)
via 2c1b79513b7b5826db48b6e5e1d7f4dc7731d13b (commit)
from 649d3ea76639424fa5445a6f44896de1fdf1e309 (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 9d8a10a94c022e5fe4b58aa4b586eda514b1189f
Merge: 0ea5ba9 4bd53c1
Author: Andy Wingo <address@hidden>
Date: Thu Apr 26 23:40:57 2012 +0200
Merge remote-tracking branch 'origin/stable-2.0'
Conflicts:
test-suite/tests/cse.test
commit 0ea5ba9ab9e749ccb19ec12129045d0753844338
Merge: 79d29f9 f66cbb9
Author: Andy Wingo <address@hidden>
Date: Thu Apr 26 23:09:21 2012 +0200
Merge commit 'f66cbb99ee096186837536885d3436bb334df34d'
commit 79d29f96c7c4631ec8096d88cbd86498f004162f
Merge: c46e0a8 1cd6311
Author: Andy Wingo <address@hidden>
Date: Thu Apr 26 23:08:14 2012 +0200
Merge commit '1cd63115be7a25d0ea18aaa0e1eff5658d8db77a'
Conflicts:
module/language/tree-il/peval.scm
test-suite/tests/peval.test
commit c46e0a8a598a16b8f68b5492a13e4032b93f21f9
Merge: e7501d4 de1eb42
Author: Andy Wingo <address@hidden>
Date: Thu Apr 26 22:56:45 2012 +0200
Merge commit 'de1eb420a5a95b17e85b19c4d98c869036e9ecb0'
Conflicts:
module/language/tree-il/primitives.scm
test-suite/tests/tree-il.test
commit e7501d4a682cc2b430514280834dfc68b97f2be2
Merge: 649d3ea d10f7b5
Author: Andy Wingo <address@hidden>
Date: Thu Apr 26 22:17:47 2012 +0200
Merge commit 'd10f7b572c0ca1ccef87f9c46069daa30946e0cf'
Conflicts:
libguile/smob.c
libguile/smob.h
test-suite/tests/tree-il.test
-----------------------------------------------------------------------
Summary of changes:
THANKS | 1 +
benchmark-guile.in | 1 +
benchmark-suite/Makefile.am | 3 +-
benchmark-suite/{ => benchmark-suite}/lib.scm | 442 +++++------
benchmark-suite/benchmarks/arithmetic.bm | 14 +-
benchmark-suite/benchmarks/r6rs-arithmetic.bm | 8 +-
check-guile.in | 1 +
doc/ref/api-utility.texi | 9 +-
libguile/Makefile.am | 1 -
libguile/bytevectors.c | 71 +--
libguile/ieee-754.h | 90 ---
libguile/sort.c | 11 +-
libguile/strings.c | 89 +++-
meta/uninstalled-env.in | 12 +-
module/Makefile.am | 2 +
module/ice-9/vlist.scm | 377 +++++-----
module/language/tree-il/cse.scm | 601 +++++++++++++++
module/language/tree-il/effects.scm | 330 ++++++++
module/language/tree-il/optimize.scm | 16 +-
module/language/tree-il/peval.scm | 145 ++--
module/language/tree-il/primitives.scm | 136 ++--
module/oop/goops/dispatch.scm | 6 +-
module/srfi/srfi-9.scm | 12 +-
test-suite/Makefile.am | 4 +-
test-suite/standalone/test-conversion.c | 69 ++
test-suite/{ => test-suite}/lib.scm | 0
test-suite/tests/asm-to-bytecode.test | 2 +-
test-suite/tests/brainfuck.test | 2 +-
test-suite/tests/bytevectors.test | 30 +-
test-suite/tests/compiler.test | 4 +-
test-suite/tests/cse.test | 255 +++++++
test-suite/tests/ftw.test | 10 +-
test-suite/tests/gc.test | 2 +-
test-suite/tests/match.test | 4 +-
test-suite/tests/peval.test | 1015 +++++++++++++++++++++++++
test-suite/tests/rnrs-libraries.test | 16 +-
test-suite/tests/rnrs-test-a.scm | 4 +-
test-suite/tests/srfi-9.test | 11 +-
test-suite/tests/sxml.match.test | 4 +-
test-suite/tests/tree-il.test | 987 +------------------------
40 files changed, 3061 insertions(+), 1736 deletions(-)
rename benchmark-suite/{ => benchmark-suite}/lib.scm (51%)
delete mode 100644 libguile/ieee-754.h
create mode 100644 module/language/tree-il/cse.scm
create mode 100644 module/language/tree-il/effects.scm
rename test-suite/{ => test-suite}/lib.scm (100%)
create mode 100644 test-suite/tests/cse.test
create mode 100644 test-suite/tests/peval.test
diff --git a/THANKS b/THANKS
index a06ba4a..bdf11ee 100644
--- a/THANKS
+++ b/THANKS
@@ -140,6 +140,7 @@ For fixes or providing information which led to a fix:
Daniel Skarda
Dale Smith
Cesar Strauss
+ Klaus Stehle
Rainer Tammer
Richard Todd
Issac Trotts
diff --git a/benchmark-guile.in b/benchmark-guile.in
index 572e008..8378e9d 100644
--- a/benchmark-guile.in
+++ b/benchmark-guile.in
@@ -41,6 +41,7 @@ if [ ! -f guile-procedures.txt ] ; then
fi
exec $guile \
+ -L "$BENCHMARK_SUITE_DIR" \
-e main -s "$BENCHMARK_SUITE_DIR/guile-benchmark" \
--benchmark-suite "$BENCHMARK_SUITE_DIR/benchmarks" \
--log-file benchmark-guile.log "$@"
diff --git a/benchmark-suite/Makefile.am b/benchmark-suite/Makefile.am
index f29743f..9fa5568 100644
--- a/benchmark-suite/Makefile.am
+++ b/benchmark-suite/Makefile.am
@@ -18,5 +18,6 @@ SCM_BENCHMARKS = benchmarks/0-reference.bm \
benchmarks/write.bm \
benchmarks/strings.bm
-EXTRA_DIST = guile-benchmark lib.scm $(SCM_BENCHMARKS) \
+EXTRA_DIST = guile-benchmark benchmark-suite/lib.scm \
+ $(SCM_BENCHMARKS) \
ChangeLog-2008
diff --git a/benchmark-suite/lib.scm b/benchmark-suite/benchmark-suite/lib.scm
similarity index 51%
rename from benchmark-suite/lib.scm
rename to benchmark-suite/benchmark-suite/lib.scm
index 4ba0e3e..ae57cc0 100644
--- a/benchmark-suite/lib.scm
+++ b/benchmark-suite/benchmark-suite/lib.scm
@@ -1,5 +1,5 @@
;;;; benchmark-suite/lib.scm --- generic support for benchmarking
-;;;; Copyright (C) 2002, 2006, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2002, 2006, 2011, 2012 Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -17,31 +17,33 @@
;;;; Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (benchmark-suite lib)
- :export (
-
- ;; Controlling the execution.
- iteration-factor
- scale-iterations
-
- ;; Running benchmarks.
- run-benchmark
- benchmark
-
- ;; Naming groups of benchmarks in a regular fashion.
- with-benchmark-prefix with-benchmark-prefix* current-benchmark-prefix
- format-benchmark-name
-
- ;; Computing timing results
- benchmark-time-base
- benchmark-total-time benchmark-user-time benchmark-system-time
- benchmark-frame-time benchmark-core-time
- benchmark-user-time\interpreter benchmark-core-time\interpreter
-
- ;; Reporting results in various ways.
- register-reporter unregister-reporter reporter-registered?
- make-log-reporter
- full-reporter
- user-reporter))
+ #:use-module (srfi srfi-9)
+ #:export (;; Controlling the execution.
+ iteration-factor
+ scale-iterations
+
+ ;; Running benchmarks.
+ run-benchmark
+ benchmark
+
+ ;; Naming groups of benchmarks in a regular fashion.
+ with-benchmark-prefix with-benchmark-prefix*
+ current-benchmark-prefix format-benchmark-name
+
+ ;; <benchmark-result> accessors
+ benchmark-result:name
+ benchmark-result:iterations
+ benchmark-result:real-time
+ benchmark-result:run-time
+ benchmark-result:gc-time
+ benchmark-result:core-time
+
+ ;; Reporting results in various ways.
+ report current-reporter
+ register-reporter unregister-reporter reporter-registered?
+ make-log-reporter
+ full-reporter
+ user-reporter))
;;;; If you're using Emacs's Scheme mode:
@@ -214,81 +216,71 @@
;;;; TIME CALCULATION
;;;;
-;;;; The library uses the guile functions (times) and (gc-run-time) to
-;;;; determine the execution time for a single benchmark. Based on these
-;;;; functions, the values of BEFORE, AFTER and GC-TIME are computed, which
-;;;; are then passed to the reporter functions. All three values BEFORE,
-;;;; AFTER and GC-TIME include the time needed to executed the benchmark code
-;;;; itself, but also the surrounding code that implements the loop to run the
-;;;; benchmark code for the given number of times. This is undesirable, since
-;;;; one would prefer to only get the timing data for the benchmarking code.
+;;;; The library uses the guile functions `get-internal-run-time',
+;;;; `get-internal-real-time', and `gc-run-time' to determine the
+;;;; execution time for a single benchmark. Based on these functions,
+;;;; Guile makes a <benchmark-result>, a record containing the elapsed
+;;;; run time, real time, gc time, and possibly other metrics. These
+;;;; times include the time needed to executed the benchmark code
+;;;; itself, but also the surrounding code that implements the loop to
+;;;; run the benchmark code for the given number of times. This is
+;;;; undesirable, since one would prefer to only get the timing data for
+;;;; the benchmarking code.
;;;;
;;;; To cope with this, the benchmarking framework uses a trick: During
-;;;; initialization of the library, the time for executing an empty benchmark
-;;;; is measured and stored. This is an estimate for the time needed by the
-;;;; benchmarking framework itself. For later benchmarks, this time can then
-;;;; be subtracted from the measured execution times.
-;;;;
-;;;; In order to simplify the time calculation for users who want to write
-;;;; their own reporters, benchmarking framework provides the following
-;;;; definitions:
-;;;;
-;;;; benchmark-time-base : This variable holds the number of time units that
-;;;; make up a second. By deviding the results of each of the functions
-;;;; below by this value, you get the corresponding time in seconds. For
-;;;; example (/ (benchmark-total-time before after) benchmark-time-base)
-;;;; will give you the total time in seconds.
-;;;; benchmark-total-time : this function takes two arguments BEFORE and AFTER
-;;;; and computes the total time between the two timestamps. The result
-;;;; of this function is what the time command of the unix command line
-;;;; would report as real time.
-;;;; benchmark-user-time : this function takes two arguments BEFORE and AFTER
-;;;; and computes the time spent in the benchmarking process between the
-;;;; two timestamps. That means, the time consumed by other processes
-;;;; running on the same machine is not part of the resulting time,
-;;;; neither is time spent within the operating system. The result of
-;;;; this function is what the time command of the unix command line would
-;;;; report as user time.
-;;;; benchmark-system-time : similar to benchmark-user-time, but here the time
-;;;; spent within the operating system is given. The result of this
-;;;; function is what the time command of the unix command line would
-;;;; report as system time.
-;;;; benchmark-frame-time : this function takes the argument ITERATIONS. It
-;;;; reports the part of the user time that is consumed by the
-;;;; benchmarking framework itself to run some benchmark for the given
-;;;; number of iterations. You can think of this as the time that would
-;;;; still be consumed, even if the benchmarking code itself was empty.
-;;;; This value does not include any time for garbage collection, even if
-;;;; it is the benchmarking framework which is responsible for causing a
-;;;; garbage collection.
-;;;; benchmark-core-time : this function takes three arguments ITERATIONS,
-;;;; BEFORE and AFTER. It reports the part of the user time that is
-;;;; actually spent within the benchmarking code. That is, the time
-;;;; needed for the benchmarking framework is subtracted from the user
-;;;; time. This value, however, includes all garbage collection times,
-;;;; even if some part of the gc-time had actually to be attributed to the
-;;;; benchmarking framework.
-;;;; benchmark-user-time\interpreter : this function takes three arguments
-;;;; BEFORE AFTER and GC-TIME. It reports the part of the user time that
-;;;; is spent in the interpreter (and not in garbage collection).
-;;;; benchmark-core-time\interpreter : this function takes four arguments
-;;;; ITERATIONS, BEFORE, AFTER. and GC-TIME. It reports the part of the
-;;;; benchmark-core-time that is spent in the interpreter (and not in
-;;;; garbage collection). This value is most probably the one you are
-;;;; interested in, except if you are doing some garbage collection
-;;;; checks.
-;;;;
-;;;; There is no function to calculate the garbage-collection time, since the
-;;;; garbage collection time is already passed as an argument GC-TIME to the
-;;;; reporter functions.
+;;;; initialization of the library, the time for executing an empty
+;;;; benchmark is measured and stored. This is an estimate for the time
+;;;; needed by the benchmarking framework itself. For later benchmarks,
+;;;; this time can then be subtracted from the measured execution times.
+;;;; Note that for very short benchmarks, this may result in a negative
+;;;; number.
+;;;;
+;;;; The benchmarking framework provides the following accessors for
+;;;; <benchmark-result> values. Note that all time values are in
+;;;; internal time units; divide by internal-time-units-per-second to
+;;;; get seconds.
+;;;;
+;;;; benchmark-result:name : Return the name of the benchmark.
+;;;;
+;;;; benchmark-result:iterations : Return the number of iterations that
+;;;; this benchmark ran for.
+;;;;
+;;;; benchmark-result:real-time : Return the clock time elapsed while
+;;;; this benchmark executed.
+;;;;
+;;;; benchmark-result:run-time : Return the CPU time elapsed while this
+;;;; benchmark executed, both in user and kernel space.
+;;;;
+;;;; benchmark-result:gc-time : Return the approximate amount of time
+;;;; spent in garbage collection while this benchmark executed, both
+;;;; in user and kernel space.
+;;;;
+;;;; benchmark-result:core-time : Like benchmark-result:run-time, but
+;;;; also estimates the time spent by the framework for the number
+;;;; of iterations, and subtracts off that time from the result.
+;;;;
+
+;;;; This module is used when benchmarking different Guiles, and so it
+;;;; should run on all the Guiles of interest. Currently this set
+;;;; includes Guile 1.8, so be careful with introducing features that
+;;;; only Guile 2.0 supports.
;;;; MISCELLANEOUS
;;;;
+(define-record-type <benchmark-result>
+ (make-benchmark-result name iterations real-time run-time gc-time)
+ benchmark-result?
+ (name benchmark-result:name)
+ (iterations benchmark-result:iterations)
+ (real-time benchmark-result:real-time)
+ (run-time benchmark-result:run-time)
+ (gc-time benchmark-result:gc-time))
+
;;; Perform a division and convert the result to inexact.
-(define (i/ a b)
- (exact->inexact (/ a b)))
+(define (->seconds time)
+ (/ time 1.0 internal-time-units-per-second))
;;; Scale the number of iterations according to the given scaling factor.
(define iteration-factor 1)
@@ -296,36 +288,49 @@
(let* ((i (inexact->exact (round (* iterations iteration-factor)))))
(if (< i 1) 1 i)))
+;;; Parameters.
+(cond-expand
+ (srfi-39 #t)
+ (else (use-modules (srfi srfi-39))))
;;;; CORE FUNCTIONS
;;;;
;;; The central routine for executing benchmarks.
;;; The idea is taken from Greg, the GNUstep regression test environment.
-(define run-benchmark #f)
-(let ((benchmark-running #f))
- (define (local-run-benchmark name iterations thunk)
- (if benchmark-running
- (error "Nested calls to run-benchmark are not permitted.")
- (let ((benchmark-name (full-name name))
- (iterations (scale-iterations iterations)))
- (set! benchmark-running #t)
- (let ((before #f) (after #f) (gc-time #f))
- (gc)
- (set! gc-time (gc-run-time))
- (set! before (times))
- (do ((i 0 (+ i 1)))
- ((= i iterations))
- (thunk))
- (set! after (times))
- (set! gc-time (- (gc-run-time) gc-time))
- (report benchmark-name iterations before after gc-time))
- (set! benchmark-running #f))))
- (set! run-benchmark local-run-benchmark))
+(define benchmark-running? (make-parameter #f))
+(define (run-benchmark name iterations thunk)
+ (if (benchmark-running?)
+ (error "Nested calls to run-benchmark are not permitted."))
+ (if (not (and (integer? iterations) (exact? iterations)))
+ (error "Expected exact integral number of iterations"))
+ (parameterize ((benchmark-running? #t))
+ ;; Warm up the benchmark first. This will resolve any toplevel-ref
+ ;; forms.
+ (thunk)
+ (gc)
+ (let* ((before-gc-time (gc-run-time))
+ (before-real-time (get-internal-real-time))
+ (before-run-time (get-internal-run-time)))
+ (do ((i iterations (1- i)))
+ ((zero? i))
+ (thunk))
+ (let ((after-run-time (get-internal-run-time))
+ (after-real-time (get-internal-real-time))
+ (after-gc-time (gc-run-time)))
+ (report (make-benchmark-result (full-name name) iterations
+ (- after-real-time before-real-time)
+ (- after-run-time before-run-time)
+ (- after-gc-time before-gc-time)))))))
;;; A short form for benchmarks.
-(defmacro benchmark (name iterations body . rest)
- `(run-benchmark ,name ,iterations (lambda () ,body ,@rest)))
+(cond-expand
+ (guile-2
+ (define-syntax-rule (benchmark name iterations body body* ...)
+ (run-benchmark name iterations (lambda () body body* ...))))
+ (else
+ (defmacro benchmark (name iterations body . rest)
+ `(run-benchmark ,name ,iterations (lambda () ,body ,@rest)))))
;;;; BENCHMARK NAMES
@@ -333,31 +338,21 @@
;;;; Turn a benchmark name into a nice human-readable string.
(define (format-benchmark-name name)
- (call-with-output-string
- (lambda (port)
- (let loop ((name name)
- (separator ""))
- (if (pair? name)
- (begin
- (display separator port)
- (display (car name) port)
- (loop (cdr name) ": ")))))))
+ (string-join name ": "))
;;;; For a given benchmark-name, deliver the full name including all prefixes.
(define (full-name name)
(append (current-benchmark-prefix) (list name)))
-;;; A fluid containing the current benchmark prefix, as a list.
-(define prefix-fluid (make-fluid '()))
-(define (current-benchmark-prefix)
- (fluid-ref prefix-fluid))
+;;; A parameter containing the current benchmark prefix, as a list.
+(define current-benchmark-prefix
+ (make-parameter '()))
;;; Postpend PREFIX to the current name prefix while evaluting THUNK.
;;; The name prefix is only changed within the dynamic scope of the
;;; call to with-benchmark-prefix*. Return the value returned by THUNK.
(define (with-benchmark-prefix* prefix thunk)
- (with-fluids ((prefix-fluid
- (append (fluid-ref prefix-fluid) (list prefix))))
+ (parameterize ((current-benchmark-prefix (full-name prefix)))
(thunk)))
;;; (with-benchmark-prefix PREFIX BODY ...)
@@ -365,77 +360,58 @@
;;; The name prefix is only changed within the dynamic scope of the
;;; with-benchmark-prefix expression. Return the value returned by the last
;;; BODY expression.
-(defmacro with-benchmark-prefix (prefix . body)
- `(with-benchmark-prefix* ,prefix (lambda () ,@body)))
+(cond-expand
+ (guile-2
+ (define-syntax-rule (with-benchmark-prefix prefix body body* ...)
+ (with-benchmark-prefix* prefix (lambda () body body* ...))))
+ (else
+ (defmacro with-benchmark-prefix (prefix . body)
+ `(with-benchmark-prefix* ,prefix (lambda () ,@body)))))
-;;;; TIME CALCULATION
+;;;; Benchmark results
;;;;
-(define benchmark-time-base
- internal-time-units-per-second)
-
-(define time-base ;; short-cut, not exported
- benchmark-time-base)
-
-(define frame-time/iteration
+(define *calibration-result*
"<will be set during initialization>")
-(define (benchmark-total-time before after)
- (- (tms:clock after) (tms:clock before)))
-
-(define (benchmark-user-time before after)
- (- (tms:utime after) (tms:utime before)))
+(define (benchmark-overhead iterations accessor)
+ (* (/ iterations 1.0 (benchmark-result:iterations *calibration-result*))
+ (accessor *calibration-result*)))
-(define (benchmark-system-time before after)
- (- (tms:stime after) (tms:stime before)))
-
-(define (benchmark-frame-time iterations)
- (* iterations frame-time/iteration))
-
-(define (benchmark-core-time iterations before after)
- (- (benchmark-user-time before after) (benchmark-frame-time iterations)))
-
-(define (benchmark-user-time\interpreter before after gc-time)
- (- (benchmark-user-time before after) gc-time))
-
-(define (benchmark-core-time\interpreter iterations before after gc-time)
- (- (benchmark-core-time iterations before after) gc-time))
+(define (benchmark-result:core-time result)
+ (- (benchmark-result:run-time result)
+ (benchmark-overhead (benchmark-result:iterations result)
+ benchmark-result:run-time)))
;;;; REPORTERS
;;;;
-;;; The global list of reporters.
-(define reporters '())
+;;; The global set of reporters.
+(define report-hook (make-hook 1))
+
+(define (default-reporter result)
+ (if (hook-empty? report-hook)
+ (user-reporter result)
+ (run-hook report-hook result)))
-;;; The default reporter, to be used only if no others exist.
-(define default-reporter #f)
+(define current-reporter
+ (make-parameter default-reporter))
-;;; Add the procedure REPORTER to the current set of reporter functions.
-;;; Signal an error if that reporter procedure object is already registered.
(define (register-reporter reporter)
- (if (memq reporter reporters)
- (error "register-reporter: reporter already registered: " reporter))
- (set! reporters (cons reporter reporters)))
+ (add-hook! report-hook reporter))
-;;; Remove the procedure REPORTER from the current set of reporter
-;;; functions. Signal an error if REPORTER is not currently registered.
(define (unregister-reporter reporter)
- (if (memq reporter reporters)
- (set! reporters (delq! reporter reporters))
- (error "unregister-reporter: reporter not registered: " reporter)))
+ (remove-hook! report-hook reporter))
;;; Return true iff REPORTER is in the current set of reporter functions.
(define (reporter-registered? reporter)
- (if (memq reporter reporters) #t #f))
+ (if (memq reporter (hook->list report-hook)) #t #f))
;;; Send RESULT to all currently registered reporter functions.
-(define (report . args)
- (if (pair? reporters)
- (for-each (lambda (reporter) (apply reporter args))
- reporters)
- (apply default-reporter args)))
+(define (report result)
+ ((current-reporter) result))
;;;; Some useful standard reporters:
@@ -444,26 +420,22 @@
;;;; User reporters write some interesting results to the standard output.
;;; Display a single benchmark result to the given port
-(define (print-result port name iterations before after gc-time)
- (let* ((name (format-benchmark-name name))
- (total-time (benchmark-total-time before after))
- (user-time (benchmark-user-time before after))
- (system-time (benchmark-system-time before after))
- (frame-time (benchmark-frame-time iterations))
- (benchmark-time (benchmark-core-time iterations before after))
- (user-time\interpreter
- (benchmark-user-time\interpreter before after gc-time))
- (benchmark-core-time\interpreter
- (benchmark-core-time\interpreter iterations before after gc-time)))
+(define (print-result port result)
+ (let ((name (format-benchmark-name (benchmark-result:name result)))
+ (iterations (benchmark-result:iterations result))
+ (real-time (benchmark-result:real-time result))
+ (run-time (benchmark-result:run-time result))
+ (gc-time (benchmark-result:gc-time result))
+ (core-time (benchmark-result:core-time result)))
(write (list name iterations
- 'total (i/ total-time time-base)
- 'user (i/ user-time time-base)
- 'system (i/ system-time time-base)
- 'frame (i/ frame-time time-base)
- 'benchmark (i/ benchmark-time time-base)
- 'user/interp (i/ user-time\interpreter time-base)
- 'bench/interp (i/ benchmark-core-time\interpreter time-base)
- 'gc (i/ gc-time time-base))
+ 'total (->seconds real-time)
+ 'user (->seconds run-time)
+ 'system 0
+ 'frame (->seconds (- run-time core-time))
+ 'benchmark (->seconds core-time)
+ 'user/interp (->seconds (- run-time gc-time))
+ 'bench/interp (->seconds (- core-time gc-time))
+ 'gc (->seconds gc-time))
port)
(newline port)))
@@ -472,58 +444,50 @@
(define (make-log-reporter file)
(let ((port (if (output-port? file) file
(open-output-file file))))
- (lambda args
- (apply print-result port args)
+ (lambda (result)
+ (print-result port result)
(force-output port))))
;;; A reporter that reports all results to the user.
-(define (full-reporter . args)
- (apply print-result (current-output-port) args))
+(define (full-reporter result)
+ (print-result (current-output-port) result))
;;; Display interesting results of a single benchmark to the given port
-(define (print-user-result port name iterations before after gc-time)
- (let* ((name (format-benchmark-name name))
- (user-time (benchmark-user-time before after))
- (benchmark-time (benchmark-core-time iterations before after))
- (benchmark-core-time\interpreter
- (benchmark-core-time\interpreter iterations before after gc-time)))
- (write (list name iterations
- 'user (i/ user-time time-base)
- 'benchmark (i/ benchmark-time time-base)
- 'bench/interp (i/ benchmark-core-time\interpreter time-base)
- 'gc (i/ gc-time time-base))
+(define (print-user-result port result)
+ (let ((name (format-benchmark-name (benchmark-result:name result)))
+ (iterations (benchmark-result:iterations result))
+ (real-time (benchmark-result:real-time result))
+ (run-time (benchmark-result:run-time result))
+ (gc-time (benchmark-result:gc-time result))
+ (core-time (benchmark-result:core-time result)))
+ (write (list name iterations
+ 'real (->seconds real-time)
+ 'real/iteration (->seconds (/ real-time iterations))
+ 'run/iteration (->seconds (/ run-time iterations))
+ 'core/iteration (->seconds (/ core-time iterations))
+ 'gc (->seconds gc-time))
port)
(newline port)))
;;; A reporter that reports interesting results to the user.
-(define (user-reporter . args)
- (apply print-user-result (current-output-port) args))
+(define (user-reporter result)
+ (print-user-result (current-output-port) result))
;;;; Initialize the benchmarking system:
;;;;
-;;; First, display version information
-(display ";; running guile version " (current-output-port))
-(display (version) (current-output-port))
-(newline (current-output-port))
-
-;;; Second, make sure the benchmarking routines are compiled.
-(define (null-reporter . args) #t)
-(set! default-reporter null-reporter)
-(benchmark "empty initialization benchmark" 2 #t)
-
-;;; Third, initialize the system constants
-(display ";; calibrating the benchmarking framework..." (current-output-port))
-(newline (current-output-port))
-(define (initialization-reporter name iterations before after gc-time)
- (let* ((frame-time (- (tms:utime after) (tms:utime before) gc-time 3)))
- (set! frame-time/iteration (/ frame-time iterations))
- (display ";; framework time per iteration: " (current-output-port))
- (display (i/ frame-time/iteration time-base) (current-output-port))
- (newline (current-output-port))))
-(set! default-reporter initialization-reporter)
-(benchmark "empty initialization benchmark" 524288 #t)
-
-;;; Finally, set the default reporter
-(set! default-reporter user-reporter)
+(define (calibrate-benchmark-framework)
+ (display ";; running guile version ")
+ (display (version))
+ (newline)
+ (display ";; calibrating the benchmarking framework...")
+ (newline)
+ (parameterize ((current-reporter
+ (lambda (result)
+ (set! *calibration-result* result)
+ (display ";; calibration: ")
+ (print-user-result (current-output-port) result))))
+ (benchmark "empty initialization benchmark" 10000000 #t)))
+
+(calibrate-benchmark-framework)
diff --git a/benchmark-suite/benchmarks/arithmetic.bm
b/benchmark-suite/benchmarks/arithmetic.bm
index c64f6c2..e0a9bf3 100644
--- a/benchmark-suite/benchmarks/arithmetic.bm
+++ b/benchmark-suite/benchmarks/arithmetic.bm
@@ -1,7 +1,7 @@
;;; -*- mode: scheme; coding: utf-8; -*-
;;; Integer arithmetic.
;;;
-;;; Copyright 2010 Free Software Foundation, Inc.
+;;; Copyright 2010, 2012 Free Software Foundation, Inc.
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public License
@@ -48,20 +48,20 @@
(with-benchmark-prefix "fixnum"
- (benchmark "1+" 1e7
+ (benchmark "1+" #e1e7
(repeat (1+ <>) 2 100))
- (benchmark "1-" 1e7
+ (benchmark "1-" #e1e7
(repeat (1- <>) 2 100))
- (benchmark "+" 1e7
+ (benchmark "+" #e1e7
(repeat (+ 2 <>) 7 100))
- (benchmark "-" 1e7
+ (benchmark "-" #e1e7
(repeat (- 2 <>) 7 100))
- (benchmark "*" 1e7
+ (benchmark "*" #e1e7
(repeat (* 1 <>) 1 100))
- (benchmark "/" 1e7
+ (benchmark "/" #e1e7
(repeat (/ 2 <>) 1 100)))
diff --git a/benchmark-suite/benchmarks/r6rs-arithmetic.bm
b/benchmark-suite/benchmarks/r6rs-arithmetic.bm
index 4c9b8e6..309f066 100644
--- a/benchmark-suite/benchmarks/r6rs-arithmetic.bm
+++ b/benchmark-suite/benchmarks/r6rs-arithmetic.bm
@@ -1,7 +1,7 @@
;;; -*- mode: scheme; coding: utf-8; -*-
;;; R6RS-specific arithmetic benchmarks
;;;
-;;; Copyright (C) 2011 Free Software Foundation, Inc.
+;;; Copyright (C) 2011, 2012 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
@@ -24,12 +24,12 @@
(with-benchmark-prefix "fixnum"
- (benchmark "fixnum? [yes]" 1e7
+ (benchmark "fixnum? [yes]" #e1e7
(fixnum? 10000))
(let ((n (+ most-positive-fixnum 100)))
- (benchmark "fixnum? [no]" 1e7
+ (benchmark "fixnum? [no]" #e1e7
(fixnum? n)))
- (benchmark "fxxor [2]" 1e7
+ (benchmark "fxxor [2]" #e1e7
(fxxor 3 8)))
diff --git a/check-guile.in b/check-guile.in
index 995199d..214deec 100644
--- a/check-guile.in
+++ b/check-guile.in
@@ -43,6 +43,7 @@ fi
exec $guile \
--debug \
+ -L "$TEST_SUITE_DIR" \
--no-auto-compile -e main -s "$TEST_SUITE_DIR/guile-test" \
--test-suite "$TEST_SUITE_DIR/tests" \
--log-file check-guile.log "$@"
diff --git a/doc/ref/api-utility.texi b/doc/ref/api-utility.texi
index 9ab1eee..17694ec 100644
--- a/doc/ref/api-utility.texi
+++ b/doc/ref/api-utility.texi
@@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2011
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2011,
2012
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -308,9 +308,10 @@ input.
@deffn {Scheme Procedure} sorted? items less
@deffnx {C Function} scm_sorted_p (items, less)
-Return @code{#t} iff @var{items} is a list or a vector such that
-for all 1 <= i <= m, the predicate @var{less} returns true when
-applied to all elements i - 1 and i
+Return @code{#t} iff @var{items} is a list or vector such that,
+for each element @var{x} and the next element @var{y} of
address@hidden, @code{(@var{less} @var{y} @var{x})} returns
address@hidden
@end deffn
@deffn {Scheme Procedure} sort items less
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index 6d2da66..68d503e 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -455,7 +455,6 @@ install-exec-hook:
## Perhaps we can deal with them normally once the merge seems to be
## working.
noinst_HEADERS = conv-integer.i.c conv-uinteger.i.c \
- ieee-754.h \
srfi-14.i.c \
quicksort.i.c \
win32-uname.h win32-socket.h \
diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c
index 668c46d..db132d4 100644
--- a/libguile/bytevectors.c
+++ b/libguile/bytevectors.c
@@ -31,7 +31,6 @@
#include "libguile/bytevectors.h"
#include "libguile/strings.h"
#include "libguile/validate.h"
-#include "libguile/ieee-754.h"
#include "libguile/arrays.h"
#include "libguile/array-handle.h"
#include "libguile/uniform.h"
@@ -1584,6 +1583,18 @@ SCM_DEFINE (scm_bytevector_s64_native_set_x,
"bytevector-s64-native-set!",
Section 2.1 of R6RS-lib (in response to
http://www.r6rs.org/formal-comments/comment-187.txt). */
+union scm_ieee754_float
+{
+ float f;
+ scm_t_uint32 i;
+};
+
+union scm_ieee754_double
+{
+ double d;
+ scm_t_uint64 i;
+};
+
/* Convert to/from a floating-point number with different endianness. This
method is probably not the most efficient but it should be portable. */
@@ -1592,20 +1603,10 @@ static inline void
float_to_foreign_endianness (union scm_ieee754_float *target,
float source)
{
- union scm_ieee754_float src;
-
- src.f = source;
+ union scm_ieee754_float input;
-#ifdef WORDS_BIGENDIAN
- /* Assuming little endian for both byte and word order. */
- target->little_endian.negative = src.big_endian.negative;
- target->little_endian.exponent = src.big_endian.exponent;
- target->little_endian.mantissa = src.big_endian.mantissa;
-#else
- target->big_endian.negative = src.little_endian.negative;
- target->big_endian.exponent = src.little_endian.exponent;
- target->big_endian.mantissa = src.little_endian.mantissa;
-#endif
+ input.f = source;
+ target->i = bswap_32 (input.i);
}
static inline float
@@ -1613,16 +1614,7 @@ float_from_foreign_endianness (const union
scm_ieee754_float *source)
{
union scm_ieee754_float result;
-#ifdef WORDS_BIGENDIAN
- /* Assuming little endian for both byte and word order. */
- result.big_endian.negative = source->little_endian.negative;
- result.big_endian.exponent = source->little_endian.exponent;
- result.big_endian.mantissa = source->little_endian.mantissa;
-#else
- result.little_endian.negative = source->big_endian.negative;
- result.little_endian.exponent = source->big_endian.exponent;
- result.little_endian.mantissa = source->big_endian.mantissa;
-#endif
+ result.i = bswap_32 (source->i);
return (result.f);
}
@@ -1631,22 +1623,10 @@ static inline void
double_to_foreign_endianness (union scm_ieee754_double *target,
double source)
{
- union scm_ieee754_double src;
+ union scm_ieee754_double input;
- src.d = source;
-
-#ifdef WORDS_BIGENDIAN
- /* Assuming little endian for both byte and word order. */
- target->little_little_endian.negative = src.big_endian.negative;
- target->little_little_endian.exponent = src.big_endian.exponent;
- target->little_little_endian.mantissa0 = src.big_endian.mantissa0;
- target->little_little_endian.mantissa1 = src.big_endian.mantissa1;
-#else
- target->big_endian.negative = src.little_little_endian.negative;
- target->big_endian.exponent = src.little_little_endian.exponent;
- target->big_endian.mantissa0 = src.little_little_endian.mantissa0;
- target->big_endian.mantissa1 = src.little_little_endian.mantissa1;
-#endif
+ input.d = source;
+ target->i = bswap_64 (input.i);
}
static inline double
@@ -1654,18 +1634,7 @@ double_from_foreign_endianness (const union
scm_ieee754_double *source)
{
union scm_ieee754_double result;
-#ifdef WORDS_BIGENDIAN
- /* Assuming little endian for both byte and word order. */
- result.big_endian.negative = source->little_little_endian.negative;
- result.big_endian.exponent = source->little_little_endian.exponent;
- result.big_endian.mantissa0 = source->little_little_endian.mantissa0;
- result.big_endian.mantissa1 = source->little_little_endian.mantissa1;
-#else
- result.little_little_endian.negative = source->big_endian.negative;
- result.little_little_endian.exponent = source->big_endian.exponent;
- result.little_little_endian.mantissa0 = source->big_endian.mantissa0;
- result.little_little_endian.mantissa1 = source->big_endian.mantissa1;
-#endif
+ result.i = bswap_64 (source->i);
return (result.d);
}
diff --git a/libguile/ieee-754.h b/libguile/ieee-754.h
deleted file mode 100644
index e345efa..0000000
--- a/libguile/ieee-754.h
+++ /dev/null
@@ -1,90 +0,0 @@
-/* Copyright (C) 1992, 1995, 1996, 1999 Free Software Foundation, Inc.
- This file is part of the GNU C Library.
-
- The GNU C 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 2.1 of the License, or (at your option) any later version.
-
- The GNU C 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 the GNU C Library; if not, write to the Free
- Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
- 02111-1307 USA. */
-
-#ifndef SCM_IEEE_754_H
-#define SCM_IEEE_754_H 1
-
-/* Based on glibc's <ieee754.h> and modified by Ludovic Courtès to include
- all possible IEEE-754 double-precision representations. */
-
-
-/* IEEE 754 simple-precision format (32-bit). */
-
-union scm_ieee754_float
- {
- float f;
-
- struct
- {
- unsigned int negative:1;
- unsigned int exponent:8;
- unsigned int mantissa:23;
- } big_endian;
-
- struct
- {
- unsigned int mantissa:23;
- unsigned int exponent:8;
- unsigned int negative:1;
- } little_endian;
- };
-
-
-
-/* IEEE 754 double-precision format (64-bit). */
-
-union scm_ieee754_double
- {
- double d;
-
- struct
- {
- /* Big endian. */
-
- unsigned int negative:1;
- unsigned int exponent:11;
- /* Together these comprise the mantissa. */
- unsigned int mantissa0:20;
- unsigned int mantissa1:32;
- } big_endian;
-
- struct
- {
- /* Both byte order and word order are little endian. */
-
- /* Together these comprise the mantissa. */
- unsigned int mantissa1:32;
- unsigned int mantissa0:20;
- unsigned int exponent:11;
- unsigned int negative:1;
- } little_little_endian;
-
- struct
- {
- /* Byte order is little endian but word order is big endian. Not
- sure this is very wide spread. */
- unsigned int mantissa0:20;
- unsigned int exponent:11;
- unsigned int negative:1;
- unsigned int mantissa1:32;
- } little_big_endian;
-
- };
-
-
-#endif /* SCM_IEEE_754_H */
diff --git a/libguile/sort.c b/libguile/sort.c
index ecadd82..2a36320 100644
--- a/libguile/sort.c
+++ b/libguile/sort.c
@@ -1,4 +1,6 @@
-/* Copyright (C) 1999,2000,2001,2002, 2004, 2006, 2007, 2008, 2009, 2010, 2011
Free Software Foundation, Inc.
+/* Copyright (C) 1999, 2000, 2001, 2002, 2004, 2006, 2007, 2008, 2009,
+ * 2010, 2011, 2012 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
@@ -101,9 +103,10 @@ SCM_DEFINE (scm_restricted_vector_sort_x,
"restricted-vector-sort!", 4, 0, 0,
* (not (less? (list-ref list i) (list-ref list (- i 1)))). */
SCM_DEFINE (scm_sorted_p, "sorted?", 2, 0, 0,
(SCM items, SCM less),
- "Return @code{#t} iff @var{items} is a list or a vector such that\n"
- "for all 1 <= i <= m, the predicate @var{less} returns true when\n"
- "applied to all elements i - 1 and i")
+ "Return @code{#t} iff @var{items} is a list or vector such that, "
+ "for each element @var{x} and the next element @var{y} of "
+ "@var{items}, @code{(@var{less} @var{y} @var{x})} returns "
+ "@code{#f}.")
#define FUNC_NAME s_scm_sorted_p
{
long len, j; /* list/vector length, temp j */
diff --git a/libguile/strings.c b/libguile/strings.c
index c84c830..bc715e0 100644
--- a/libguile/strings.c
+++ b/libguile/strings.c
@@ -1949,6 +1949,52 @@ latin1_to_u8 (const scm_t_uint8 *str, size_t latin_len,
return u8_result;
}
+/* UTF-8 code table
+
+ (Note that this includes code points that are not allowed by Unicode,
+ but since this function has no way to report an error, and its
+ purpose is to determine the size of destination buffers for
+ libunicode conversion functions, we err on the safe side and handle
+ everything that libunicode might conceivably handle, now or in the
+ future.)
+
+ Char. number range | UTF-8 octet sequence
+ (hexadecimal) | (binary)
+ --------------------+------------------------------------------------------
+ 0000 0000-0000 007F | 0xxxxxxx
+ 0000 0080-0000 07FF | 110xxxxx 10xxxxxx
+ 0000 0800-0000 FFFF | 1110xxxx 10xxxxxx 10xxxxxx
+ 0001 0000-001F FFFF | 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx
+ 0020 0000-03FF FFFF | 111110xx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
+ 0400 0000-7FFF FFFF | 1111110x 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
+*/
+
+static size_t
+u32_u8_length_in_bytes (const scm_t_uint32 *str, size_t len)
+{
+ size_t ret, i;
+
+ for (i = 0, ret = 0; i < len; i++)
+ {
+ scm_t_uint32 c = str[i];
+
+ if (c <= 0x7f)
+ ret += 1;
+ else if (c <= 0x7ff)
+ ret += 2;
+ else if (c <= 0xffff)
+ ret += 3;
+ else if (c <= 0x1fffff)
+ ret += 4;
+ else if (c <= 0x3ffffff)
+ ret += 5;
+ else
+ ret += 6;
+ }
+
+ return ret;
+}
+
char *
scm_to_utf8_stringn (SCM str, size_t *lenp)
{
@@ -1957,9 +2003,46 @@ scm_to_utf8_stringn (SCM str, size_t *lenp)
scm_i_string_length (str),
NULL, lenp);
else
- return (char *) u32_to_u8 ((scm_t_uint32*)scm_i_string_wide_chars (str),
- scm_i_string_length (str),
- NULL, lenp);
+ {
+ scm_t_uint32 *chars = (scm_t_uint32 *) scm_i_string_wide_chars (str);
+ scm_t_uint8 *buf, *ret;
+ size_t num_chars = scm_i_string_length (str);
+ size_t num_bytes_predicted, num_bytes_actual;
+
+ num_bytes_predicted = u32_u8_length_in_bytes (chars, num_chars);
+
+ if (lenp)
+ {
+ *lenp = num_bytes_predicted;
+ buf = scm_malloc (num_bytes_predicted);
+ }
+ else
+ {
+ buf = scm_malloc (num_bytes_predicted + 1);
+ buf[num_bytes_predicted] = 0;
+ }
+
+ num_bytes_actual = num_bytes_predicted;
+ ret = u32_to_u8 (chars, num_chars, buf, &num_bytes_actual);
+
+ if (SCM_LIKELY (ret == buf && num_bytes_actual == num_bytes_predicted))
+ return (char *) ret;
+
+ /* An error: a bad codepoint. */
+ {
+ int saved_errno = errno;
+
+ free (buf);
+ if (!saved_errno)
+ abort ();
+
+ scm_decoding_error ("scm_to_utf8_stringn", errno,
+ "invalid codepoint in string", str);
+
+ /* Not reached. */
+ return NULL;
+ }
+ }
}
scm_t_wchar *
diff --git a/meta/uninstalled-env.in b/meta/uninstalled-env.in
index 5fa0db0..567c6e2 100644
--- a/meta/uninstalled-env.in
+++ b/meta/uninstalled-env.in
@@ -1,6 +1,6 @@
#!/bin/sh
-# Copyright (C) 2003, 2006, 2008, 2009, 2010, 2011 Free Software
Foundation
+# Copyright (C) 2003, 2006, 2008, 2009, 2010, 2011, 2012 Free Software
Foundation
#
# This file is part of GUILE.
#
@@ -57,12 +57,12 @@ if test "@cross_compiling@" = "no"
then
if [ x"$GUILE_LOAD_PATH" = x ]
then
-
GUILE_LOAD_PATH="${top_srcdir}/module:${top_srcdir}/guile-readline:${top_srcdir}"
+ GUILE_LOAD_PATH="${top_srcdir}/module:${top_srcdir}/guile-readline"
if test "${top_srcdir}" != "${top_builddir}"; then
-
GUILE_LOAD_PATH="$GUILE_LOAD_PATH:${top_builddir}/module:${top_builddir}/guile-readline:${top_builddir}"
+
GUILE_LOAD_PATH="$GUILE_LOAD_PATH:${top_builddir}/module:${top_builddir}/guile-readline"
fi
else
- for d in "/module" "/guile-readline" ""
+ for d in "/module" "/guile-readline"
do
# This hair prevents double inclusion.
# The ":" prevents prefix aliasing.
@@ -82,9 +82,9 @@ then
if test "x$GUILE_LOAD_COMPILED_PATH" = "x"
then
-
GUILE_LOAD_COMPILED_PATH="${top_builddir}/module:${top_builddir}/guile-readline:${top_builddir}"
+
GUILE_LOAD_COMPILED_PATH="${top_builddir}/module:${top_builddir}/guile-readline"
else
- for d in "/module" "/guile-readline" ""
+ for d in "/module" "/guile-readline"
do
# This hair prevents double inclusion.
# The ":" prevents prefix aliasing.
diff --git a/module/Makefile.am b/module/Makefile.am
index e161b9c..486cbe7 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -96,12 +96,14 @@ SCHEME_LANG_SOURCES =
\
TREE_IL_LANG_SOURCES = \
language/tree-il/primitives.scm \
language/tree-il/peval.scm \
+ language/tree-il/effects.scm \
language/tree-il/fix-letrec.scm \
language/tree-il/optimize.scm \
language/tree-il/canonicalize.scm \
language/tree-il/analyze.scm \
language/tree-il/inline.scm \
language/tree-il/compile-glil.scm \
+ language/tree-il/cse.scm \
language/tree-il/debug.scm \
language/tree-il/spec.scm
diff --git a/module/ice-9/vlist.scm b/module/ice-9/vlist.scm
index 0ed4b6d..a09b374 100644
--- a/module/ice-9/vlist.scm
+++ b/module/ice-9/vlist.scm
@@ -69,26 +69,19 @@
(define block-growth-factor
(make-fluid 2))
-(define-syntax-rule (define-inline (name formals ...) body ...)
- ;; Work around the lack of an inliner.
- (define-syntax name
- (syntax-rules ()
- ((_ formals ...)
- (begin body ...)))))
-
-(define-inline (make-block base offset size hash-tab?)
- ;; Return a block (and block descriptor) of SIZE elements pointing to BASE
- ;; at OFFSET. If HASH-TAB? is true, a "hash table" is also added.
- ;; Note: We use `next-free' instead of `last-used' as suggested by Bagwell.
-
- ;; XXX: We could improve locality here by having a single vector but
currently
- ;; the extra arithmetic outweighs the benefits (!).
- (vector (make-vector size)
- base offset size 0
- (and hash-tab? (make-vector size #f))))
+(define-inlinable (make-block base offset size hash-tab?)
+ ;; Return a block (and block descriptor) of SIZE elements pointing to
+ ;; BASE at OFFSET. If HASH-TAB? is true, we also reserve space for a
+ ;; "hash table". Note: We use `next-free' instead of `last-used' as
+ ;; suggested by Bagwell.
+ (if hash-tab?
+ (vector (make-vector (* size 3) #f)
+ base offset size 0)
+ (vector (make-vector size)
+ base offset size 0)))
(define-syntax-rule (define-block-accessor name index)
- (define-inline (name block)
+ (define-inlinable (name block)
(vector-ref block index)))
(define-block-accessor block-content 0)
@@ -96,33 +89,51 @@
(define-block-accessor block-offset 2)
(define-block-accessor block-size 3)
(define-block-accessor block-next-free 4)
-(define-block-accessor block-hash-table 5)
-(define-inline (increment-block-next-free! block)
- (vector-set! block 4
- (+ (block-next-free block) 1)))
+(define-inlinable (block-hash-table? block)
+ (< (block-size block) (vector-length (block-content block))))
-(define-inline (block-append! block value)
- ;; This is not thread-safe. To fix it, see Section 2.8 of the paper.
- (let ((offset (block-next-free block)))
- (increment-block-next-free! block)
- (vector-set! (block-content block) offset value)
- #t))
-
-(define-inline (block-ref block offset)
- (vector-ref (block-content block) offset))
-
-(define-inline (block-ref* block offset)
- (let ((v (block-ref block offset)))
- (if (block-hash-table block)
- (car v) ;; hide the vhash link
- v)))
-
-(define-inline (block-hash-table-ref block offset)
- (vector-ref (block-hash-table block) offset))
+(define-inlinable (set-block-next-free! block next-free)
+ (vector-set! block 4 next-free))
-(define-inline (block-hash-table-set! block offset value)
- (vector-set! (block-hash-table block) offset value))
+(define-inlinable (block-append! block value offset)
+ ;; This is not thread-safe. To fix it, see Section 2.8 of the paper.
+ (and (< offset (block-size block))
+ (= offset (block-next-free block))
+ (begin
+ (set-block-next-free! block (1+ offset))
+ (vector-set! (block-content block) offset value)
+ #t)))
+
+;; Return the item at slot OFFSET.
+(define-inlinable (block-ref content offset)
+ (vector-ref content offset))
+
+;; Return the offset of the next item in the hash bucket, after the one
+;; at OFFSET.
+(define-inlinable (block-hash-table-next-offset content size offset)
+ (vector-ref content (+ size size offset)))
+
+;; Save the offset of the next item in the hash bucket, after the one
+;; at OFFSET.
+(define-inlinable (block-hash-table-set-next-offset! content size offset
+ next-offset)
+ (vector-set! content (+ size size offset) next-offset))
+
+;; Returns the index of the last entry stored in CONTENT with
+;; SIZE-modulo hash value KHASH.
+(define-inlinable (block-hash-table-ref content size khash)
+ (vector-ref content (+ size khash)))
+
+(define-inlinable (block-hash-table-set! content size khash offset)
+ (vector-set! content (+ size khash) offset))
+
+;; Add hash table information for the item recently added at OFFSET,
+;; with SIZE-modulo hash KHASH.
+(define-inlinable (block-hash-table-add! content size khash offset)
+ (block-hash-table-set-next-offset! content size offset
+ (block-hash-table-ref content size khash))
+ (block-hash-table-set! content size khash offset))
(define block-null
;; The null block.
@@ -149,13 +160,10 @@
(lambda (vl port)
(cond ((vlist-null? vl)
(format port "#<vlist ()>"))
- ((block-hash-table (vlist-base vl))
+ ((vhash? vl)
(format port "#<vhash ~x ~a pairs>"
(object-address vl)
- (vhash-fold (lambda (k v r)
- (+ 1 r))
- 0
- vl)))
+ (vlist-length vl)))
(else
(format port "#<vlist ~a>"
(vlist->list vl))))))
@@ -165,42 +173,61 @@
;; The empty vlist.
(make-vlist block-null 0))
-(define-inline (block-cons item vlist hash-tab?)
- (let loop ((base (vlist-base vlist))
- (offset (+ 1 (vlist-offset vlist))))
- (if (and (< offset (block-size base))
- (= offset (block-next-free base))
- (block-append! base item))
- (make-vlist base offset)
- (let ((size (cond ((eq? base block-null) 1)
- ((< offset (block-size base))
- ;; new vlist head
- 1)
- (else
- (* (fluid-ref block-growth-factor)
- (block-size base))))))
- ;; Prepend a new block pointing to BASE.
- (loop (make-block base (- offset 1) size hash-tab?)
- 0)))))
+;; Asserting that something is a vlist is actually a win if your next
+;; step is to call record accessors, because that causes CSE to
+;; eliminate the type checks in those accessors.
+;;
+(define-inlinable (assert-vlist val)
+ (unless (vlist? val)
+ (throw 'wrong-type-arg
+ #f
+ "Not a vlist: ~S"
+ (list val)
+ (list val))))
+
+(define-inlinable (block-cons item vlist hash-tab?)
+ (let ((base (vlist-base vlist))
+ (offset (1+ (vlist-offset vlist))))
+ (cond
+ ((block-append! base item offset)
+ ;; Fast path: We added the item directly to the block.
+ (make-vlist base offset))
+ (else
+ ;; Slow path: Allocate a new block.
+ (let* ((size (block-size base))
+ (base (make-block
+ base
+ (1- offset)
+ (cond
+ ((zero? size) 1)
+ ((< offset size) 1) ;; new vlist head
+ (else (* (fluid-ref block-growth-factor) size)))
+ hash-tab?)))
+ (set-block-next-free! base 1)
+ (vector-set! (block-content base) 0 item)
+ (make-vlist base 0))))))
(define (vlist-cons item vlist)
"Return a new vlist with @var{item} as its head and @var{vlist} as its
tail."
- ;; Note: Calling `vlist-cons' on a vhash will not do the right thing: it
- ;; doesn't box ITEM so that it can have the hidden "next" link used by
- ;; vhash items, and it passes `#f' as the HASH-TAB? argument to
- ;; `block-cons'. However, inserting all the checks here has an important
- ;; performance penalty, hence this choice.
+ ;; Note: Although the result of `vlist-cons' on a vhash is a valid
+ ;; vlist, it is not a valid vhash. The new item does not get a hash
+ ;; table entry. If we allocate a new block, the new block will not
+ ;; have a hash table. Perhaps we can do something more sensible here,
+ ;; but this is a hot function, so there are performance impacts.
+ (assert-vlist vlist)
(block-cons item vlist #f))
(define (vlist-head vlist)
"Return the head of @var{vlist}."
+ (assert-vlist vlist)
(let ((base (vlist-base vlist))
(offset (vlist-offset vlist)))
- (block-ref* base offset)))
+ (block-ref (block-content base) offset)))
(define (vlist-tail vlist)
"Return the tail of @var{vlist}."
+ (assert-vlist vlist)
(let ((base (vlist-base vlist))
(offset (vlist-offset vlist)))
(if (> offset 0)
@@ -210,6 +237,7 @@ tail."
(define (vlist-null? vlist)
"Return true if @var{vlist} is empty."
+ (assert-vlist vlist)
(let ((base (vlist-base vlist)))
(and (not (block-base base))
(= 0 (block-size base)))))
@@ -226,6 +254,7 @@ tail."
(define (vlist-fold proc init vlist)
"Fold over @var{vlist}, calling @var{proc} for each element."
;; FIXME: Handle multiple lists.
+ (assert-vlist vlist)
(let loop ((base (vlist-base vlist))
(offset (vlist-offset vlist))
(result init))
@@ -235,19 +264,18 @@ tail."
(done? (< next 0)))
(loop (if done? (block-base base) base)
(if done? (block-offset base) next)
- (proc (block-ref* base offset) result))))))
+ (proc (block-ref (block-content base) offset) result))))))
(define (vlist-fold-right proc init vlist)
"Fold over @var{vlist}, calling @var{proc} for each element, starting from
the last element."
- (define len (vlist-length vlist))
-
- (let loop ((index (1- len))
+ (assert-vlist vlist)
+ (let loop ((index (1- (vlist-length vlist)))
(result init))
(if (< index 0)
result
(loop (1- index)
- (proc (vlist-ref vlist index) result)))))
+ (proc (vlist-ref vlist index) result)))))
(define (vlist-reverse vlist)
"Return a new @var{vlist} whose content are those of @var{vlist} in reverse
@@ -267,11 +295,12 @@ order."
(define (vlist-ref vlist index)
"Return the element at index @var{index} in @var{vlist}."
+ (assert-vlist vlist)
(let loop ((index index)
(base (vlist-base vlist))
(offset (vlist-offset vlist)))
(if (<= index offset)
- (block-ref* base (- offset index))
+ (block-ref (block-content base) (- offset index))
(loop (- index offset 1)
(block-base base)
(block-offset base)))))
@@ -279,6 +308,7 @@ order."
(define (vlist-drop vlist count)
"Return a new vlist that does not contain the @var{count} first elements of
@var{vlist}."
+ (assert-vlist vlist)
(let loop ((count count)
(base (vlist-base vlist))
(offset (vlist-offset vlist)))
@@ -319,6 +349,7 @@ satisfy @var{pred}."
(define (vlist-length vlist)
"Return the length of @var{vlist}."
+ (assert-vlist vlist)
(let loop ((base (vlist-base vlist))
(len (vlist-offset vlist)))
(if (eq? base block-null)
@@ -371,98 +402,94 @@ details."
;; associated with K1 and K2, respectively. The resulting layout is a
;; follows:
;;
-;; ,--------------------.
-;; | ,-> (K1 . V1) ---. |
-;; | | | |
-;; | | (K2 . V2) <--' |
-;; | | |
-;; +-|------------------+
-;; | | |
-;; | | |
-;; | `-- O <---------------H
-;; | |
-;; `--------------------'
+;; ,--------------------.
+;; 0| ,-> (K1 . V1) | Vlist array
+;; 1| | |
+;; 2| | (K2 . V2) |
+;; 3| | |
+;; size +-|------------------+
+;; 0| | | Hash table
+;; 1| | |
+;; 2| +-- O <------------- H
+;; 3| | |
+;; size * 2 +-|------------------+
+;; 0| `-> 2 | Chain links
+;; 1| |
+;; 2| #f |
+;; 3| |
+;; size * 3 `--------------------'
+;;
+;; The backing store for the vhash is partitioned into three areas: the
+;; vlist part, the hash table part, and the chain links part. In this
+;; example we have a hash H which, when indexed into the hash table
+;; part, indicates that a value with this hash can be found at offset 0
+;; in the vlist part. The corresponding index (in this case, 0) of the
+;; chain links array holds the index of the next element in this block
+;; with this hash value, or #f if we reached the end of the chain.
;;
-;; The bottom part is the "hash table" part of the vhash, as returned by
-;; `block-hash-table'; the other half is the data part. O is the offset of
-;; the first value associated with a key that hashes to H in the data part.
-;; The (K1 . V1) pair has a "hidden" link to the (K2 . V2) pair; hiding the
-;; link is handled by `block-ref'.
-
-;; This API potentially requires users to repeat which hash function and which
-;; equality predicate to use. This can lead to unpredictable results if they
-;; are used in consistenly, e.g., between `vhash-cons' and `vhash-assoc', which
-;; is undesirable, as argued in http://savannah.gnu.org/bugs/?22159 . OTOH,
two
-;; arguments can be made in favor of this API:
+;; This API potentially requires users to repeat which hash function and
+;; which equality predicate to use. This can lead to unpredictable
+;; results if they are used in consistenly, e.g., between `vhash-cons'
+;; and `vhash-assoc', which is undesirable, as argued in
+;; http://savannah.gnu.org/bugs/?22159 . OTOH, two arguments can be
+;; made in favor of this API:
;;
;; - It's consistent with how alists are handled in SRFI-1.
;;
-;; - In practice, users will probably consistenly use either the `q', the `v',
-;; or the plain variant (`vlist-cons' and `vlist-assoc' without any optional
-;; argument), i.e., they will rarely explicitly pass a hash function or
-;; equality predicate.
+;; - In practice, users will probably consistenly use either the `q',
+;; the `v', or the plain variant (`vlist-cons' and `vlist-assoc'
+;; without any optional argument), i.e., they will rarely explicitly
+;; pass a hash function or equality predicate.
(define (vhash? obj)
"Return true if @var{obj} is a hash list."
(and (vlist? obj)
- (let ((base (vlist-base obj)))
- (and base
- (vector? (block-hash-table base))))))
+ (block-hash-table? (vlist-base obj))))
(define* (vhash-cons key value vhash #:optional (hash hash))
"Return a new hash list based on @var{vhash} where @var{key} is associated
with @var{value}. Use @var{hash} to compute @var{key}'s hash."
- (let* ((key+value (cons key value))
- (entry (cons key+value #f))
- (vlist (block-cons entry vhash #t))
- (base (vlist-base vlist))
- (khash (hash key (block-size base))))
-
- (let ((o (block-hash-table-ref base khash)))
- (if o (set-cdr! entry o)))
-
- (block-hash-table-set! base khash
- (vlist-offset vlist))
-
- vlist))
+ (assert-vlist vhash)
+ ;; We should also assert that it is a hash table. Need to check the
+ ;; performance impacts of that. Also, vlist-null is a valid hash
+ ;; table, which does not pass vhash?. A bug, perhaps.
+ (let* ((vhash (block-cons (cons key value) vhash #t))
+ (base (vlist-base vhash))
+ (offset (vlist-offset vhash))
+ (size (block-size base))
+ (khash (hash key size))
+ (content (block-content base)))
+ (block-hash-table-add! content size khash offset)
+ vhash))
(define vhash-consq (cut vhash-cons <> <> <> hashq))
(define vhash-consv (cut vhash-cons <> <> <> hashv))
-(define-inline (%vhash-fold* proc init key vhash equal? hash)
+(define-inlinable (%vhash-fold* proc init key vhash equal? hash)
;; Fold over all the values associated with KEY in VHASH.
- (define khash
- (let ((size (block-size (vlist-base vhash))))
- (and (> size 0) (hash key size))))
-
- (let loop ((base (vlist-base vhash))
- (khash khash)
- (offset (and khash
- (block-hash-table-ref (vlist-base vhash)
- khash)))
- (max-offset (vlist-offset vhash))
- (result init))
-
- (let ((answer (and offset (block-ref base offset))))
- (cond ((and (pair? answer)
- (<= offset max-offset)
- (let ((answer-key (caar answer)))
- (equal? key answer-key)))
- (let ((result (proc (cdar answer) result))
- (next-offset (cdr answer)))
- (loop base khash next-offset max-offset result)))
- ((and (pair? answer) (cdr answer))
- =>
- (lambda (next-offset)
- (loop base khash next-offset max-offset result)))
- (else
- (let ((next-base (block-base base)))
- (if (and next-base (> (block-size next-base) 0))
- (let* ((khash (hash key (block-size next-base)))
- (offset (block-hash-table-ref next-base khash)))
- (loop next-base khash offset (block-offset base)
- result))
- result)))))))
+ (define (visit-block base max-offset result)
+ (let* ((size (block-size base))
+ (content (block-content base))
+ (khash (hash key size)))
+ (let loop ((offset (block-hash-table-ref content size khash))
+ (result result))
+ (if offset
+ (loop (block-hash-table-next-offset content size offset)
+ (if (and (<= offset max-offset)
+ (equal? key (car (block-ref content offset))))
+ (proc (cdr (block-ref content offset)) result)
+ result))
+ (let ((next-block (block-base base)))
+ (if (> (block-size next-block) 0)
+ (visit-block next-block (block-offset base) result)
+ result))))))
+
+ (assert-vlist vhash)
+ (if (> (block-size (vlist-base vhash)) 0)
+ (visit-block (vlist-base vhash)
+ (vlist-offset vhash)
+ init)
+ init))
(define* (vhash-fold* proc init key vhash
#:optional (equal? equal?) (hash hash))
@@ -480,39 +507,29 @@ value of @var{result} for the first call to @var{proc}."
"Same as @code{vhash-fold*}, but using @code{hashv} and @code{eqv?}."
(%vhash-fold* proc init key vhash eqv? hashv))
-(define-inline (%vhash-assoc key vhash equal? hash)
+(define-inlinable (%vhash-assoc key vhash equal? hash)
;; A specialization of `vhash-fold*' that stops when the first value
;; associated with KEY is found or when the end-of-list is reached. Inline
to
;; make sure `vhash-assq' gets to use the `eq?' instruction instead of
calling
;; the `eq?' subr.
- (define khash
- (let ((size (block-size (vlist-base vhash))))
- (and (> size 0) (hash key size))))
-
- (let loop ((base (vlist-base vhash))
- (khash khash)
- (offset (and khash
- (block-hash-table-ref (vlist-base vhash)
- khash)))
- (max-offset (vlist-offset vhash)))
- (let ((answer (and offset (block-ref base offset))))
- (cond ((and (pair? answer)
- (<= offset max-offset)
- (let ((answer-key (caar answer)))
- (equal? key answer-key)))
- (car answer))
- ((and (pair? answer) (cdr answer))
- =>
- (lambda (next-offset)
- (loop base khash next-offset max-offset)))
- (else
- (let ((next-base (block-base base)))
- (and next-base
- (> (block-size next-base) 0)
- (let* ((khash (hash key (block-size next-base)))
- (offset (block-hash-table-ref next-base khash)))
- (loop next-base khash offset
- (block-offset base))))))))))
+ (define (visit-block base max-offset)
+ (let* ((size (block-size base))
+ (content (block-content base))
+ (khash (hash key size)))
+ (let loop ((offset (block-hash-table-ref content size khash)))
+ (if offset
+ (if (and (<= offset max-offset)
+ (equal? key (car (block-ref content offset))))
+ (block-ref content offset)
+ (loop (block-hash-table-next-offset content size offset)))
+ (let ((next-block (block-base base)))
+ (and (> (block-size next-block) 0)
+ (visit-block next-block (block-offset base))))))))
+
+ (assert-vlist vhash)
+ (and (> (block-size (vlist-base vhash)) 0)
+ (visit-block (vlist-base vhash)
+ (vlist-offset vhash))))
(define* (vhash-assoc key vhash #:optional (equal? equal?) (hash hash))
"Return the first key/value pair from @var{vhash} whose key is equal to
diff --git a/module/language/tree-il/cse.scm b/module/language/tree-il/cse.scm
new file mode 100644
index 0000000..7ae4723
--- /dev/null
+++ b/module/language/tree-il/cse.scm
@@ -0,0 +1,601 @@
+;;; Common Subexpression Elimination (CSE) on Tree-IL
+
+;; Copyright (C) 2011, 2012 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
+
+(define-module (language tree-il cse)
+ #:use-module (language tree-il)
+ #:use-module (language tree-il primitives)
+ #:use-module (language tree-il effects)
+ #:use-module (ice-9 vlist)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
+ #:export (cse))
+
+;;;
+;;; This pass eliminates common subexpressions in Tree-IL. It works
+;;; best locally -- within a function -- so it is meant to be run after
+;;; partial evaluation, which usually inlines functions and so opens up
+;;; a bigger space for CSE to work.
+;;;
+;;; The algorithm traverses the tree of expressions, returning two
+;;; values: the newly rebuilt tree, and a "database". The database is
+;;; the set of expressions that will have been evaluated as part of
+;;; evaluating an expression. For example, in:
+;;;
+;;; (1- (+ (if a b c) (* x y)))
+;;;
+;;; We can say that when it comes time to evaluate (1- <>), that the
+;;; subexpressions +, x, y, and (* x y) must have been evaluated in
+;;; values context. We know that a was evaluated in test context, but
+;;; we don't know if it was true or false.
+;;;
+;;; The expressions in the database /dominate/ any subsequent
+;;; expression: FOO dominates BAR if evaluation of BAR implies that any
+;;; effects associated with FOO have already occured.
+;;;
+;;; When adding expressions to the database, we record the context in
+;;; which they are evaluated. We treat expressions in test context
+;;; specially: the presence of such an expression indicates that the
+;;; expression is true. In this way we can elide duplicate predicates.
+;;;
+;;; Duplicate predicates are not common in code that users write, but
+;;; can occur quite frequently in macro-generated code.
+;;;
+;;; For example:
+;;;
+;;; (and (foo? x) (foo-bar x))
+;;; => (if (and (struct? x) (eq? (struct-vtable x) <foo>))
+;;; (if (and (struct? x) (eq? (struct-vtable x) <foo>))
+;;; (struct-ref x 1)
+;;; (throw 'not-a-foo))
+;;; #f))
+;;; => (if (and (struct? x) (eq? (struct-vtable x) <foo>))
+;;; (struct-ref x 1)
+;;; #f)
+;;;
+;;; A conditional bailout in effect context also has the effect of
+;;; adding predicates to the database:
+;;;
+;;; (begin (foo-bar x) (foo-baz x))
+;;; => (begin
+;;; (if (and (struct? x) (eq? (struct-vtable x) <foo>))
+;;; (struct-ref x 1)
+;;; (throw 'not-a-foo))
+;;; (if (and (struct? x) (eq? (struct-vtable x) <foo>))
+;;; (struct-ref x 2)
+;;; (throw 'not-a-foo)))
+;;; => (begin
+;;; (if (and (struct? x) (eq? (struct-vtable x) <foo>))
+;;; (struct-ref x 1)
+;;; (throw 'not-a-foo))
+;;; (struct-ref x 2))
+;;;
+;;; When removing code, we have to ensure that the semantics of the
+;;; source program and the residual program are the same. It's easy to
+;;; ensure that they have the same value, because those manipulations
+;;; are just algebraic, but the tricky thing is to ensure that the
+;;; expressions exhibit the same ordering of effects. For that, we use
+;;; the effects analysis of (language tree-il effects). We only
+;;; eliminate code if the duplicate code commutes with all of the
+;;; dominators on the path from the duplicate to the original.
+;;;
+;;; The implementation uses vhashes as the fundamental data structure.
+;;; This can be seen as a form of global value numbering. This
+;;; algorithm currently spends most of its time in vhash-assoc. I'm not
+;;; sure whether that is due to our bad hash function in Guile 2.0, an
+;;; inefficiency in vhashes, or what. Overall though the complexity
+;;; should be linear, or N log N -- whatever vhash-assoc's complexity
+;;; is. Walking the dominators is nonlinear, but that only happens when
+;;; we've actually found a common subexpression so that should be OK.
+;;;
+
+;; Logging helpers, as in peval.
+;;
+(define-syntax *logging* (identifier-syntax #f))
+;; (define %logging #f)
+;; (define-syntax *logging* (identifier-syntax %logging))
+(define-syntax log
+ (syntax-rules (quote)
+ ((log 'event arg ...)
+ (if (and *logging*
+ (or (eq? *logging* #t)
+ (memq 'event *logging*)))
+ (log* 'event arg ...)))))
+(define (log* event . args)
+ (let ((pp (module-ref (resolve-interface '(ice-9 pretty-print))
+ 'pretty-print)))
+ (pp `(log ,event . ,args))
+ (newline)
+ (values)))
+
+;; A pre-pass on the source program to determine the set of assigned
+;; lexicals.
+;;
+(define* (build-assigned-var-table exp #:optional (table vlist-null))
+ (tree-il-fold
+ (lambda (exp res)
+ res)
+ (lambda (exp res)
+ (match exp
+ (($ <lexical-set> src name gensym exp)
+ (vhash-consq gensym #t res))
+ (_ res)))
+ (lambda (exp res) res)
+ table exp))
+
+(define (boolean-valued-primitive? primitive)
+ (or (negate-primitive primitive)
+ (eq? primitive 'not)
+ (let ((chars (symbol->string primitive)))
+ (eqv? (string-ref chars (1- (string-length chars)))
+ #\?))))
+
+(define (boolean-valued-expression? x ctx)
+ (match x
+ (($ <primcall> _ (? boolean-valued-primitive?)) #t)
+ (($ <const> _ (? boolean?)) #t)
+ (_ (eq? ctx 'test))))
+
+(define* (cse exp)
+ "Eliminate common subexpressions in EXP."
+
+ (define assigned-lexical?
+ (let ((table (build-assigned-var-table exp)))
+ (lambda (sym)
+ (vhash-assq sym table))))
+
+ (define compute-effects
+ (make-effects-analyzer assigned-lexical?))
+
+ (define (negate exp ctx)
+ (match exp
+ (($ <const> src x)
+ (make-const src (not x)))
+ (($ <void> src)
+ (make-const src #f))
+ (($ <conditional> src test consequent alternate)
+ (make-conditional src test (negate consequent ctx) (negate alternate
ctx)))
+ (($ <primcall> _ 'not
+ ((and x (? (cut boolean-valued-expression? <> ctx)))))
+ x)
+ (($ <primcall> src (and pred (? negate-primitive)) args)
+ (make-primcall src (negate-primitive pred) args))
+ (_
+ (make-primcall #f 'not (list exp)))))
+
+
+ (define (bailout? exp)
+ (causes-effects? (compute-effects exp) &definite-bailout))
+
+ (define (struct-nfields x)
+ (/ (string-length (symbol->string (struct-layout x))) 2))
+
+ (define hash-bits (logcount most-positive-fixnum))
+ (define hash-depth 4)
+ (define hash-width 3)
+ (define (hash-expression exp)
+ (define (hash-exp exp depth)
+ (define (rotate x bits)
+ (logior (ash x (- bits))
+ (ash (logand x (1- (ash 1 bits))) (- hash-bits bits))))
+ (define (mix h1 h2)
+ (logxor h1 (rotate h2 8)))
+ (define (hash-struct s)
+ (let ((len (struct-nfields s))
+ (h (hashq (struct-vtable s) most-positive-fixnum)))
+ (if (zero? depth)
+ h
+ (let lp ((i (max (- len hash-width) 1)) (h h))
+ (if (< i len)
+ (lp (1+ i) (mix (hash-exp (struct-ref s i) (1+ depth)) h))
+ h)))))
+ (define (hash-list l)
+ (let ((h (hashq 'list most-positive-fixnum)))
+ (if (zero? depth)
+ h
+ (let lp ((l l) (width 0) (h h))
+ (if (< width hash-width)
+ (lp (cdr l) (1+ width)
+ (mix (hash-exp (car l) (1+ depth)) h))
+ h)))))
+ (cond
+ ((struct? exp) (hash-struct exp))
+ ((list? exp) (hash-list exp))
+ (else (hash exp most-positive-fixnum))))
+ (hash-exp exp 0))
+
+ (define (expressions-equal? a b)
+ (cond
+ ((struct? a)
+ (and (struct? b)
+ (eq? (struct-vtable a) (struct-vtable b))
+ ;; Assume that all structs are tree-il, so we skip over the
+ ;; src slot.
+ (let lp ((n (1- (struct-nfields a))))
+ (or (zero? n)
+ (and (expressions-equal? (struct-ref a n) (struct-ref b n))
+ (lp (1- n)))))))
+ ((pair? a)
+ (and (pair? b)
+ (expressions-equal? (car a) (car b))
+ (expressions-equal? (cdr a) (cdr b))))
+ (else
+ (equal? a b))))
+
+ (define (hasher n)
+ (lambda (x size) (modulo n size)))
+
+ (define (add-to-db exp effects ctx db)
+ (let ((v (vector exp effects ctx))
+ (h (hash-expression exp)))
+ (vhash-cons v h db (hasher h))))
+
+ (define (control-flow-boundary db)
+ (let ((h (hashq 'lambda most-positive-fixnum)))
+ (vhash-cons 'lambda h db (hasher h))))
+
+ (define (find-dominating-expression exp effects ctx db)
+ (define (entry-matches? v1 v2)
+ (match (if (vector? v1) v1 v2)
+ (#(exp* effects* ctx*)
+ (and (expressions-equal? exp exp*)
+ (or (not ctx) (eq? ctx* ctx))))
+ (_ #f)))
+
+ (let ((len (vlist-length db))
+ (h (hash-expression exp)))
+ (and (vhash-assoc #t db entry-matches? (hasher h))
+ (let lp ((n 0))
+ (and (< n len)
+ (match (vlist-ref db n)
+ (('lambda . h*)
+ ;; We assume that lambdas can escape and thus be
+ ;; called from anywhere. Thus code inside a lambda
+ ;; only has a dominating expression if it does not
+ ;; depend on any effects.
+ (and (not (depends-on-effects? effects &all-effects))
+ (lp (1+ n))))
+ ((#(exp* effects* ctx*) . h*)
+ (log 'walk (unparse-tree-il exp) effects
+ (unparse-tree-il exp*) effects* ctx*)
+ (or (and (= h h*)
+ (or (not ctx) (eq? ctx ctx*))
+ (expressions-equal? exp exp*))
+ (and (effects-commute? effects effects*)
+ (lp (1+ n)))))))))))
+
+ ;; Return #t if EXP is dominated by an instance of itself. In that
+ ;; case, we can exclude *type-check* effects, because the first
+ ;; expression already caused them if needed.
+ (define (has-dominating-effect? exp effects db)
+ (or (constant? effects)
+ (and
+ (effect-free?
+ (exclude-effects effects
+ (logior &zero-values
+ &allocation
+ &type-check)))
+ (find-dominating-expression exp effects #f db))))
+
+ (define (find-dominating-test exp effects db)
+ (and
+ (effect-free?
+ (exclude-effects effects (logior &allocation
+ &type-check)))
+ (match exp
+ (($ <const> src val)
+ (if (boolean? val)
+ exp
+ (make-const src (not (not val)))))
+ ;; For (not FOO), try to prove FOO, then negate the result.
+ (($ <primcall> src 'not (exp*))
+ (match (find-dominating-test exp* effects db)
+ (($ <const> _ val)
+ (log 'inferring exp (not val))
+ (make-const src (not val)))
+ (_
+ #f)))
+ (_
+ (cond
+ ((find-dominating-expression exp effects #f db)
+ ;; We have an EXP fact, so we infer #t.
+ (log 'inferring exp #t)
+ (make-const (tree-il-src exp) #t))
+ ((find-dominating-expression (negate exp 'test) effects #f db)
+ ;; We have a (not EXP) fact, so we infer #f.
+ (log 'inferring exp #f)
+ (make-const (tree-il-src exp) #f))
+ (else
+ ;; Otherwise we don't know.
+ #f))))))
+
+ (define (add-to-env exp name sym db env)
+ (let* ((v (vector exp name sym (vlist-length db)))
+ (h (hash-expression exp)))
+ (vhash-cons v h env (hasher h))))
+
+ (define (augment-env env names syms exps db)
+ (if (null? names)
+ env
+ (let ((name (car names)) (sym (car syms)) (exp (car exps)))
+ (augment-env (if (or (assigned-lexical? sym)
+ (lexical-ref? exp))
+ env
+ (add-to-env exp name sym db env))
+ (cdr names) (cdr syms) (cdr exps) db))))
+
+ (define (find-dominating-lexical exp effects env db)
+ (define (entry-matches? v1 v2)
+ (match (if (vector? v1) v1 v2)
+ (#(exp* name sym db)
+ (expressions-equal? exp exp*))
+ (_ #f)))
+
+ (define (unroll db base n)
+ (or (zero? n)
+ (match (vlist-ref db base)
+ (('lambda . h*)
+ ;; See note in find-dominating-expression.
+ (and (not (depends-on-effects? effects &all-effects))
+ (unroll db (1+ base) (1- n))))
+ ((#(exp* effects* ctx*) . h*)
+ (and (effects-commute? effects effects*)
+ (unroll db (1+ base) (1- n)))))))
+
+ (let ((h (hash-expression exp)))
+ (and (effect-free? (exclude-effects effects &type-check))
+ (vhash-assoc exp env entry-matches? (hasher h))
+ (let ((env-len (vlist-length env))
+ (db-len (vlist-length db)))
+ (let lp ((n 0) (m 0))
+ (and (< n env-len)
+ (match (vlist-ref env n)
+ ((#(exp* name sym db-len*) . h*)
+ (and (unroll db m (- db-len db-len*))
+ (if (and (= h h*) (expressions-equal? exp* exp))
+ (make-lexical-ref (tree-il-src exp) name sym)
+ (lp (1+ n) (- db-len db-len*))))))))))))
+
+ (define (intersection db+ db-)
+ (vhash-fold-right
+ (lambda (k h out)
+ (if (vhash-assoc k db- equal? (hasher h))
+ (vhash-cons k h out (hasher h))
+ out))
+ vlist-null
+ db+))
+
+ (define (concat db1 db2)
+ (vhash-fold-right (lambda (k h tail)
+ (vhash-cons k h tail (hasher h)))
+ db2 db1))
+
+ (let visit ((exp exp)
+ (db vlist-null) ; dominating expressions: #(exp effects ctx) ->
hash
+ (env vlist-null) ; named expressions: #(exp name sym db) -> hash
+ (ctx 'values)) ; test, effect, value, or values
+
+ (define (parallel-visit exps db env ctx)
+ (let lp ((in exps) (out '()) (db* vlist-null))
+ (if (pair? in)
+ (call-with-values (lambda () (visit (car in) db env ctx))
+ (lambda (x db**)
+ (lp (cdr in) (cons x out) (concat db** db*))))
+ (values (reverse out) db*))))
+
+ (define (return exp db*)
+ (let ((effects (compute-effects exp)))
+ (cond
+ ((and (eq? ctx 'effect)
+ (not (lambda-case? exp))
+ (or (effect-free?
+ (exclude-effects effects
+ (logior &zero-values
+ &allocation)))
+ (has-dominating-effect? exp effects db)))
+ (cond
+ ((void? exp)
+ (values exp db*))
+ (else
+ (log 'elide ctx (unparse-tree-il exp))
+ (values (make-void #f) db*))))
+ ((and (boolean-valued-expression? exp ctx)
+ (find-dominating-test exp effects db))
+ => (lambda (exp)
+ (log 'propagate-test ctx (unparse-tree-il exp))
+ (values exp db*)))
+ ((and (eq? ctx 'value)
+ (find-dominating-lexical exp effects env db))
+ => (lambda (exp)
+ (log 'propagate-value ctx (unparse-tree-il exp))
+ (values exp db*)))
+ ((and (constant? effects) (memq ctx '(value values)))
+ ;; Adds nothing to the db.
+ (values exp db*))
+ (else
+ (log 'return ctx effects (unparse-tree-il exp) db*)
+ (values exp
+ (add-to-db exp effects ctx db*))))))
+
+ (log 'visit ctx (unparse-tree-il exp) db env)
+
+ (match exp
+ (($ <const>)
+ (return exp vlist-null))
+ (($ <void>)
+ (return exp vlist-null))
+ (($ <lexical-ref> _ _ gensym)
+ (return exp vlist-null))
+ (($ <lexical-set> src name gensym exp)
+ (let*-values (((exp db*) (visit exp db env 'value)))
+ (return (make-lexical-set src name gensym exp)
+ db*)))
+ (($ <let> src names gensyms vals body)
+ (let*-values (((vals db*) (parallel-visit vals db env 'value))
+ ((body db**) (visit body (concat db* db)
+ (augment-env env names gensyms vals
db)
+ ctx)))
+ (return (make-let src names gensyms vals body)
+ (concat db** db*))))
+ (($ <letrec> src in-order? names gensyms vals body)
+ (let*-values (((vals db*) (parallel-visit vals db env 'value))
+ ((body db**) (visit body (concat db* db)
+ (augment-env env names gensyms vals
db)
+ ctx)))
+ (return (make-letrec src in-order? names gensyms vals body)
+ (concat db** db*))))
+ (($ <fix> src names gensyms vals body)
+ (let*-values (((vals db*) (parallel-visit vals db env 'value))
+ ((body db**) (visit body (concat db* db) env ctx)))
+ (return (make-fix src names gensyms vals body)
+ (concat db** db*))))
+ (($ <let-values> src producer consumer)
+ (let*-values (((producer db*) (visit producer db env 'values))
+ ((consumer db**) (visit consumer (concat db* db) env
ctx)))
+ (return (make-let-values src producer consumer)
+ (concat db** db*))))
+ (($ <dynwind> src winder pre body post unwinder)
+ (let*-values (((winder db*) (visit winder db env 'value))
+ ((db**) db*)
+ ((unwinder db*) (visit unwinder db env 'value))
+ ((db**) (concat db* db**))
+ ((pre db*) (visit pre (concat db** db) env 'effect))
+ ((db**) (concat db* db**))
+ ((body db*) (visit body (concat db** db) env ctx))
+ ((db**) (concat db* db**))
+ ((post db*) (visit post (concat db** db) env 'effect))
+ ((db**) (concat db* db**)))
+ (return (make-dynwind src winder pre body post unwinder)
+ db**)))
+ (($ <dynlet> src fluids vals body)
+ (let*-values (((fluids db*) (parallel-visit fluids db env 'value))
+ ((vals db**) (parallel-visit vals db env 'value))
+ ((body db***) (visit body (concat db** (concat db* db))
+ env ctx)))
+ (return (make-dynlet src fluids vals body)
+ (concat db*** (concat db** db*)))))
+ (($ <dynref> src fluid)
+ (let*-values (((fluid db*) (visit fluid db env 'value)))
+ (return (make-dynref src fluid)
+ db*)))
+ (($ <dynset> src fluid exp)
+ (let*-values (((fluid db*) (visit fluid db env 'value))
+ ((exp db**) (visit exp db env 'value)))
+ (return (make-dynset src fluid exp)
+ (concat db** db*))))
+ (($ <toplevel-ref>)
+ (return exp vlist-null))
+ (($ <module-ref>)
+ (return exp vlist-null))
+ (($ <module-set> src mod name public? exp)
+ (let*-values (((exp db*) (visit exp db env 'value)))
+ (return (make-module-set src mod name public? exp)
+ db*)))
+ (($ <toplevel-define> src name exp)
+ (let*-values (((exp db*) (visit exp db env 'value)))
+ (return (make-toplevel-define src name exp)
+ db*)))
+ (($ <toplevel-set> src name exp)
+ (let*-values (((exp db*) (visit exp db env 'value)))
+ (return (make-toplevel-set src name exp)
+ db*)))
+ (($ <primitive-ref>)
+ (return exp vlist-null))
+ (($ <conditional> src test consequent alternate)
+ (let*-values
+ (((test db+) (visit test db env 'test))
+ ((converse db-) (visit (negate test 'test) db env 'test))
+ ((consequent db++) (visit consequent (concat db+ db) env ctx))
+ ((alternate db--) (visit alternate (concat db- db) env ctx)))
+ (match (make-conditional src test consequent alternate)
+ (($ <conditional> _ ($ <const> _ exp))
+ (if exp
+ (return consequent (concat db++ db+))
+ (return alternate (concat db-- db-))))
+ ;; (if FOO A A) => (begin FOO A)
+ (($ <conditional> src _
+ ($ <const> _ a) ($ <const> _ (? (cut equal? a <>))))
+ (visit (make-seq #f test (make-const #f a))
+ db env ctx))
+ ;; (if FOO #t #f) => FOO for boolean-valued FOO.
+ (($ <conditional> src
+ (? (cut boolean-valued-expression? <> ctx))
+ ($ <const> _ #t) ($ <const> _ #f))
+ (return test db+))
+ ;; (if FOO #f #t) => (not FOO)
+ (($ <conditional> src _ ($ <const> _ #f) ($ <const> _ #t))
+ (visit (negate test ctx) db env ctx))
+
+ ;; Allow "and"-like conditions to accumulate in test context.
+ ((and c ($ <conditional> _ _ _ ($ <const> _ #f)))
+ (return c (if (eq? ctx 'test) (concat db++ db+) vlist-null)))
+ ((and c ($ <conditional> _ _ ($ <const> _ #f) _))
+ (return c (if (eq? ctx 'test) (concat db-- db-) vlist-null)))
+
+ ;; Conditional bailouts turn expressions into predicates.
+ ((and c ($ <conditional> _ _ _ (? bailout?)))
+ (return c (concat db++ db+)))
+ ((and c ($ <conditional> _ _ (? bailout?) _))
+ (return c (concat db-- db-)))
+
+ (c
+ (return c (intersection (concat db++ db+) (concat db-- db-)))))))
+ (($ <primcall> src primitive args)
+ (let*-values (((args db*) (parallel-visit args db env 'value)))
+ (return (make-primcall src primitive args) db*)))
+ (($ <call> src proc args)
+ (let*-values (((proc db*) (visit proc db env 'value))
+ ((args db**) (parallel-visit args db env 'value)))
+ (return (make-call src proc args)
+ (concat db** db*))))
+ (($ <lambda> src meta body)
+ (let*-values (((body _) (visit body (control-flow-boundary db)
+ env 'values)))
+ (return (make-lambda src meta body)
+ vlist-null)))
+ (($ <lambda-case> src req opt rest kw inits gensyms body alt)
+ (let*-values (((inits _) (parallel-visit inits db env 'value))
+ ((body db*) (visit body db env ctx))
+ ((alt _) (if alt
+ (visit alt db env ctx)
+ (values #f #f))))
+ (return (make-lambda-case src req opt rest kw inits gensyms body alt)
+ (if alt vlist-null db*))))
+ (($ <seq> src head tail)
+ (let*-values (((head db*) (visit head db env 'effect)))
+ (cond
+ ((void? head)
+ (visit tail db env ctx))
+ (else
+ (let*-values (((tail db**) (visit tail (concat db* db) env ctx)))
+ (values (make-seq src head tail)
+ (concat db** db*)))))))
+ (($ <prompt> src tag body handler)
+ (let*-values (((tag db*) (visit tag db env 'value))
+ ((body _) (visit body (concat db* db) env ctx))
+ ((handler _) (visit handler (concat db* db) env ctx)))
+ (return (make-prompt src tag body handler)
+ db*)))
+ (($ <abort> src tag args tail)
+ (let*-values (((tag db*) (visit tag db env 'value))
+ ((args db**) (parallel-visit args db env 'value))
+ ((tail db***) (visit tail db env 'value)))
+ (return (make-abort src tag args tail)
+ (concat db* (concat db** db***))))))))
diff --git a/module/language/tree-il/effects.scm
b/module/language/tree-il/effects.scm
new file mode 100644
index 0000000..e698a37
--- /dev/null
+++ b/module/language/tree-il/effects.scm
@@ -0,0 +1,330 @@
+;;; Effects analysis on Tree-IL
+
+;; Copyright (C) 2011, 2012 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
+
+(define-module (language tree-il effects)
+ #:use-module (language tree-il)
+ #:use-module (language tree-il primitives)
+ #:use-module (ice-9 match)
+ #:export (make-effects-analyzer
+ &mutable-lexical
+ &toplevel
+ &fluid
+ &definite-bailout
+ &possible-bailout
+ &zero-values
+ &allocation
+ &mutable-data
+ &type-check
+ &all-effects
+ effects-commute?
+ exclude-effects
+ effect-free?
+ constant?
+ depends-on-effects?
+ causes-effects?))
+
+;;;
+;;; Hey, it's some effects analysis! If you invoke
+;;; `make-effects-analyzer', you get a procedure that computes 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
+;;; toplevel reference to FOO is modelled as depending on the &toplevel
+;;; effect, and causing a &type-check effect. If any intervening code
+;;; sets any toplevel variable, that will block motion of FOO.
+;;;
+;;; 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.
+;;;
+
+(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 ...)))))))))
+
+;; 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.
+;;
+(define-effects &all-effects
+ ;; Indicates that an expression depends on the value of a mutable
+ ;; lexical variable.
+ &mutable-lexical
+
+ ;; Indicates that an expression depends on the value of a toplevel
+ ;; variable.
+ &toplevel
+
+ ;; Indicates that an expression depends on the value of a fluid
+ ;; variable.
+ &fluid
+
+ ;; 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 than an expression may return zero values -- a "causes"
+ ;; effect.
+ &zero-values
+
+ ;; Indicates that an expression may return a fresh object -- a
+ ;; "causes" effect.
+ &allocation
+
+ ;; Indicates that an expression depends on the value of a mutable data
+ ;; structure.
+ &mutable-data
+
+ ;; 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)
+
+(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 (make-effects-analyzer assigned-lexical?)
+ "Returns a procedure of type EXP -> EFFECTS that analyzes the effects
+of an expression."
+
+ (define compute-effects
+ (let ((cache (make-hash-table)))
+ (lambda (exp)
+ (or (hashq-ref cache exp)
+ (let ((effects (visit exp)))
+ (hashq-set! cache exp effects)
+ effects)))))
+
+ (define (accumulate-effects exps)
+ (let lp ((exps exps) (out &no-effects))
+ (if (null? exps)
+ out
+ (lp (cdr exps) (logior out (compute-effects (car exps)))))))
+
+ (define (visit exp)
+ (match exp
+ (($ <const>)
+ &no-effects)
+ (($ <void>)
+ &no-effects)
+ (($ <lexical-ref> _ _ gensym)
+ (if (assigned-lexical? gensym)
+ &mutable-lexical
+ &no-effects))
+ (($ <lexical-set> _ name gensym exp)
+ (logior (cause &mutable-lexical)
+ (compute-effects exp)))
+ (($ <let> _ names gensyms vals body)
+ (logior (if (or-map assigned-lexical? gensyms)
+ (cause &allocation)
+ &no-effects)
+ (accumulate-effects vals)
+ (compute-effects body)))
+ (($ <letrec> _ in-order? names gensyms vals body)
+ (logior (if (or-map assigned-lexical? gensyms)
+ (cause &allocation)
+ &no-effects)
+ (accumulate-effects vals)
+ (compute-effects body)))
+ (($ <fix> _ names gensyms vals body)
+ (logior (if (or-map assigned-lexical? gensyms)
+ (cause &allocation)
+ &no-effects)
+ (accumulate-effects vals)
+ (compute-effects body)))
+ (($ <let-values> _ producer consumer)
+ (logior (compute-effects producer)
+ (compute-effects consumer)
+ (cause &type-check)))
+ (($ <dynwind> _ winder pre body post unwinder)
+ (logior (compute-effects winder)
+ (compute-effects pre)
+ (compute-effects body)
+ (compute-effects post)
+ (compute-effects unwinder)))
+ (($ <dynlet> _ fluids vals body)
+ (logior (accumulate-effects fluids)
+ (accumulate-effects vals)
+ (cause &type-check)
+ (cause &fluid)
+ (compute-effects body)))
+ (($ <dynref> _ fluid)
+ (logior (compute-effects fluid)
+ (cause &type-check)
+ &fluid))
+ (($ <dynset> _ fluid exp)
+ (logior (compute-effects fluid)
+ (compute-effects exp)
+ (cause &type-check)
+ (cause &fluid)))
+ (($ <toplevel-ref>)
+ (logior &toplevel
+ (cause &type-check)))
+ (($ <module-ref>)
+ (logior &toplevel
+ (cause &type-check)))
+ (($ <module-set> _ mod name public? exp)
+ (logior (cause &toplevel)
+ (cause &type-check)
+ (compute-effects exp)))
+ (($ <toplevel-define> _ name exp)
+ (logior (cause &toplevel)
+ (compute-effects exp)))
+ (($ <toplevel-set> _ name exp)
+ (logior (cause &toplevel)
+ (compute-effects exp)))
+ (($ <primitive-ref>)
+ &no-effects)
+ (($ <conditional> _ test consequent alternate)
+ (let ((tfx (compute-effects test))
+ (cfx (compute-effects consequent))
+ (afx (compute-effects alternate)))
+ (if (causes-effects? (logior tfx (logand afx cfx))
+ &definite-bailout)
+ (logior tfx cfx afx)
+ (exclude-effects (logior tfx cfx afx)
+ &definite-bailout))))
+
+ ;; Zero values.
+ (($ <primcall> _ 'values ())
+ (cause &zero-values))
+
+ ;; Effect-free primitives.
+ (($ <primcall> _ (and name (? effect+exception-free-primitive?)) args)
+ (logior (accumulate-effects args)
+ (if (constructor-primitive? name)
+ (cause &allocation)
+ &no-effects)))
+ (($ <primcall> _ (and name (? effect-free-primitive?)) args)
+ (logior (accumulate-effects args)
+ (cause &type-check)
+ (if (constructor-primitive? name)
+ (cause &allocation)
+ (if (accessor-primitive? name)
+ &mutable-data
+ &no-effects))))
+
+ ;; Lambda applications might throw wrong-number-of-args.
+ (($ <call> _ ($ <lambda> _ _ body) args)
+ (logior (compute-effects body)
+ (accumulate-effects args)
+ (cause &type-check)))
+
+ ;; Bailout primitives.
+ (($ <primcall> _ (? bailout-primitive? name) args)
+ (logior (accumulate-effects args)
+ (cause &definite-bailout)
+ (cause &possible-bailout)))
+
+ ;; A call to an unknown procedure can do anything.
+ (($ <primcall> _ name args)
+ (logior &all-effects-but-bailout
+ (cause &all-effects-but-bailout)))
+ (($ <call> _ proc args)
+ (logior &all-effects-but-bailout
+ (cause &all-effects-but-bailout)))
+
+ (($ <lambda> _ meta body)
+ &no-effects)
+ (($ <lambda-case> _ req opt rest kw inits gensyms body alt)
+ (logior (exclude-effects (accumulate-effects inits)
+ &definite-bailout)
+ (if (or-map assigned-lexical? gensyms)
+ (cause &allocation)
+ &no-effects)
+ (compute-effects body)
+ (if alt (compute-effects alt) &no-effects)))
+
+ (($ <seq> _ head tail)
+ (logior
+ ;; Returning zero values to a for-effect continuation is
+ ;; not observable.
+ (exclude-effects (compute-effects head)
+ (cause &zero-values))
+ (compute-effects tail)))
+
+ (($ <prompt> _ tag body handler)
+ (logior (compute-effects tag)
+ (compute-effects body)
+ (compute-effects handler)))
+
+ (($ <abort> _ tag args tail)
+ (logior &all-effects-but-bailout
+ (cause &all-effects-but-bailout)))))
+
+ compute-effects)
diff --git a/module/language/tree-il/optimize.scm
b/module/language/tree-il/optimize.scm
index baac915..c6e4fec 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -1,6 +1,6 @@
;;; Tree-il optimizer
-;; Copyright (C) 2009, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2011, 2012 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
@@ -22,6 +22,7 @@
#:use-module (language tree-il)
#:use-module (language tree-il primitives)
#:use-module (language tree-il peval)
+ #:use-module (language tree-il cse)
#:use-module (language tree-il fix-letrec)
#:use-module (language tree-il debug)
#:use-module (ice-9 match)
@@ -32,8 +33,15 @@
((#:partial-eval? #f _ ...)
;; Disable partial evaluation.
(lambda (x e) x))
- (_ peval))))
+ (_ peval)))
+ (cse (match (memq #:cse? opts)
+ ((#:cse? #f _ ...)
+ ;; Disable CSE.
+ (lambda (x) x))
+ (_ cse))))
(fix-letrec!
(verify-tree-il
- (peval (expand-primitives! (resolve-primitives! x env))
- env)))))
+ (cse
+ (verify-tree-il
+ (peval (expand-primitives! (resolve-primitives! x env))
+ env)))))))
diff --git a/module/language/tree-il/peval.scm
b/module/language/tree-il/peval.scm
index 6b37591..11cdb49 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -19,6 +19,7 @@
(define-module (language tree-il peval)
#:use-module (language tree-il)
#:use-module (language tree-il primitives)
+ #:use-module (language tree-il effects)
#:use-module (ice-9 vlist)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
@@ -285,7 +286,7 @@
;;
(define-record-type <operand>
(%make-operand var sym visit source visit-count residualize?
- copyable? residual-value constant-value)
+ copyable? residual-value constant-value alias-value)
operand?
(var operand-var)
(sym operand-sym)
@@ -295,18 +296,27 @@
(residualize? operand-residualize? set-operand-residualize?!)
(copyable? operand-copyable? set-operand-copyable?!)
(residual-value operand-residual-value %set-operand-residual-value!)
- (constant-value operand-constant-value set-operand-constant-value!))
-
-(define* (make-operand var sym #:optional source visit)
- ;; Bind SYM to VAR, with value SOURCE. Bound operands are considered
- ;; copyable until we prove otherwise. If we have a source expression,
- ;; truncate it to one value. Copy propagation does not work on
- ;; multiply-valued expressions.
+ (constant-value operand-constant-value set-operand-constant-value!)
+ (alias-value operand-alias-value set-operand-alias-value!))
+
+(define* (make-operand var sym #:optional source visit alias)
+ ;; Bind SYM to VAR, with value SOURCE. Unassigned bound operands are
+ ;; considered copyable until we prove otherwise. If we have a source
+ ;; expression, truncate it to one value. Copy propagation does not
+ ;; work on multiply-valued expressions.
(let ((source (and=> source truncate-values)))
- (%make-operand var sym visit source 0 #f (and source #t) #f #f)))
-
-(define (make-bound-operands vars syms sources visit)
- (map (lambda (x y z) (make-operand x y z visit)) vars syms sources))
+ (%make-operand var sym visit source 0 #f
+ (and source (not (var-set? var))) #f #f
+ (and (not (var-set? var)) alias))))
+
+(define* (make-bound-operands vars syms sources visit #:optional aliases)
+ (if aliases
+ (map (lambda (name sym source alias)
+ (make-operand name sym source visit alias))
+ vars syms sources aliases)
+ (map (lambda (name sym source)
+ (make-operand name sym source visit #f))
+ vars syms sources)))
(define (make-unbound-operands vars syms)
(map make-operand vars syms))
@@ -340,7 +350,12 @@
(if (or counter (and (not effort-limit) (not size-limit)))
((%operand-visit op) (operand-source op) counter ctx)
(let/ec k
- (define (abort) (k #f))
+ (define (abort)
+ ;; If we abort when visiting the value in a
+ ;; fresh context, we won't succeed in any future
+ ;; attempt, so don't try to copy it again.
+ (set-operand-copyable?! op #f)
+ (k #f))
((%operand-visit op)
(operand-source op)
(make-top-counter effort-limit size-limit abort op)
@@ -555,52 +570,15 @@ top-level bindings from ENV and return the resulting
expression."
(let ((tail (loop tail)))
(and tail (make-seq src head tail)))))))
+ (define compute-effects
+ (make-effects-analyzer assigned-lexical?))
+
(define (constant-expression? x)
;; Return true if X is constant, for the purposes of copying or
;; elision---i.e., if it is known to have no effects, does not
;; allocate storage for a mutable object, and does not access
;; mutable data (like `car' or toplevel references).
- (let loop ((x x))
- (match x
- (($ <void>) #t)
- (($ <const>) #t)
- (($ <lambda>) #t)
- (($ <lambda-case> _ req opt rest kw inits syms body alternate)
- (and (not (any assigned-lexical? syms))
- (every loop inits) (loop body)
- (or (not alternate) (loop alternate))))
- (($ <lexical-ref> _ _ gensym)
- (not (assigned-lexical? gensym)))
- (($ <primitive-ref>) #t)
- (($ <conditional> _ condition subsequent alternate)
- (and (loop condition) (loop subsequent) (loop alternate)))
- (($ <primcall> _ 'values exps)
- (and (not (null? exps))
- (every loop exps)))
- (($ <primcall> _ name args)
- (and (effect-free-primitive? name)
- (not (constructor-primitive? name))
- (types-check? name args)
- (if (accessor-primitive? name)
- (every const? args)
- (every loop args))))
- (($ <call> _ ($ <lambda> _ _ body) args)
- (and (loop body) (every loop args)))
- (($ <seq> _ head tail)
- (and (loop head) (loop tail)))
- (($ <let> _ _ syms vals body)
- (and (not (any assigned-lexical? syms))
- (every loop vals) (loop body)))
- (($ <letrec> _ _ _ syms vals body)
- (and (not (any assigned-lexical? syms))
- (every loop vals) (loop body)))
- (($ <fix> _ _ _ vals body)
- (and (every loop vals) (loop body)))
- (($ <let-values> _ exp body)
- (and (loop exp) (loop body)))
- (($ <prompt> _ tag body handler)
- (and (loop tag) (loop body) (loop handler)))
- (_ #f))))
+ (constant? (compute-effects x)))
(define (prune-bindings ops in-order? body counter ctx build-result)
;; This helper handles both `let' and `letrec'/`fix'. In the latter
@@ -736,6 +714,11 @@ top-level bindings from ENV and return the resulting
expression."
((eq? ctx 'effect)
(log 'lexical-for-effect gensym)
(make-void #f))
+ ((operand-alias-value op)
+ ;; This is an unassigned operand that simply aliases some
+ ;; other operand. Recurse to avoid residualizing the leaf
+ ;; binding.
+ => for-tail)
((eq? ctx 'call)
;; Don't propagate copies if we are residualizing a call.
(log 'residualize-lexical-call gensym op)
@@ -828,11 +811,37 @@ top-level bindings from ENV and return the resulting
expression."
(set-operand-residualize?! op #t)
(make-lexical-set src name (operand-sym op) (for-value exp))))))
(($ <let> src names gensyms vals body)
+ (define (compute-alias exp)
+ ;; It's very common for macros to introduce something like:
+ ;;
+ ;; ((lambda (x y) ...) x-exp y-exp)
+ ;;
+ ;; In that case you might end up trying to inline something like:
+ ;;
+ ;; (let ((x x-exp) (y y-exp)) ...)
+ ;;
+ ;; But if x-exp is itself a lexical-ref that aliases some much
+ ;; larger expression, perhaps it will fail to inline due to
+ ;; size. However we don't want to introduce a useless alias
+ ;; (in this case, x). So if the RHS of a let expression is a
+ ;; lexical-ref, we record that expression. If we end up having
+ ;; to residualize X, then instead we residualize X-EXP, as long
+ ;; as it isn't assigned.
+ ;;
+ (match exp
+ (($ <lexical-ref> _ _ sym)
+ (let ((op (lookup sym)))
+ (and (not (var-set? (operand-var op)))
+ (or (operand-alias-value op)
+ exp))))
+ (_ #f)))
+
(let* ((vars (map lookup-var gensyms))
(new (fresh-gensyms vars))
(ops (make-bound-operands vars new vals
(lambda (exp counter ctx)
- (loop exp env counter ctx))))
+ (loop exp env counter ctx))
+ (map compute-alias vals)))
(env (fold extend-env env gensyms ops))
(body (loop body env counter ctx)))
(cond
@@ -858,7 +867,9 @@ top-level bindings from ENV and return the resulting
expression."
(($ <letrec> src in-order? names gensyms vals body)
;; Note the difference from the `let' case: here we use letrec*
;; so that the `visit' procedure for the new operands closes over
- ;; an environment that includes the operands.
+ ;; an environment that includes the operands. Also we don't try
+ ;; to elide aliases, because we can't sensibly reduce something
+ ;; like (letrec ((a b) (b a)) a).
(letrec* ((visit (lambda (exp counter ctx)
(loop exp env* counter ctx)))
(vars (map lookup-var gensyms))
@@ -940,14 +951,20 @@ top-level bindings from ENV and return the resulting
expression."
((test) (make-const #f #t))
(else exp)))
(($ <conditional> src condition subsequent alternate)
- (let ((condition (for-test condition)))
- (if (const? condition)
- (if (const-exp condition)
- (for-tail subsequent)
- (for-tail alternate))
- (make-conditional src condition
- (for-tail subsequent)
- (for-tail alternate)))))
+ (match (for-test condition)
+ (($ <const> _ val)
+ (if val
+ (for-tail subsequent)
+ (for-tail alternate)))
+ ;; Swap the arms of (if (not FOO) A B), to simplify.
+ (($ <primcall> _ 'not (c))
+ (make-conditional src c
+ (for-tail alternate)
+ (for-tail subsequent)))
+ (c
+ (make-conditional src c
+ (for-tail subsequent)
+ (for-tail alternate)))))
(($ <primcall> src '@call-with-values
(producer
($ <lambda> _ _
diff --git a/module/language/tree-il/primitives.scm
b/module/language/tree-il/primitives.scm
index 8aecb85..a44bc1a 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -29,8 +29,12 @@
expand-primitives!
effect-free-primitive? effect+exception-free-primitive?
constructor-primitive? accessor-primitive?
- singly-valued-primitive? equality-primitive?))
+ singly-valued-primitive? equality-primitive?
+ bailout-primitive?
+ negate-primitive))
+;; When adding to this, be sure to update *multiply-valued-primitives*
+;; if appropriate.
(define *interesting-primitive-names*
'(apply @apply
call-with-values @call-with-values
@@ -43,10 +47,14 @@
memq memv
= < > <= >= zero?
+ * - / 1- 1+ quotient remainder modulo
- ash logand logior logxor
+ ash logand logior logxor lognot
not
- pair? null? list? symbol? vector? string? struct?
- nil?
+ pair? null? list? symbol? vector? string? struct? number? char? nil?
+
+ complex? real? rational? inf? nan? integer? exact? inexact? even? odd?
+
+ char<? char<=? char>=? char>?
+
acons cons cons*
list vector
@@ -70,6 +78,8 @@
@prompt call-with-prompt @abort abort-to-prompt
make-prompt-tag
+ throw error scm-error
+
string-length string-ref string-set!
struct-vtable make-struct struct-ref struct-set!
@@ -123,7 +133,7 @@
'(vector-ref
car cdr
memq memv
- struct-vtable struct-ref
+ struct-ref
string-ref
bytevector-u8-ref bytevector-s8-ref
bytevector-u16-ref bytevector-u16-native-ref
@@ -139,10 +149,13 @@
`(values
eq? eqv? equal?
= < > <= >= zero?
+ ash logand logior logxor lognot
+ * - / 1- 1+ quotient remainder modulo
not
- pair? null? list? symbol? vector? struct? string?
- nil?
+ pair? null? list? symbol? vector? struct? string? number? char? nil
+ complex? real? rational? inf? nan? integer? exact? inexact? even? odd?
+ char<? char<=? char>=? char>?
+ struct-vtable
string-length vector-length
;; These all should get expanded out by expand-primitives!.
caar cadr cdar cddr
@@ -158,64 +171,42 @@
'(values
eq? eqv? equal?
not
- pair? null? list? symbol? vector? struct? string?
+ pair? null? list? symbol? vector? struct? string? number? char?
acons cons cons* list vector))
-;; Primitives that only return one value.
-(define *singly-valued-primitives*
- '(eq? eqv? equal?
- memq memv
- = < > <= >= zero?
- + * - / 1- 1+ quotient remainder modulo
- ash logand logior logxor
- not
- pair? null? list? symbol? vector? acons cons cons*
- nil?
- list vector
- car cdr
- set-car! set-cdr!
- caar cadr cdar cddr
- caaar caadr cadar caddr cdaar cdadr cddar cdddr
- caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
- cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
- vector-ref vector-set!
- variable-ref variable-set!
- variable-bound?
- fluid-ref fluid-set!
- make-prompt-tag
- struct? struct-vtable make-struct struct-ref struct-set!
- string-length string-ref string-set!
- bytevector-u8-ref bytevector-u8-set!
- bytevector-s8-ref bytevector-s8-set!
- u8vector-ref u8vector-set! s8vector-ref s8vector-set!
- bytevector-u16-ref bytevector-u16-set!
- bytevector-u16-native-ref bytevector-u16-native-set!
- bytevector-s16-ref bytevector-s16-set!
- bytevector-s16-native-ref bytevector-s16-native-set!
- u16vector-ref u16vector-set! s16vector-ref s16vector-set!
- bytevector-u32-ref bytevector-u32-set!
- bytevector-u32-native-ref bytevector-u32-native-set!
- bytevector-s32-ref bytevector-s32-set!
- bytevector-s32-native-ref bytevector-s32-native-set!
- u32vector-ref u32vector-set! s32vector-ref s32vector-set!
- bytevector-u64-ref bytevector-u64-set!
- bytevector-u64-native-ref bytevector-u64-native-set!
- bytevector-s64-ref bytevector-s64-set!
- bytevector-s64-native-ref bytevector-s64-native-set!
- u64vector-ref u64vector-set! s64vector-ref s64vector-set!
- bytevector-ieee-single-ref bytevector-ieee-single-set!
- bytevector-ieee-single-native-ref bytevector-ieee-single-native-set!
- bytevector-ieee-double-ref bytevector-ieee-double-set!
- bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!
- f32vector-ref f32vector-set! f64vector-ref f64vector-set!))
+;; Primitives that don't always return one value.
+(define *multiply-valued-primitives*
+ '(apply @apply
+ call-with-values @call-with-values
+ call-with-current-continuation @call-with-current-continuation
+ call/cc
+ dynamic-wind
+ @dynamic-wind
+ values
+ @prompt call-with-prompt @abort abort-to-prompt))
+
+;; Procedures that cause a nonlocal, non-resumable abort.
+(define *bailout-primitives*
+ '(throw error scm-error))
+
+;; Negatable predicates.
+(define *negatable-primitives*
+ '((even? . odd?)
+ (exact? . inexact?)
+ (< . >=)
+ (> . <=)
+ (char<? . char>=?)
+ (char>? . char<=?)))
(define *equality-primitives*
'(eq? eqv? equal?))
(define *effect-free-primitive-table* (make-hash-table))
(define *effect+exceptions-free-primitive-table* (make-hash-table))
-(define *singly-valued-primitive-table* (make-hash-table))
(define *equality-primitive-table* (make-hash-table))
+(define *multiply-valued-primitive-table* (make-hash-table))
+(define *bailout-primitive-table* (make-hash-table))
+(define *negatable-primitive-table* (make-hash-table))
(for-each (lambda (x)
(hashq-set! *effect-free-primitive-table* x #t))
@@ -223,12 +214,19 @@
(for-each (lambda (x)
(hashq-set! *effect+exceptions-free-primitive-table* x #t))
*effect+exception-free-primitives*)
-(for-each (lambda (x)
- (hashq-set! *singly-valued-primitive-table* x #t))
- *singly-valued-primitives*)
(for-each (lambda (x)
(hashq-set! *equality-primitive-table* x #t))
*equality-primitives*)
+(for-each (lambda (x)
+ (hashq-set! *multiply-valued-primitive-table* x #t))
+ *multiply-valued-primitives*)
+(for-each (lambda (x)
+ (hashq-set! *bailout-primitive-table* x #t))
+ *bailout-primitives*)
+(for-each (lambda (x)
+ (hashq-set! *negatable-primitive-table* (car x) (cdr x))
+ (hashq-set! *negatable-primitive-table* (cdr x) (car x)))
+ *negatable-primitives*)
(define (constructor-primitive? prim)
(memq prim *primitive-constructors*))
@@ -238,10 +236,14 @@
(hashq-ref *effect-free-primitive-table* prim))
(define (effect+exception-free-primitive? prim)
(hashq-ref *effect+exceptions-free-primitive-table* prim))
-(define (singly-valued-primitive? prim)
- (hashq-ref *singly-valued-primitive-table* prim))
(define (equality-primitive? prim)
(hashq-ref *equality-primitive-table* prim))
+(define (singly-valued-primitive? prim)
+ (not (hashq-ref *multiply-valued-primitive-table* prim)))
+(define (bailout-primitive? prim)
+ (hashq-ref *bailout-primitive-table* prim))
+(define (negate-primitive prim)
+ (hashq-ref *negatable-primitive-table* prim))
(define (resolve-primitives! x mod)
(define local-definitions
@@ -389,6 +391,18 @@
(x) (/ 1 x)
(x y z . rest) (/ x (* y z . rest)))
+(define-primitive-expander logior
+ () 0
+ (x) (logior x 0)
+ (x y) (logior x y)
+ (x y z . rest) (logior x (logior y z . rest)))
+
+(define-primitive-expander logand
+ () -1
+ (x) (logand x -1)
+ (x y) (logand x y)
+ (x y z . rest) (logand x (logand y z . rest)))
+
(define-primitive-expander caar (x) (car (car x)))
(define-primitive-expander cadr (x) (car (cdr x)))
(define-primitive-expander cdar (x) (cdr (car x)))
diff --git a/module/oop/goops/dispatch.scm b/module/oop/goops/dispatch.scm
index e433b86..b12ab15 100644
--- a/module/oop/goops/dispatch.scm
+++ b/module/oop/goops/dispatch.scm
@@ -1,4 +1,4 @@
-;;;; Copyright (C) 1999, 2000, 2001, 2003, 2006, 2009 Free Software
Foundation, Inc.
+;;;; Copyright (C) 1999, 2000, 2001, 2003, 2006, 2009, 2012 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,9 @@
'())
(acons gf gf-sym '()))))
(define (comp exp vals)
- (let ((p ((@ (system base compile) compile) exp #:env *dispatch-module*)))
+ (let ((p ((@ (system base compile) compile) exp
+ #:env *dispatch-module*
+ #:opts '(#:partial-eval? #f #:cse? #f))))
(apply p vals)))
;; kick it.
diff --git a/module/srfi/srfi-9.scm b/module/srfi/srfi-9.scm
index cb8dd0a..da71d1e 100644
--- a/module/srfi/srfi-9.scm
+++ b/module/srfi/srfi-9.scm
@@ -1,6 +1,6 @@
;;; srfi-9.scm --- define-record-type
-;; Copyright (C) 2001, 2002, 2006, 2009, 2010, 2011 Free Software
Foundation, Inc.
+;; Copyright (C) 2001, 2002, 2006, 2009, 2010, 2011, 2012 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
@@ -188,8 +188,12 @@
(let* ((fields (field-identifiers #'(field-spec ...)))
(field-count (length fields))
(layout (string-concatenate (make-list field-count "pw")))
- (indices (field-indices (map syntax->datum fields))))
+ (indices (field-indices (map syntax->datum fields)))
+ (ctor-name (syntax-case #'constructor-spec ()
+ ((ctor args ...) #'ctor))))
#`(begin
+ #,(constructor #'type-name #'constructor-spec indices)
+
(define type-name
(let ((rtd (make-struct/no-tail
record-type-vtable
@@ -198,13 +202,13 @@
'type-name
'#,fields)))
(set-struct-vtable-name! rtd 'type-name)
+ (struct-set! rtd (+ 2 vtable-offset-user) #,ctor-name)
rtd))
+
(define-inlinable (predicate-name obj)
(and (struct? obj)
(eq? (struct-vtable obj) type-name)))
- #,(constructor #'type-name #'constructor-spec indices)
-
#,@(accessors #'type-name #'(field-spec ...) indices)))))))
;;; srfi-9.scm ends here
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 8daa2e0..c20a977 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -40,6 +40,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/control.test \
tests/continuations.test \
tests/coverage.test \
+ tests/cse.test \
tests/curried-definitions.test \
tests/ecmascript.test \
tests/elisp.test \
@@ -76,6 +77,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/optargs.test \
tests/options.test \
tests/parameters.test \
+ tests/peval.test \
tests/print.test \
tests/procprop.test \
tests/procs.test \
@@ -165,7 +167,7 @@ SCM_TESTS = tests/00-initial-env.test \
EXTRA_DIST = \
guile-test \
- lib.scm \
+ test-suite/lib.scm \
$(SCM_TESTS) \
tests/rnrs-test-a.scm
ChangeLog-2008
diff --git a/test-suite/standalone/test-conversion.c
b/test-suite/standalone/test-conversion.c
index 09b74bf..700e5b3 100644
--- a/test-suite/standalone/test-conversion.c
+++ b/test-suite/standalone/test-conversion.c
@@ -1079,6 +1079,74 @@ test_locale_strings ()
}
static void
+test_to_utf8_stringn ()
+{
+ scm_t_wchar wstr[] = { 0x20, /* 0x20 */
+ 0xDF, /* 0xC3, 0x9F */
+ 0x65E5, /* 0xE6, 0x97, 0xA5 */
+ 0x1D400 }; /* 0xF0, 0x9D, 0x90, 0x80 */
+
+ SCM str0 = scm_from_utf32_stringn (wstr, 1); /* ASCII */
+ SCM str1 = scm_from_utf32_stringn (wstr, 2); /* Narrow */
+ SCM str2 = scm_from_utf32_stringn (wstr, 4); /* Wide */
+
+ char cstr0[] = { 0x20, 0 };
+ char cstr1[] = { 0x20, 0xC3, 0x9F, 0 };
+ char cstr2[] = { 0x20, 0xC3, 0x9F, 0xE6, 0x97, 0xA5,
+ 0xF0, 0x9D, 0x90, 0x80, 0 };
+ char *cstr;
+ size_t len;
+
+ /* Test conversion of ASCII string */
+ cstr = scm_to_utf8_stringn (str0, &len);
+ if (len + 1 != sizeof (cstr0) || memcmp (cstr, cstr0, len))
+ {
+ fprintf (stderr, "fail: scm_to_utf8_stringn (<ASCII>, &len)");
+ exit (EXIT_FAILURE);
+ }
+ free (cstr);
+ cstr = scm_to_utf8_stringn (str0, NULL);
+ if (memcmp (cstr, cstr0, len + 1))
+ {
+ fprintf (stderr, "fail: scm_to_utf8_stringn (<ASCII>, NULL)");
+ exit (EXIT_FAILURE);
+ }
+ free (cstr);
+
+ /* Test conversion of narrow string */
+ cstr = scm_to_utf8_stringn (str1, &len);
+ if (len + 1 != sizeof (cstr1) || memcmp (cstr, cstr1, len))
+ {
+ fprintf (stderr, "fail: scm_to_utf8_stringn (<NARROW>, &len)");
+ exit (EXIT_FAILURE);
+ }
+ free (cstr);
+ cstr = scm_to_utf8_stringn (str1, NULL);
+ if (memcmp (cstr, cstr1, len + 1))
+ {
+ fprintf (stderr, "fail: scm_to_utf8_stringn (<NARROW>, NULL)");
+ exit (EXIT_FAILURE);
+ }
+ free (cstr);
+
+ /* Test conversion of wide string */
+ cstr = scm_to_utf8_stringn (str2, &len);
+ if (len + 1 != sizeof (cstr2) || memcmp (cstr, cstr2, len))
+ {
+ fprintf (stderr, "fail: scm_to_utf8_stringn (<WIDE>, &len)");
+ exit (EXIT_FAILURE);
+ }
+ free (cstr);
+ cstr = scm_to_utf8_stringn (str2, NULL);
+ if (memcmp (cstr, cstr2, len + 1))
+ {
+ fprintf (stderr, "fail: scm_to_utf8_stringn (<WIDE>, NULL)");
+ exit (EXIT_FAILURE);
+ }
+ free (cstr);
+}
+
+static void
test_is_exact ()
{
if (1 != scm_is_exact (scm_c_eval_string ("3")))
@@ -1122,6 +1190,7 @@ tests (void *data, int argc, char **argv)
test_from_double ();
test_to_double ();
test_locale_strings ();
+ test_to_utf8_stringn ();
test_is_exact ();
test_is_inexact ();
}
diff --git a/test-suite/lib.scm b/test-suite/test-suite/lib.scm
similarity index 100%
rename from test-suite/lib.scm
rename to test-suite/test-suite/lib.scm
diff --git a/test-suite/tests/asm-to-bytecode.test
b/test-suite/tests/asm-to-bytecode.test
index 9a8178c..52bc7e1 100644
--- a/test-suite/tests/asm-to-bytecode.test
+++ b/test-suite/tests/asm-to-bytecode.test
@@ -16,7 +16,7 @@
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-(define-module (test-suite tests asm-to-bytecode)
+(define-module (tests asm-to-bytecode)
#:use-module (rnrs bytevectors)
#:use-module ((rnrs io ports) #:select (open-bytevector-output-port))
#:use-module (test-suite lib)
diff --git a/test-suite/tests/brainfuck.test b/test-suite/tests/brainfuck.test
index f612fb5..cdbceaa 100644
--- a/test-suite/tests/brainfuck.test
+++ b/test-suite/tests/brainfuck.test
@@ -14,7 +14,7 @@
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-(define-module (test-suite tests brainfuck)
+(define-module (tests brainfuck)
#:use-module (test-suite lib)
#:use-module (system base compile))
diff --git a/test-suite/tests/bytevectors.test
b/test-suite/tests/bytevectors.test
index 3007434..4ba5012 100644
--- a/test-suite/tests/bytevectors.test
+++ b/test-suite/tests/bytevectors.test
@@ -1,6 +1,6 @@
;;;; bytevectors.test --- R6RS bytevectors. -*- mode: scheme; coding: utf-8;
-*-
;;;;
-;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
;;;; Ludovic Courtès
;;;;
;;;; This library is free software; you can redistribute it and/or
@@ -325,6 +325,18 @@
(with-test-prefix/c&e "2.8 Operations on IEEE-754 Representations"
+ (pass-if "single, little endian"
+ ;; http://bugs.gnu.org/11310
+ (let ((b (make-bytevector 4)))
+ (bytevector-ieee-single-set! b 0 1.0 (endianness little))
+ (equal? #vu8(0 0 128 63) b)))
+
+ (pass-if "single, big endian"
+ ;; http://bugs.gnu.org/11310
+ (let ((b (make-bytevector 4)))
+ (bytevector-ieee-single-set! b 0 1.0 (endianness big))
+ (equal? #vu8(63 128 0 0) b)))
+
(pass-if "bytevector-ieee-single-native-{ref,set!}"
(let ((b (make-bytevector 4))
(number 3.00))
@@ -348,6 +360,18 @@
(equal? (bytevector-ieee-single-ref b 1 (endianness little))
(bytevector-ieee-single-ref b 5 (endianness big)))))
+ (pass-if "double, little endian"
+ ;; http://bugs.gnu.org/11310
+ (let ((b (make-bytevector 8)))
+ (bytevector-ieee-double-set! b 0 1.0 (endianness little))
+ (equal? #vu8(0 0 0 0 0 0 240 63) b)))
+
+ (pass-if "double, big endian"
+ ;; http://bugs.gnu.org/11310
+ (let ((b (make-bytevector 8)))
+ (bytevector-ieee-double-set! b 0 1.0 (endianness big))
+ (equal? #vu8(63 240 0 0 0 0 0 0) b)))
+
(pass-if "bytevector-ieee-double-native-{ref,set!}"
(let ((b (make-bytevector 8))
(number 3.14))
@@ -653,3 +677,7 @@
(pass-if "bitvector > 8"
(let ((bv (uniform-array->bytevector (make-bitvector 9 #t))))
(= (bytevector-length bv) 2))))
+
+;;; Local Variables:
+;;; eval: (put 'with-test-prefix/c&e 'scheme-indent-function 1)
+;;; End:
diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test
index ee688c0..619b167 100644
--- a/test-suite/tests/compiler.test
+++ b/test-suite/tests/compiler.test
@@ -1,5 +1,5 @@
;;;; compiler.test --- tests for the compiler -*- scheme -*-
-;;;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2008, 2009, 2010, 2011, 2012 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
@@ -15,7 +15,7 @@
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-(define-module (test-suite tests compiler)
+(define-module (tests compiler)
#:use-module (test-suite lib)
#:use-module (test-suite guile-test)
#:use-module (system base compile)
diff --git a/test-suite/tests/cse.test b/test-suite/tests/cse.test
new file mode 100644
index 0000000..c2d2ccc
--- /dev/null
+++ b/test-suite/tests/cse.test
@@ -0,0 +1,255 @@
+;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
+;;;; Andy Wingo <address@hidden> --- May 2009
+;;;;
+;;;; Copyright (C) 2009, 2010, 2011, 2012 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
+
+(define-module (test-suite tree-il)
+ #:use-module (test-suite lib)
+ #:use-module (system base compile)
+ #:use-module (system base pmatch)
+ #:use-module (system base message)
+ #:use-module (language tree-il)
+ #:use-module (language tree-il primitives)
+ #:use-module (language tree-il cse)
+ #:use-module (language tree-il peval)
+ #:use-module (language glil)
+ #:use-module (srfi srfi-13))
+
+(define-syntax pass-if-cse
+ (syntax-rules ()
+ ((_ in pat)
+ (pass-if 'in
+ (let ((evaled (unparse-tree-il
+ (cse
+ (peval
+ (expand-primitives!
+ (resolve-primitives!
+ (compile 'in #:from 'scheme #:to 'tree-il)
+ (current-module))))))))
+ (pmatch evaled
+ (pat #t)
+ (_ (pk 'cse-mismatch)
+ ((@ (ice-9 pretty-print) pretty-print)
+ 'in)
+ (newline)
+ ((@ (ice-9 pretty-print) pretty-print)
+ evaled)
+ (newline)
+ ((@ (ice-9 pretty-print) pretty-print)
+ 'pat)
+ (newline)
+ #f)))))))
+
+
+(with-test-prefix "cse"
+
+ ;; The eq? propagates, and (if TEST #t #f) folds to TEST if TEST is
+ ;; boolean-valued.
+ (pass-if-cse
+ (lambda (x y)
+ (and (eq? x y)
+ (eq? x y)))
+ (lambda _
+ (lambda-case
+ (((x y) #f #f #f () (_ _))
+ (primcall eq? (lexical x _) (lexical y _))))))
+
+ ;; The eq? propagates, and (if TEST #f #t) folds to (not TEST).
+ (pass-if-cse
+ (lambda (x y)
+ (if (eq? x y) #f #t))
+ (lambda _
+ (lambda-case
+ (((x y) #f #f #f () (_ _))
+ (primcall not
+ (primcall eq? (lexical x _) (lexical y _)))))))
+
+ ;; (if TEST (not TEST) #f)
+ ;; => (if TEST #f #f)
+ ;; => (begin TEST #f)
+ ;; => #f
+ (pass-if-cse
+ (lambda (x y)
+ (and (eq? x y) (not (eq? x y))))
+ (lambda _
+ (lambda-case
+ (((x y) #f #f #f () (_ _))
+ (const #f)))))
+
+ ;; (if TEST #f TEST) => (if TEST #f #f) => ...
+ (pass-if-cse
+ (lambda (x y)
+ (if (eq? x y) #f (eq? x y)))
+ (lambda _
+ (lambda-case
+ (((x y) #f #f #f () (_ _))
+ (const #f)))))
+
+ ;; The same, but side-effecting primitives do not propagate.
+ (pass-if-cse
+ (lambda (x y)
+ (and (set-car! x y) (not (set-car! x y))))
+ (lambda _
+ (lambda-case
+ (((x y) #f #f #f () (_ _))
+ (if (primcall set-car!
+ (lexical x _)
+ (lexical y _))
+ (primcall not
+ (primcall set-car!
+ (lexical x _)
+ (lexical y _)))
+ (const #f))))))
+
+ ;; Primitives that access mutable memory can propagate, as long as
+ ;; there is no intervening mutation.
+ (pass-if-cse
+ (lambda (x y)
+ (and (string-ref x y)
+ (begin
+ (string-ref x y)
+ (not (string-ref x y)))))
+ (lambda _
+ (lambda-case
+ (((x y) #f #f #f () (_ _))
+ (seq (primcall string-ref
+ (lexical x _)
+ (lexical y _))
+ (const #f))))))
+
+ ;; However, expressions with dependencies on effects do not propagate
+ ;; through a lambda.
+ (pass-if-cse
+ (lambda (x y)
+ (and (string-ref x y)
+ (lambda ()
+ (and (string-ref x y) #t))))
+ (lambda _
+ (lambda-case
+ (((x y) #f #f #f () (_ _))
+ (if (primcall string-ref
+ (lexical x _)
+ (lexical y _))
+ (lambda _
+ (lambda-case
+ ((() #f #f #f () ())
+ (if (primcall string-ref
+ (lexical x _)
+ (lexical y _))
+ (const #t)
+ (const #f)))))
+ (const #f))))))
+
+ ;; A mutation stops the propagation.
+ (pass-if-cse
+ (lambda (x y)
+ (and (string-ref x y)
+ (begin
+ (string-set! x #\!)
+ (not (string-ref x y)))))
+ (lambda _
+ (lambda-case
+ (((x y) #f #f #f () (_ _))
+ (if (primcall string-ref
+ (lexical x _)
+ (lexical y _))
+ (seq (primcall string-set!
+ (lexical x _)
+ (const #\!))
+ (primcall not
+ (primcall string-ref
+ (lexical x _)
+ (lexical y _))))
+ (const #f))))))
+
+ ;; Predicates are only added to the database if they are in a
+ ;; predicate context.
+ (pass-if-cse
+ (lambda (x y)
+ (begin (eq? x y) (eq? x y)))
+ (lambda _
+ (lambda-case
+ (((x y) #f #f #f () (_ _))
+ (primcall eq? (lexical x _) (lexical y _))))))
+
+ ;; Conditional bailouts do cause primitives to be added to the DB.
+ (pass-if-cse
+ (lambda (x y)
+ (begin (unless (eq? x y) (throw 'foo)) (eq? x y)))
+ (lambda _
+ (lambda-case
+ (((x y) #f #f #f () (_ _))
+ (seq (if (primcall eq?
+ (lexical x _) (lexical y _))
+ (void)
+ (primcall throw (const foo)))
+ (const #t))))))
+
+ ;; A chain of tests in a conditional bailout add data to the DB
+ ;; correctly.
+ (pass-if-cse
+ (lambda (x y)
+ (begin
+ (unless (and (struct? x) (eq? (struct-vtable x) x-vtable))
+ (throw 'foo))
+ (if (and (struct? x) (eq? (struct-vtable x) x-vtable))
+ (struct-ref x y)
+ (throw 'bar))))
+ (lambda _
+ (lambda-case
+ (((x y) #f #f #f () (_ _))
+ (seq (if (if (primcall struct? (lexical x _))
+ (primcall eq?
+ (primcall struct-vtable
+ (lexical x _))
+ (toplevel x-vtable))
+ (const #f))
+ (void)
+ (primcall throw (const foo)))
+ (primcall struct-ref (lexical x _) (lexical y _)))))))
+
+ ;; Strict argument evaluation also adds info to the DB.
+ (pass-if-cse
+ (lambda (x)
+ ((lambda (z)
+ (+ z (if (and (struct? x) (eq? (struct-vtable x) x-vtable))
+ (struct-ref x 2)
+ (throw 'bar))))
+ (if (and (struct? x) (eq? (struct-vtable x) x-vtable))
+ (struct-ref x 1)
+ (throw 'foo))))
+
+ (lambda _
+ (lambda-case
+ (((x) #f #f #f () (_))
+ (let (z) (_) ((if (if (primcall struct? (lexical x _))
+ (primcall eq?
+ (primcall struct-vtable
+ (lexical x _))
+ (toplevel x-vtable))
+ (const #f))
+ (primcall struct-ref (lexical x _) (const 1))
+ (primcall throw (const foo))))
+ (primcall + (lexical z _)
+ (primcall struct-ref (lexical x _) (const 2))))))))
+
+ ;; Replacing named expressions with lexicals.
+ (pass-if-cse
+ (let ((x (car y)))
+ (cons x (car y)))
+ (let (x) (_) ((primcall car (toplevel y)))
+ (primcall cons (lexical x _) (lexical x _)))))
diff --git a/test-suite/tests/ftw.test b/test-suite/tests/ftw.test
index be983a1..805c779 100644
--- a/test-suite/tests/ftw.test
+++ b/test-suite/tests/ftw.test
@@ -90,6 +90,9 @@
(define %test-dir
(string-append %top-srcdir "/test-suite"))
+(define %test-suite-lib-dir
+ (string-append %top-srcdir "/test-suite/test-suite"))
+
(define (make-file-tree dir tree)
"Make file system TREE at DIR."
(define (touch file)
@@ -152,7 +155,8 @@
(let ((enter? (lambda (n s r)
;; Enter only `test-suite/tests/'.
(if (member `(down ,%test-dir) r)
- (string=? (basename n) "tests")
+ (or (string=? (basename n) "tests")
+ (string=? (basename n) "test-suite"))
(string=? (basename n) "test-suite"))))
(leaf (lambda (n s r) (cons `(leaf ,n) r)))
(down (lambda (n s r) (cons `(down ,n) r)))
@@ -167,7 +171,7 @@
((('down (? (cut string=? <> %test-dir)))
between ...
('up (? (cut string=? <> %test-dir))))
- (and (any (match-lambda (('leaf (= basename "lib.scm")) #t) (_ #f))
+ (and (any (match-lambda (('down (= basename "test-suite")) #t) (_ #f))
between)
(any (match-lambda (('down (= basename "tests")) #t) (_ #f))
between)
@@ -195,7 +199,7 @@
(up (lambda (n s r) (cons `(up ,n) r)))
(skip (lambda (n s r) (cons `(skip ,n) r)))
(error (lambda (n s e r) (cons `(error ,n) r)))
- (name (string-append %test-dir "/lib.scm")))
+ (name (string-append %test-suite-lib-dir "/lib.scm")))
(equal? (file-system-fold enter? leaf down up skip error '() name)
`((leaf ,name)))))
diff --git a/test-suite/tests/gc.test b/test-suite/tests/gc.test
index e13c8f7..a969752 100644
--- a/test-suite/tests/gc.test
+++ b/test-suite/tests/gc.test
@@ -16,7 +16,7 @@
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-(define-module (test-suite tests gc)
+(define-module (tests gc)
#:use-module (ice-9 documentation)
#:use-module (test-suite lib)
#:use-module ((system base compile) #:select (compile)))
diff --git a/test-suite/tests/match.test b/test-suite/tests/match.test
index 8b19ff7..6bf5bdd 100644
--- a/test-suite/tests/match.test
+++ b/test-suite/tests/match.test
@@ -1,6 +1,6 @@
;;;; match.test --- (ice-9 match) -*- mode: scheme; coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2011, 2012 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
@@ -205,4 +205,4 @@
(test-end (syntax-rules ()
((_) #t))))
(with-test-prefix "upstream tests"
- (include-from-path "test-suite/tests/match.test.upstream")))
+ (include-from-path "tests/match.test.upstream")))
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
new file mode 100644
index 0000000..2bd8919
--- /dev/null
+++ b/test-suite/tests/peval.test
@@ -0,0 +1,1015 @@
+;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
+;;;; Andy Wingo <address@hidden> --- May 2009
+;;;;
+;;;; Copyright (C) 2009, 2010, 2011, 2012 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
+
+(define-module (test-suite tree-il)
+ #:use-module (test-suite lib)
+ #:use-module (system base compile)
+ #:use-module (system base pmatch)
+ #:use-module (system base message)
+ #:use-module (language tree-il)
+ #:use-module (language tree-il primitives)
+ #:use-module (language glil)
+ #:use-module (srfi srfi-13))
+
+(define peval
+ ;; The partial evaluator.
+ (@@ (language tree-il optimize) peval))
+
+(define-syntax pass-if-peval
+ (syntax-rules (resolve-primitives)
+ ((_ in pat)
+ (pass-if-peval in pat
+ (expand-primitives!
+ (resolve-primitives!
+ (compile 'in #:from 'scheme #:to 'tree-il)
+ (current-module)))))
+ ((_ in pat code)
+ (pass-if 'in
+ (let ((evaled (unparse-tree-il (peval code))))
+ (pmatch evaled
+ (pat #t)
+ (_ (pk 'peval-mismatch)
+ ((@ (ice-9 pretty-print) pretty-print)
+ 'in)
+ (newline)
+ ((@ (ice-9 pretty-print) pretty-print)
+ evaled)
+ (newline)
+ ((@ (ice-9 pretty-print) pretty-print)
+ 'pat)
+ (newline)
+ #f)))))))
+
+
+(with-test-prefix "partial evaluation"
+
+ (pass-if-peval
+ ;; First order, primitive.
+ (let ((x 1) (y 2)) (+ x y))
+ (const 3))
+
+ (pass-if-peval
+ ;; First order, thunk.
+ (let ((x 1) (y 2))
+ (let ((f (lambda () (+ x y))))
+ (f)))
+ (const 3))
+
+ (pass-if-peval
+ ;; First order, let-values (requires primitive expansion for
+ ;; `call-with-values'.)
+ (let ((x 0))
+ (call-with-values
+ (lambda () (if (zero? x) (values 1 2) (values 3 4)))
+ (lambda (a b)
+ (+ a b))))
+ (const 3))
+
+ (pass-if-peval
+ ;; First order, multiple values.
+ (let ((x 1) (y 2))
+ (values x y))
+ (primcall values (const 1) (const 2)))
+
+ (pass-if-peval
+ ;; First order, multiple values truncated.
+ (let ((x (values 1 'a)) (y 2))
+ (values x y))
+ (primcall values (const 1) (const 2)))
+
+ (pass-if-peval
+ ;; First order, multiple values truncated.
+ (or (values 1 2) 3)
+ (const 1))
+
+ (pass-if-peval
+ ;; First order, coalesced, mutability preserved.
+ (cons 0 (cons 1 (cons 2 (list 3 4 5))))
+ (primcall list
+ (const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
+
+ (pass-if-peval
+ ;; First order, coalesced, immutability preserved.
+ (cons 0 (cons 1 (cons 2 '(3 4 5))))
+ (primcall cons (const 0)
+ (primcall cons (const 1)
+ (primcall cons (const 2)
+ (const (3 4 5))))))
+
+ ;; These two tests doesn't work any more because we changed the way we
+ ;; deal with constants -- now the algorithm will see a construction as
+ ;; being bound to the lexical, so it won't propagate it. It can't
+ ;; even propagate it in the case that it is only referenced once,
+ ;; because:
+ ;;
+ ;; (let ((x (cons 1 2))) (lambda () x))
+ ;;
+ ;; is not the same as
+ ;;
+ ;; (lambda () (cons 1 2))
+ ;;
+ ;; Perhaps if we determined that not only was it only referenced once,
+ ;; it was not closed over by a lambda, then we could propagate it, and
+ ;; re-enable these two tests.
+ ;;
+ #;
+ (pass-if-peval
+ ;; First order, mutability preserved.
+ (let loop ((i 3) (r '()))
+ (if (zero? i)
+ r
+ (loop (1- i) (cons (cons i i) r))))
+ (primcall list
+ (primcall cons (const 1) (const 1))
+ (primcall cons (const 2) (const 2))
+ (primcall cons (const 3) (const 3))))
+ ;;
+ ;; See above.
+ #;
+ (pass-if-peval
+ ;; First order, evaluated.
+ (let loop ((i 7)
+ (r '()))
+ (if (<= i 0)
+ (car r)
+ (loop (1- i) (cons i r))))
+ (const 1))
+
+ ;; Instead here are tests for what happens for the above cases: they
+ ;; unroll but they don't fold.
+ (pass-if-peval
+ (let loop ((i 3) (r '()))
+ (if (zero? i)
+ r
+ (loop (1- i) (cons (cons i i) r))))
+ (let (r) (_)
+ ((primcall list
+ (primcall cons (const 3) (const 3))))
+ (let (r) (_)
+ ((primcall cons
+ (primcall cons (const 2) (const 2))
+ (lexical r _)))
+ (primcall cons
+ (primcall cons (const 1) (const 1))
+ (lexical r _)))))
+
+ ;; See above.
+ (pass-if-peval
+ (let loop ((i 4)
+ (r '()))
+ (if (<= i 0)
+ (car r)
+ (loop (1- i) (cons i r))))
+ (let (r) (_)
+ ((primcall list (const 4)))
+ (let (r) (_)
+ ((primcall cons
+ (const 3)
+ (lexical r _)))
+ (let (r) (_)
+ ((primcall cons
+ (const 2)
+ (lexical r _)))
+ (let (r) (_)
+ ((primcall cons
+ (const 1)
+ (lexical r _)))
+ (primcall car
+ (lexical r _)))))))
+
+ ;; Static sums.
+ (pass-if-peval
+ (let loop ((l '(1 2 3 4)) (sum 0))
+ (if (null? l)
+ sum
+ (loop (cdr l) (+ sum (car l)))))
+ (const 10))
+
+ (pass-if-peval
+ (let ((string->chars
+ (lambda (s)
+ (define (char-at n)
+ (string-ref s n))
+ (define (len)
+ (string-length s))
+ (let loop ((i 0))
+ (if (< i (len))
+ (cons (char-at i)
+ (loop (1+ i)))
+ '())))))
+ (string->chars "yo"))
+ (primcall list (const #\y) (const #\o)))
+
+ (pass-if-peval
+ ;; Primitives in module-refs are resolved (the expansion of `pmatch'
+ ;; below leads to calls to (@@ (system base pmatch) car) and
+ ;; similar, which is what we want to be inlined.)
+ (begin
+ (use-modules (system base pmatch))
+ (pmatch '(a b c d)
+ ((a b . _)
+ #t)))
+ (seq (call . _)
+ (const #t)))
+
+ (pass-if-peval
+ ;; Mutability preserved.
+ ((lambda (x y z) (list x y z)) 1 2 3)
+ (primcall list (const 1) (const 2) (const 3)))
+
+ (pass-if-peval
+ ;; Don't propagate effect-free expressions that operate on mutable
+ ;; objects.
+ (let* ((x (list 1))
+ (y (car x)))
+ (set-car! x 0)
+ y)
+ (let (x) (_) ((primcall list (const 1)))
+ (let (y) (_) ((primcall car (lexical x _)))
+ (seq
+ (primcall set-car! (lexical x _) (const 0))
+ (lexical y _)))))
+
+ (pass-if-peval
+ ;; Don't propagate effect-free expressions that operate on objects we
+ ;; don't know about.
+ (let ((y (car x)))
+ (set-car! x 0)
+ y)
+ (let (y) (_) ((primcall car (toplevel x)))
+ (seq
+ (primcall set-car! (toplevel x) (const 0))
+ (lexical y _))))
+
+ (pass-if-peval
+ ;; Infinite recursion
+ ((lambda (x) (x x)) (lambda (x) (x x)))
+ (let (x) (_)
+ ((lambda _
+ (lambda-case
+ (((x) _ _ _ _ _)
+ (call (lexical x _) (lexical x _))))))
+ (call (lexical x _) (lexical x _))))
+
+ (pass-if-peval
+ ;; First order, aliased primitive.
+ (let* ((x *) (y (x 1 2))) y)
+ (const 2))
+
+ (pass-if-peval
+ ;; First order, shadowed primitive.
+ (begin
+ (define (+ x y) (pk x y))
+ (+ 1 2))
+ (seq
+ (define +
+ (lambda (_)
+ (lambda-case
+ (((x y) #f #f #f () (_ _))
+ (call (toplevel pk) (lexical x _) (lexical y _))))))
+ (call (toplevel +) (const 1) (const 2))))
+
+ (pass-if-peval
+ ;; First-order, effects preserved.
+ (let ((x 2))
+ (do-something!)
+ x)
+ (seq
+ (call (toplevel do-something!))
+ (const 2)))
+
+ (pass-if-peval
+ ;; First order, residual bindings removed.
+ (let ((x 2) (y 3))
+ (* (+ x y) z))
+ (primcall * (const 5) (toplevel z)))
+
+ (pass-if-peval
+ ;; First order, with lambda.
+ (define (foo x)
+ (define (bar z) (* z z))
+ (+ x (bar 3)))
+ (define foo
+ (lambda (_)
+ (lambda-case
+ (((x) #f #f #f () (_))
+ (primcall + (lexical x _) (const 9)))))))
+
+ (pass-if-peval
+ ;; First order, with lambda inlined & specialized twice.
+ (let ((f (lambda (x y)
+ (+ (* x top) y)))
+ (x 2)
+ (y 3))
+ (+ (* x (f x y))
+ (f something x)))
+ (primcall +
+ (primcall *
+ (const 2)
+ (primcall + ; (f 2 3)
+ (primcall *
+ (const 2)
+ (toplevel top))
+ (const 3)))
+ (let (x) (_) ((toplevel something)) ; (f something 2)
+ ;; `something' is not const, so preserve order of
+ ;; effects with a lexical binding.
+ (primcall +
+ (primcall *
+ (lexical x _)
+ (toplevel top))
+ (const 2)))))
+
+ (pass-if-peval
+ ;; First order, with lambda inlined & specialized 3 times.
+ (let ((f (lambda (x y) (if (> x 0) y x))))
+ (+ (f -1 0)
+ (f 1 0)
+ (f -1 y)
+ (f 2 y)
+ (f z y)))
+ (primcall
+ +
+ (const -1) ; (f -1 0)
+ (primcall
+ +
+ (const 0) ; (f 1 0)
+ (primcall
+ +
+ (seq (toplevel y) (const -1)) ; (f -1 y)
+ (primcall
+ +
+ (toplevel y) ; (f 2 y)
+ (let (x y) (_ _) ((toplevel z) (toplevel y)) ; (f z y)
+ (if (primcall > (lexical x _) (const 0))
+ (lexical y _)
+ (lexical x _))))))))
+
+ (pass-if-peval
+ ;; First order, conditional.
+ (let ((y 2))
+ (lambda (x)
+ (if (> y 0)
+ (display x)
+ 'never-reached)))
+ (lambda ()
+ (lambda-case
+ (((x) #f #f #f () (_))
+ (call (toplevel display) (lexical x _))))))
+
+ (pass-if-peval
+ ;; First order, recursive procedure.
+ (letrec ((fibo (lambda (n)
+ (if (<= n 1)
+ n
+ (+ (fibo (- n 1))
+ (fibo (- n 2)))))))
+ (fibo 4))
+ (const 3))
+
+ (pass-if-peval
+ ;; Don't propagate toplevel references, as intervening expressions
+ ;; could alter their bindings.
+ (let ((x top))
+ (foo)
+ x)
+ (let (x) (_) ((toplevel top))
+ (seq
+ (call (toplevel foo))
+ (lexical x _))))
+
+ (pass-if-peval
+ ;; Higher order.
+ ((lambda (f x)
+ (f (* (car x) (cadr x))))
+ (lambda (x)
+ (+ x 1))
+ '(2 3))
+ (const 7))
+
+ (pass-if-peval
+ ;; Higher order with optional argument (default value).
+ ((lambda* (f x #:optional (y 0))
+ (+ y (f (* (car x) (cadr x)))))
+ (lambda (x)
+ (+ x 1))
+ '(2 3))
+ (const 7))
+
+ (pass-if-peval
+ ;; Higher order with optional argument (caller-supplied value).
+ ((lambda* (f x #:optional (y 0))
+ (+ y (f (* (car x) (cadr x)))))
+ (lambda (x)
+ (+ x 1))
+ '(2 3)
+ 35)
+ (const 42))
+
+ (pass-if-peval
+ ;; Higher order with optional argument (side-effecting default
+ ;; value).
+ ((lambda* (f x #:optional (y (foo)))
+ (+ y (f (* (car x) (cadr x)))))
+ (lambda (x)
+ (+ x 1))
+ '(2 3))
+ (let (y) (_) ((call (toplevel foo)))
+ (primcall + (lexical y _) (const 7))))
+
+ (pass-if-peval
+ ;; Higher order with optional argument (caller-supplied value).
+ ((lambda* (f x #:optional (y (foo)))
+ (+ y (f (* (car x) (cadr x)))))
+ (lambda (x)
+ (+ x 1))
+ '(2 3)
+ 35)
+ (const 42))
+
+ (pass-if-peval
+ ;; Higher order.
+ ((lambda (f) (f x)) (lambda (x) x))
+ (toplevel x))
+
+ (pass-if-peval
+ ;; Bug reported at
+ ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>.
+ (let ((fold (lambda (f g) (f (g top)))))
+ (fold 1+ (lambda (x) x)))
+ (primcall 1+ (toplevel top)))
+
+ (pass-if-peval
+ ;; Procedure not inlined when residual code contains recursive calls.
+ ;; <http://debbugs.gnu.org/9542>
+ (letrec ((fold (lambda (f x3 b null? car cdr)
+ (if (null? x3)
+ b
+ (f (car x3) (fold f (cdr x3) b null? car cdr))))))
+ (fold * x 1 zero? (lambda (x1) x1) (lambda (x2) (- x2 1))))
+ (letrec (fold) (_) (_)
+ (call (lexical fold _)
+ (primitive *)
+ (toplevel x)
+ (const 1)
+ (primitive zero?)
+ (lambda ()
+ (lambda-case
+ (((x1) #f #f #f () (_))
+ (lexical x1 _))))
+ (lambda ()
+ (lambda-case
+ (((x2) #f #f #f () (_))
+ (primcall 1- (lexical x2 _))))))))
+
+ (pass-if "inlined lambdas are alpha-renamed"
+ ;; In this example, `make-adder' is inlined more than once; thus,
+ ;; they should use different gensyms for their arguments, because
+ ;; the various optimization passes assume uniquely-named variables.
+ ;;
+ ;; Bug reported at
+ ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html> and
+ ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00029.html>.
+ (pmatch (unparse-tree-il
+ (peval (expand-primitives!
+ (resolve-primitives!
+ (compile
+ '(let ((make-adder
+ (lambda (x) (lambda (y) (+ x y)))))
+ (cons (make-adder 1) (make-adder 2)))
+ #:to 'tree-il)
+ (current-module)))))
+ ((primcall cons
+ (lambda ()
+ (lambda-case
+ (((y) #f #f #f () (,gensym1))
+ (primcall +
+ (const 1)
+ (lexical y ,ref1)))))
+ (lambda ()
+ (lambda-case
+ (((y) #f #f #f () (,gensym2))
+ (primcall +
+ (const 2)
+ (lexical y ,ref2))))))
+ (and (eq? gensym1 ref1)
+ (eq? gensym2 ref2)
+ (not (eq? gensym1 gensym2))))
+ (_ #f)))
+
+ (pass-if-peval
+ ;; Unused letrec bindings are pruned.
+ (letrec ((a (lambda () (b)))
+ (b (lambda () (a)))
+ (c (lambda (x) x)))
+ (c 10))
+ (const 10))
+
+ (pass-if-peval
+ ;; Unused letrec bindings are pruned.
+ (letrec ((a (foo!))
+ (b (lambda () (a)))
+ (c (lambda (x) x)))
+ (c 10))
+ (seq (call (toplevel foo!))
+ (const 10)))
+
+ (pass-if-peval
+ ;; Higher order, mutually recursive procedures.
+ (letrec ((even? (lambda (x)
+ (or (= 0 x)
+ (odd? (- x 1)))))
+ (odd? (lambda (x)
+ (not (even? x)))))
+ (and (even? 4) (odd? 7)))
+ (const #t))
+
+ (pass-if-peval
+ ;; Memv with constants.
+ (memv 1 '(3 2 1))
+ (const '(1)))
+
+ (pass-if-peval
+ ;; Memv with non-constant list. It could fold but doesn't
+ ;; currently.
+ (memv 1 (list 3 2 1))
+ (primcall memv
+ (const 1)
+ (primcall list (const 3) (const 2) (const 1))))
+
+ (pass-if-peval
+ ;; Memv with non-constant key, constant list, test context
+ (case foo
+ ((3 2 1) 'a)
+ (else 'b))
+ (let (key) (_) ((toplevel foo))
+ (if (if (primcall eqv? (lexical key _) (const 3))
+ (const #t)
+ (if (primcall eqv? (lexical key _) (const 2))
+ (const #t)
+ (primcall eqv? (lexical key _) (const 1))))
+ (const a)
+ (const b))))
+
+ (pass-if-peval
+ ;; Memv with non-constant key, empty list, test context.
+ (case foo
+ (() 'a)
+ (else 'b))
+ (seq (toplevel foo) (const 'b)))
+
+ ;;
+ ;; Below are cases where constant propagation should bail out.
+ ;;
+
+ (pass-if-peval
+ ;; Non-constant lexical is not propagated.
+ (let ((v (make-vector 6 #f)))
+ (lambda (n)
+ (vector-set! v n n)))
+ (let (v) (_)
+ ((call (toplevel make-vector) (const 6) (const #f)))
+ (lambda ()
+ (lambda-case
+ (((n) #f #f #f () (_))
+ (primcall vector-set!
+ (lexical v _) (lexical n _) (lexical n _)))))))
+
+ (pass-if-peval
+ ;; Mutable lexical is not propagated.
+ (let ((v (vector 1 2 3)))
+ (lambda ()
+ v))
+ (let (v) (_)
+ ((primcall vector (const 1) (const 2) (const 3)))
+ (lambda ()
+ (lambda-case
+ ((() #f #f #f () ())
+ (lexical v _))))))
+
+ (pass-if-peval
+ ;; Lexical that is not provably pure is not inlined nor propagated.
+ (let* ((x (if (> p q) (frob!) (display 'chbouib)))
+ (y (* x 2)))
+ (+ x x y))
+ (let (x) (_) ((if (primcall > (toplevel p) (toplevel q))
+ (call (toplevel frob!))
+ (call (toplevel display) (const chbouib))))
+ (let (y) (_) ((primcall * (lexical x _) (const 2)))
+ (primcall +
+ (lexical x _)
+ (primcall + (lexical x _) (lexical y _))))))
+
+ (pass-if-peval
+ ;; Non-constant arguments not propagated to lambdas.
+ ((lambda (x y z)
+ (vector-set! x 0 0)
+ (set-car! y 0)
+ (set-cdr! z '()))
+ (vector 1 2 3)
+ (make-list 10)
+ (list 1 2 3))
+ (let (x y z) (_ _ _)
+ ((primcall vector (const 1) (const 2) (const 3))
+ (call (toplevel make-list) (const 10))
+ (primcall list (const 1) (const 2) (const 3)))
+ (seq
+ (primcall vector-set!
+ (lexical x _) (const 0) (const 0))
+ (seq (primcall set-car!
+ (lexical y _) (const 0))
+ (primcall set-cdr!
+ (lexical z _) (const ()))))))
+
+ (pass-if-peval
+ (let ((foo top-foo) (bar top-bar))
+ (let* ((g (lambda (x y) (+ x y)))
+ (f (lambda (g x) (g x x))))
+ (+ (f g foo) (f g bar))))
+ (let (foo bar) (_ _) ((toplevel top-foo) (toplevel top-bar))
+ (primcall +
+ (primcall + (lexical foo _) (lexical foo _))
+ (primcall + (lexical bar _) (lexical bar _)))))
+
+ (pass-if-peval
+ ;; Fresh objects are not turned into constants, nor are constants
+ ;; turned into fresh objects.
+ (let* ((c '(2 3))
+ (x (cons 1 c))
+ (y (cons 0 x)))
+ y)
+ (let (x) (_) ((primcall cons (const 1) (const (2 3))))
+ (primcall cons (const 0) (lexical x _))))
+
+ (pass-if-peval
+ ;; Bindings mutated.
+ (let ((x 2))
+ (set! x 3)
+ x)
+ (let (x) (_) ((const 2))
+ (seq
+ (set! (lexical x _) (const 3))
+ (lexical x _))))
+
+ (pass-if-peval
+ ;; Bindings mutated.
+ (letrec ((x 0)
+ (f (lambda ()
+ (set! x (+ 1 x))
+ x)))
+ (frob f) ; may mutate `x'
+ x)
+ (letrec (x) (_) ((const 0))
+ (seq
+ (call (toplevel frob) (lambda _ _))
+ (lexical x _))))
+
+ (pass-if-peval
+ ;; Bindings mutated.
+ (letrec ((f (lambda (x)
+ (set! f (lambda (_) x))
+ x)))
+ (f 2))
+ (letrec _ . _))
+
+ (pass-if-peval
+ ;; Bindings possibly mutated.
+ (let ((x (make-foo)))
+ (frob! x) ; may mutate `x'
+ x)
+ (let (x) (_) ((call (toplevel make-foo)))
+ (seq
+ (call (toplevel frob!) (lexical x _))
+ (lexical x _))))
+
+ (pass-if-peval
+ ;; Inlining stops at recursive calls with dynamic arguments.
+ (let loop ((x x))
+ (if (< x 0) x (loop (1- x))))
+ (letrec (loop) (_) ((lambda (_)
+ (lambda-case
+ (((x) #f #f #f () (_))
+ (if _ _
+ (call (lexical loop _)
+ (primcall 1-
+ (lexical x _))))))))
+ (call (lexical loop _) (toplevel x))))
+
+ (pass-if-peval
+ ;; Recursion on the 2nd argument is fully evaluated.
+ (let ((x (top)))
+ (let loop ((x x) (y 10))
+ (if (> y 0)
+ (loop x (1- y))
+ (foo x y))))
+ (let (x) (_) ((call (toplevel top)))
+ (call (toplevel foo) (lexical x _) (const 0))))
+
+ (pass-if-peval
+ ;; Inlining aborted when residual code contains recursive calls.
+ ;;
+ ;; <http://debbugs.gnu.org/9542>
+ (let loop ((x x) (y 0))
+ (if (> y 0)
+ (loop (1- x) (1- y))
+ (if (< x 0)
+ x
+ (loop (1+ x) (1+ y)))))
+ (letrec (loop) (_) ((lambda (_)
+ (lambda-case
+ (((x y) #f #f #f () (_ _))
+ (if (primcall >
+ (lexical y _) (const 0))
+ _ _)))))
+ (call (lexical loop _) (toplevel x) (const 0))))
+
+ (pass-if-peval
+ ;; Infinite recursion: `peval' gives up and leaves it as is.
+ (letrec ((f (lambda (x) (g (1- x))))
+ (g (lambda (x) (h (1+ x))))
+ (h (lambda (x) (f x))))
+ (f 0))
+ (letrec _ . _))
+
+ (pass-if-peval
+ ;; Infinite recursion: all the arguments to `loop' are static, but
+ ;; unrolling it would lead `peval' to enter an infinite loop.
+ (let loop ((x 0))
+ (and (< x top)
+ (loop (1+ x))))
+ (letrec (loop) (_) ((lambda . _))
+ (call (lexical loop _) (const 0))))
+
+ (pass-if-peval
+ ;; This test checks that the `start' binding is indeed residualized.
+ ;; See the `referenced?' procedure in peval's `prune-bindings'.
+ (let ((pos 0))
+ (let ((here (let ((start pos)) (lambda () start))))
+ (set! pos 1) ;; Cause references to `pos' to residualize.
+ (here)))
+ (let (pos) (_) ((const 0))
+ (let (here) (_) (_)
+ (seq
+ (set! (lexical pos _) (const 1))
+ (call (lexical here _))))))
+
+ (pass-if-peval
+ ;; FIXME: should this one residualize the binding?
+ (letrec ((a a))
+ 1)
+ (const 1))
+
+ (pass-if-peval
+ ;; This is a fun one for peval to handle.
+ (letrec ((a a))
+ a)
+ (letrec (a) (_) ((lexical a _))
+ (lexical a _)))
+
+ (pass-if-peval
+ ;; Another interesting recursive case.
+ (letrec ((a b) (b a))
+ a)
+ (letrec (a) (_) ((lexical a _))
+ (lexical a _)))
+
+ (pass-if-peval
+ ;; Another pruning case, that `a' is residualized.
+ (letrec ((a (lambda () (a)))
+ (b (lambda () (a)))
+ (c (lambda (x) x)))
+ (let ((d (foo b)))
+ (c d)))
+
+ ;; "b c a" is the current order that we get with unordered letrec,
+ ;; but it's not important to this test, so if it changes, just adapt
+ ;; the test.
+ (letrec (b c a) (_ _ _)
+ ((lambda _
+ (lambda-case
+ ((() #f #f #f () ())
+ (call (lexical a _)))))
+ (lambda _
+ (lambda-case
+ (((x) #f #f #f () (_))
+ (lexical x _))))
+ (lambda _
+ (lambda-case
+ ((() #f #f #f () ())
+ (call (lexical a _))))))
+ (let (d)
+ (_)
+ ((call (toplevel foo) (lexical b _)))
+ (call (lexical c _) (lexical d _)))))
+
+ (pass-if-peval
+ ;; In this case, we can prune the bindings. `a' ends up being copied
+ ;; because it is only referenced once in the source program. Oh
+ ;; well.
+ (letrec* ((a (lambda (x) (top x)))
+ (b (lambda () a)))
+ (foo (b) (b)))
+ (call (toplevel foo)
+ (lambda _
+ (lambda-case
+ (((x) #f #f #f () (_))
+ (call (toplevel top) (lexical x _)))))
+ (lambda _
+ (lambda-case
+ (((x) #f #f #f () (_))
+ (call (toplevel top) (lexical x _)))))))
+
+ (pass-if-peval
+ ;; Constant folding: cons of #nil does not make list
+ (cons 1 #nil)
+ (primcall cons (const 1) (const '#nil)))
+
+ (pass-if-peval
+ ;; Constant folding: cons
+ (begin (cons 1 2) #f)
+ (const #f))
+
+ (pass-if-peval
+ ;; Constant folding: cons
+ (begin (cons (foo) 2) #f)
+ (seq (call (toplevel foo)) (const #f)))
+
+ (pass-if-peval
+ ;; Constant folding: cons
+ (if (cons 0 0) 1 2)
+ (const 1))
+
+ (pass-if-peval
+ ;; Constant folding: car+cons
+ (car (cons 1 0))
+ (const 1))
+
+ (pass-if-peval
+ ;; Constant folding: cdr+cons
+ (cdr (cons 1 0))
+ (const 0))
+
+ (pass-if-peval
+ ;; Constant folding: car+cons, impure
+ (car (cons 1 (bar)))
+ (seq (call (toplevel bar)) (const 1)))
+
+ (pass-if-peval
+ ;; Constant folding: cdr+cons, impure
+ (cdr (cons (bar) 0))
+ (seq (call (toplevel bar)) (const 0)))
+
+ (pass-if-peval
+ ;; Constant folding: car+list
+ (car (list 1 0))
+ (const 1))
+
+ (pass-if-peval
+ ;; Constant folding: cdr+list
+ (cdr (list 1 0))
+ (primcall list (const 0)))
+
+ (pass-if-peval
+ ;; Constant folding: car+list, impure
+ (car (list 1 (bar)))
+ (seq (call (toplevel bar)) (const 1)))
+
+ (pass-if-peval
+ ;; Constant folding: cdr+list, impure
+ (cdr (list (bar) 0))
+ (seq (call (toplevel bar)) (primcall list (const 0))))
+
+ (pass-if-peval
+ ;; Equality primitive: same lexical
+ (let ((x (random))) (eq? x x))
+ (seq (call (toplevel random)) (const #t)))
+
+ (pass-if-peval
+ ;; Equality primitive: merge lexical identities
+ (let* ((x (random)) (y x)) (eq? x y))
+ (seq (call (toplevel random)) (const #t)))
+
+ (pass-if-peval
+ ;; Non-constant guards get lexical bindings.
+ (dynamic-wind foo (lambda () bar) baz)
+ (let (w u) (_ _) ((toplevel foo) (toplevel baz))
+ (dynwind (lexical w _)
+ (call (lexical w _))
+ (toplevel bar)
+ (call (lexical u _))
+ (lexical u _))))
+
+ (pass-if-peval
+ ;; Constant guards don't need lexical bindings.
+ (dynamic-wind (lambda () foo) (lambda () bar) (lambda () baz))
+ (dynwind
+ (lambda ()
+ (lambda-case
+ ((() #f #f #f () ()) (toplevel foo))))
+ (toplevel foo)
+ (toplevel bar)
+ (toplevel baz)
+ (lambda ()
+ (lambda-case
+ ((() #f #f #f () ()) (toplevel baz))))))
+
+ (pass-if-peval
+ ;; Prompt is removed if tag is unreferenced
+ (let ((tag (make-prompt-tag)))
+ (call-with-prompt tag
+ (lambda () 1)
+ (lambda args args)))
+ (const 1))
+
+ (pass-if-peval
+ ;; Prompt is removed if tag is unreferenced, with explicit stem
+ (let ((tag (make-prompt-tag "foo")))
+ (call-with-prompt tag
+ (lambda () 1)
+ (lambda args args)))
+ (const 1))
+
+ ;; Handler lambda inlined
+ (pass-if-peval
+ (call-with-prompt tag
+ (lambda () 1)
+ (lambda (k x) x))
+ (prompt (toplevel tag)
+ (const 1)
+ (lambda-case
+ (((k x) #f #f #f () (_ _))
+ (lexical x _)))))
+
+ ;; Handler toplevel not inlined
+ (pass-if-peval
+ (call-with-prompt tag
+ (lambda () 1)
+ handler)
+ (let (handler) (_) ((toplevel handler))
+ (prompt (toplevel tag)
+ (const 1)
+ (lambda-case
+ ((() #f args #f () (_))
+ (primcall @apply
+ (lexical handler _)
+ (lexical args _)))))))
+
+ (pass-if-peval
+ ;; `while' without `break' or `continue' has no prompts and gets its
+ ;; condition folded. Unfortunately the outer `lp' does not yet get
+ ;; elided.
+ (while #t #t)
+ (letrec (lp) (_)
+ ((lambda _
+ (lambda-case
+ ((() #f #f #f () ())
+ (letrec (loop) (_)
+ ((lambda _
+ (lambda-case
+ ((() #f #f #f () ())
+ (call (lexical loop _))))))
+ (call (lexical loop _)))))))
+ (call (lexical lp _))))
+
+ (pass-if-peval
+ (lambda (a . rest)
+ (apply (lambda (x y) (+ x y))
+ a rest))
+ (lambda _
+ (lambda-case
+ (((x y) #f #f #f () (_ _))
+ _))))
+
+ (pass-if-peval
+ (car '(1 2))
+ (const 1))
+
+ ;; If we bail out when inlining an identifier because it's too big,
+ ;; but the identifier simply aliases some other identifier, then avoid
+ ;; residualizing a reference to the leaf identifier. The bailout is
+ ;; driven by the recursive-effort-limit, which is currently 100. We
+ ;; make sure to trip it with this recursive sum thing.
+ (pass-if-peval resolve-primitives
+ (let ((x (let sum ((n 0) (out 0))
+ (if (< n 10000)
+ (sum (1+ n) (+ out n))
+ out))))
+ ((lambda (y) (list y)) x))
+ (let (x) (_) (_)
+ (apply (primitive list) (lexical x _)))))
diff --git a/test-suite/tests/rnrs-libraries.test
b/test-suite/tests/rnrs-libraries.test
index e162714..e961c28 100644
--- a/test-suite/tests/rnrs-libraries.test
+++ b/test-suite/tests/rnrs-libraries.test
@@ -1,5 +1,5 @@
;;;; rnrs-libraries.test --- test library and import forms -*- scheme -*-
-;;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2012 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
@@ -15,7 +15,7 @@
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-(define-module (test-suite tests rnrs-libraries)
+(define-module (tests rnrs-libraries)
#:use-module (test-suite lib))
;; First, check that Guile modules are r6rs modules.
@@ -71,7 +71,7 @@
(pass-if "import"
(eval '(begin
- (import (test-suite tests rnrs-test-a))
+ (import (tests rnrs-test-a))
#t)
(current-module)))
@@ -79,18 +79,18 @@
(not (module-local-variable (current-module) 'double)))
(pass-if "resolve-interface"
- (module? (resolve-interface '(test-suite tests rnrs-test-a))))
+ (module? (resolve-interface '(tests rnrs-test-a))))
- (set! iface (resolve-interface '(test-suite tests rnrs-test-a)))
+ (set! iface (resolve-interface '(tests rnrs-test-a)))
(pass-if "resolve-interface (2)"
- (eq? iface (resolve-interface '(test-suite tests rnrs-test-a))))
+ (eq? iface (resolve-interface '(tests rnrs-test-a))))
(pass-if "resolve-r6rs-interface"
- (eq? iface (resolve-r6rs-interface '(test-suite tests rnrs-test-a))))
+ (eq? iface (resolve-r6rs-interface '(tests rnrs-test-a))))
(pass-if "resolve-r6rs-interface (2)"
- (eq? iface (resolve-r6rs-interface '(library (test-suite tests
rnrs-test-a)))))
+ (eq? iface (resolve-r6rs-interface '(library (tests rnrs-test-a)))))
(pass-if "module uses"
(and (memq iface (module-uses (current-module))) #t))
diff --git a/test-suite/tests/rnrs-test-a.scm b/test-suite/tests/rnrs-test-a.scm
index 7b46fd6..474069b 100644
--- a/test-suite/tests/rnrs-test-a.scm
+++ b/test-suite/tests/rnrs-test-a.scm
@@ -1,6 +1,6 @@
;;; test of defining rnrs libraries
-;; Copyright (C) 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2012 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
@@ -17,7 +17,7 @@
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-(library (test-suite tests rnrs-test-a)
+(library (tests rnrs-test-a)
(export double)
(import (guile))
diff --git a/test-suite/tests/srfi-9.test b/test-suite/tests/srfi-9.test
index f26a7a2..321fe16 100644
--- a/test-suite/tests/srfi-9.test
+++ b/test-suite/tests/srfi-9.test
@@ -1,7 +1,7 @@
;;;; srfi-9.test --- Test suite for Guile's SRFI-9 functions. -*- scheme -*-
;;;; Martin Grabmueller, 2001-05-10
;;;;
-;;;; Copyright (C) 2001, 2006, 2007, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001, 2006, 2007, 2010, 2011, 2012 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
@@ -110,3 +110,12 @@
(let ((frotz (make-frotz 1 2)))
(and (= (frotz-a frotz) 1)
(= (frotz-b frotz) 2)))))
+
+(with-test-prefix "record compatibility"
+
+ (pass-if "record?"
+ (record? (make-foo 1)))
+
+ (pass-if "record-constructor"
+ (equal? ((record-constructor :foo) 1)
+ (make-foo 1))))
diff --git a/test-suite/tests/sxml.match.test b/test-suite/tests/sxml.match.test
index b3dbbe7..fcb089f 100644
--- a/test-suite/tests/sxml.match.test
+++ b/test-suite/tests/sxml.match.test
@@ -1,6 +1,6 @@
;;;; sxml.simple.test --- (sxml simple) -*- mode: scheme; coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2012 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
@@ -42,4 +42,4 @@
;; FIXME: The `xyzpq' variable in there is originally named `x' but using that
;; name triggers a psyntax "identifier out of context" error.
-(include-from-path "test-suite/tests/sxml-match-tests.ss")
+(include-from-path "tests/sxml-match-tests.ss")
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 47289c3..ba76ad6 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -69,35 +69,6 @@
(pat (guard guard-exp) #t)
(_ #f))))))
-(define peval
- ;; The partial evaluator.
- (@@ (language tree-il optimize) peval))
-
-(define-syntax pass-if-peval
- (syntax-rules ()
- ((_ in pat)
- (pass-if-peval in pat
- (expand-primitives!
- (resolve-primitives!
- (compile 'in #:from 'scheme #:to 'tree-il)
- (current-module)))))
- ((_ in pat code)
- (pass-if 'in
- (let ((evaled (unparse-tree-il (peval code))))
- (pmatch evaled
- (pat #t)
- (_ (pk 'peval-mismatch)
- ((@ (ice-9 pretty-print) pretty-print)
- 'in)
- (newline)
- ((@ (ice-9 pretty-print) pretty-print)
- evaled)
- (newline)
- ((@ (ice-9 pretty-print) pretty-print)
- 'pat)
- (newline)
- #f)))))))
-
(with-test-prefix "tree-il->scheme"
(pass-if-tree-il->scheme
@@ -177,7 +148,7 @@
(lexical #t #f ref 0) (call return 1)
(unbind)))
- (assert-tree-il->glil without-partial-evaluation
+ (assert-tree-il->glil with-options (#:partial-eval? #f #:cse? #f)
(let (x) (y) ((const 1)) (begin (lexical x y) (const #f)))
(program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
@@ -654,962 +625,6 @@
#:opts '(#:partial-eval? #f)))))
-(with-test-prefix "partial evaluation"
-
- (pass-if-peval
- ;; First order, primitive.
- (let ((x 1) (y 2)) (+ x y))
- (const 3))
-
- (pass-if-peval
- ;; First order, thunk.
- (let ((x 1) (y 2))
- (let ((f (lambda () (+ x y))))
- (f)))
- (const 3))
-
- (pass-if-peval
- ;; First order, let-values (requires primitive expansion for
- ;; `call-with-values'.)
- (let ((x 0))
- (call-with-values
- (lambda () (if (zero? x) (values 1 2) (values 3 4)))
- (lambda (a b)
- (+ a b))))
- (const 3))
-
- (pass-if-peval
- ;; First order, multiple values.
- (let ((x 1) (y 2))
- (values x y))
- (primcall values (const 1) (const 2)))
-
- (pass-if-peval
- ;; First order, multiple values truncated.
- (let ((x (values 1 'a)) (y 2))
- (values x y))
- (primcall values (const 1) (const 2)))
-
- (pass-if-peval
- ;; First order, multiple values truncated.
- (or (values 1 2) 3)
- (const 1))
-
- (pass-if-peval
- ;; First order, coalesced, mutability preserved.
- (cons 0 (cons 1 (cons 2 (list 3 4 5))))
- (primcall list
- (const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
-
- (pass-if-peval
- ;; First order, coalesced, mutability preserved.
- (cons 0 (cons 1 (cons 2 (list 3 4 5))))
- ;; This must not be a constant.
- (primcall list
- (const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
-
- (pass-if-peval
- ;; First order, coalesced, immutability preserved.
- (cons 0 (cons 1 (cons 2 '(3 4 5))))
- (primcall cons (const 0)
- (primcall cons (const 1)
- (primcall cons (const 2)
- (const (3 4 5))))))
-
- ;; These two tests doesn't work any more because we changed the way we
- ;; deal with constants -- now the algorithm will see a construction as
- ;; being bound to the lexical, so it won't propagate it. It can't
- ;; even propagate it in the case that it is only referenced once,
- ;; because:
- ;;
- ;; (let ((x (cons 1 2))) (lambda () x))
- ;;
- ;; is not the same as
- ;;
- ;; (lambda () (cons 1 2))
- ;;
- ;; Perhaps if we determined that not only was it only referenced once,
- ;; it was not closed over by a lambda, then we could propagate it, and
- ;; re-enable these two tests.
- ;;
- #;
- (pass-if-peval
- ;; First order, mutability preserved.
- (let loop ((i 3) (r '()))
- (if (zero? i)
- r
- (loop (1- i) (cons (cons i i) r))))
- (primcall list
- (primcall cons (const 1) (const 1))
- (primcall cons (const 2) (const 2))
- (primcall cons (const 3) (const 3))))
- ;;
- ;; See above.
- #;
- (pass-if-peval
- ;; First order, evaluated.
- (let loop ((i 7)
- (r '()))
- (if (<= i 0)
- (car r)
- (loop (1- i) (cons i r))))
- (const 1))
-
- ;; Instead here are tests for what happens for the above cases: they
- ;; unroll but they don't fold.
- (pass-if-peval
- (let loop ((i 3) (r '()))
- (if (zero? i)
- r
- (loop (1- i) (cons (cons i i) r))))
- (let (r) (_)
- ((primcall list
- (primcall cons (const 3) (const 3))))
- (let (r) (_)
- ((primcall cons
- (primcall cons (const 2) (const 2))
- (lexical r _)))
- (primcall cons
- (primcall cons (const 1) (const 1))
- (lexical r _)))))
-
- ;; See above.
- (pass-if-peval
- (let loop ((i 4)
- (r '()))
- (if (<= i 0)
- (car r)
- (loop (1- i) (cons i r))))
- (let (r) (_)
- ((primcall list (const 4)))
- (let (r) (_)
- ((primcall cons
- (const 3)
- (lexical r _)))
- (let (r) (_)
- ((primcall cons
- (const 2)
- (lexical r _)))
- (let (r) (_)
- ((primcall cons
- (const 1)
- (lexical r _)))
- (primcall car
- (lexical r _)))))))
-
- ;; Static sums.
- (pass-if-peval
- (let loop ((l '(1 2 3 4)) (sum 0))
- (if (null? l)
- sum
- (loop (cdr l) (+ sum (car l)))))
- (const 10))
-
- (pass-if-peval
- (let ((string->chars
- (lambda (s)
- (define (char-at n)
- (string-ref s n))
- (define (len)
- (string-length s))
- (let loop ((i 0))
- (if (< i (len))
- (cons (char-at i)
- (loop (1+ i)))
- '())))))
- (string->chars "yo"))
- (primcall list (const #\y) (const #\o)))
-
- (pass-if-peval
- ;; Primitives in module-refs are resolved (the expansion of `pmatch'
- ;; below leads to calls to (@@ (system base pmatch) car) and
- ;; similar, which is what we want to be inlined.)
- (begin
- (use-modules (system base pmatch))
- (pmatch '(a b c d)
- ((a b . _)
- #t)))
- (seq (call . _)
- (const #t)))
-
- (pass-if-peval
- ;; Mutability preserved.
- ((lambda (x y z) (list x y z)) 1 2 3)
- (primcall list (const 1) (const 2) (const 3)))
-
- (pass-if-peval
- ;; Don't propagate effect-free expressions that operate on mutable
- ;; objects.
- (let* ((x (list 1))
- (y (car x)))
- (set-car! x 0)
- y)
- (let (x) (_) ((primcall list (const 1)))
- (let (y) (_) ((primcall car (lexical x _)))
- (seq
- (primcall set-car! (lexical x _) (const 0))
- (lexical y _)))))
-
- (pass-if-peval
- ;; Don't propagate effect-free expressions that operate on objects we
- ;; don't know about.
- (let ((y (car x)))
- (set-car! x 0)
- y)
- (let (y) (_) ((primcall car (toplevel x)))
- (seq
- (primcall set-car! (toplevel x) (const 0))
- (lexical y _))))
-
- (pass-if-peval
- ;; Infinite recursion
- ((lambda (x) (x x)) (lambda (x) (x x)))
- (let (x) (_)
- ((lambda _
- (lambda-case
- (((x) _ _ _ _ _)
- (call (lexical x _) (lexical x _))))))
- (call (lexical x _) (lexical x _))))
-
- (pass-if-peval
- ;; First order, aliased primitive.
- (let* ((x *) (y (x 1 2))) y)
- (const 2))
-
- (pass-if-peval
- ;; First order, shadowed primitive.
- (begin
- (define (+ x y) (pk x y))
- (+ 1 2))
- (seq
- (define +
- (lambda (_)
- (lambda-case
- (((x y) #f #f #f () (_ _))
- (call (toplevel pk) (lexical x _) (lexical y _))))))
- (call (toplevel +) (const 1) (const 2))))
-
- (pass-if-peval
- ;; First-order, effects preserved.
- (let ((x 2))
- (do-something!)
- x)
- (seq
- (call (toplevel do-something!))
- (const 2)))
-
- (pass-if-peval
- ;; First order, residual bindings removed.
- (let ((x 2) (y 3))
- (* (+ x y) z))
- (primcall * (const 5) (toplevel z)))
-
- (pass-if-peval
- ;; First order, with lambda.
- (define (foo x)
- (define (bar z) (* z z))
- (+ x (bar 3)))
- (define foo
- (lambda (_)
- (lambda-case
- (((x) #f #f #f () (_))
- (primcall + (lexical x _) (const 9)))))))
-
- (pass-if-peval
- ;; First order, with lambda inlined & specialized twice.
- (let ((f (lambda (x y)
- (+ (* x top) y)))
- (x 2)
- (y 3))
- (+ (* x (f x y))
- (f something x)))
- (primcall +
- (primcall *
- (const 2)
- (primcall + ; (f 2 3)
- (primcall *
- (const 2)
- (toplevel top))
- (const 3)))
- (let (x) (_) ((toplevel something)) ; (f something 2)
- ;; `something' is not const, so preserve order of
- ;; effects with a lexical binding.
- (primcall +
- (primcall *
- (lexical x _)
- (toplevel top))
- (const 2)))))
-
- (pass-if-peval
- ;; First order, with lambda inlined & specialized 3 times.
- (let ((f (lambda (x y) (if (> x 0) y x))))
- (+ (f -1 0)
- (f 1 0)
- (f -1 y)
- (f 2 y)
- (f z y)))
- (primcall
- +
- (const -1) ; (f -1 0)
- (primcall
- +
- (const 0) ; (f 1 0)
- (primcall
- +
- (seq (toplevel y) (const -1)) ; (f -1 y)
- (primcall
- +
- (toplevel y) ; (f 2 y)
- (let (x y) (_ _) ((toplevel z) (toplevel y)) ; (f z y)
- (if (primcall > (lexical x _) (const 0))
- (lexical y _)
- (lexical x _))))))))
-
- (pass-if-peval
- ;; First order, conditional.
- (let ((y 2))
- (lambda (x)
- (if (> y 0)
- (display x)
- 'never-reached)))
- (lambda ()
- (lambda-case
- (((x) #f #f #f () (_))
- (call (toplevel display) (lexical x _))))))
-
- (pass-if-peval
- ;; First order, recursive procedure.
- (letrec ((fibo (lambda (n)
- (if (<= n 1)
- n
- (+ (fibo (- n 1))
- (fibo (- n 2)))))))
- (fibo 4))
- (const 3))
-
- (pass-if-peval
- ;; Don't propagate toplevel references, as intervening expressions
- ;; could alter their bindings.
- (let ((x top))
- (foo)
- x)
- (let (x) (_) ((toplevel top))
- (seq
- (call (toplevel foo))
- (lexical x _))))
-
- (pass-if-peval
- ;; Higher order.
- ((lambda (f x)
- (f (* (car x) (cadr x))))
- (lambda (x)
- (+ x 1))
- '(2 3))
- (const 7))
-
- (pass-if-peval
- ;; Higher order with optional argument (default value).
- ((lambda* (f x #:optional (y 0))
- (+ y (f (* (car x) (cadr x)))))
- (lambda (x)
- (+ x 1))
- '(2 3))
- (const 7))
-
- (pass-if-peval
- ;; Higher order with optional argument (caller-supplied value).
- ((lambda* (f x #:optional (y 0))
- (+ y (f (* (car x) (cadr x)))))
- (lambda (x)
- (+ x 1))
- '(2 3)
- 35)
- (const 42))
-
- (pass-if-peval
- ;; Higher order with optional argument (side-effecting default
- ;; value).
- ((lambda* (f x #:optional (y (foo)))
- (+ y (f (* (car x) (cadr x)))))
- (lambda (x)
- (+ x 1))
- '(2 3))
- (let (y) (_) ((call (toplevel foo)))
- (primcall + (lexical y _) (const 7))))
-
- (pass-if-peval
- ;; Higher order with optional argument (caller-supplied value).
- ((lambda* (f x #:optional (y (foo)))
- (+ y (f (* (car x) (cadr x)))))
- (lambda (x)
- (+ x 1))
- '(2 3)
- 35)
- (const 42))
-
- (pass-if-peval
- ;; Higher order.
- ((lambda (f) (f x)) (lambda (x) x))
- (toplevel x))
-
- (pass-if-peval
- ;; Bug reported at
- ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>.
- (let ((fold (lambda (f g) (f (g top)))))
- (fold 1+ (lambda (x) x)))
- (primcall 1+ (toplevel top)))
-
- (pass-if-peval
- ;; Procedure not inlined when residual code contains recursive calls.
- ;; <http://debbugs.gnu.org/9542>
- (letrec ((fold (lambda (f x3 b null? car cdr)
- (if (null? x3)
- b
- (f (car x3) (fold f (cdr x3) b null? car cdr))))))
- (fold * x 1 zero? (lambda (x1) x1) (lambda (x2) (- x2 1))))
- (letrec (fold) (_) (_)
- (call (lexical fold _)
- (primitive *)
- (toplevel x)
- (const 1)
- (primitive zero?)
- (lambda ()
- (lambda-case
- (((x1) #f #f #f () (_))
- (lexical x1 _))))
- (lambda ()
- (lambda-case
- (((x2) #f #f #f () (_))
- (primcall 1- (lexical x2 _))))))))
-
- (pass-if "inlined lambdas are alpha-renamed"
- ;; In this example, `make-adder' is inlined more than once; thus,
- ;; they should use different gensyms for their arguments, because
- ;; the various optimization passes assume uniquely-named variables.
- ;;
- ;; Bug reported at
- ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html> and
- ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00029.html>.
- (pmatch (unparse-tree-il
- (peval (expand-primitives!
- (resolve-primitives!
- (compile
- '(let ((make-adder
- (lambda (x) (lambda (y) (+ x y)))))
- (cons (make-adder 1) (make-adder 2)))
- #:to 'tree-il)
- (current-module)))))
- ((primcall cons
- (lambda ()
- (lambda-case
- (((y) #f #f #f () (,gensym1))
- (primcall +
- (const 1)
- (lexical y ,ref1)))))
- (lambda ()
- (lambda-case
- (((y) #f #f #f () (,gensym2))
- (primcall +
- (const 2)
- (lexical y ,ref2))))))
- (and (eq? gensym1 ref1)
- (eq? gensym2 ref2)
- (not (eq? gensym1 gensym2))))
- (_ #f)))
-
- (pass-if-peval
- ;; Unused letrec bindings are pruned.
- (letrec ((a (lambda () (b)))
- (b (lambda () (a)))
- (c (lambda (x) x)))
- (c 10))
- (const 10))
-
- (pass-if-peval
- ;; Unused letrec bindings are pruned.
- (letrec ((a (foo!))
- (b (lambda () (a)))
- (c (lambda (x) x)))
- (c 10))
- (seq (call (toplevel foo!))
- (const 10)))
-
- (pass-if-peval
- ;; Higher order, mutually recursive procedures.
- (letrec ((even? (lambda (x)
- (or (= 0 x)
- (odd? (- x 1)))))
- (odd? (lambda (x)
- (not (even? x)))))
- (and (even? 4) (odd? 7)))
- (const #t))
-
- (pass-if-peval
- ;; Memv with constants.
- (memv 1 '(3 2 1))
- (const '(1)))
-
- (pass-if-peval
- ;; Memv with non-constant list. It could fold but doesn't
- ;; currently.
- (memv 1 (list 3 2 1))
- (primcall memv
- (const 1)
- (primcall list (const 3) (const 2) (const 1))))
-
- (pass-if-peval
- ;; Memv with non-constant key, constant list, test context
- (case foo
- ((3 2 1) 'a)
- (else 'b))
- (let (key) (_) ((toplevel foo))
- (if (if (primcall eqv? (lexical key _) (const 3))
- (const #t)
- (if (primcall eqv? (lexical key _) (const 2))
- (const #t)
- (primcall eqv? (lexical key _) (const 1))))
- (const a)
- (const b))))
-
- (pass-if-peval
- ;; Memv with non-constant key, empty list, test context.
- (case foo
- (() 'a)
- (else 'b))
- (seq (toplevel foo) (const 'b)))
-
- ;;
- ;; Below are cases where constant propagation should bail out.
- ;;
-
- (pass-if-peval
- ;; Non-constant lexical is not propagated.
- (let ((v (make-vector 6 #f)))
- (lambda (n)
- (vector-set! v n n)))
- (let (v) (_)
- ((call (toplevel make-vector) (const 6) (const #f)))
- (lambda ()
- (lambda-case
- (((n) #f #f #f () (_))
- (primcall vector-set!
- (lexical v _) (lexical n _) (lexical n _)))))))
-
- (pass-if-peval
- ;; Mutable lexical is not propagated.
- (let ((v (vector 1 2 3)))
- (lambda ()
- v))
- (let (v) (_)
- ((primcall vector (const 1) (const 2) (const 3)))
- (lambda ()
- (lambda-case
- ((() #f #f #f () ())
- (lexical v _))))))
-
- (pass-if-peval
- ;; Lexical that is not provably pure is not inlined nor propagated.
- (let* ((x (if (> p q) (frob!) (display 'chbouib)))
- (y (* x 2)))
- (+ x x y))
- (let (x) (_) ((if (primcall > (toplevel p) (toplevel q))
- (call (toplevel frob!))
- (call (toplevel display) (const chbouib))))
- (let (y) (_) ((primcall * (lexical x _) (const 2)))
- (primcall +
- (lexical x _)
- (primcall + (lexical x _) (lexical y _))))))
-
- (pass-if-peval
- ;; Non-constant arguments not propagated to lambdas.
- ((lambda (x y z)
- (vector-set! x 0 0)
- (set-car! y 0)
- (set-cdr! z '()))
- (vector 1 2 3)
- (make-list 10)
- (list 1 2 3))
- (let (x y z) (_ _ _)
- ((primcall vector (const 1) (const 2) (const 3))
- (call (toplevel make-list) (const 10))
- (primcall list (const 1) (const 2) (const 3)))
- (seq
- (primcall vector-set!
- (lexical x _) (const 0) (const 0))
- (seq (primcall set-car!
- (lexical y _) (const 0))
- (primcall set-cdr!
- (lexical z _) (const ()))))))
-
- (pass-if-peval
- (let ((foo top-foo) (bar top-bar))
- (let* ((g (lambda (x y) (+ x y)))
- (f (lambda (g x) (g x x))))
- (+ (f g foo) (f g bar))))
- (let (foo bar) (_ _) ((toplevel top-foo) (toplevel top-bar))
- (primcall +
- (primcall + (lexical foo _) (lexical foo _))
- (primcall + (lexical bar _) (lexical bar _)))))
-
- (pass-if-peval
- ;; Fresh objects are not turned into constants, nor are constants
- ;; turned into fresh objects.
- (let* ((c '(2 3))
- (x (cons 1 c))
- (y (cons 0 x)))
- y)
- (let (x) (_) ((primcall cons (const 1) (const (2 3))))
- (primcall cons (const 0) (lexical x _))))
-
- (pass-if-peval
- ;; Bindings mutated.
- (let ((x 2))
- (set! x 3)
- x)
- (let (x) (_) ((const 2))
- (seq
- (set! (lexical x _) (const 3))
- (lexical x _))))
-
- (pass-if-peval
- ;; Bindings mutated.
- (letrec ((x 0)
- (f (lambda ()
- (set! x (+ 1 x))
- x)))
- (frob f) ; may mutate `x'
- x)
- (letrec (x) (_) ((const 0))
- (seq
- (call (toplevel frob) (lambda _ _))
- (lexical x _))))
-
- (pass-if-peval
- ;; Bindings mutated.
- (letrec ((f (lambda (x)
- (set! f (lambda (_) x))
- x)))
- (f 2))
- (letrec _ . _))
-
- (pass-if-peval
- ;; Bindings possibly mutated.
- (let ((x (make-foo)))
- (frob! x) ; may mutate `x'
- x)
- (let (x) (_) ((call (toplevel make-foo)))
- (seq
- (call (toplevel frob!) (lexical x _))
- (lexical x _))))
-
- (pass-if-peval
- ;; Inlining stops at recursive calls with dynamic arguments.
- (let loop ((x x))
- (if (< x 0) x (loop (1- x))))
- (letrec (loop) (_) ((lambda (_)
- (lambda-case
- (((x) #f #f #f () (_))
- (if _ _
- (call (lexical loop _)
- (primcall 1-
- (lexical x _))))))))
- (call (lexical loop _) (toplevel x))))
-
- (pass-if-peval
- ;; Recursion on the 2nd argument is fully evaluated.
- (let ((x (top)))
- (let loop ((x x) (y 10))
- (if (> y 0)
- (loop x (1- y))
- (foo x y))))
- (let (x) (_) ((call (toplevel top)))
- (call (toplevel foo) (lexical x _) (const 0))))
-
- (pass-if-peval
- ;; Inlining aborted when residual code contains recursive calls.
- ;;
- ;; <http://debbugs.gnu.org/9542>
- (let loop ((x x) (y 0))
- (if (> y 0)
- (loop (1- x) (1- y))
- (if (< x 0)
- x
- (loop (1+ x) (1+ y)))))
- (letrec (loop) (_) ((lambda (_)
- (lambda-case
- (((x y) #f #f #f () (_ _))
- (if (primcall >
- (lexical y _) (const 0))
- _ _)))))
- (call (lexical loop _) (toplevel x) (const 0))))
-
- (pass-if-peval
- ;; Infinite recursion: `peval' gives up and leaves it as is.
- (letrec ((f (lambda (x) (g (1- x))))
- (g (lambda (x) (h (1+ x))))
- (h (lambda (x) (f x))))
- (f 0))
- (letrec _ . _))
-
- (pass-if-peval
- ;; Infinite recursion: all the arguments to `loop' are static, but
- ;; unrolling it would lead `peval' to enter an infinite loop.
- (let loop ((x 0))
- (and (< x top)
- (loop (1+ x))))
- (letrec (loop) (_) ((lambda . _))
- (call (lexical loop _) (const 0))))
-
- (pass-if-peval
- ;; This test checks that the `start' binding is indeed residualized.
- ;; See the `referenced?' procedure in peval's `prune-bindings'.
- (let ((pos 0))
- (set! pos 1) ;; Cause references to `pos' to residualize.
- (let ((here (let ((start pos)) (lambda () start))))
- (here)))
- (let (pos) (_) ((const 0))
- (seq
- (set! (lexical pos _) (const 1))
- (let (here) (_) (_)
- (call (lexical here _))))))
-
- (pass-if-peval
- ;; FIXME: should this one residualize the binding?
- (letrec ((a a))
- 1)
- (const 1))
-
- (pass-if-peval
- ;; This is a fun one for peval to handle.
- (letrec ((a a))
- a)
- (letrec (a) (_) ((lexical a _))
- (lexical a _)))
-
- (pass-if-peval
- ;; Another interesting recursive case.
- (letrec ((a b) (b a))
- a)
- (letrec (a) (_) ((lexical a _))
- (lexical a _)))
-
- (pass-if-peval
- ;; Another pruning case, that `a' is residualized.
- (letrec ((a (lambda () (a)))
- (b (lambda () (a)))
- (c (lambda (x) x)))
- (let ((d (foo b)))
- (c d)))
-
- ;; "b c a" is the current order that we get with unordered letrec,
- ;; but it's not important to this test, so if it changes, just adapt
- ;; the test.
- (letrec (b c a) (_ _ _)
- ((lambda _
- (lambda-case
- ((() #f #f #f () ())
- (call (lexical a _)))))
- (lambda _
- (lambda-case
- (((x) #f #f #f () (_))
- (lexical x _))))
- (lambda _
- (lambda-case
- ((() #f #f #f () ())
- (call (lexical a _))))))
- (let (d)
- (_)
- ((call (toplevel foo) (lexical b _)))
- (call (lexical c _) (lexical d _)))))
-
- (pass-if-peval
- ;; In this case, we can prune the bindings. `a' ends up being copied
- ;; because it is only referenced once in the source program. Oh
- ;; well.
- (letrec* ((a (lambda (x) (top x)))
- (b (lambda () a)))
- (foo (b) (b)))
- (call (toplevel foo)
- (lambda _
- (lambda-case
- (((x) #f #f #f () (_))
- (call (toplevel top) (lexical x _)))))
- (lambda _
- (lambda-case
- (((x) #f #f #f () (_))
- (call (toplevel top) (lexical x _)))))))
-
- (pass-if-peval
- ;; Constant folding: cons of #nil does not make list
- (cons 1 #nil)
- (primcall cons (const 1) (const '#nil)))
-
- (pass-if-peval
- ;; Constant folding: cons
- (begin (cons 1 2) #f)
- (const #f))
-
- (pass-if-peval
- ;; Constant folding: cons
- (begin (cons (foo) 2) #f)
- (seq (call (toplevel foo)) (const #f)))
-
- (pass-if-peval
- ;; Constant folding: cons
- (if (cons 0 0) 1 2)
- (const 1))
-
- (pass-if-peval
- ;; Constant folding: car+cons
- (car (cons 1 0))
- (const 1))
-
- (pass-if-peval
- ;; Constant folding: cdr+cons
- (cdr (cons 1 0))
- (const 0))
-
- (pass-if-peval
- ;; Constant folding: car+cons, impure
- (car (cons 1 (bar)))
- (seq (call (toplevel bar)) (const 1)))
-
- (pass-if-peval
- ;; Constant folding: cdr+cons, impure
- (cdr (cons (bar) 0))
- (seq (call (toplevel bar)) (const 0)))
-
- (pass-if-peval
- ;; Constant folding: car+list
- (car (list 1 0))
- (const 1))
-
- (pass-if-peval
- ;; Constant folding: cdr+list
- (cdr (list 1 0))
- (primcall list (const 0)))
-
- (pass-if-peval
- ;; Constant folding: car+list, impure
- (car (list 1 (bar)))
- (seq (call (toplevel bar)) (const 1)))
-
- (pass-if-peval
- ;; Constant folding: cdr+list, impure
- (cdr (list (bar) 0))
- (seq (call (toplevel bar)) (primcall list (const 0))))
-
- (pass-if-peval
- ;; Equality primitive: same lexical
- (let ((x (random))) (eq? x x))
- (seq (call (toplevel random)) (const #t)))
-
- (pass-if-peval
- ;; Equality primitive: merge lexical identities
- (let* ((x (random)) (y x)) (eq? x y))
- (seq (call (toplevel random)) (const #t)))
-
- (pass-if-peval
- ;; Non-constant guards get lexical bindings.
- (dynamic-wind foo (lambda () bar) baz)
- (let (w u) (_ _) ((toplevel foo) (toplevel baz))
- (dynwind (lexical w _)
- (call (lexical w _))
- (toplevel bar)
- (call (lexical u _))
- (lexical u _))))
-
- (pass-if-peval
- ;; Constant guards don't need lexical bindings.
- (dynamic-wind (lambda () foo) (lambda () bar) (lambda () baz))
- (dynwind
- (lambda ()
- (lambda-case
- ((() #f #f #f () ()) (toplevel foo))))
- (toplevel foo)
- (toplevel bar)
- (toplevel baz)
- (lambda ()
- (lambda-case
- ((() #f #f #f () ()) (toplevel baz))))))
-
- (pass-if-peval
- ;; Prompt is removed if tag is unreferenced
- (let ((tag (make-prompt-tag)))
- (call-with-prompt tag
- (lambda () 1)
- (lambda args args)))
- (const 1))
-
- (pass-if-peval
- ;; Prompt is removed if tag is unreferenced, with explicit stem
- (let ((tag (make-prompt-tag "foo")))
- (call-with-prompt tag
- (lambda () 1)
- (lambda args args)))
- (const 1))
-
- ;; Handler lambda inlined
- (pass-if-peval
- (call-with-prompt tag
- (lambda () 1)
- (lambda (k x) x))
- (prompt (toplevel tag)
- (const 1)
- (lambda-case
- (((k x) #f #f #f () (_ _))
- (lexical x _)))))
-
- ;; Handler toplevel not inlined
- (pass-if-peval
- (call-with-prompt tag
- (lambda () 1)
- handler)
- (let (handler) (_) ((toplevel handler))
- (prompt (toplevel tag)
- (const 1)
- (lambda-case
- ((() #f args #f () (_))
- (primcall @apply
- (lexical handler _)
- (lexical args _)))))))
-
- (pass-if-peval
- ;; `while' without `break' or `continue' has no prompts and gets its
- ;; condition folded. Unfortunately the outer `lp' does not yet get
- ;; elided.
- (while #t #t)
- (letrec (lp) (_)
- ((lambda _
- (lambda-case
- ((() #f #f #f () ())
- (letrec (loop) (_)
- ((lambda _
- (lambda-case
- ((() #f #f #f () ())
- (call (lexical loop _))))))
- (call (lexical loop _)))))))
- (call (lexical lp _))))
-
- (pass-if-peval
- (lambda (a . rest)
- (apply (lambda (x y) (+ x y))
- a rest))
- (lambda _
- (lambda-case
- (((x y) #f #f #f () (_ _))
- _))))
-
- (pass-if-peval resolve-primitives
- ((@ (guile) car) '(1 2))
- (const 1))
-
- (pass-if-peval resolve-primitives
- ((@@ (guile) car) '(1 2))
- (const 1)))
-
-
-
(with-test-prefix "tree-il-fold"
(pass-if "empty tree"
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-239-g9d8a10a,
Andy Wingo <=