Merge commit 'de1eb420a5'

Conflicts:
	module/language/tree-il/primitives.scm
	test-suite/tests/tree-il.test

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 (
+  #:use-module (srfi srfi-9)
+  #:export (;; Controlling the execution.
+            iteration-factor
+            scale-iterations
 
- ;; Controlling the execution.
+            ;; Running benchmarks.
- iteration-factor
+            run-benchmark
- scale-iterations
+            benchmark
 
- ;; Running benchmarks.
+            ;; Naming groups of benchmarks in a regular fashion.
- run-benchmark
+            with-benchmark-prefix with-benchmark-prefix*
- benchmark
+            current-benchmark-prefix format-benchmark-name
 
- ;; Naming groups of benchmarks in a regular fashion.
+            ;; <benchmark-result> accessors
- with-benchmark-prefix with-benchmark-prefix* current-benchmark-prefix
+            benchmark-result:name
- format-benchmark-name
+            benchmark-result:iterations
+            benchmark-result:real-time
+            benchmark-result:run-time
+            benchmark-result:gc-time
+            benchmark-result:core-time
 
- ;; Computing timing results
+            ;; Reporting results in various ways.
- benchmark-time-base
+            report current-reporter
- benchmark-total-time benchmark-user-time benchmark-system-time
+            register-reporter unregister-reporter reporter-registered?
- benchmark-frame-time benchmark-core-time
+            make-log-reporter
- benchmark-user-time\interpreter benchmark-core-time\interpreter
+            full-reporter
-
+            user-reporter))
- ;; Reporting results in various ways.
- 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
+;;;; The library uses the guile functions `get-internal-run-time',
-;;;; determine the execution time for a single benchmark.  Based on these
+;;;; `get-internal-real-time', and `gc-run-time' to determine the
-;;;; functions, the values of BEFORE, AFTER and GC-TIME are computed, which
+;;;; execution time for a single benchmark.  Based on these functions,
-;;;; are then passed to the reporter functions.  All three values BEFORE,
+;;;; Guile makes a <benchmark-result>, a record containing the elapsed
-;;;; AFTER and GC-TIME include the time needed to executed the benchmark code
+;;;; run time, real time, gc time, and possibly other metrics.  These
-;;;; itself, but also the surrounding code that implements the loop to run the
+;;;; times include the time needed to executed the benchmark code
-;;;; benchmark code for the given number of times.  This is undesirable, since
+;;;; itself, but also the surrounding code that implements the loop to
-;;;; one would prefer to only get the timing data for the benchmarking code.
+;;;; 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
+;;;; initialization of the library, the time for executing an empty
-;;;; is measured and stored.  This is an estimate for the time needed by the
+;;;; benchmark is measured and stored.  This is an estimate for the time
-;;;; benchmarking framework itself.  For later benchmarks, this time can then
+;;;; needed by the benchmarking framework itself.  For later benchmarks,
-;;;; be subtracted from the measured execution times.
+;;;; this time can then be subtracted from the measured execution times.
+;;;; Note that for very short benchmarks, this may result in a negative
+;;;; number.
 ;;;;
-;;;; In order to simplify the time calculation for users who want to write
+;;;; The benchmarking framework provides the following accessors for
-;;;; their own reporters, benchmarking framework provides the following
+;;;; <benchmark-result> values.  Note that all time values are in
-;;;; definitions:
+;;;; internal time units; divide by internal-time-units-per-second to
+;;;; get seconds.
 ;;;;
-;;;; benchmark-time-base : This variable holds the number of time units that
+;;;; benchmark-result:name : Return the name of the benchmark.
-;;;;     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
+;;;; benchmark-result:iterations : Return the number of iterations that
-;;;; garbage collection time is already passed as an argument GC-TIME to the
+;;;;     this benchmark ran for.
-;;;; reporter functions.
+;;;;
+;;;; 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)
+(define (->seconds time)
-  (exact->inexact (/ a b)))
+  (/ 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)
+(define benchmark-running? (make-parameter #f))
-(let ((benchmark-running #f))
+(define (run-benchmark name iterations thunk)
-  (define (local-run-benchmark name iterations thunk)
+  (if (benchmark-running?)
-    (if benchmark-running
+      (error "Nested calls to run-benchmark are not permitted."))
-	(error "Nested calls to run-benchmark are not permitted.")
+  (if (not (and (integer? iterations) (exact? iterations)))
-	(let ((benchmark-name (full-name name))
+      (error "Expected exact integral number of iterations"))
-	      (iterations (scale-iterations iterations)))
+  (parameterize ((benchmark-running? #t))
-	  (set! benchmark-running #t)
+    ;; Warm up the benchmark first.  This will resolve any toplevel-ref
-	  (let ((before #f) (after #f) (gc-time #f))
+    ;; forms.
-	    (gc)
+    (thunk)
-	    (set! gc-time (gc-run-time))
+    (gc)
-	    (set! before (times))
+    (let* ((before-gc-time (gc-run-time))
-	    (do ((i 0 (+ i 1)))
+           (before-real-time (get-internal-real-time))
-		((= i iterations))
+           (before-run-time (get-internal-run-time)))
-	      (thunk))
+      (do ((i iterations (1- i)))
-	    (set! after (times))
+          ((zero? i))
-	    (set! gc-time (- (gc-run-time) gc-time))
+        (thunk))
-	    (report benchmark-name iterations before after gc-time))
+      (let ((after-run-time (get-internal-run-time))
-	  (set! benchmark-running #f))))
+            (after-real-time (get-internal-real-time))
-  (set! run-benchmark local-run-benchmark))
+            (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)
+(cond-expand
-  `(run-benchmark ,name ,iterations (lambda () ,body ,@rest)))
+ (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
+  (string-join name ": "))
-   (lambda (port)
-     (let loop ((name name)
-		(separator ""))
-       (if (pair? name)
-	   (begin
-	     (display separator port)
-	     (display (car name) port)
-	     (loop (cdr 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.
+;;; A parameter containing the current benchmark prefix, as a list.
-(define prefix-fluid (make-fluid '()))
+(define current-benchmark-prefix
-(define (current-benchmark-prefix)
+  (make-parameter '()))
-  (fluid-ref prefix-fluid))
 
 ;;; 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
+  (parameterize ((current-benchmark-prefix (full-name prefix)))
-		 (append (fluid-ref prefix-fluid) (list 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)
+(cond-expand
-  `(with-benchmark-prefix* ,prefix (lambda () ,@body)))
+ (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
+(define *calibration-result*
-  internal-time-units-per-second)
-
-(define time-base ;; short-cut, not exported
-  benchmark-time-base)
-
-(define frame-time/iteration
   "<will be set during initialization>")
 
-(define (benchmark-total-time before after)
+(define (benchmark-overhead iterations accessor)
-  (- (tms:clock after) (tms:clock before)))
+  (* (/ iterations 1.0 (benchmark-result:iterations *calibration-result*))
+     (accessor *calibration-result*)))
 
-(define (benchmark-user-time before after)
+(define (benchmark-result:core-time result)
-  (- (tms:utime after) (tms:utime before)))
+  (- (benchmark-result:run-time result)
-
+     (benchmark-overhead (benchmark-result:iterations result)
-(define (benchmark-system-time before after)
+                         benchmark-result:run-time)))
-  (- (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))
 
 
 ;;;; REPORTERS
 ;;;;
 
-;;; The global list of reporters.
+;;; The global set of reporters.
-(define reporters '())
+(define report-hook (make-hook 1))
 
-;;; The default reporter, to be used only if no others exist.
+(define (default-reporter result)
-(define default-reporter #f)
+  (if (hook-empty? report-hook)
+      (user-reporter result)
+      (run-hook report-hook result)))
+
+(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)
+  (add-hook! report-hook reporter))
-      (error "register-reporter: reporter already registered: " reporter))
-  (set! reporters (cons reporter reporters)))
 
-;;; 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)
+  (remove-hook! report-hook reporter))
-      (set! reporters (delq! reporter reporters))
-      (error "unregister-reporter: reporter not registered: " 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)
+(define (report result)
-  (if (pair? reporters)
+  ((current-reporter) result))
-      (for-each (lambda (reporter) (apply reporter args))
-		reporters)
-      (apply default-reporter args)))
 
 
 ;;;; 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)
+(define (print-result port result)
-  (let* ((name (format-benchmark-name name))
+  (let ((name (format-benchmark-name (benchmark-result:name result)))
-	 (total-time (benchmark-total-time before after))
+        (iterations (benchmark-result:iterations result))
-	 (user-time (benchmark-user-time before after))
+        (real-time (benchmark-result:real-time result))
-	 (system-time (benchmark-system-time before after))
+        (run-time (benchmark-result:run-time result))
-	 (frame-time (benchmark-frame-time iterations))
+        (gc-time (benchmark-result:gc-time result))
-	 (benchmark-time (benchmark-core-time iterations before after))
+        (core-time (benchmark-result:core-time result)))
-	 (user-time\interpreter
-	  (benchmark-user-time\interpreter before after gc-time))
-	 (benchmark-core-time\interpreter 
-	  (benchmark-core-time\interpreter iterations before after gc-time)))
     (write (list name iterations
-		 'total (i/ total-time time-base)
+		 'total (->seconds real-time)
-		 'user (i/ user-time time-base)
+		 'user (->seconds run-time)
-		 'system (i/ system-time time-base)
+		 'system 0
-		 'frame (i/ frame-time time-base)
+                 'frame (->seconds (- run-time core-time))
-		 'benchmark (i/ benchmark-time time-base)
+		 'benchmark (->seconds core-time)
-		 'user/interp (i/ user-time\interpreter time-base)
+		 'user/interp (->seconds (- run-time gc-time))
-		 'bench/interp (i/ benchmark-core-time\interpreter time-base)
+		 'bench/interp (->seconds (- core-time gc-time))
-		 'gc (i/ gc-time time-base))
+		 '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
+    (lambda (result)
-      (apply print-result port args)
+      (print-result port result)
       (force-output port))))
 
 ;;; A reporter that reports all results to the user.
-(define (full-reporter . args)
+(define (full-reporter result)
-  (apply print-result (current-output-port) args))
+  (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)
+(define (print-user-result port result)
-  (let* ((name (format-benchmark-name name))
+  (let ((name (format-benchmark-name (benchmark-result:name result)))
-	 (user-time (benchmark-user-time before after))
+        (iterations (benchmark-result:iterations result))
-	 (benchmark-time (benchmark-core-time iterations before after))
+        (real-time (benchmark-result:real-time result))
-	 (benchmark-core-time\interpreter
+        (run-time (benchmark-result:run-time result))
-	  (benchmark-core-time\interpreter iterations before after gc-time)))
+        (gc-time (benchmark-result:gc-time result))
+        (core-time (benchmark-result:core-time result)))
     (write (list name iterations
-		 'user (i/ user-time time-base)
+                 'real (->seconds real-time)
-		 'benchmark (i/ benchmark-time time-base)
+		 'real/iteration (->seconds (/ real-time iterations))
-		 'bench/interp (i/ benchmark-core-time\interpreter time-base)
+		 'run/iteration (->seconds (/ run-time iterations))
-		 'gc (i/ gc-time time-base))
+		 '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)
+(define (user-reporter result)
-  (apply print-user-result (current-output-port) args))
+  (print-user-result (current-output-port) result))
 
 
 ;;;; Initialize the benchmarking system:
 ;;;;
 
-;;; First, display version information
+(define (calibrate-benchmark-framework)
-(display ";; running guile version " (current-output-port))
+  (display ";; running guile version ")
-(display (version) (current-output-port))
+  (display (version))
-(newline (current-output-port))
+  (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)))
 
-;;; Second, make sure the benchmarking routines are compiled.
+(calibrate-benchmark-framework)
-(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)

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)))

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)))

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
@@ -45,8 +49,12 @@
     + * - / 1- 1+ quotient remainder modulo
     ash logand logior logxor
     not
-    pair? null? list? symbol? vector? string? struct?
+    pair? null? list? symbol? vector? string? struct? number? char? nil?
-    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
@@ -141,8 +151,10 @@
     = < > <= >= zero?
     + * - / 1- 1+ quotient remainder modulo
     not
-    pair? null? list? symbol? vector? struct? string?
+    pair? null? list? symbol? vector? struct? string? number? char? nil
-    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 +170,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.
+;; Primitives that don't always return one value.
-(define *singly-valued-primitives* 
+(define *multiply-valued-primitives* 
-  '(eq? eqv? equal?
+  '(apply @apply
-    memq memv
+    call-with-values @call-with-values
-    = < > <= >= zero?
+    call-with-current-continuation @call-with-current-continuation
-    + * - / 1- 1+ quotient remainder modulo
+    call/cc
-    ash logand logior logxor
+    dynamic-wind
-    not
+    @dynamic-wind
-    pair? null? list? symbol? vector? acons cons cons*
+    values
-    nil?
+    @prompt call-with-prompt @abort abort-to-prompt))
-    list vector
+
-    car cdr
+;; Procedures that cause a nonlocal, non-resumable abort.
-    set-car! set-cdr!
+(define *bailout-primitives*
-    caar cadr cdar cddr
+  '(throw error scm-error))
-    caaar caadr cadar caddr cdaar cdadr cddar cdddr
+
-    caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
+;; Negatable predicates.
-    cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
+(define *negatable-primitives*
-    vector-ref vector-set!
+  '((even? . odd?)
-    variable-ref variable-set!
+    (exact? . inexact?)
-    variable-bound?
+    (< . >=)
-    fluid-ref fluid-set!
+    (> . <=)
-    make-prompt-tag
+    (char<? . char>=?)
-    struct? struct-vtable make-struct struct-ref struct-set!
+    (char>? . char<=?)))
-    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!))
 
 (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 +213,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 +235,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

test-suite/Makefile.am

@@ -76,6 +76,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			\

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
@@ -653,955 +624,6 @@
               ;; reduce the entire thing to #t.
               #: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, 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"