Commit | Line | Data |
---|---|---|
83e3ac94 LC |
1 | ; |
2 | ; GCOld.sch x.x 00/08/03 | |
3 | ; translated from GCOld.java 2.0a 00/08/23 | |
4 | ; | |
5 | ; Copyright 2000 Sun Microsystems, Inc. All rights reserved. | |
6 | ; | |
7 | ; | |
8 | ||
9 | ; Should be good enough for this benchmark. | |
10 | ||
11 | (define (newRandom) | |
12 | (letrec ((random14 | |
13 | (lambda (n) | |
14 | (set! x (remainder (+ (* a x) c) m)) | |
15 | (remainder (quotient x 8) n))) | |
16 | (a 701) | |
17 | (x 1) | |
18 | (c 743483) | |
19 | (m 524288) | |
20 | (loop | |
21 | (lambda (q r n) | |
22 | (if (zero? q) | |
23 | (remainder r n) | |
24 | (loop (quotient q 16384) | |
25 | (+ (* 16384 r) (random14 16384)) | |
26 | n))))) | |
27 | (lambda (n) | |
28 | (if (and (exact? n) (integer? n) (< n 16384)) | |
29 | (random14 n) | |
30 | (loop n (random14 16384) n))))) | |
31 | ||
32 | ; A TreeNode is a record with three fields: left, right, val. | |
33 | ; The left and right fields contain a TreeNode or 0, and the | |
34 | ; val field will contain the integer height of the tree. | |
35 | ||
36 | (define-syntax newTreeNode | |
37 | (syntax-rules () | |
38 | ((newTreeNode left right val) | |
39 | (vector left right val)) | |
40 | ((newTreeNode) | |
41 | (vector 0 0 0)))) | |
42 | ||
43 | (define-syntax TreeNode.left | |
44 | (syntax-rules () | |
45 | ((TreeNode.left node) | |
46 | (vector-ref node 0)))) | |
47 | ||
48 | (define-syntax TreeNode.right | |
49 | (syntax-rules () | |
50 | ((TreeNode.right node) | |
51 | (vector-ref node 1)))) | |
52 | ||
53 | (define-syntax TreeNode.val | |
54 | (syntax-rules () | |
55 | ((TreeNode.val node) | |
56 | (vector-ref node 2)))) | |
57 | ||
58 | (define-syntax setf | |
59 | (syntax-rules (TreeNode.left TreeNode.right TreeNode.val) | |
60 | ((setf (TreeNode.left node) x) | |
61 | (vector-set! node 0 x)) | |
62 | ((setf (TreeNode.right node) x) | |
63 | (vector-set! node 1 x)) | |
64 | ((setf (TreeNode.val node) x) | |
65 | (vector-set! node 2 x)))) | |
66 | ||
67 | ; Args: | |
68 | ; live-data-size: in megabytes. | |
69 | ; work: units of mutator non-allocation work per byte allocated, | |
70 | ; (in unspecified units. This will affect the promotion rate | |
71 | ; printed at the end of the run: more mutator work per step implies | |
72 | ; fewer steps per second implies fewer bytes promoted per second.) | |
73 | ; short/long ratio: ratio of short-lived bytes allocated to long-lived | |
74 | ; bytes allocated. | |
75 | ; pointer mutation rate: number of pointer mutations per step. | |
76 | ; steps: number of steps to do. | |
77 | ; | |
78 | ||
79 | (define (GCOld size workUnits promoteRate ptrMutRate steps) | |
80 | ||
81 | (define (println . args) | |
82 | (for-each display args) | |
83 | (newline)) | |
84 | ||
85 | ; Rounds an inexact real to two decimal places. | |
86 | ||
87 | (define (round2 x) | |
88 | (/ (round (* 100.0 x)) 100.0)) | |
89 | ||
90 | ; Returns the height of the given tree. | |
91 | ||
92 | (define (height t) | |
93 | (if (eqv? t 0) | |
94 | 0 | |
95 | (+ 1 (max (height (TreeNode.left t)) | |
96 | (height (TreeNode.right t)))))) | |
97 | ||
98 | ; Returns the length of the shortest path in the given tree. | |
99 | ||
100 | (define (shortestPath t) | |
101 | (if (eqv? t 0) | |
102 | 0 | |
103 | (+ 1 (min (shortestPath (TreeNode.left t)) | |
104 | (shortestPath (TreeNode.right t)))))) | |
105 | ||
106 | ; Returns the number of nodes in a balanced tree of the given height. | |
107 | ||
108 | (define (heightToNodes h) | |
109 | (- (expt 2 h) 1)) | |
110 | ||
111 | ; Returns the height of the largest balanced tree | |
112 | ; that has no more than the given number of nodes. | |
113 | ||
114 | (define (nodesToHeight nodes) | |
115 | (do ((h 1 (+ h 1)) | |
116 | (n 1 (+ n n))) | |
117 | ((> (+ n n -1) nodes) | |
118 | (- h 1)))) | |
119 | ||
120 | (let* ( | |
121 | ||
122 | ; Constants. | |
123 | ||
124 | (null 0) ; Java's null | |
125 | (pathBits 65536) ; to generate 16 random bits | |
126 | ||
127 | (MEG 1000000) | |
128 | (INSIGNIFICANT 999) ; this many bytes don't matter | |
129 | (bytes/word 4) | |
130 | (bytes/node 20) ; bytes per tree node in typical JVM | |
131 | (words/dead 100) ; size of young garbage objects | |
132 | ||
133 | ; Returns the number of bytes in a balanced tree of the given height. | |
134 | ||
135 | (heightToBytes | |
136 | (lambda (h) | |
137 | (* bytes/node (heightToNodes h)))) | |
138 | ||
139 | ; Returns the height of the largest balanced tree | |
140 | ; that occupies no more than the given number of bytes. | |
141 | ||
142 | (bytesToHeight | |
143 | (lambda (bytes) | |
144 | (nodesToHeight (/ bytes bytes/node)))) | |
145 | ||
146 | (treeHeight 14) | |
147 | (treeSize (heightToBytes treeHeight)) | |
148 | ||
149 | (msg1 "Usage: java GCOld <size> <work> <ratio> <mutation> <steps>") | |
150 | (msg2 " where <size> is the live storage in megabytes") | |
151 | (msg3 " <work> is the mutator work per step (arbitrary units)") | |
152 | (msg4 " <ratio> is the ratio of short-lived to long-lived allocation") | |
153 | (msg5 " <mutation> is the mutations per step") | |
154 | (msg6 " <steps> is the number of steps") | |
155 | ||
156 | ; Counters (and global variables that discourage optimization). | |
157 | ||
158 | (youngBytes 0) | |
159 | (nodes 0) | |
160 | (actuallyMut 0) | |
161 | (mutatorSum 0) | |
162 | (aexport '#()) | |
163 | ||
164 | ; Global variables. | |
165 | ||
166 | (trees '#()) | |
167 | (where 0) | |
168 | (rnd (newRandom)) | |
169 | ||
170 | ) | |
171 | ||
172 | ; Returns a newly allocated balanced binary tree of height h. | |
173 | ||
174 | (define (makeTree h) | |
175 | (if (zero? h) | |
176 | null | |
177 | (let ((res (newTreeNode))) | |
178 | (set! nodes (+ nodes 1)) | |
179 | (setf (TreeNode.left res) (makeTree (- h 1))) | |
180 | (setf (TreeNode.right res) (makeTree (- h 1))) | |
181 | (setf (TreeNode.val res) h) | |
182 | res))) | |
183 | ||
184 | ; Allocates approximately size megabytes of trees and stores | |
185 | ; them into a global array. | |
186 | ||
187 | (define (init) | |
188 | ; Each tree will be about a megabyte. | |
189 | (let ((ntrees (quotient (* size MEG) treeSize))) | |
190 | (set! trees (make-vector ntrees null)) | |
191 | (println "Allocating " ntrees " trees.") | |
192 | (println " (" (* ntrees treeSize) " bytes)") | |
193 | (do ((i 0 (+ i 1))) | |
194 | ((>= i ntrees)) | |
195 | (vector-set! trees i (makeTree treeHeight)) | |
196 | (doYoungGenAlloc (* promoteRate ntrees treeSize) words/dead)) | |
197 | (println " (" nodes " nodes)"))) | |
198 | ||
199 | ; Confirms that all trees are balanced and have the correct height. | |
200 | ||
201 | (define (checkTrees) | |
202 | (let ((ntrees (vector-length trees))) | |
203 | (do ((i 0 (+ i 1))) | |
204 | ((>= i ntrees)) | |
205 | (let* ((t (vector-ref trees i)) | |
206 | (h1 (height t)) | |
207 | (h2 (shortestPath t))) | |
208 | (if (or (not (= h1 treeHeight)) | |
209 | (not (= h2 treeHeight))) | |
210 | (println "*****BUG: " h1 " " h2)))))) | |
211 | ||
212 | ; Called only by replaceTree (below) and by itself. | |
213 | ||
214 | (define (replaceTreeWork full partial dir) | |
215 | (let ((canGoLeft (and (not (eq? (TreeNode.left full) null)) | |
216 | (> (TreeNode.val (TreeNode.left full)) | |
217 | (TreeNode.val partial)))) | |
218 | (canGoRight (and (not (eq? (TreeNode.right full) null)) | |
219 | (> (TreeNode.val (TreeNode.right full)) | |
220 | (TreeNode.val partial))))) | |
221 | (cond ((and canGoLeft canGoRight) | |
222 | (if dir | |
223 | (replaceTreeWork (TreeNode.left full) | |
224 | partial | |
225 | (not dir)) | |
226 | (replaceTreeWork (TreeNode.right full) | |
227 | partial | |
228 | (not dir)))) | |
229 | ((and (not canGoLeft) (not canGoRight)) | |
230 | (if dir | |
231 | (setf (TreeNode.left full) partial) | |
232 | (setf (TreeNode.right full) partial))) | |
233 | ((not canGoLeft) | |
234 | (setf (TreeNode.left full) partial)) | |
235 | (else | |
236 | (setf (TreeNode.right full) partial))))) | |
237 | ||
238 | ; Given a balanced tree full and a smaller balanced tree partial, | |
239 | ; replaces an appropriate subtree of full by partial, taking care | |
240 | ; to preserve the shape of the full tree. | |
241 | ||
242 | (define (replaceTree full partial) | |
243 | (let ((dir (zero? (modulo (TreeNode.val partial) 2)))) | |
244 | (set! actuallyMut (+ actuallyMut 1)) | |
245 | (replaceTreeWork full partial dir))) | |
246 | ||
247 | ; Allocates approximately n bytes of long-lived storage, | |
248 | ; replacing oldest existing long-lived storage. | |
249 | ||
250 | (define (oldGenAlloc n) | |
251 | (let ((full (quotient n treeSize)) | |
252 | (partial (modulo n treeSize))) | |
253 | ;(println "In oldGenAlloc, doing " | |
254 | ; full | |
255 | ; " full trees and one partial tree of size " | |
256 | ; partial) | |
257 | (do ((i 0 (+ i 1))) | |
258 | ((>= i full)) | |
259 | (vector-set! trees where (makeTree treeHeight)) | |
260 | (set! where | |
261 | (modulo (+ where 1) (vector-length trees)))) | |
262 | (let loop ((partial partial)) | |
263 | (if (> partial INSIGNIFICANT) | |
264 | (let* ((h (bytesToHeight partial)) | |
265 | (newTree (makeTree h))) | |
266 | (replaceTree (vector-ref trees where) newTree) | |
267 | (set! where | |
268 | (modulo (+ where 1) (vector-length trees))) | |
269 | (loop (- partial (heightToBytes h)))))))) | |
270 | ||
271 | ; Interchanges two randomly selected subtrees (of same size and depth). | |
272 | ||
273 | (define (oldGenSwapSubtrees) | |
274 | ; Randomly pick: | |
275 | ; * two tree indices | |
276 | ; * A depth | |
277 | ; * A path to that depth. | |
278 | (let* ((index1 (rnd (vector-length trees))) | |
279 | (index2 (rnd (vector-length trees))) | |
280 | (depth (rnd treeHeight)) | |
281 | (path (rnd pathBits)) | |
282 | (tn1 (vector-ref trees index1)) | |
283 | (tn2 (vector-ref trees index2))) | |
284 | (do ((i 0 (+ i 1))) | |
285 | ((>= i depth)) | |
286 | (if (even? path) | |
287 | (begin (set! tn1 (TreeNode.left tn1)) | |
288 | (set! tn2 (TreeNode.left tn2))) | |
289 | (begin (set! tn1 (TreeNode.right tn1)) | |
290 | (set! tn2 (TreeNode.right tn2)))) | |
291 | (set! path (quotient path 2))) | |
292 | (if (even? path) | |
293 | (let ((tmp (TreeNode.left tn1))) | |
294 | (setf (TreeNode.left tn1) (TreeNode.left tn2)) | |
295 | (setf (TreeNode.left tn2) tmp)) | |
296 | (let ((tmp (TreeNode.right tn1))) | |
297 | (setf (TreeNode.right tn1) (TreeNode.right tn2)) | |
298 | (setf (TreeNode.right tn2) tmp))) | |
299 | (set! actuallyMut (+ actuallyMut 2)))) | |
300 | ||
301 | ; Update "n" old-generation pointers. | |
302 | ||
303 | (define (oldGenMut n) | |
304 | (do ((i 0 (+ i 1))) | |
305 | ((>= i (quotient n 2))) | |
306 | (oldGenSwapSubtrees))) | |
307 | ||
308 | ; Does the amount of mutator work appropriate for n bytes of young-gen | |
309 | ; garbage allocation. | |
310 | ||
311 | (define (doMutWork n) | |
312 | (let ((limit (quotient (* workUnits n) 10))) | |
313 | (do ((k 0 (+ k 1)) | |
314 | (sum 0 (+ sum 1))) | |
315 | ((>= k limit) | |
316 | ; We don't want dead code elimination to eliminate this loop. | |
317 | (set! mutatorSum (+ mutatorSum sum)))))) | |
318 | ||
319 | ; Allocate n bytes of young-gen garbage, in units of "nwords" | |
320 | ; words. | |
321 | ||
322 | (define (doYoungGenAlloc n nwords) | |
323 | (let ((nbytes (* nwords bytes/word))) | |
324 | (do ((allocated 0 (+ allocated nbytes))) | |
325 | ((>= allocated n) | |
326 | (set! youngBytes (+ youngBytes allocated))) | |
327 | (set! aexport (make-vector nwords 0))))) | |
328 | ||
329 | ; Allocate "n" bytes of young-gen data; and do the | |
330 | ; corresponding amount of old-gen allocation and pointer | |
331 | ; mutation. | |
332 | ||
333 | ; oldGenAlloc may perform some mutations, so this code | |
334 | ; takes those mutations into account. | |
335 | ||
336 | (define (doStep n) | |
337 | (let ((mutations actuallyMut)) | |
338 | (doYoungGenAlloc n words/dead) | |
339 | (doMutWork n) | |
340 | ; Now do old-gen allocation | |
341 | (oldGenAlloc (quotient n promoteRate)) | |
342 | (oldGenMut (max 0 (- (+ mutations ptrMutRate) actuallyMut))))) | |
343 | ||
344 | (println size " megabytes") | |
345 | (println workUnits " work units per step.") | |
346 | (println "promotion ratio is 1:" promoteRate) | |
347 | (println "pointer mutation rate is " ptrMutRate) | |
348 | (println steps " steps") | |
349 | ||
350 | (init) | |
351 | (checkTrees) | |
352 | (set! youngBytes 0) | |
353 | (set! nodes 0) | |
354 | ||
355 | (println "Initialization complete...") | |
356 | ||
357 | (run-benchmark "GCOld" | |
358 | 1 | |
83e3ac94 LC |
359 | (lambda () |
360 | (lambda () | |
361 | (do ((step 0 (+ step 1))) | |
362 | ((>= step steps)) | |
1c14d767 LC |
363 | (doStep MEG)))) |
364 | (lambda (result) #t)) | |
83e3ac94 LC |
365 | |
366 | (checkTrees) | |
367 | ||
368 | (println "Allocated " steps " Mb of young gen garbage") | |
369 | (println " (actually allocated " | |
370 | (round2 (/ youngBytes MEG)) | |
371 | " megabytes)") | |
372 | (println "Promoted " (round2 (/ steps promoteRate)) " Mb") | |
373 | (println " (actually promoted " | |
374 | (round2 (/ (* nodes bytes/node) MEG)) | |
375 | " megabytes)") | |
376 | (if (not (zero? ptrMutRate)) | |
377 | (println "Mutated " actuallyMut " pointers")) | |
378 | ||
379 | ; This output serves mainly to discourage optimization. | |
380 | ||
381 | (+ mutatorSum (vector-length aexport)))) | |
382 | ||
1c14d767 LC |
383 | (define (gcold-benchmark . args) |
384 | (define gcold-iters 1) | |
385 | ||
83e3ac94 | 386 | (GCOld 25 0 10 10 gcold-iters)) |