--- /dev/null
+#!/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)))
+ ))
+
+\f
+(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))))))
--- /dev/null
+; 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))
HCoop / bpt / guile.git / commitdiff