gc-benchmarks: Add `gcold.scm', by Clinger, Hansen et al.

See http://www.ccs.neu.edu/home/will/Twobit/benchmarksAbout.html for
details.

1 files changed, 384 insertions, 0 deletions

diff --git a/gc-benchmarks/larceny/gcold.scm b/gc-benchmarks/larceny/gcold.scm
new file mode 100644
index 000000000..2dc3cc72c
--- /dev/null
+++ b/gc-benchmarks/larceny/gcold.scm
@@ -0,0 +1,384 @@
+;
+;  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))