Add GC benchmarks.

5 files changed, 402 insertions, 0 deletions

diff --git a/gc-benchmarks/gc-profile.scm b/gc-benchmarks/gc-profile.scm
new file mode 100755
index 000000000..f19753a5e
--- /dev/null
+++ b/gc-benchmarks/gc-profile.scm
@@ -0,0 +1,154 @@
+#!/bin/sh
+# -*- Scheme -*-
+exec ${GUILE-guile} --no-debug -q -l "$0" \
+                    -c '(apply main (command-line))' "$@"
+!#
+;;; Copyright (C) 2008 Free Software Foundation, Inc.
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2, or (at your option)
+;;; any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this software; see the file COPYING.  If not, write to
+;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;; Boston, MA 02110-1301 USA
+
+(use-modules (ice-9 format)
+             (ice-9 rdelim)
+             (ice-9 regex)
+             (srfi srfi-1))
+
+(define (memory-mappings pid)
+  "Return an list of alists, each of which contains information about a
+memory mapping of process @var{pid}.  This information is obtained by reading
+@file{/proc/PID/smaps} on Linux.  See `procs(5)' for details."
+
+  (define mapping-line-rx
+    (make-regexp
+     "^([[:xdigit:]]+)-([[:xdigit:]]+) ([rwx-]{3}[ps]) ([[:xdigit:]]+) [0-9]{2}:[0-9]{2} [0-9]+[[:blank:]]+(.*)$"))
+
+  (define rss-line-rx
+    (make-regexp
+     "^Rss:[[:blank:]]+([[:digit:]]+) kB$"))
+
+  (with-input-from-port (open-input-file (format #f "/proc/~a/smaps" pid))
+    (lambda ()
+      (let loop ((line   (read-line))
+                 (result '()))
+        (if (eof-object? line)
+            (reverse result)
+            (cond ((regexp-exec mapping-line-rx line)
+                   =>
+                   (lambda (match)
+                     (let ((mapping-start (string->number
+                                           (match:substring match 1)
+                                           16))
+                           (mapping-end   (string->number
+                                           (match:substring match 2)
+                                           16))
+                           (access-bits   (match:substring match 3))
+                           (name          (match:substring match 5)))
+                       (loop (read-line)
+                             (cons `((mapping-start . ,mapping-start)
+                                     (mapping-end   . ,mapping-end)
+                                     (access-bits   . ,access-bits)
+                                     (name          . ,(if (string=? name "")
+                                                           #f
+                                                           name)))
+                                   result)))))
+                  ((regexp-exec rss-line-rx line)
+                   =>
+                   (lambda (match)
+                     (let ((section+ (cons (cons 'rss
+                                                 (string->number
+                                                  (match:substring match 1)))
+                                           (car result))))
+                       (loop (read-line)
+                             (cons section+ (cdr result))))))
+                  (else
+                   (loop (read-line) result))))))))
+
+(define (total-heap-size pid)
+  "Return the total heap size of process @var{pid}."
+
+  (define heap-or-anon-rx
+    (make-regexp "\\[(heap|anon)\\]"))
+
+  (define private-mapping-rx
+    (make-regexp "^[r-][w-][x-]p$"))
+
+  (fold (lambda (heap total+rss)
+          (let ((name (assoc-ref heap 'name))
+                (perm (assoc-ref heap 'access-bits)))
+            ;; Include anonymous private mappings.
+            (if (or (and (not name)
+                         (regexp-exec private-mapping-rx perm))
+                    (and name
+                         (regexp-exec heap-or-anon-rx name)))
+                (let ((start (assoc-ref heap 'mapping-start))
+                      (end   (assoc-ref heap 'mapping-end))
+                      (rss   (assoc-ref heap 'rss)))
+                  (cons (+ (car total+rss) (- end start))
+                        (+ (cdr total+rss) rss)))
+                total+rss)))
+        '(0 . 0)
+        (memory-mappings pid)))
+
+
+(define (display-stats start end)
+  (define (->usecs sec+usecs)
+    (+ (* 1000000 (car sec+usecs))
+       (cdr sec+usecs)))
+
+  (let ((usecs        (- (->usecs end) (->usecs start)))
+        (heap-size    (total-heap-size (getpid)))
+        (gc-heap-size (assoc-ref (gc-stats) 'heap-size)))
+
+    (format #t "execution time:              ~6,3f seconds~%"
+            (/ usecs 1000000.0))
+
+    (and gc-heap-size
+         (format #t "GC-reported heap size: ~8d B   (~1,2f MiB)~%"
+                 gc-heap-size
+                 (/ gc-heap-size 1024.0 1024.0)))
+
+    (format #t "heap size:             ~8d B   (~1,2f MiB)~%"
+            (car heap-size)
+            (/ (car heap-size) 1024.0 1024.0))
+    (format #t "heap RSS:              ~8d KiB (~1,2f MiB)~%"
+            (cdr heap-size)
+            (/ (cdr heap-size) 1024.0))
+;;     (system (format #f "cat /proc/~a/smaps" (getpid)))
+;;     (system (format #f "exmtool procs | grep -E '^(PID|~a)'" (getpid)))
+    ))
+
+
+(define (main . args)
+  (if (not (= (length args) 2))
+      (begin
+        (format #t "Usage: run FILE.SCM
+
+Load FILE.SCM, a Guile Scheme source file, and report its execution time and
+final heap usage.~%")
+        (exit 1)))
+
+  (let ((prog  (cadr args))
+        (start (gettimeofday)))
+    (format #t "running `~a'...~%" prog)
+    (dynamic-wind
+        (lambda ()
+          #t)
+        (lambda ()
+          (set! quit (lambda args args))
+          (load prog))
+        (lambda ()
+          (let ((end (gettimeofday)))
+            (format #t "done~%")
+            (display-stats start end))))))
diff --git a/gc-benchmarks/gcbench.scm b/gc-benchmarks/gcbench.scm
new file mode 100644
index 000000000..31098ec24
--- /dev/null
+++ b/gc-benchmarks/gcbench.scm
@@ -0,0 +1,210 @@
+;  This is adapted from a benchmark written by John Ellis and Pete Kovac
+;  of Post Communications.
+;  It was modified by Hans Boehm of Silicon Graphics.
+;  It was translated into Scheme by William D Clinger of Northeastern Univ;
+;    the Scheme version uses (RUN-BENCHMARK <string> <thunk>)
+;  Last modified 30 May 1997.
+; 
+;       This is no substitute for real applications.  No actual application
+;       is likely to behave in exactly this way.  However, this benchmark was
+;       designed to be more representative of real applications than other
+;       Java GC benchmarks of which we are aware.
+;       It attempts to model those properties of allocation requests that
+;       are important to current GC techniques.
+;       It is designed to be used either to obtain a single overall performance
+;       number, or to give a more detailed estimate of how collector
+;       performance varies with object lifetimes.  It prints the time
+;       required to allocate and collect balanced binary trees of various
+;       sizes.  Smaller trees result in shorter object lifetimes.  Each cycle
+;       allocates roughly the same amount of memory.
+;       Two data structures are kept around during the entire process, so
+;       that the measured performance is representative of applications
+;       that maintain some live in-memory data.  One of these is a tree
+;       containing many pointers.  The other is a large array containing
+;       double precision floating point numbers.  Both should be of comparable
+;       size.
+; 
+;       The results are only really meaningful together with a specification
+;       of how much memory was used.  It is possible to trade memory for
+;       better time performance.  This benchmark should be run in a 32 MB
+;       heap, though we don't currently know how to enforce that uniformly.
+
+; In the Java version, this routine prints the heap size and the amount
+; of free memory.  There is no portable way to do this in Scheme; each
+; implementation needs its own version.
+
+(use-modules (ice-9 syncase))
+
+(define (PrintDiagnostics)
+  (display " Total memory available= ???????? bytes")
+  (display "  Free memory= ???????? bytes")
+  (newline))
+
+
+
+(define (run-benchmark str thu)
+	(display str)
+  (thu))
+; Should we implement a Java class as procedures or hygienic macros?
+; Take your pick.
+
+(define-syntax let-class
+  (syntax-rules
+   ()
+
+   ;; Put this rule first to implement a class using procedures.
+   ((let-class (((method . args) . method-body) ...) . body)
+    (let () (define (method . args) . method-body) ... . body))
+
+   
+   ;; Put this rule first to implement a class using hygienic macros.
+   ((let-class (((method . args) . method-body) ...) . body)
+    (letrec-syntax ((method (syntax-rules () ((method . args) (begin .  method-body))))
+                    ...)
+      . body))
+
+   
+   ))
+                          
+
+(define (gcbench kStretchTreeDepth)
+  
+  ;  Nodes used by a tree of a given size
+  (define (TreeSize i)
+    (- (expt 2 (+ i 1)) 1))
+  
+  ;  Number of iterations to use for a given tree depth
+  (define (NumIters i)
+    (quotient (* 2 (TreeSize kStretchTreeDepth))
+              (TreeSize i)))
+  
+  ;  Parameters are determined by kStretchTreeDepth.
+  ;  In Boehm's version the parameters were fixed as follows:
+  ;    public static final int kStretchTreeDepth    = 18;  // about 16Mb
+  ;    public static final int kLongLivedTreeDepth  = 16;  // about 4Mb
+  ;    public static final int kArraySize  = 500000;       // about 4Mb
+  ;    public static final int kMinTreeDepth = 4;
+  ;    public static final int kMaxTreeDepth = 16;
+  ;  In Larceny the storage numbers above would be 12 Mby, 3 Mby, 6 Mby.
+  
+  (let* ((kLongLivedTreeDepth (- kStretchTreeDepth 2))
+         (kArraySize          (* 4 (TreeSize kLongLivedTreeDepth)))
+         (kMinTreeDepth       4)
+         (kMaxTreeDepth       kLongLivedTreeDepth))
+    
+    ; Elements 3 and 4 of the allocated vectors are useless.
+    
+    (let-class (((make-node l r)
+                 (let ((v (make-empty-node)))
+                   (vector-set! v 0 l)
+                   (vector-set! v 1 r)
+                   v))
+                ((make-empty-node) (make-vector 4 0))
+                ((node.left node) (vector-ref node 0))
+                ((node.right node) (vector-ref node 1))
+                ((node.left-set! node x) (vector-set! node 0 x))
+                ((node.right-set! node x) (vector-set! node 1 x)))
+      
+      ;  Build tree top down, assigning to older objects.
+      (define (Populate iDepth thisNode)
+        (if (<= iDepth 0)
+            #f
+            (let ((iDepth (- iDepth 1)))
+              (node.left-set! thisNode (make-empty-node))
+              (node.right-set! thisNode (make-empty-node))
+              (Populate iDepth (node.left thisNode))
+              (Populate iDepth (node.right thisNode)))))
+      
+      ;  Build tree bottom-up
+      (define (MakeTree iDepth)
+        (if (<= iDepth 0)
+            (make-empty-node)
+            (make-node (MakeTree (- iDepth 1))
+                       (MakeTree (- iDepth 1)))))
+      
+      (define (TimeConstruction depth)
+        (let ((iNumIters (NumIters depth)))
+          (display (string-append "Creating "
+                                  (number->string iNumIters)
+                                  " trees of depth "
+                                  (number->string depth)))
+          (newline)
+          (run-benchmark "GCBench: Top down construction"
+                         (lambda ()
+                           (do ((i 0 (+ i 1)))
+                               ((>= i iNumIters))
+                               (Populate depth (make-empty-node)))))
+          (run-benchmark "GCBench: Bottom up construction"
+                         (lambda ()
+                           (do ((i 0 (+ i 1)))
+                               ((>= i iNumIters))
+                               (MakeTree depth))))))
+      
+      (define (main)
+        (display "Garbage Collector Test")
+        (newline)
+        (display (string-append
+                  " Stretching memory with a binary tree of depth "
+                  (number->string kStretchTreeDepth)))
+        (newline)
+        (run-benchmark "GCBench: Main"
+                       (lambda ()
+                         ;  Stretch the memory space quickly
+                         (MakeTree kStretchTreeDepth)
+                         
+                         ;  Create a long lived object
+                         (display (string-append
+                                   " Creating a long-lived binary tree of depth "
+                                   (number->string kLongLivedTreeDepth)))
+                         (newline)
+                         (let ((longLivedTree (make-empty-node)))
+                           (Populate kLongLivedTreeDepth longLivedTree)
+                           
+                           ;  Create long-lived array, filling half of it
+                           (display (string-append
+                                     " Creating a long-lived array of "
+                                     (number->string kArraySize)
+                                     " inexact reals"))
+                           (newline)
+                           (let ((array (make-vector kArraySize 0.0)))
+                             (do ((i 0 (+ i 1)))
+                                 ((>= i (quotient kArraySize 2)))
+                                 (vector-set! array i (/ 1.0 (exact->inexact i))))
+                             (PrintDiagnostics)
+                             
+                             (do ((d kMinTreeDepth (+ d 2)))
+                                 ((> d kMaxTreeDepth))
+                                 (TimeConstruction d))
+                             
+                             (if (or (eq? longLivedTree '())
+                                     (let ((n (min 1000
+                                                   (- (quotient (vector-length array)
+                                                                2)
+                                                      1))))
+                                       (not (= (vector-ref array n)
+                                               (/ 1.0 (exact->inexact
+n))))))
+                                 (begin (display "Failed") (newline)))
+                             ;  fake reference to LongLivedTree
+                             ;  and array
+                             ;  to keep them from being optimized away
+                             ))))
+        (PrintDiagnostics))
+      
+      (main))))
+
+(define (gc-benchmark . rest)
+  (let ((k (if (null? rest) 18 (car rest))))
+    (display "The garbage collector should touch about ")
+    (display (expt 2 (- k 13)))
+    (display " megabytes of heap storage.")
+    (newline)
+    (display "The use of more or less memory will skew the results.")
+    (newline)
+    (run-benchmark (string-append "GCBench" (number->string k))
+                   (lambda () (gcbench k)))))
+
+
+
+(gc-benchmark )
+(display (gc-stats))
diff --git a/gc-benchmarks/guile-test.scm b/gc-benchmarks/guile-test.scm
new file mode 100644
index 000000000..ddc414dba
--- /dev/null
+++ b/gc-benchmarks/guile-test.scm
@@ -0,0 +1,9 @@
+(set! %load-path (cons (string-append (getenv "HOME") "/src/guile")
+                       %load-path))
+
+(load "../test-suite/guile-test")
+
+(main `("guile-test"
+        "--test-suite" ,(string-append (getenv "HOME")
+                                       "/src/guile/test-suite/tests")
+        "--log-file" ",,test-suite.log"))
diff --git a/gc-benchmarks/loop.scm b/gc-benchmarks/loop.scm
new file mode 100644
index 000000000..7e81e7a9e
--- /dev/null
+++ b/gc-benchmarks/loop.scm
@@ -0,0 +1,4 @@
+(let loop ((i 10000000))
+  (and (> i 0)
+       (loop (1- i))))
+
diff --git a/gc-benchmarks/string.scm b/gc-benchmarks/string.scm
new file mode 100644
index 000000000..727016352
--- /dev/null
+++ b/gc-benchmarks/string.scm
@@ -0,0 +1,25 @@
+;;; From from http://www.ccs.neu.edu/home/will/Twobit/KVW/string.txt .
+; string test
+; (try 100000)
+
+(define s "abcdef")
+
+(define (grow)
+	(set! s (string-append "123" s "456" s "789"))
+	(set! s (string-append
+		(substring s (quotient (string-length s) 2) (string-length s))
+		(substring s 0 (+ 1 (quotient (string-length s) 2)))))
+	s)
+
+(define (trial n)
+	(do ((i 0 (+ i 1)))
+		((> (string-length s) n) (string-length s))
+		(grow)))
+
+(define (try n)
+	(do ((i 0 (+ i 1)))
+		((>= i 10) (string-length s))
+		(set! s "abcdef")
+		(trial n)))
+
+(try 50000000)
\ No newline at end of file