mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-22 04:30:19 +02:00
Code Activity

Merge commit 'de1eb420a5'

Browse source 
Conflicts:
	module/language/tree-il/primitives.scm
	test-suite/tests/tree-il.test
This commit is contained in:
Andy Wingo 2012-04-26 22:56:45 +02:00
commit c46e0a8a59
7 changed files with 1270 additions and 1281 deletions
Download patch file Download diff file Expand all files Collapse all files

424
benchmark-suite/benchmark-suite/lib.scm
View file

@ -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.
iteration-factor
scale-iterations
;; Running benchmarks.
run-benchmark
benchmark
;; 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
;; 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
;; 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))
;; 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.
;;;; 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.
;;;;
;;;; In order to simplify the time calculation for users who want to write
;;;; their own reporters, benchmarking framework provides the following
;;;; definitions:
;;;; 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-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.
;;;; benchmark-result:name : Return the name of the benchmark.
;;;;
;;;; 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.
;;;; 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-overhead iterations accessor)
(* (/ iterations 1.0 (benchmark-result:iterations *calibration-result*))
(accessor *calibration-result*)))
(define (benchmark-user-time before after)
(- (tms:utime after) (tms:utime before)))
(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))
;;; The default reporter, to be used only if no others exist.
(define default-reporter #f)
(define (default-reporter result)
(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)
(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)))
(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
'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))
'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))
(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)))
;;; 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)
(calibrate-benchmark-framework)

14
benchmark-suite/benchmarks/arithmetic.bm
View file

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

8
benchmark-suite/benchmarks/r6rs-arithmetic.bm
View file

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

121
module/language/tree-il/primitives.scm
View file

@ -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?
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
@ -141,8 +151,10 @@
= < > <= >= zero?
+ * - / 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 +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.
(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 +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

1
test-suite/Makefile.am
View file

@ -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 \

1001
test-suite/tests/peval.test Normal file
View file

File diff suppressed because it is too large Load diff

978
test-suite/tests/tree-il.test
View file

@ -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"