"Fossies" - the Fresh Open Source Software Archive

Member "scm/bench.scm" (30 Dec 2017, 4245 Bytes) of package /linux/privat/scm-5f3.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Lisp source code syntax highlighting (style: standard) with prefixed line numbers. Alternatively you can here view or download the uninterpreted source code file. See also the latest Fossies "Diffs" side-by-side code changes report for "bench.scm": 5f2_vs_5f3.

    1 ;;;; "bench.scm", Scheme benchmarks: digits of pi and random statistics.
    2 ;; Copyright (C) 1996, 1997, 2001, 2002 Free Software Foundation, Inc.
    3 ;; 
    4 ;; This program is free software: you can redistribute it and/or modify
    5 ;; it under the terms of the GNU General Public License as
    6 ;; published by the Free Software Foundation, either version 3 of the
    7 ;; License, or (at your option) any later version.
    8 ;;
    9 ;; This program is distributed in the hope that it will be useful, but
   10 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
   11 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
   12 ;; General Public License for more details.
   13 ;;
   14 ;; You should have received a copy of the GNU General Public
   15 ;; License along with this program.  If not, see
   16 ;; <http://www.gnu.org/licenses/>.
   17 
   18 ;;; Author: Aubrey Jaffer.
   19 
   20 (require 'transcript)
   21 (require-if 'inexact 'root)
   22 (require-if 'inexact 'printf)
   23 (require 'random)
   24 (require 'array)
   25 ;;(load (in-vicinity (implementation-vicinity) "prng-v.scm"))
   26 
   27 (load (in-vicinity (program-vicinity) "pi.scm"))
   28 (define isqrt
   29   (cond ((provided? 'inexact) sqrt)
   30     (else (require 'root) integer-sqrt)))
   31 (define i/
   32   (cond ((provided? 'inexact) /)
   33     (else quotient)))
   34 (define around
   35   (cond ((provided? 'inexact)
   36      (let ()
   37        (require 'printf)
   38        (lambda (x prec) (sprintf #f "%.*g" prec x))))
   39     (else (lambda (x prec) x))))
   40 
   41 (define (time-call proc . args)
   42   (let ((start-time (get-internal-run-time)))
   43     (apply proc args)
   44     (i/ (* 1000 (- (get-internal-run-time) start-time))
   45     internal-time-units-per-second)))
   46 
   47 (define (benchmark-pi . arg)
   48   (define file (if (null? arg) "pi.log" (car arg)))
   49   (do ((digits 50 (+ digits digits))
   50        (t 0 (time-call pi (+ digits digits) 4)))
   51       ((> t 3600)
   52        (do ((tl '() (cons (time-call pi digits 4) tl))
   53         (j 12 (+ -1 j)))
   54        ((zero? j)
   55         (let* ((avg (i/ (apply + tl) (length tl)))
   56            (dev (isqrt (i/ (apply
   57                     + (map (lambda (x) (* (- x avg) (- x avg)))
   58                        tl))
   59                    (length tl)))))
   60           (and file (transcript-on file))
   61           (for-each display
   62             (list digits " digits of pi took " (around avg 4) ".ms"
   63                   " +/- " (around dev 2) ".ms"))
   64           (newline)
   65           (let ((scaled-avg (i/ (* (i/ (* avg 1000) digits) 1000) digits))
   66             (scaled-dev (i/ (* (i/ (* dev 1000) digits) 1000) digits)))
   67         (for-each display
   68               (list " That is about "
   69                 (around scaled-avg 4) ".ms/(kB)^2"
   70                 " +/- "
   71                 (around scaled-dev 2) ".ms/(kB)^2"))
   72         (newline)
   73         (and file (transcript-off)))
   74           ))))))
   75 
   76 (define (prng samples modu sta)
   77   (define sra (make-array (A:fixN32b) samples))
   78   (do ((cnt (+ -1 samples) (+ -1  cnt))
   79        (num (random modu sta) (random modu sta))
   80        (sum 0 (+ sum num)))
   81       ((negative? cnt)
   82        (set! sum (+ sum num))
   83        (let ((mean (i/ sum samples)))
   84      (define (square-diff x) (define z (- x mean)) (* z z))
   85      (do ((cnt (+ -1 samples) (+ -1 cnt))
   86           (var2 0 (+ (square-diff (array-ref sra cnt)) var2)))
   87          ((negative? cnt)
   88           (for-each display
   89             (list sum " / " samples " = "
   90                   mean " +/- " (isqrt (i/ var2 samples))))
   91           (newline)))))
   92     (array-set! sra num cnt)))
   93 
   94 (define (benchmark-prng . arg)
   95   (define file (if (null? arg) "prng.log" (car arg)))
   96   (define sta
   97     (seed->random-state "http://swissnet.ai.mit.edu/~jaffer/SLIB.html"))
   98   (do ((samples 125 (* 4 samples))
   99        (t 0 (time-call prng (* 2 samples) 999 sta)))
  100       ((or (> t 1000) (and (not (provided? 'bignum)) (> samples 1000)))
  101        (do ((tl '() (cons (time-call prng samples 999 sta) tl))
  102         (j 12 (+ -1 j)))
  103        ((zero? j)
  104         (let* ((avg (i/ (apply + tl) (length tl)))
  105            (dev (isqrt (i/ (apply
  106                     + (map (lambda (x) (* (- x avg) (- x avg)))
  107                        tl))
  108                    (length tl)))))
  109           (and file (transcript-on file))
  110           (for-each display
  111             (list samples " random samples took " (around avg 4) ".ms"
  112                   " +/- " (around dev 2) ".ms"))
  113           (newline)
  114           (let ((scaled-avg (i/ (* avg 1000) samples))
  115             (scaled-dev (i/ (* dev 1000) samples)))
  116         (for-each display
  117               (list " That is about "
  118                 (around scaled-avg 4) ".ms/kB"
  119                 " +/- "
  120                 (around scaled-dev 2) ".ms/kB"))
  121         (newline)
  122         (and file (transcript-off)))))))))
  123 
  124 (benchmark-prng)
  125 (newline)
  126 (benchmark-pi)