From b064d565141ca777778fa38e0fe98c0aed834eb9 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 23 Apr 2012 04:27:34 -0400 Subject: [PATCH 1/4] avoid inexact iteration count in benchmarks * benchmark-suite/benchmarks/arithmetic.bm: * benchmark-suite/benchmarks/r6rs-arithmetic.bm: Use #e1e7 for the iteration count, instead of the flonum 1e7. --- benchmark-suite/benchmarks/arithmetic.bm | 14 +++++++------- benchmark-suite/benchmarks/r6rs-arithmetic.bm | 8 ++++---- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/benchmark-suite/benchmarks/arithmetic.bm b/benchmark-suite/benchmarks/arithmetic.bm index c64f6c20b..e0a9bf3c1 100644 --- a/benchmark-suite/benchmarks/arithmetic.bm +++ b/benchmark-suite/benchmarks/arithmetic.bm @@ -1,7 +1,7 @@ ;;; -*- mode: scheme; coding: utf-8; -*- ;;; Integer arithmetic. ;;; -;;; Copyright 2010 Free Software Foundation, Inc. +;;; Copyright 2010, 2012 Free Software Foundation, Inc. ;;; ;;; This program is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Lesser General Public License @@ -48,20 +48,20 @@ (with-benchmark-prefix "fixnum" - (benchmark "1+" 1e7 + (benchmark "1+" #e1e7 (repeat (1+ <>) 2 100)) - (benchmark "1-" 1e7 + (benchmark "1-" #e1e7 (repeat (1- <>) 2 100)) - (benchmark "+" 1e7 + (benchmark "+" #e1e7 (repeat (+ 2 <>) 7 100)) - (benchmark "-" 1e7 + (benchmark "-" #e1e7 (repeat (- 2 <>) 7 100)) - (benchmark "*" 1e7 + (benchmark "*" #e1e7 (repeat (* 1 <>) 1 100)) - (benchmark "/" 1e7 + (benchmark "/" #e1e7 (repeat (/ 2 <>) 1 100))) diff --git a/benchmark-suite/benchmarks/r6rs-arithmetic.bm b/benchmark-suite/benchmarks/r6rs-arithmetic.bm index 4c9b8e6b7..309f0666b 100644 --- a/benchmark-suite/benchmarks/r6rs-arithmetic.bm +++ b/benchmark-suite/benchmarks/r6rs-arithmetic.bm @@ -1,7 +1,7 @@ ;;; -*- mode: scheme; coding: utf-8; -*- ;;; R6RS-specific arithmetic benchmarks ;;; -;;; Copyright (C) 2011 Free Software Foundation, Inc. +;;; Copyright (C) 2011, 2012 Free Software Foundation, Inc. ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Lesser General Public @@ -24,12 +24,12 @@ (with-benchmark-prefix "fixnum" - (benchmark "fixnum? [yes]" 1e7 + (benchmark "fixnum? [yes]" #e1e7 (fixnum? 10000)) (let ((n (+ most-positive-fixnum 100))) - (benchmark "fixnum? [no]" 1e7 + (benchmark "fixnum? [no]" #e1e7 (fixnum? n))) - (benchmark "fxxor [2]" 1e7 + (benchmark "fxxor [2]" #e1e7 (fxxor 3 8))) From 7e822b32d2a165a027fd1de4d59fdfae568599bf Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 23 Apr 2012 04:42:09 -0400 Subject: [PATCH 2/4] modernize (benchmark-suite lib) * benchmark-suite/benchmark-suite/lib.scm: Rewrite to be more modern, using parameters, records, and higher precision timers. Since this file was never installed, this is an acceptable interface change. (run-benchmark): Run the thunk once before going into the benchmark. Adapt to new `report' interface. (report): Change to expect only one argument, a object. (print-result): Adapt. The result is in the same format as before. (print-user-result): Adapt. The result is different from before, but as this is just printed on stdout and not logged, there should be no problem. (calibrate-benchmark-framework): Pull initialization into a function. --- benchmark-suite/benchmark-suite/lib.scm | 428 +++++++++++------------- 1 file changed, 196 insertions(+), 232 deletions(-) diff --git a/benchmark-suite/benchmark-suite/lib.scm b/benchmark-suite/benchmark-suite/lib.scm index 4ba0e3e1c..ae57cc02a 100644 --- a/benchmark-suite/benchmark-suite/lib.scm +++ b/benchmark-suite/benchmark-suite/lib.scm @@ -1,5 +1,5 @@ ;;;; benchmark-suite/lib.scm --- generic support for benchmarking -;;;; Copyright (C) 2002, 2006, 2011 Free Software Foundation, Inc. +;;;; Copyright (C) 2002, 2006, 2011, 2012 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -17,31 +17,33 @@ ;;;; Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (benchmark-suite lib) - :export ( + #: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 + ;; 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 , 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 +;;;; 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. -;;;; -;;;; 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:name : Return the name of the benchmark. +;;;; +;;;; benchmark-result:iterations : Return the number of iterations that +;;;; this benchmark ran for. +;;;; +;;;; benchmark-result:real-time : Return the clock time elapsed while +;;;; this benchmark executed. +;;;; +;;;; benchmark-result:run-time : Return the CPU time elapsed while this +;;;; benchmark executed, both in user and kernel space. +;;;; +;;;; benchmark-result:gc-time : Return the approximate amount of time +;;;; spent in garbage collection while this benchmark executed, both +;;;; in user and kernel space. +;;;; +;;;; benchmark-result:core-time : Like benchmark-result:run-time, but +;;;; also estimates the time spent by the framework for the number +;;;; of iterations, and subtracts off that time from the result. +;;;; + +;;;; This module is used when benchmarking different Guiles, and so it +;;;; should run on all the Guiles of interest. Currently this set +;;;; includes Guile 1.8, so be careful with introducing features that +;;;; only Guile 2.0 supports. ;;;; MISCELLANEOUS ;;;; +(define-record-type + (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* "") -(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))) - (write (list name iterations - 'user (i/ user-time time-base) - 'benchmark (i/ benchmark-time time-base) - 'bench/interp (i/ benchmark-core-time\interpreter time-base) - 'gc (i/ gc-time time-base)) +(define (print-user-result port result) + (let ((name (format-benchmark-name (benchmark-result:name result))) + (iterations (benchmark-result:iterations result)) + (real-time (benchmark-result:real-time result)) + (run-time (benchmark-result:run-time result)) + (gc-time (benchmark-result:gc-time result)) + (core-time (benchmark-result:core-time result))) + (write (list name iterations + 'real (->seconds real-time) + 'real/iteration (->seconds (/ real-time iterations)) + 'run/iteration (->seconds (/ run-time iterations)) + 'core/iteration (->seconds (/ core-time iterations)) + 'gc (->seconds gc-time)) port) (newline port))) ;;; A reporter that reports interesting results to the user. -(define (user-reporter . args) - (apply print-user-result (current-output-port) args)) +(define (user-reporter result) + (print-user-result (current-output-port) result)) ;;;; Initialize the benchmarking system: ;;;; -;;; First, display version information -(display ";; running guile version " (current-output-port)) -(display (version) (current-output-port)) -(newline (current-output-port)) +(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) From 5deea34d0eb3d2ec5db421eb79516e747eed5841 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 10 Apr 2012 15:47:21 -0700 Subject: [PATCH 3/4] add more primitives and predicates to (language tree-il primitives) * module/language/tree-il/primitives.scm (*interesting-primitive-names*): Add number? and char?. Add more numeric predicates. Add character comparators. Add throw, error, and scm-error. (*primitive-accessors*): Remove struct-vtable. Though the vtable's contents may change (through redefinition), its identity does not change. (*effect-free-primitives*): Put struct-vtable, number?, and char? here. (*multiply-valued-primitives*): Instead of listing singly-valued primitives, list multiply-valued primitives. (*bailout-primitives*): New list. (*negatable-primitives*): New alist. (*bailout-primitive-table*, *multiply-valued-primitive-table*) (*negatable-primitive-table*): New tables. (singly-valued-primitive?): Adapt to use *multiply-valued-primitive-table*. (bailout-primitive?, negate-primitive): New exported procedures. --- module/language/tree-il/primitives.scm | 113 +++++++++++++------------ 1 file changed, 58 insertions(+), 55 deletions(-) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index 2039faa63..704f7c294 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -29,8 +29,11 @@ expand-primitives! effect-free-primitive? effect+exception-free-primitive? constructor-primitive? accessor-primitive? - singly-valued-primitive?)) + singly-valued-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,7 +48,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? + + complex? real? rational? inf? nan? integer? exact? inexact? even? odd? + + char=? char>? + acons cons cons* list vector @@ -69,6 +77,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! @@ -122,7 +132,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 @@ -140,7 +150,10 @@ = < > <= >= zero? + * - / 1- 1+ quotient remainder modulo not - pair? null? list? symbol? vector? struct? string? + pair? null? list? symbol? vector? struct? string? number? char? + complex? real? rational? inf? nan? integer? exact? inexact? even? odd? + char=? char>? + struct-vtable string-length ;; These all should get expanded out by expand-primitives!. caar cadr cdar cddr @@ -156,59 +169,38 @@ '(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* - 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<=?))) (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 *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)) @@ -217,8 +209,15 @@ (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*) + (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*)) @@ -229,7 +228,11 @@ (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)) + (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) (post-order! From de1eb420a5a95b17e85b19c4d98c869036e9ecb0 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 11 Apr 2012 11:43:00 -0700 Subject: [PATCH 4/4] peval tests into separate file * test-suite/tests/tree-il.test ("partial evaluation"): * test-suite/tests/peval.test ("partial evaluation"): Separate peval * tests. * test-suite/Makefile.am: Adapt. --- test-suite/Makefile.am | 1 + test-suite/tests/peval.test | 988 ++++++++++++++++++++++++++++++++++ test-suite/tests/tree-il.test | 965 --------------------------------- 3 files changed, 989 insertions(+), 965 deletions(-) create mode 100644 test-suite/tests/peval.test diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index c87af17d5..054a94b54 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -75,6 +75,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 \ diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test new file mode 100644 index 000000000..400c3e7fb --- /dev/null +++ b/test-suite/tests/peval.test @@ -0,0 +1,988 @@ +;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*- +;;;; Andy Wingo --- May 2009 +;;;; +;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (test-suite tree-il) + #:use-module (test-suite lib) + #:use-module (system base compile) + #:use-module (system base pmatch) + #:use-module (system base message) + #:use-module (language tree-il) + #:use-module (language tree-il primitives) + #:use-module (language glil) + #:use-module (srfi srfi-13)) + +(define peval + ;; The partial evaluator. + (@@ (language tree-il optimize) peval)) + +(define-syntax pass-if-peval + (syntax-rules (resolve-primitives) + ((_ in pat) + (pass-if-peval in pat + (compile 'in #:from 'scheme #:to 'tree-il))) + ((_ resolve-primitives in pat) + (pass-if-peval in pat + (expand-primitives! + (resolve-primitives! + (compile 'in #:from 'scheme #:to 'tree-il) + (current-module))))) + ((_ in pat code) + (pass-if 'in + (let ((evaled (unparse-tree-il (peval code)))) + (pmatch evaled + (pat #t) + (_ (pk 'peval-mismatch) + ((@ (ice-9 pretty-print) pretty-print) + 'in) + (newline) + ((@ (ice-9 pretty-print) pretty-print) + evaled) + (newline) + ((@ (ice-9 pretty-print) pretty-print) + 'pat) + (newline) + #f))))))) + + +(with-test-prefix "partial evaluation" + + (pass-if-peval + ;; First order, primitive. + (let ((x 1) (y 2)) (+ x y)) + (const 3)) + + (pass-if-peval + ;; First order, thunk. + (let ((x 1) (y 2)) + (let ((f (lambda () (+ x y)))) + (f))) + (const 3)) + + (pass-if-peval resolve-primitives + ;; 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 resolve-primitives + ;; First order, multiple values. + (let ((x 1) (y 2)) + (values x y)) + (apply (primitive values) (const 1) (const 2))) + + (pass-if-peval resolve-primitives + ;; First order, multiple values truncated. + (let ((x (values 1 'a)) (y 2)) + (values x y)) + (apply (primitive values) (const 1) (const 2))) + + (pass-if-peval resolve-primitives + ;; 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)))) + (apply (primitive 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)))) + (apply (primitive cons) (const 0) + (apply (primitive cons) (const 1) + (apply (primitive 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)))) + (apply (primitive list) + (apply (primitive cons) (const 1) (const 1)) + (apply (primitive cons) (const 2) (const 2)) + (apply (primitive 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) (_) + ((apply (primitive list) + (apply (primitive cons) (const 3) (const 3)))) + (let (r) (_) + ((apply (primitive cons) + (apply (primitive cons) (const 2) (const 2)) + (lexical r _))) + (apply (primitive cons) + (apply (primitive 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) (_) + ((apply (primitive list) (const 4))) + (let (r) (_) + ((apply (primitive cons) + (const 3) + (lexical r _))) + (let (r) (_) + ((apply (primitive cons) + (const 2) + (lexical r _))) + (let (r) (_) + ((apply (primitive cons) + (const 1) + (lexical r _))) + (apply (primitive 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 resolve-primitives + (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")) + (apply (primitive 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))) + (begin + (apply . _) + (const #t))) + + (pass-if-peval + ;; Mutability preserved. + ((lambda (x y z) (list x y z)) 1 2 3) + (apply (primitive 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) (_) ((apply (primitive list) (const 1))) + (let (y) (_) ((apply (primitive car) (lexical x _))) + (begin + (apply (toplevel 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) (_) ((apply (primitive car) (toplevel x))) + (begin + (apply (toplevel 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) _ _ _ _ _) + (apply (lexical x _) (lexical x _)))))) + (apply (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)) + (begin + (define + + (lambda (_) + (lambda-case + (((x y) #f #f #f () (_ _)) + (apply (toplevel pk) (lexical x _) (lexical y _)))))) + (apply (toplevel +) (const 1) (const 2)))) + + (pass-if-peval + ;; First-order, effects preserved. + (let ((x 2)) + (do-something!) + x) + (begin + (apply (toplevel do-something!)) + (const 2))) + + (pass-if-peval + ;; First order, residual bindings removed. + (let ((x 2) (y 3)) + (* (+ x y) z)) + (apply (primitive *) (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 () (_)) + (apply (primitive +) (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))) + (apply (primitive +) + (apply (primitive *) + (const 2) + (apply (primitive +) ; (f 2 3) + (apply (primitive *) + (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. + (apply (primitive +) + (apply (primitive *) + (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))) + (apply (primitive +) + (const -1) ; (f -1 0) + (const 0) ; (f 1 0) + (begin (toplevel y) (const -1)) ; (f -1 y) + (toplevel y) ; (f 2 y) + (let (x y) (_ _) ((toplevel z) (toplevel y)) ; (f z y) + (if (apply (primitive >) (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 () (_)) + (apply (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)) + (begin + (apply (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) (_) ((apply (toplevel foo))) + (apply (primitive +) (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 + ;; . + (let ((fold (lambda (f g) (f (g top))))) + (fold 1+ (lambda (x) x))) + (apply (primitive 1+) (toplevel top))) + + (pass-if-peval + ;; Procedure not inlined when residual code contains recursive calls. + ;; + (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) (_) (_) + (apply (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 () (_)) + (apply (primitive -) (lexical x2 _) (const 1)))))))) + + (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 + ;; and + ;; . + (pmatch (unparse-tree-il + (peval (compile + '(let ((make-adder + (lambda (x) (lambda (y) (+ x y))))) + (cons (make-adder 1) (make-adder 2))) + #:to 'tree-il))) + ((apply (primitive cons) + (lambda () + (lambda-case + (((y) #f #f #f () (,gensym1)) + (apply (primitive +) + (const 1) + (lexical y ,ref1))))) + (lambda () + (lambda-case + (((y) #f #f #f () (,gensym2)) + (apply (primitive +) + (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)) + (begin (apply (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)) + (apply (primitive memv) + (const 1) + (apply (primitive 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 (apply (primitive eqv?) (lexical key _) (const 3)) + (const #t) + (if (apply (primitive eqv?) (lexical key _) (const 2)) + (const #t) + (apply (primitive eqv?) (lexical key _) (const 1)))) + (const a) + (const b)))) + + (pass-if-peval + ;; Memv with non-constant key, empty list, test context. Currently + ;; doesn't fold entirely. + (case foo + (() 'a) + (else 'b)) + (begin (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) (_) + ((apply (toplevel make-vector) (const 6) (const #f))) + (lambda () + (lambda-case + (((n) #f #f #f () (_)) + (apply (toplevel 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) (_) + ((apply (primitive 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 (apply (primitive >) (toplevel p) (toplevel q)) + (apply (toplevel frob!)) + (apply (toplevel display) (const chbouib)))) + (let (y) (_) ((apply (primitive *) (lexical x _) (const 2))) + (apply (primitive +) + (lexical x _) (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) (_ _ _) + ((apply (primitive vector) (const 1) (const 2) (const 3)) + (apply (toplevel make-list) (const 10)) + (apply (primitive list) (const 1) (const 2) (const 3))) + (begin + (apply (toplevel vector-set!) + (lexical x _) (const 0) (const 0)) + (apply (toplevel set-car!) + (lexical y _) (const 0)) + (apply (toplevel 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)) + (apply (primitive +) + (apply (primitive +) (lexical foo _) (lexical foo _)) + (apply (primitive +) (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) (_) ((apply (primitive cons) (const 1) (const (2 3)))) + (apply (primitive cons) (const 0) (lexical x _)))) + + (pass-if-peval + ;; Bindings mutated. + (let ((x 2)) + (set! x 3) + x) + (let (x) (_) ((const 2)) + (begin + (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)) + (begin + (apply (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) (_) ((apply (toplevel make-foo))) + (begin + (apply (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 _ _ + (apply (lexical loop _) + (apply (primitive 1-) + (lexical x _)))))))) + (apply (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) (_) ((apply (toplevel top))) + (apply (toplevel foo) (lexical x _) (const 0)))) + + (pass-if-peval + ;; Inlining aborted when residual code contains recursive calls. + ;; + ;; + (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 (apply (primitive >) + (lexical y _) (const 0)) + _ _))))) + (apply (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 . _)) + (apply (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)) + (begin + (set! (lexical pos _) (const 1)) + (let (here) (_) (_) + (apply (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 () ()) + (apply (lexical a _))))) + (lambda _ + (lambda-case + (((x) #f #f #f () (_)) + (lexical x _)))) + (lambda _ + (lambda-case + ((() #f #f #f () ()) + (apply (lexical a _)))))) + (let (d) + (_) + ((apply (toplevel foo) (lexical b _))) + (apply (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))) + (apply (toplevel foo) + (lambda _ + (lambda-case + (((x) #f #f #f () (_)) + (apply (toplevel top) (lexical x _))))) + (lambda _ + (lambda-case + (((x) #f #f #f () (_)) + (apply (toplevel top) (lexical x _))))))) + + (pass-if-peval + ;; Constant folding: cons of #nil does not make list + (cons 1 #nil) + (apply (primitive 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) + (begin (apply (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))) + (begin (apply (toplevel bar)) (const 1))) + + (pass-if-peval + ;; Constant folding: cdr+cons, impure + (cdr (cons (bar) 0)) + (begin (apply (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)) + (apply (primitive list) (const 0))) + + (pass-if-peval + ;; Constant folding: car+list, impure + (car (list 1 (bar))) + (begin (apply (toplevel bar)) (const 1))) + + (pass-if-peval + ;; Constant folding: cdr+list, impure + (cdr (list (bar) 0)) + (begin (apply (toplevel bar)) (apply (primitive list) (const 0)))) + + (pass-if-peval + resolve-primitives + ;; Non-constant guards get lexical bindings. + (dynamic-wind foo (lambda () bar) baz) + (let (pre post) (_ _) ((toplevel foo) (toplevel baz)) + (dynwind (lexical pre _) (toplevel bar) (lexical post _)))) + + (pass-if-peval + resolve-primitives + ;; 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 bar) + (lambda () + (lambda-case + ((() #f #f #f () ()) (toplevel baz)))))) + + (pass-if-peval + resolve-primitives + ;; 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 + resolve-primitives + ;; 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 + resolve-primitives + (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 + resolve-primitives + (call-with-prompt tag + (lambda () 1) + handler) + (let (handler) (_) ((toplevel handler)) + (prompt (toplevel tag) + (const 1) + (lambda-case + ((() #f args #f () (_)) + (apply (primitive @apply) + (lexical handler _) + (lexical args _))))))) + + (pass-if-peval + resolve-primitives + ;; `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 () ()) + (apply (lexical loop _)))))) + (apply (lexical loop _))))))) + (apply (lexical lp _)))) + + (pass-if-peval + resolve-primitives + (lambda (a . rest) + (apply (lambda (x y) (+ x y)) + a rest)) + (lambda _ + (lambda-case + (((x y) #f #f #f () (_ _)) + _)))) + + (pass-if-peval resolve-primitives + (car '(1 2)) + (const 1))) diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index 0f0e553e9..2d0784ed8 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -69,38 +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 (resolve-primitives) - ((_ in pat) - (pass-if-peval in pat - (compile 'in #:from 'scheme #:to 'tree-il))) - ((_ resolve-primitives in pat) - (pass-if-peval in pat - (expand-primitives! - (resolve-primitives! - (compile 'in #:from 'scheme #:to 'tree-il) - (current-module))))) - ((_ in pat code) - (pass-if 'in - (let ((evaled (unparse-tree-il (peval code)))) - (pmatch evaled - (pat #t) - (_ (pk 'peval-mismatch) - ((@ (ice-9 pretty-print) pretty-print) - 'in) - (newline) - ((@ (ice-9 pretty-print) pretty-print) - evaled) - (newline) - ((@ (ice-9 pretty-print) pretty-print) - 'pat) - (newline) - #f))))))) - (with-test-prefix "tree-il->scheme" (pass-if-tree-il->scheme @@ -656,939 +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 resolve-primitives - ;; 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 resolve-primitives - ;; First order, multiple values. - (let ((x 1) (y 2)) - (values x y)) - (apply (primitive values) (const 1) (const 2))) - - (pass-if-peval resolve-primitives - ;; First order, multiple values truncated. - (let ((x (values 1 'a)) (y 2)) - (values x y)) - (apply (primitive values) (const 1) (const 2))) - - (pass-if-peval resolve-primitives - ;; 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)))) - (apply (primitive 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)))) - (apply (primitive cons) (const 0) - (apply (primitive cons) (const 1) - (apply (primitive 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)))) - (apply (primitive list) - (apply (primitive cons) (const 1) (const 1)) - (apply (primitive cons) (const 2) (const 2)) - (apply (primitive 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) (_) - ((apply (primitive list) - (apply (primitive cons) (const 3) (const 3)))) - (let (r) (_) - ((apply (primitive cons) - (apply (primitive cons) (const 2) (const 2)) - (lexical r _))) - (apply (primitive cons) - (apply (primitive 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) (_) - ((apply (primitive list) (const 4))) - (let (r) (_) - ((apply (primitive cons) - (const 3) - (lexical r _))) - (let (r) (_) - ((apply (primitive cons) - (const 2) - (lexical r _))) - (let (r) (_) - ((apply (primitive cons) - (const 1) - (lexical r _))) - (apply (primitive 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 resolve-primitives - (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")) - (apply (primitive 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))) - (begin - (apply . _) - (const #t))) - - (pass-if-peval - ;; Mutability preserved. - ((lambda (x y z) (list x y z)) 1 2 3) - (apply (primitive 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) (_) ((apply (primitive list) (const 1))) - (let (y) (_) ((apply (primitive car) (lexical x _))) - (begin - (apply (toplevel 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) (_) ((apply (primitive car) (toplevel x))) - (begin - (apply (toplevel 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) _ _ _ _ _) - (apply (lexical x _) (lexical x _)))))) - (apply (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)) - (begin - (define + - (lambda (_) - (lambda-case - (((x y) #f #f #f () (_ _)) - (apply (toplevel pk) (lexical x _) (lexical y _)))))) - (apply (toplevel +) (const 1) (const 2)))) - - (pass-if-peval - ;; First-order, effects preserved. - (let ((x 2)) - (do-something!) - x) - (begin - (apply (toplevel do-something!)) - (const 2))) - - (pass-if-peval - ;; First order, residual bindings removed. - (let ((x 2) (y 3)) - (* (+ x y) z)) - (apply (primitive *) (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 () (_)) - (apply (primitive +) (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))) - (apply (primitive +) - (apply (primitive *) - (const 2) - (apply (primitive +) ; (f 2 3) - (apply (primitive *) - (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. - (apply (primitive +) - (apply (primitive *) - (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))) - (apply (primitive +) - (const -1) ; (f -1 0) - (const 0) ; (f 1 0) - (begin (toplevel y) (const -1)) ; (f -1 y) - (toplevel y) ; (f 2 y) - (let (x y) (_ _) ((toplevel z) (toplevel y)) ; (f z y) - (if (apply (primitive >) (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 () (_)) - (apply (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)) - (begin - (apply (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) (_) ((apply (toplevel foo))) - (apply (primitive +) (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 - ;; . - (let ((fold (lambda (f g) (f (g top))))) - (fold 1+ (lambda (x) x))) - (apply (primitive 1+) (toplevel top))) - - (pass-if-peval - ;; Procedure not inlined when residual code contains recursive calls. - ;; - (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) (_) (_) - (apply (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 () (_)) - (apply (primitive -) (lexical x2 _) (const 1)))))))) - - (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 - ;; and - ;; . - (pmatch (unparse-tree-il - (peval (compile - '(let ((make-adder - (lambda (x) (lambda (y) (+ x y))))) - (cons (make-adder 1) (make-adder 2))) - #:to 'tree-il))) - ((apply (primitive cons) - (lambda () - (lambda-case - (((y) #f #f #f () (,gensym1)) - (apply (primitive +) - (const 1) - (lexical y ,ref1))))) - (lambda () - (lambda-case - (((y) #f #f #f () (,gensym2)) - (apply (primitive +) - (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)) - (begin (apply (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)) - (apply (primitive memv) - (const 1) - (apply (primitive 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 (apply (primitive eqv?) (lexical key _) (const 3)) - (const #t) - (if (apply (primitive eqv?) (lexical key _) (const 2)) - (const #t) - (apply (primitive eqv?) (lexical key _) (const 1)))) - (const a) - (const b)))) - - (pass-if-peval - ;; Memv with non-constant key, empty list, test context. Currently - ;; doesn't fold entirely. - (case foo - (() 'a) - (else 'b)) - (begin (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) (_) - ((apply (toplevel make-vector) (const 6) (const #f))) - (lambda () - (lambda-case - (((n) #f #f #f () (_)) - (apply (toplevel 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) (_) - ((apply (primitive 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 (apply (primitive >) (toplevel p) (toplevel q)) - (apply (toplevel frob!)) - (apply (toplevel display) (const chbouib)))) - (let (y) (_) ((apply (primitive *) (lexical x _) (const 2))) - (apply (primitive +) - (lexical x _) (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) (_ _ _) - ((apply (primitive vector) (const 1) (const 2) (const 3)) - (apply (toplevel make-list) (const 10)) - (apply (primitive list) (const 1) (const 2) (const 3))) - (begin - (apply (toplevel vector-set!) - (lexical x _) (const 0) (const 0)) - (apply (toplevel set-car!) - (lexical y _) (const 0)) - (apply (toplevel 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)) - (apply (primitive +) - (apply (primitive +) (lexical foo _) (lexical foo _)) - (apply (primitive +) (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) (_) ((apply (primitive cons) (const 1) (const (2 3)))) - (apply (primitive cons) (const 0) (lexical x _)))) - - (pass-if-peval - ;; Bindings mutated. - (let ((x 2)) - (set! x 3) - x) - (let (x) (_) ((const 2)) - (begin - (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)) - (begin - (apply (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) (_) ((apply (toplevel make-foo))) - (begin - (apply (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 _ _ - (apply (lexical loop _) - (apply (primitive 1-) - (lexical x _)))))))) - (apply (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) (_) ((apply (toplevel top))) - (apply (toplevel foo) (lexical x _) (const 0)))) - - (pass-if-peval - ;; Inlining aborted when residual code contains recursive calls. - ;; - ;; - (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 (apply (primitive >) - (lexical y _) (const 0)) - _ _))))) - (apply (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 . _)) - (apply (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)) - (begin - (set! (lexical pos _) (const 1)) - (let (here) (_) (_) - (apply (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 () ()) - (apply (lexical a _))))) - (lambda _ - (lambda-case - (((x) #f #f #f () (_)) - (lexical x _)))) - (lambda _ - (lambda-case - ((() #f #f #f () ()) - (apply (lexical a _)))))) - (let (d) - (_) - ((apply (toplevel foo) (lexical b _))) - (apply (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))) - (apply (toplevel foo) - (lambda _ - (lambda-case - (((x) #f #f #f () (_)) - (apply (toplevel top) (lexical x _))))) - (lambda _ - (lambda-case - (((x) #f #f #f () (_)) - (apply (toplevel top) (lexical x _))))))) - - (pass-if-peval - ;; Constant folding: cons of #nil does not make list - (cons 1 #nil) - (apply (primitive 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) - (begin (apply (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))) - (begin (apply (toplevel bar)) (const 1))) - - (pass-if-peval - ;; Constant folding: cdr+cons, impure - (cdr (cons (bar) 0)) - (begin (apply (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)) - (apply (primitive list) (const 0))) - - (pass-if-peval - ;; Constant folding: car+list, impure - (car (list 1 (bar))) - (begin (apply (toplevel bar)) (const 1))) - - (pass-if-peval - ;; Constant folding: cdr+list, impure - (cdr (list (bar) 0)) - (begin (apply (toplevel bar)) (apply (primitive list) (const 0)))) - - (pass-if-peval - resolve-primitives - ;; Non-constant guards get lexical bindings. - (dynamic-wind foo (lambda () bar) baz) - (let (pre post) (_ _) ((toplevel foo) (toplevel baz)) - (dynwind (lexical pre _) (toplevel bar) (lexical post _)))) - - (pass-if-peval - resolve-primitives - ;; 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 bar) - (lambda () - (lambda-case - ((() #f #f #f () ()) (toplevel baz)))))) - - (pass-if-peval - resolve-primitives - ;; 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 - resolve-primitives - ;; 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 - resolve-primitives - (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 - resolve-primitives - (call-with-prompt tag - (lambda () 1) - handler) - (let (handler) (_) ((toplevel handler)) - (prompt (toplevel tag) - (const 1) - (lambda-case - ((() #f args #f () (_)) - (apply (primitive @apply) - (lexical handler _) - (lexical args _))))))) - - (pass-if-peval - resolve-primitives - ;; `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 () ()) - (apply (lexical loop _)))))) - (apply (lexical loop _))))))) - (apply (lexical lp _)))) - - (pass-if-peval - resolve-primitives - (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"