summaryrefslogtreecommitdiffstats
path: root/bench.scm
diff options
context:
space:
mode:
authorSteve Langasek <vorlon@debian.org>2004-12-07 23:23:48 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:28 -0800
commit37f2f5e0bb11a18deecf48c7ad6bcbf7bd932db2 (patch)
tree692caebb60ec5f80ce528a403b69351ca756d530 /bench.scm
parente21d47d7813159bb71e0671df9b52ec0470c358d (diff)
parentc7d035ae1a729232579a0fe41ed5affa131d3623 (diff)
downloadscm-37f2f5e0bb11a18deecf48c7ad6bcbf7bd932db2.tar.gz
scm-37f2f5e0bb11a18deecf48c7ad6bcbf7bd932db2.zip
Import Debian changes 5d9-4.1debian/5d9-4.1
scm (5d9-4.1) unstable; urgency=high * Non-maintainer upload. * High-urgency upload for sarge-targetted RC bugfix. * Revert upstream "CAUTIOUS" define, which causes the scm build to fail its test suite on alpha (and, it appears, powerpc as well). Closes: #245810. scm (5d9-4) unstable; urgency=low * Apply patch from 144062 to fix hppa build (Closes: #144062) * Change scm.1 section from Jan 4 200 to 1. (lintian) scm (5d9-3) unstable; urgency=low * Properly clean up info files. * Make and install Xlibscm.info. scm (5d9-2) unstable; urgency=low * Fix path problem in slibcat. Hack at mklibcat.scm. (Closes: #241510) scm (5d9-1) unstable; urgency=low * New upstream release * Merge NMU sparc changes (Closes: #191171, #191356) * SHORT_INT is defined for ia64 upstream (Closes: #141928) * Scheme imps now grouped in info file (has been for a while) (Closes: #115452)
Diffstat (limited to 'bench.scm')
-rw-r--r--bench.scm99
1 files changed, 76 insertions, 23 deletions
diff --git a/bench.scm b/bench.scm
index 2d1cc07..4262564 100644
--- a/bench.scm
+++ b/bench.scm
@@ -1,4 +1,4 @@
-;; Copyright (C) 1996, 1997, 2001 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1997, 2001, 2002 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
@@ -38,11 +38,17 @@
;; whether to permit this exception to apply to your modifications.
;; If you do not wish that, delete this exception notice.
-;;;; "bench.scm", Scheme benchmark computing digits of pi.
+;;;; "bench.scm", Scheme benchmarks: digits of pi and random statistics.
;;; Author: Aubrey Jaffer.
-(load (in-vicinity (implementation-vicinity) "pi.scm"))
(require 'transcript)
+(require-if 'inexact 'root)
+(require-if 'inexact 'printf)
+(require 'random)
+(require 'array)
+;;(load (in-vicinity (implementation-vicinity) "prng-v.scm"))
+
+(load (in-vicinity (implementation-vicinity) "pi.scm"))
(define isqrt
(cond ((provided? 'inexact) sqrt)
(else (require 'root) integer-sqrt)))
@@ -51,26 +57,23 @@
(else quotient)))
(define around
(cond ((provided? 'inexact)
- (lambda (x bnd)
- (cond ((>= 99999 (abs x) bnd) (inexact->exact (round x)))
- ((> (abs x) 99999) (round x))
- (else x))))
- (else (lambda (x bnd) x))))
+ (let ()
+ (require 'printf)
+ (lambda (x prec) (sprintf #f "%.*g" prec x))))
+ (else (lambda (x prec) x))))
-(define (time-pi digits)
+(define (time-call proc . args)
(let ((start-time (get-internal-run-time)))
- (pi digits 4)
+ (apply proc args)
(i/ (* 1000 (- (get-internal-run-time) start-time))
internal-time-units-per-second)))
-(define (benchmark . arg)
- (define file
- (cond ((null? arg) "bench.log")
- (else (car arg))))
+(define (benchmark-pi . arg)
+ (define file (if (null? arg) "pi.log" (car arg)))
(do ((digits 50 (+ digits digits))
- (t 0 (time-pi (+ digits digits))))
- ((> t 3000)
- (do ((tl '() (cons (time-pi digits) tl))
+ (t 0 (time-call pi (+ digits digits) 4)))
+ ((> t 3600)
+ (do ((tl '() (cons (time-call pi digits 4) tl))
(j 12 (+ -1 j)))
((zero? j)
(let* ((avg (i/ (apply + tl) (length tl)))
@@ -80,18 +83,68 @@
(length tl)))))
(and file (transcript-on file))
(for-each display
- (list digits " digits took " (around avg 99)
- " +/- " (around dev 3) ".ms"))
+ (list digits " digits of pi took " (around avg 4) ".ms"
+ " +/- " (around dev 2) ".ms"))
(newline)
(let ((scaled-avg (i/ (* (i/ (* avg 1000) digits) 1000) digits))
(scaled-dev (i/ (* (i/ (* dev 1000) digits) 1000) digits)))
(for-each display
(list " That is about "
- (around scaled-avg 99)
+ (around scaled-avg 4) ".ms/(kB)^2"
" +/- "
- (around scaled-dev 3)
- ".ms/(kB)^2"))
+ (around scaled-dev 2) ".ms/(kB)^2"))
(newline)
(and file (transcript-off)))
))))))
-(benchmark)
+
+(define (prng samples modu sta)
+ (define sra (create-array (Au32) samples))
+ (do ((cnt (+ -1 samples) (+ -1 cnt))
+ (num (random modu sta) (random modu sta))
+ (sum 0 (+ sum num)))
+ ((negative? cnt)
+ (set! sum (+ sum num))
+ (let ((mean (i/ sum samples)))
+ (define (square-diff x) (define z (- x mean)) (* z z))
+ (do ((cnt (+ -1 samples) (+ -1 cnt))
+ (var2 0 (+ (square-diff (array-ref sra cnt)) var2)))
+ ((negative? cnt)
+ (for-each display
+ (list sum " / " samples " = "
+ mean " +/- " (isqrt (i/ var2 samples))))
+ (newline)))))
+ (array-set! sra num cnt)))
+
+(define (benchmark-prng . arg)
+ (define file (if (null? arg) "prng.log" (car arg)))
+ (define sta
+ (seed->random-state "http://swissnet.ai.mit.edu/~jaffer/SLIB.html"))
+ (do ((samples 125 (* 4 samples))
+ (t 0 (time-call prng (* 2 samples) 999 sta)))
+ ((or (> t 1000) (and (not (provided? 'bignum)) (> samples 1000)))
+ (do ((tl '() (cons (time-call prng samples 999 sta) tl))
+ (j 12 (+ -1 j)))
+ ((zero? j)
+ (let* ((avg (i/ (apply + tl) (length tl)))
+ (dev (isqrt (i/ (apply
+ + (map (lambda (x) (* (- x avg) (- x avg)))
+ tl))
+ (length tl)))))
+ (and file (transcript-on file))
+ (for-each display
+ (list samples " random samples took " (around avg 4) ".ms"
+ " +/- " (around dev 2) ".ms"))
+ (newline)
+ (let ((scaled-avg (i/ (* avg 1000) samples))
+ (scaled-dev (i/ (* dev 1000) samples)))
+ (for-each display
+ (list " That is about "
+ (around scaled-avg 4) ".ms/kB"
+ " +/- "
+ (around scaled-dev 2) ".ms/kB"))
+ (newline)
+ (and file (transcript-off)))))))))
+
+(benchmark-prng)
+(newline)
+(benchmark-pi)