test-suite/tests/statprof.test

   1 ;; guile-lib                    -*- scheme -*-
   2 ;; Copyright (C) 2004, 2009, 2010, 2014 Andy Wingo <wingo at pobox dot com>
   3 ;; Copyright (C) 2001 Rob Browning <rlb at defaultvalue dot org>
   4
   5 ;; This library is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the GNU Lesser General Public
   7 ;; License as published by the Free Software Foundation; either
   8 ;; version 2.1 of the License, or (at your option) any later version.
   9 ;;
  10 ;; This library is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;; Lesser General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU Lesser General Public
  16 ;; License along with this program; if not, contact:
  17 ;;
  18 ;; Free Software Foundation           Voice:  +1-617-542-5942
  19 ;; 59 Temple Place - Suite 330        Fax:    +1-617-542-2652
  20 ;; Boston, MA  02111-1307,  USA       gnu@gnu.org
  21
  22 ;;; Commentary:
  23 ;;
  24 ;; Unit tests for (debugging statprof).
  25 ;;
  26 ;;; Code:
  27
  28 (define-module (test-suite test-statprof)
  29   #:use-module (test-suite lib)
  30   #:use-module (system base compile)
  31   #:use-module (srfi srfi-1)
  32   #:use-module (statprof))
  33
  34 ;; Throw `unresolved' upon ENOSYS.  This is used to skip tests on
  35 ;; platforms such as GNU/Hurd where `ITIMER_PROF' is is currently
  36 ;; unimplemented.
  37 (define-syntax-rule (when-implemented body ...)
  38   (catch 'system-error
  39     (lambda ()
  40       body ...)
  41     (lambda args
  42       (let ((errno (system-error-errno args)))
  43         (false-if-exception (statprof-stop))
  44         (if (= errno ENOSYS)
  45             (throw 'unresolved)
  46             (apply throw args))))))
  47
  48 (pass-if-equal "return values"
  49     '(42 77)
  50   (call-with-values
  51       (lambda ()
  52         (with-output-to-port (%make-void-port "w")
  53           (lambda ()
  54             (with-statprof
  55                 (let loop ((i 10000))
  56                   (if (zero? i)
  57                       (values 42 77)
  58                       (loop (1- i))))))))
  59     list))
  60
  61 (pass-if "statistical sample counts within expected range"
  62   (when-implemented
  63     ;; test to see that if we call 3 identical functions equally, they
  64     ;; show up equally in the call count, +/- 30%. it's a big range, and
  65     ;; I tried to do something more statistically valid, but failed (for
  66     ;; the moment).
  67
  68     ;; make sure these are compiled so we're not swamped in `eval'
  69     (define (make-func)
  70       ;; Disable partial evaluation so that `(+ i i)' doesn't get
  71       ;; stripped.
  72       (compile '(lambda (n)
  73                   (do ((i 0 (+ i 1))) ((= 200 i)) (+ i i)))
  74                #:opts '(#:partial-eval? #f)))
  75     (define run-test
  76       (compile '(lambda (num-calls funcs)
  77                   (let loop ((x num-calls) (funcs funcs))
  78                     (cond
  79                      ((positive? x)
  80                       ((car funcs) x)
  81                       (loop (- x 1) (cdr funcs))))))))
  82
  83     (let ((num-calls 200000)
  84           (funcs (circular-list (make-func) (make-func) (make-func))))
  85
  86       ;; Run test. 20000 us == 200 Hz.
  87       (statprof-reset 0 20000 #f #f)
  88       (statprof-start)
  89       (run-test num-calls funcs)
  90       (statprof-stop)
  91
  92       (let ((a-data (statprof-proc-call-data (car funcs)))
  93             (b-data (statprof-proc-call-data (cadr funcs)))
  94             (c-data (statprof-proc-call-data (caddr funcs))))
  95         (if (and a-data b-data c-data)
  96             (let* ((samples (map statprof-call-data-cum-samples
  97                                  (list a-data b-data c-data)))
  98                    (expected (/ (apply + samples) 3.0))
  99                    (diffs (map (lambda (x) (abs (- x expected)))
 100                                samples))
 101                    (max-diff (apply max diffs)))
 102
 103               (or (< max-diff (sqrt expected))
 104                   ;; don't stop the test suite for what statistically is
 105                   ;; bound to happen.
 106                   (begin
 107                     (format (current-warning-port)
 108                             ";;; warning: max diff ~a > (sqrt ~a)\n"
 109                             max-diff expected)
 110                     (throw 'unresolved))))
 111
 112             ;; Samples were not collected for at least one of the
 113             ;; functions, possibly because NUM-CALLS is too low compared
 114             ;; to the CPU speed.
 115             (throw 'unresolved (pk (list a-data b-data c-data))))))))
 116
 117 (pass-if "accurate call counting"
 118   (when-implemented
 119     ;; Test to see that if we call a function N times while the profiler
 120     ;; is active, it shows up N times.
 121     (let ((num-calls 200))
 122
 123       (define do-nothing
 124         (compile '(lambda (n)
 125                     (simple-format #f "FOO ~A\n" (+ n n)))))
 126
 127       ;; Run test.
 128       (statprof-reset 0 50000 #t #f)
 129       (statprof-start)
 130       (let loop ((x num-calls))
 131         (cond
 132          ((positive? x)
 133           (do-nothing x)
 134           (loop (- x 1))
 135           #t)))
 136       (statprof-stop)
 137
 138       ;; Check result.
 139       (let ((proc-data (statprof-proc-call-data do-nothing)))
 140         (and proc-data
 141              (= (statprof-call-data-calls proc-data)
 142                 num-calls))))))