389 lines
12 KiB
Scheme
389 lines
12 KiB
Scheme
;
|
|
; GCOld.sch x.x 00/08/03
|
|
; translated from GCOld.java 2.0a 00/08/23
|
|
;
|
|
; Copyright 2000 Sun Microsystems, Inc. All rights reserved.
|
|
;
|
|
;
|
|
|
|
; Should be good enough for this benchmark.
|
|
|
|
(library (r6rs-benchmarks gcold)
|
|
(export main)
|
|
(import (r6rs) (r6rs-benchmarks))
|
|
|
|
(define (newRandom)
|
|
(letrec ((random14
|
|
(lambda (n)
|
|
(set! x (remainder (+ (* a x) c) m))
|
|
(remainder (quotient x 8) n)))
|
|
(a 701)
|
|
(x 1)
|
|
(c 743483)
|
|
(m 524288)
|
|
(loop
|
|
(lambda (q r n)
|
|
(if (zero? q)
|
|
(remainder r n)
|
|
(loop (quotient q 16384)
|
|
(+ (* 16384 r) (random14 16384))
|
|
n)))))
|
|
(lambda (n)
|
|
(if (and (exact? n) (integer? n) (< n 16384))
|
|
(random14 n)
|
|
(loop n (random14 16384) n)))))
|
|
|
|
; A TreeNode is a record with three fields: left, right, val.
|
|
; The left and right fields contain a TreeNode or 0, and the
|
|
; val field will contain the integer height of the tree.
|
|
|
|
(define-syntax newTreeNode
|
|
(syntax-rules ()
|
|
((newTreeNode left right val)
|
|
(vector left right val))
|
|
((newTreeNode)
|
|
(vector 0 0 0))))
|
|
|
|
(define-syntax TreeNode.left
|
|
(syntax-rules ()
|
|
((TreeNode.left node)
|
|
(vector-ref node 0))))
|
|
|
|
(define-syntax TreeNode.right
|
|
(syntax-rules ()
|
|
((TreeNode.right node)
|
|
(vector-ref node 1))))
|
|
|
|
(define-syntax TreeNode.val
|
|
(syntax-rules ()
|
|
((TreeNode.val node)
|
|
(vector-ref node 2))))
|
|
|
|
(define-syntax setf
|
|
(syntax-rules (TreeNode.left TreeNode.right TreeNode.val)
|
|
((setf (TreeNode.left node) x)
|
|
(vector-set! node 0 x))
|
|
((setf (TreeNode.right node) x)
|
|
(vector-set! node 1 x))
|
|
((setf (TreeNode.val node) x)
|
|
(vector-set! node 2 x))))
|
|
|
|
; Args:
|
|
; live-data-size: in megabytes.
|
|
; work: units of mutator non-allocation work per byte allocated,
|
|
; (in unspecified units. This will affect the promotion rate
|
|
; printed at the end of the run: more mutator work per step implies
|
|
; fewer steps per second implies fewer bytes promoted per second.)
|
|
; short/long ratio: ratio of short-lived bytes allocated to long-lived
|
|
; bytes allocated.
|
|
; pointer mutation rate: number of pointer mutations per step.
|
|
; steps: number of steps to do.
|
|
;
|
|
|
|
(define (GCOld size workUnits promoteRate ptrMutRate steps)
|
|
|
|
(define (println . args)
|
|
(for-each display args)
|
|
(newline))
|
|
|
|
; Rounds an inexact real to two decimal places.
|
|
|
|
(define (round2 x)
|
|
(/ (round (* 100.0 x)) 100.0))
|
|
|
|
; Returns the height of the given tree.
|
|
|
|
(define (height t)
|
|
(if (eqv? t 0)
|
|
0
|
|
(+ 1 (max (height (TreeNode.left t))
|
|
(height (TreeNode.right t))))))
|
|
|
|
; Returns the length of the shortest path in the given tree.
|
|
|
|
(define (shortestPath t)
|
|
(if (eqv? t 0)
|
|
0
|
|
(+ 1 (min (shortestPath (TreeNode.left t))
|
|
(shortestPath (TreeNode.right t))))))
|
|
|
|
; Returns the number of nodes in a balanced tree of the given height.
|
|
|
|
(define (heightToNodes h)
|
|
(- (expt 2 h) 1))
|
|
|
|
; Returns the height of the largest balanced tree
|
|
; that has no more than the given number of nodes.
|
|
|
|
(define (nodesToHeight nodes)
|
|
(do ((h 1 (+ h 1))
|
|
(n 1 (+ n n)))
|
|
((> (+ n n -1) nodes)
|
|
(- h 1))))
|
|
|
|
(let* (
|
|
|
|
; Constants.
|
|
|
|
(null 0) ; Java's null
|
|
(pathBits 65536) ; to generate 16 random bits
|
|
|
|
(MEG 1000000)
|
|
(INSIGNIFICANT 999) ; this many bytes don't matter
|
|
(bytes/word 4)
|
|
(bytes/node 20) ; bytes per tree node in typical JVM
|
|
(words/dead 100) ; size of young garbage objects
|
|
|
|
; Returns the number of bytes in a balanced tree of the given height.
|
|
|
|
(heightToBytes
|
|
(lambda (h)
|
|
(* bytes/node (heightToNodes h))))
|
|
|
|
; Returns the height of the largest balanced tree
|
|
; that occupies no more than the given number of bytes.
|
|
|
|
(bytesToHeight
|
|
(lambda (bytes)
|
|
(nodesToHeight (/ bytes bytes/node))))
|
|
|
|
(treeHeight 14)
|
|
(treeSize (heightToBytes treeHeight))
|
|
|
|
(msg1 "Usage: java GCOld <size> <work> <ratio> <mutation> <steps>")
|
|
(msg2 " where <size> is the live storage in megabytes")
|
|
(msg3 " <work> is the mutator work per step (arbitrary units)")
|
|
(msg4 " <ratio> is the ratio of short-lived to long-lived allocation")
|
|
(msg5 " <mutation> is the mutations per step")
|
|
(msg6 " <steps> is the number of steps")
|
|
|
|
; Counters (and global variables that discourage optimization).
|
|
|
|
(youngBytes 0)
|
|
(nodes 0)
|
|
(actuallyMut 0)
|
|
(mutatorSum 0)
|
|
(aexport '#())
|
|
|
|
; Global variables.
|
|
|
|
(trees '#())
|
|
(where 0)
|
|
(rnd (newRandom))
|
|
|
|
)
|
|
|
|
; Returns a newly allocated balanced binary tree of height h.
|
|
|
|
(define (makeTree h)
|
|
(if (zero? h)
|
|
null
|
|
(let ((res (newTreeNode)))
|
|
(set! nodes (+ nodes 1))
|
|
(setf (TreeNode.left res) (makeTree (- h 1)))
|
|
(setf (TreeNode.right res) (makeTree (- h 1)))
|
|
(setf (TreeNode.val res) h)
|
|
res)))
|
|
|
|
; Allocates approximately size megabytes of trees and stores
|
|
; them into a global array.
|
|
|
|
(define (init)
|
|
; Each tree will be about a megabyte.
|
|
(let ((ntrees (quotient (* size MEG) treeSize)))
|
|
(set! trees (make-vector ntrees null))
|
|
(println "Allocating " ntrees " trees.")
|
|
(println " (" (* ntrees treeSize) " bytes)")
|
|
(do ((i 0 (+ i 1)))
|
|
((>= i ntrees))
|
|
(vector-set! trees i (makeTree treeHeight))
|
|
(doYoungGenAlloc (* promoteRate ntrees treeSize) words/dead))
|
|
(println " (" nodes " nodes)")))
|
|
|
|
; Confirms that all trees are balanced and have the correct height.
|
|
|
|
(define (checkTrees)
|
|
(let ((ntrees (vector-length trees)))
|
|
(do ((i 0 (+ i 1)))
|
|
((>= i ntrees))
|
|
(let* ((t (vector-ref trees i))
|
|
(h1 (height t))
|
|
(h2 (shortestPath t)))
|
|
(if (or (not (= h1 treeHeight))
|
|
(not (= h2 treeHeight)))
|
|
(println "*****BUG: " h1 " " h2))))))
|
|
|
|
; Called only by replaceTree (below) and by itself.
|
|
|
|
(define (replaceTreeWork full partial dir)
|
|
(let ((canGoLeft (and (not (eq? (TreeNode.left full) null))
|
|
(> (TreeNode.val (TreeNode.left full))
|
|
(TreeNode.val partial))))
|
|
(canGoRight (and (not (eq? (TreeNode.right full) null))
|
|
(> (TreeNode.val (TreeNode.right full))
|
|
(TreeNode.val partial)))))
|
|
(cond ((and canGoLeft canGoRight)
|
|
(if dir
|
|
(replaceTreeWork (TreeNode.left full)
|
|
partial
|
|
(not dir))
|
|
(replaceTreeWork (TreeNode.right full)
|
|
partial
|
|
(not dir))))
|
|
((and (not canGoLeft) (not canGoRight))
|
|
(if dir
|
|
(setf (TreeNode.left full) partial)
|
|
(setf (TreeNode.right full) partial)))
|
|
((not canGoLeft)
|
|
(setf (TreeNode.left full) partial))
|
|
(else
|
|
(setf (TreeNode.right full) partial)))))
|
|
|
|
; Given a balanced tree full and a smaller balanced tree partial,
|
|
; replaces an appropriate subtree of full by partial, taking care
|
|
; to preserve the shape of the full tree.
|
|
|
|
(define (replaceTree full partial)
|
|
(let ((dir (zero? (modulo (TreeNode.val partial) 2))))
|
|
(set! actuallyMut (+ actuallyMut 1))
|
|
(replaceTreeWork full partial dir)))
|
|
|
|
; Allocates approximately n bytes of long-lived storage,
|
|
; replacing oldest existing long-lived storage.
|
|
|
|
(define (oldGenAlloc n)
|
|
(let ((full (quotient n treeSize))
|
|
(partial (modulo n treeSize)))
|
|
;(println "In oldGenAlloc, doing "
|
|
; full
|
|
; " full trees and one partial tree of size "
|
|
; partial)
|
|
(do ((i 0 (+ i 1)))
|
|
((>= i full))
|
|
(vector-set! trees where (makeTree treeHeight))
|
|
(set! where
|
|
(modulo (+ where 1) (vector-length trees))))
|
|
(let loop ((partial partial))
|
|
(if (> partial INSIGNIFICANT)
|
|
(let* ((h (bytesToHeight partial))
|
|
(newTree (makeTree h)))
|
|
(replaceTree (vector-ref trees where) newTree)
|
|
(set! where
|
|
(modulo (+ where 1) (vector-length trees)))
|
|
(loop (- partial (heightToBytes h))))))))
|
|
|
|
; Interchanges two randomly selected subtrees (of same size and depth).
|
|
|
|
(define (oldGenSwapSubtrees)
|
|
; Randomly pick:
|
|
; * two tree indices
|
|
; * A depth
|
|
; * A path to that depth.
|
|
(let* ((index1 (rnd (vector-length trees)))
|
|
(index2 (rnd (vector-length trees)))
|
|
(depth (rnd treeHeight))
|
|
(path (rnd pathBits))
|
|
(tn1 (vector-ref trees index1))
|
|
(tn2 (vector-ref trees index2)))
|
|
(do ((i 0 (+ i 1)))
|
|
((>= i depth))
|
|
(if (even? path)
|
|
(begin (set! tn1 (TreeNode.left tn1))
|
|
(set! tn2 (TreeNode.left tn2)))
|
|
(begin (set! tn1 (TreeNode.right tn1))
|
|
(set! tn2 (TreeNode.right tn2))))
|
|
(set! path (quotient path 2)))
|
|
(if (even? path)
|
|
(let ((tmp (TreeNode.left tn1)))
|
|
(setf (TreeNode.left tn1) (TreeNode.left tn2))
|
|
(setf (TreeNode.left tn2) tmp))
|
|
(let ((tmp (TreeNode.right tn1)))
|
|
(setf (TreeNode.right tn1) (TreeNode.right tn2))
|
|
(setf (TreeNode.right tn2) tmp)))
|
|
(set! actuallyMut (+ actuallyMut 2))))
|
|
|
|
; Update "n" old-generation pointers.
|
|
|
|
(define (oldGenMut n)
|
|
(do ((i 0 (+ i 1)))
|
|
((>= i (quotient n 2)))
|
|
(oldGenSwapSubtrees)))
|
|
|
|
; Does the amount of mutator work appropriate for n bytes of young-gen
|
|
; garbage allocation.
|
|
|
|
(define (doMutWork n)
|
|
(let ((limit (quotient (* workUnits n) 10)))
|
|
(do ((k 0 (+ k 1))
|
|
(sum 0 (+ sum 1)))
|
|
((>= k limit)
|
|
; We don't want dead code elimination to eliminate this loop.
|
|
(set! mutatorSum (+ mutatorSum sum))))))
|
|
|
|
; Allocate n bytes of young-gen garbage, in units of "nwords"
|
|
; words.
|
|
|
|
(define (doYoungGenAlloc n nwords)
|
|
(let ((nbytes (* nwords bytes/word)))
|
|
(do ((allocated 0 (+ allocated nbytes)))
|
|
((>= allocated n)
|
|
(set! youngBytes (+ youngBytes allocated)))
|
|
(set! aexport (make-vector nwords 0)))))
|
|
|
|
; Allocate "n" bytes of young-gen data; and do the
|
|
; corresponding amount of old-gen allocation and pointer
|
|
; mutation.
|
|
|
|
; oldGenAlloc may perform some mutations, so this code
|
|
; takes those mutations into account.
|
|
|
|
(define (doStep n)
|
|
(let ((mutations actuallyMut))
|
|
(doYoungGenAlloc n words/dead)
|
|
(doMutWork n)
|
|
; Now do old-gen allocation
|
|
(oldGenAlloc (quotient n promoteRate))
|
|
(oldGenMut (max 0 (- (+ mutations ptrMutRate) actuallyMut)))))
|
|
|
|
(println size " megabytes")
|
|
(println workUnits " work units per step.")
|
|
(println "promotion ratio is 1:" promoteRate)
|
|
(println "pointer mutation rate is " ptrMutRate)
|
|
(println steps " steps")
|
|
|
|
(init)
|
|
(checkTrees)
|
|
(set! youngBytes 0)
|
|
(set! nodes 0)
|
|
|
|
(println "Initialization complete...")
|
|
|
|
(run-benchmark "GCOld"
|
|
1
|
|
(lambda (result) #t)
|
|
(lambda ()
|
|
(lambda ()
|
|
(do ((step 0 (+ step 1)))
|
|
((>= step steps))
|
|
(doStep MEG)))))
|
|
|
|
(checkTrees)
|
|
|
|
(println "Allocated " steps " Mb of young gen garbage")
|
|
(println " (actually allocated "
|
|
(round2 (/ youngBytes MEG))
|
|
" megabytes)")
|
|
(println "Promoted " (round2 (/ steps promoteRate)) " Mb")
|
|
(println " (actually promoted "
|
|
(round2 (/ (* nodes bytes/node) MEG))
|
|
" megabytes)")
|
|
(if (not (zero? ptrMutRate))
|
|
(println "Mutated " actuallyMut " pointers"))
|
|
|
|
; This output serves mainly to discourage optimization.
|
|
|
|
(+ mutatorSum (vector-length aexport))))
|
|
|
|
(define (main . args)
|
|
(GCOld 25 0 10 10 gcold-iters)))
|