--- /dev/null
+;
+; 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.
+
+(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))
HCoop / bpt / guile.git / blobdiff