gc-benchmarks/gc-profile.scm

   1 #!/bin/sh
   2 # -*- Scheme -*-
   3 exec ${GUILE-guile} --no-debug -q -l "$0" \
   4                     -c '(apply main (cdr (command-line)))' "$@"
   5 !#
   6 ;;; Copyright (C) 2008 Free Software Foundation, Inc.
   7 ;;;
   8 ;;; This program is free software; you can redistribute it and/or
   9 ;;; modify it under the terms of the GNU Lesser General Public License
  10 ;;; as published by the Free Software Foundation; either version 3, or
  11 ;;; (at your option) any later version.
  12 ;;;
  13 ;;; This program is distributed in the hope that it will be useful,
  14 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU Lesser General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU Lesser General Public
  19 ;;; License along with this software; see the file COPYING.LESSER.  If
  20 ;;; not, write to the Free Software Foundation, Inc., 51 Franklin
  21 ;;; Street, Fifth Floor, Boston, MA 02110-1301 USA
  22
  23 (use-modules (ice-9 format)
  24              (ice-9 rdelim)
  25              (ice-9 regex)
  26              (srfi srfi-1)
  27              (srfi srfi-37)
  28              (srfi srfi-39))
  29
  30 \f
  31 ;;;
  32 ;;; Memory usage.
  33 ;;;
  34
  35 (define (memory-mappings pid)
  36   "Return an list of alists, each of which contains information about a
  37 memory mapping of process @var{pid}.  This information is obtained by reading
  38 @file{/proc/PID/smaps} on Linux.  See `procs(5)' for details."
  39
  40   (define mapping-line-rx
  41     (make-regexp
  42      "^([[:xdigit:]]+)-([[:xdigit:]]+) ([rwx-]{3}[ps]) ([[:xdigit:]]+) [0-9]{2}:[0-9]{2} [0-9]+[[:blank:]]+(.*)$"))
  43
  44   (define rss-line-rx
  45     (make-regexp
  46      "^Rss:[[:blank:]]+([[:digit:]]+) kB$"))
  47
  48   (with-input-from-port (open-input-file (format #f "/proc/~a/smaps" pid))
  49     (lambda ()
  50       (let loop ((line   (read-line))
  51                  (result '()))
  52         (if (eof-object? line)
  53             (reverse result)
  54             (cond ((regexp-exec mapping-line-rx line)
  55                    =>
  56                    (lambda (match)
  57                      (let ((mapping-start (string->number
  58                                            (match:substring match 1)
  59                                            16))
  60                            (mapping-end   (string->number
  61                                            (match:substring match 2)
  62                                            16))
  63                            (access-bits   (match:substring match 3))
  64                            (name          (match:substring match 5)))
  65                        (loop (read-line)
  66                              (cons `((mapping-start . ,mapping-start)
  67                                      (mapping-end   . ,mapping-end)
  68                                      (access-bits   . ,access-bits)
  69                                      (name          . ,(if (string=? name "")
  70                                                            #f
  71                                                            name)))
  72                                    result)))))
  73                   ((regexp-exec rss-line-rx line)
  74                    =>
  75                    (lambda (match)
  76                      (let ((section+ (cons (cons 'rss
  77                                                  (string->number
  78                                                   (match:substring match 1)))
  79                                            (car result))))
  80                        (loop (read-line)
  81                              (cons section+ (cdr result))))))
  82                   (else
  83                    (loop (read-line) result))))))))
  84
  85 (define (total-heap-size pid)
  86   "Return the total heap size of process @var{pid}."
  87
  88   (define heap-or-anon-rx
  89     (make-regexp "\\[(heap|anon)\\]"))
  90
  91   (define private-mapping-rx
  92     (make-regexp "^[r-][w-][x-]p$"))
  93
  94   (fold (lambda (heap total+rss)
  95           (let ((name (assoc-ref heap 'name))
  96                 (perm (assoc-ref heap 'access-bits)))
  97             ;; Include anonymous private mappings.
  98             (if (or (and (not name)
  99                          (regexp-exec private-mapping-rx perm))
 100                     (and name
 101                          (regexp-exec heap-or-anon-rx name)))
 102                 (let ((start (assoc-ref heap 'mapping-start))
 103                       (end   (assoc-ref heap 'mapping-end))
 104                       (rss   (assoc-ref heap 'rss)))
 105                   (cons (+ (car total+rss) (- end start))
 106                         (+ (cdr total+rss) rss)))
 107                 total+rss)))
 108         '(0 . 0)
 109         (memory-mappings pid)))
 110
 111
 112 (define (display-stats start end)
 113   (define (->usecs sec+usecs)
 114     (+ (* 1000000 (car sec+usecs))
 115        (cdr sec+usecs)))
 116
 117   (let ((usecs        (- (->usecs end) (->usecs start)))
 118         (heap-size    (total-heap-size (getpid)))
 119         (gc-heap-size (assoc-ref (gc-stats) 'heap-size)))
 120
 121     (format #t "execution time:              ~6,3f seconds~%"
 122             (/ usecs 1000000.0))
 123
 124     (and gc-heap-size
 125          (format #t "GC-reported heap size: ~8d B   (~1,2f MiB)~%"
 126                  gc-heap-size
 127                  (/ gc-heap-size 1024.0 1024.0)))
 128
 129     (format #t "heap size:             ~8d B   (~1,2f MiB)~%"
 130             (car heap-size)
 131             (/ (car heap-size) 1024.0 1024.0))
 132     (format #t "heap RSS:              ~8d KiB (~1,2f MiB)~%"
 133             (cdr heap-size)
 134             (/ (cdr heap-size) 1024.0))
 135 ;;     (system (format #f "cat /proc/~a/smaps" (getpid)))
 136 ;;     (system (format #f "exmtool procs | grep -E '^(PID|~a)'" (getpid)))
 137     ))
 138
 139 \f
 140 ;;;
 141 ;;; Larceny/Twobit benchmarking compability layer.
 142 ;;;
 143
 144 (define *iteration-count*
 145   (make-parameter #f))
 146
 147 (define (run-benchmark name . args)
 148   "A @code{run-benchmark} procedure compatible with Larceny's GC benchmarking
 149 framework.  See
 150 @url{http://www.ccs.neu.edu/home/will/Twobit/benchmarksAbout.html} for
 151 details."
 152
 153   (define %concise-invocation?
 154     ;; This procedure can be called with only two arguments, NAME and
 155     ;; RUN-MAKER.
 156     (procedure? (car args)))
 157
 158   (let ((count     (or (*iteration-count*)
 159                        (if %concise-invocation? 0 (car args))))
 160         (run-maker (if %concise-invocation? (car args) (cadr args)))
 161         (ok?       (if %concise-invocation?
 162                        (lambda (result) #t)
 163                        (caddr args)))
 164         (args      (if %concise-invocation? '() (cdddr args))))
 165     (let loop ((i 0))
 166       (and (< i count)
 167            (let ((result (apply run-maker args)))
 168              (if (not (ok? result))
 169                  (begin
 170                    (format (current-output-port) "invalid result for `~A'~%"
 171                            name)
 172                    (exit 1)))
 173              (loop (1+ i)))))))
 174
 175 (define (save-directory-excursion directory thunk)
 176   (let ((previous-dir (getcwd)))
 177     (dynamic-wind
 178       (lambda ()
 179         (chdir directory))
 180       thunk
 181       (lambda ()
 182         (chdir previous-dir)))))
 183
 184 (define (load-larceny-benchmark file)
 185   "Load the Larceny benchmark from @var{file}."
 186   (let ((name   (let ((base (basename file)))
 187                   (substring base 0 (or (string-rindex base #\.)
 188                                         (string-length base)))))
 189         (module (let ((m (make-module)))
 190                   (beautify-user-module! m)
 191                   (module-use! m (resolve-interface '(ice-9 syncase)))
 192                   m)))
 193     (save-directory-excursion (dirname file)
 194      (lambda ()
 195        (save-module-excursion
 196         (lambda ()
 197           (set-current-module module)
 198           (module-define! module 'run-benchmark run-benchmark)
 199           (load (basename file))
 200
 201           ;; Invoke the benchmark's entry point.
 202           (let ((entry (module-ref (current-module)
 203                                    (symbol-append (string->symbol name)
 204                                                   '-benchmark))))
 205             (entry))))))))
 206
 207
 208 \f
 209 ;;;
 210 ;;; Option processing.
 211 ;;;
 212
 213 (define %options
 214   (list (option '(#\h "help") #f #f
 215                 (lambda args
 216                   (show-help)
 217                   (exit 0)))
 218         (option '(#\l "larceny") #f #f
 219                 (lambda (opt name arg result)
 220                   (alist-cons 'larceny? #t result)))
 221         (option '(#\i "iterations") #t #f
 222                 (lambda (opt name arg result)
 223                   (alist-cons 'iterations (string->number arg) result)))))
 224
 225 (define (show-help)
 226   (format #t "Usage: gc-profile [OPTIONS] FILE.SCM
 227 Load FILE.SCM, a Guile Scheme source file, and report its execution time and
 228 final heap usage.
 229
 230   -h, --help      Show this help message
 231
 232   -l, --larceny   Provide mechanisms compatible with the Larceny/Twobit
 233                   GC benchmark suite.
 234   -i, --iterations=COUNT
 235                   Run the given benchmark COUNT times, regardless of the
 236                   iteration count passed to `run-benchmark' (for Larceny
 237                   benchmarks).
 238
 239 Report bugs to <bug-guile@gnu.org>.~%"))
 240
 241 (define (parse-args args)
 242   (define (leave fmt . args)
 243     (apply format (current-error-port) (string-append fmt "~%") args)
 244     (exit 1))
 245
 246   (args-fold args %options
 247              (lambda (opt name arg result)
 248                (leave "~A: unrecognized option" opt))
 249              (lambda (file result)
 250                (if (pair? (assoc 'input result))
 251                    (leave "~a: only one input file at a time" file)
 252                    (alist-cons 'input file result)))
 253              '()))
 254
 255 \f
 256 ;;;
 257 ;;; Main program.
 258 ;;;
 259
 260 (define (main . args)
 261   (let* ((options (parse-args args))
 262          (prog    (assoc-ref options 'input))
 263          (load    (if (assoc-ref options 'larceny?)
 264                       load-larceny-benchmark
 265                       load)))
 266
 267     (parameterize ((*iteration-count* (assoc-ref options 'iterations)))
 268       (format #t "running `~a' with Guile ~a...~%" prog (version))
 269
 270       (let ((start (gettimeofday)))
 271         (dynamic-wind
 272           (lambda ()
 273             #t)
 274           (lambda ()
 275             (set! quit (lambda args args))
 276             (load prog))
 277           (lambda ()
 278             (let ((end (gettimeofday)))
 279               (format #t "done~%")
 280               (display-stats start end))))))))