gc-profile.scm 10 KB

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