gc-profile.scm 9.8 KB

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