mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
210 lines
8.8 KiB
Scheme
210 lines
8.8 KiB
Scheme
; This is adapted from a benchmark written by John Ellis and Pete Kovac
|
|
; of Post Communications.
|
|
; It was modified by Hans Boehm of Silicon Graphics.
|
|
; It was translated into Scheme by William D Clinger of Northeastern Univ;
|
|
; the Scheme version uses (RUN-BENCHMARK <string> <thunk>)
|
|
; Last modified 30 May 1997.
|
|
;
|
|
; This is no substitute for real applications. No actual application
|
|
; is likely to behave in exactly this way. However, this benchmark was
|
|
; designed to be more representative of real applications than other
|
|
; Java GC benchmarks of which we are aware.
|
|
; It attempts to model those properties of allocation requests that
|
|
; are important to current GC techniques.
|
|
; It is designed to be used either to obtain a single overall performance
|
|
; number, or to give a more detailed estimate of how collector
|
|
; performance varies with object lifetimes. It prints the time
|
|
; required to allocate and collect balanced binary trees of various
|
|
; sizes. Smaller trees result in shorter object lifetimes. Each cycle
|
|
; allocates roughly the same amount of memory.
|
|
; Two data structures are kept around during the entire process, so
|
|
; that the measured performance is representative of applications
|
|
; that maintain some live in-memory data. One of these is a tree
|
|
; containing many pointers. The other is a large array containing
|
|
; double precision floating point numbers. Both should be of comparable
|
|
; size.
|
|
;
|
|
; The results are only really meaningful together with a specification
|
|
; of how much memory was used. It is possible to trade memory for
|
|
; better time performance. This benchmark should be run in a 32 MB
|
|
; heap, though we don't currently know how to enforce that uniformly.
|
|
|
|
; In the Java version, this routine prints the heap size and the amount
|
|
; of free memory. There is no portable way to do this in Scheme; each
|
|
; implementation needs its own version.
|
|
|
|
(use-modules (ice-9 syncase))
|
|
|
|
(define (PrintDiagnostics)
|
|
(display " Total memory available= ???????? bytes")
|
|
(display " Free memory= ???????? bytes")
|
|
(newline))
|
|
|
|
|
|
|
|
(define (run-benchmark str thu)
|
|
(display str)
|
|
(thu))
|
|
; Should we implement a Java class as procedures or hygienic macros?
|
|
; Take your pick.
|
|
|
|
(define-syntax let-class
|
|
(syntax-rules
|
|
()
|
|
|
|
;; Put this rule first to implement a class using procedures.
|
|
((let-class (((method . args) . method-body) ...) . body)
|
|
(let () (define (method . args) . method-body) ... . body))
|
|
|
|
|
|
;; Put this rule first to implement a class using hygienic macros.
|
|
((let-class (((method . args) . method-body) ...) . body)
|
|
(letrec-syntax ((method (syntax-rules () ((method . args) (begin . method-body))))
|
|
...)
|
|
. body))
|
|
|
|
|
|
))
|
|
|
|
|
|
(define (gcbench kStretchTreeDepth)
|
|
|
|
; Nodes used by a tree of a given size
|
|
(define (TreeSize i)
|
|
(- (expt 2 (+ i 1)) 1))
|
|
|
|
; Number of iterations to use for a given tree depth
|
|
(define (NumIters i)
|
|
(quotient (* 2 (TreeSize kStretchTreeDepth))
|
|
(TreeSize i)))
|
|
|
|
; Parameters are determined by kStretchTreeDepth.
|
|
; In Boehm's version the parameters were fixed as follows:
|
|
; public static final int kStretchTreeDepth = 18; // about 16Mb
|
|
; public static final int kLongLivedTreeDepth = 16; // about 4Mb
|
|
; public static final int kArraySize = 500000; // about 4Mb
|
|
; public static final int kMinTreeDepth = 4;
|
|
; public static final int kMaxTreeDepth = 16;
|
|
; In Larceny the storage numbers above would be 12 Mby, 3 Mby, 6 Mby.
|
|
|
|
(let* ((kLongLivedTreeDepth (- kStretchTreeDepth 2))
|
|
(kArraySize (* 4 (TreeSize kLongLivedTreeDepth)))
|
|
(kMinTreeDepth 4)
|
|
(kMaxTreeDepth kLongLivedTreeDepth))
|
|
|
|
; Elements 3 and 4 of the allocated vectors are useless.
|
|
|
|
(let-class (((make-node l r)
|
|
(let ((v (make-empty-node)))
|
|
(vector-set! v 0 l)
|
|
(vector-set! v 1 r)
|
|
v))
|
|
((make-empty-node) (make-vector 4 0))
|
|
((node.left node) (vector-ref node 0))
|
|
((node.right node) (vector-ref node 1))
|
|
((node.left-set! node x) (vector-set! node 0 x))
|
|
((node.right-set! node x) (vector-set! node 1 x)))
|
|
|
|
; Build tree top down, assigning to older objects.
|
|
(define (Populate iDepth thisNode)
|
|
(if (<= iDepth 0)
|
|
#f
|
|
(let ((iDepth (- iDepth 1)))
|
|
(node.left-set! thisNode (make-empty-node))
|
|
(node.right-set! thisNode (make-empty-node))
|
|
(Populate iDepth (node.left thisNode))
|
|
(Populate iDepth (node.right thisNode)))))
|
|
|
|
; Build tree bottom-up
|
|
(define (MakeTree iDepth)
|
|
(if (<= iDepth 0)
|
|
(make-empty-node)
|
|
(make-node (MakeTree (- iDepth 1))
|
|
(MakeTree (- iDepth 1)))))
|
|
|
|
(define (TimeConstruction depth)
|
|
(let ((iNumIters (NumIters depth)))
|
|
(display (string-append "Creating "
|
|
(number->string iNumIters)
|
|
" trees of depth "
|
|
(number->string depth)))
|
|
(newline)
|
|
(run-benchmark "GCBench: Top down construction"
|
|
(lambda ()
|
|
(do ((i 0 (+ i 1)))
|
|
((>= i iNumIters))
|
|
(Populate depth (make-empty-node)))))
|
|
(run-benchmark "GCBench: Bottom up construction"
|
|
(lambda ()
|
|
(do ((i 0 (+ i 1)))
|
|
((>= i iNumIters))
|
|
(MakeTree depth))))))
|
|
|
|
(define (main)
|
|
(display "Garbage Collector Test")
|
|
(newline)
|
|
(display (string-append
|
|
" Stretching memory with a binary tree of depth "
|
|
(number->string kStretchTreeDepth)))
|
|
(newline)
|
|
(run-benchmark "GCBench: Main"
|
|
(lambda ()
|
|
; Stretch the memory space quickly
|
|
(MakeTree kStretchTreeDepth)
|
|
|
|
; Create a long lived object
|
|
(display (string-append
|
|
" Creating a long-lived binary tree of depth "
|
|
(number->string kLongLivedTreeDepth)))
|
|
(newline)
|
|
(let ((longLivedTree (make-empty-node)))
|
|
(Populate kLongLivedTreeDepth longLivedTree)
|
|
|
|
; Create long-lived array, filling half of it
|
|
(display (string-append
|
|
" Creating a long-lived array of "
|
|
(number->string kArraySize)
|
|
" inexact reals"))
|
|
(newline)
|
|
(let ((array (make-vector kArraySize 0.0)))
|
|
(do ((i 0 (+ i 1)))
|
|
((>= i (quotient kArraySize 2)))
|
|
(vector-set! array i (/ 1.0 (exact->inexact i))))
|
|
(PrintDiagnostics)
|
|
|
|
(do ((d kMinTreeDepth (+ d 2)))
|
|
((> d kMaxTreeDepth))
|
|
(TimeConstruction d))
|
|
|
|
(if (or (eq? longLivedTree '())
|
|
(let ((n (min 1000
|
|
(- (quotient (vector-length array)
|
|
2)
|
|
1))))
|
|
(not (= (vector-ref array n)
|
|
(/ 1.0 (exact->inexact
|
|
n))))))
|
|
(begin (display "Failed") (newline)))
|
|
; fake reference to LongLivedTree
|
|
; and array
|
|
; to keep them from being optimized away
|
|
))))
|
|
(PrintDiagnostics))
|
|
|
|
(main))))
|
|
|
|
(define (gc-benchmark . rest)
|
|
(let ((k (if (null? rest) 18 (car rest))))
|
|
(display "The garbage collector should touch about ")
|
|
(display (expt 2 (- k 13)))
|
|
(display " megabytes of heap storage.")
|
|
(newline)
|
|
(display "The use of more or less memory will skew the results.")
|
|
(newline)
|
|
(run-benchmark (string-append "GCBench" (number->string k))
|
|
(lambda () (gcbench k)))))
|
|
|
|
|
|
|
|
(gc-benchmark )
|
|
(display (gc-stats))
|