| 1 | ; This is adapted from a benchmark written by John Ellis and Pete Kovac |
| 2 | ; of Post Communications. |
| 3 | ; It was modified by Hans Boehm of Silicon Graphics. |
| 4 | ; It was translated into Scheme by William D Clinger of Northeastern Univ; |
| 5 | ; the Scheme version uses (RUN-BENCHMARK <string> <thunk>) |
| 6 | ; Last modified 30 May 1997. |
| 7 | ; |
| 8 | ; This is no substitute for real applications. No actual application |
| 9 | ; is likely to behave in exactly this way. However, this benchmark was |
| 10 | ; designed to be more representative of real applications than other |
| 11 | ; Java GC benchmarks of which we are aware. |
| 12 | ; It attempts to model those properties of allocation requests that |
| 13 | ; are important to current GC techniques. |
| 14 | ; It is designed to be used either to obtain a single overall performance |
| 15 | ; number, or to give a more detailed estimate of how collector |
| 16 | ; performance varies with object lifetimes. It prints the time |
| 17 | ; required to allocate and collect balanced binary trees of various |
| 18 | ; sizes. Smaller trees result in shorter object lifetimes. Each cycle |
| 19 | ; allocates roughly the same amount of memory. |
| 20 | ; Two data structures are kept around during the entire process, so |
| 21 | ; that the measured performance is representative of applications |
| 22 | ; that maintain some live in-memory data. One of these is a tree |
| 23 | ; containing many pointers. The other is a large array containing |
| 24 | ; double precision floating point numbers. Both should be of comparable |
| 25 | ; size. |
| 26 | ; |
| 27 | ; The results are only really meaningful together with a specification |
| 28 | ; of how much memory was used. It is possible to trade memory for |
| 29 | ; better time performance. This benchmark should be run in a 32 MB |
| 30 | ; heap, though we don't currently know how to enforce that uniformly. |
| 31 | |
| 32 | ; In the Java version, this routine prints the heap size and the amount |
| 33 | ; of free memory. There is no portable way to do this in Scheme; each |
| 34 | ; implementation needs its own version. |
| 35 | |
| 36 | (use-modules (ice-9 syncase)) |
| 37 | |
| 38 | (define (PrintDiagnostics) |
| 39 | (display " Total memory available= ???????? bytes") |
| 40 | (display " Free memory= ???????? bytes") |
| 41 | (newline)) |
| 42 | |
| 43 | |
| 44 | |
| 45 | (define (run-benchmark str thu) |
| 46 | (display str) |
| 47 | (thu)) |
| 48 | ; Should we implement a Java class as procedures or hygienic macros? |
| 49 | ; Take your pick. |
| 50 | |
| 51 | (define-syntax let-class |
| 52 | (syntax-rules |
| 53 | () |
| 54 | |
| 55 | ;; Put this rule first to implement a class using procedures. |
| 56 | ((let-class (((method . args) . method-body) ...) . body) |
| 57 | (let () (define (method . args) . method-body) ... . body)) |
| 58 | |
| 59 | |
| 60 | ;; Put this rule first to implement a class using hygienic macros. |
| 61 | ((let-class (((method . args) . method-body) ...) . body) |
| 62 | (letrec-syntax ((method (syntax-rules () ((method . args) (begin . method-body)))) |
| 63 | ...) |
| 64 | . body)) |
| 65 | |
| 66 | |
| 67 | )) |
| 68 | |
| 69 | |
| 70 | (define (gcbench kStretchTreeDepth) |
| 71 | |
| 72 | ; Nodes used by a tree of a given size |
| 73 | (define (TreeSize i) |
| 74 | (- (expt 2 (+ i 1)) 1)) |
| 75 | |
| 76 | ; Number of iterations to use for a given tree depth |
| 77 | (define (NumIters i) |
| 78 | (quotient (* 2 (TreeSize kStretchTreeDepth)) |
| 79 | (TreeSize i))) |
| 80 | |
| 81 | ; Parameters are determined by kStretchTreeDepth. |
| 82 | ; In Boehm's version the parameters were fixed as follows: |
| 83 | ; public static final int kStretchTreeDepth = 18; // about 16Mb |
| 84 | ; public static final int kLongLivedTreeDepth = 16; // about 4Mb |
| 85 | ; public static final int kArraySize = 500000; // about 4Mb |
| 86 | ; public static final int kMinTreeDepth = 4; |
| 87 | ; public static final int kMaxTreeDepth = 16; |
| 88 | ; In Larceny the storage numbers above would be 12 Mby, 3 Mby, 6 Mby. |
| 89 | |
| 90 | (let* ((kLongLivedTreeDepth (- kStretchTreeDepth 2)) |
| 91 | (kArraySize (* 4 (TreeSize kLongLivedTreeDepth))) |
| 92 | (kMinTreeDepth 4) |
| 93 | (kMaxTreeDepth kLongLivedTreeDepth)) |
| 94 | |
| 95 | ; Elements 3 and 4 of the allocated vectors are useless. |
| 96 | |
| 97 | (let-class (((make-node l r) |
| 98 | (let ((v (make-empty-node))) |
| 99 | (vector-set! v 0 l) |
| 100 | (vector-set! v 1 r) |
| 101 | v)) |
| 102 | ((make-empty-node) (make-vector 4 0)) |
| 103 | ((node.left node) (vector-ref node 0)) |
| 104 | ((node.right node) (vector-ref node 1)) |
| 105 | ((node.left-set! node x) (vector-set! node 0 x)) |
| 106 | ((node.right-set! node x) (vector-set! node 1 x))) |
| 107 | |
| 108 | ; Build tree top down, assigning to older objects. |
| 109 | (define (Populate iDepth thisNode) |
| 110 | (if (<= iDepth 0) |
| 111 | #f |
| 112 | (let ((iDepth (- iDepth 1))) |
| 113 | (node.left-set! thisNode (make-empty-node)) |
| 114 | (node.right-set! thisNode (make-empty-node)) |
| 115 | (Populate iDepth (node.left thisNode)) |
| 116 | (Populate iDepth (node.right thisNode))))) |
| 117 | |
| 118 | ; Build tree bottom-up |
| 119 | (define (MakeTree iDepth) |
| 120 | (if (<= iDepth 0) |
| 121 | (make-empty-node) |
| 122 | (make-node (MakeTree (- iDepth 1)) |
| 123 | (MakeTree (- iDepth 1))))) |
| 124 | |
| 125 | (define (TimeConstruction depth) |
| 126 | (let ((iNumIters (NumIters depth))) |
| 127 | (display (string-append "Creating " |
| 128 | (number->string iNumIters) |
| 129 | " trees of depth " |
| 130 | (number->string depth))) |
| 131 | (newline) |
| 132 | (run-benchmark "GCBench: Top down construction" |
| 133 | (lambda () |
| 134 | (do ((i 0 (+ i 1))) |
| 135 | ((>= i iNumIters)) |
| 136 | (Populate depth (make-empty-node))))) |
| 137 | (run-benchmark "GCBench: Bottom up construction" |
| 138 | (lambda () |
| 139 | (do ((i 0 (+ i 1))) |
| 140 | ((>= i iNumIters)) |
| 141 | (MakeTree depth)))))) |
| 142 | |
| 143 | (define (main) |
| 144 | (display "Garbage Collector Test") |
| 145 | (newline) |
| 146 | (display (string-append |
| 147 | " Stretching memory with a binary tree of depth " |
| 148 | (number->string kStretchTreeDepth))) |
| 149 | (newline) |
| 150 | (run-benchmark "GCBench: Main" |
| 151 | (lambda () |
| 152 | ; Stretch the memory space quickly |
| 153 | (MakeTree kStretchTreeDepth) |
| 154 | |
| 155 | ; Create a long lived object |
| 156 | (display (string-append |
| 157 | " Creating a long-lived binary tree of depth " |
| 158 | (number->string kLongLivedTreeDepth))) |
| 159 | (newline) |
| 160 | (let ((longLivedTree (make-empty-node))) |
| 161 | (Populate kLongLivedTreeDepth longLivedTree) |
| 162 | |
| 163 | ; Create long-lived array, filling half of it |
| 164 | (display (string-append |
| 165 | " Creating a long-lived array of " |
| 166 | (number->string kArraySize) |
| 167 | " inexact reals")) |
| 168 | (newline) |
| 169 | (let ((array (make-vector kArraySize 0.0))) |
| 170 | (do ((i 0 (+ i 1))) |
| 171 | ((>= i (quotient kArraySize 2))) |
| 172 | (vector-set! array i (/ 1.0 (exact->inexact i)))) |
| 173 | (PrintDiagnostics) |
| 174 | |
| 175 | (do ((d kMinTreeDepth (+ d 2))) |
| 176 | ((> d kMaxTreeDepth)) |
| 177 | (TimeConstruction d)) |
| 178 | |
| 179 | (if (or (eq? longLivedTree '()) |
| 180 | (let ((n (min 1000 |
| 181 | (- (quotient (vector-length array) |
| 182 | 2) |
| 183 | 1)))) |
| 184 | (not (= (vector-ref array n) |
| 185 | (/ 1.0 (exact->inexact |
| 186 | n)))))) |
| 187 | (begin (display "Failed") (newline))) |
| 188 | ; fake reference to LongLivedTree |
| 189 | ; and array |
| 190 | ; to keep them from being optimized away |
| 191 | )))) |
| 192 | (PrintDiagnostics)) |
| 193 | |
| 194 | (main)))) |
| 195 | |
| 196 | (define (gc-benchmark . rest) |
| 197 | (let ((k (if (null? rest) 18 (car rest)))) |
| 198 | (display "The garbage collector should touch about ") |
| 199 | (display (expt 2 (- k 13))) |
| 200 | (display " megabytes of heap storage.") |
| 201 | (newline) |
| 202 | (display "The use of more or less memory will skew the results.") |
| 203 | (newline) |
| 204 | (run-benchmark (string-append "GCBench" (number->string k)) |
| 205 | (lambda () (gcbench k))))) |
| 206 | |
| 207 | |
| 208 | |
| 209 | (gc-benchmark ) |
| 210 | (display (gc-stats)) |