contrib/sb-sprof/test.lisp

   1 (cl:defpackage #:sb-sprof-test
   2   (:use #:cl #:sb-sprof)
   3   (:export #:run-tests))
   4
   5 (cl:in-package #:sb-sprof-test)
   6
   7 ;#+sb-fasteval (setq sb-ext:*evaluator-mode* :compile)
   8
   9 (defvar *compiler-input* "../contrib/sb-sprof/graph.lisp")
  10 (defvar *compiler-output* "./foo.fasl")
  11 (defvar *sprof-loop-test-max-samples* 50)
  12
  13 (defun run-tests ()
  14   (proclaim '(sb-ext:muffle-conditions style-warning))
  15   (sb-sprof:with-profiling (:max-samples *sprof-loop-test-max-samples*
  16                             :report :flat :loop t :show-progress t)
  17     ;; Notice that "./foo.fasl" writes into this directory, whereas simply "foo.fasl"
  18     ;; would write into "../../src/code/"
  19     ;; Notice also that our file I/O routines are so crappy that 15% of the test
  20     ;; is spent in lseek, and 12% in write. Just wow!
  21     ;;            Self        Total        Cumul
  22     ;;   Nr  Count     %  Count     %  Count     %    Calls  Function
  23     ;; ------------------------------------------------------------------------
  24     ;;    1     15  15.0     15  15.0     15  15.0        -  foreign function __lseek
  25     ;;    2     12  12.0     12  12.0     27  27.0        -  foreign function write
  26     ;;    3      7   7.0      7   7.0     34  34.0        -  foreign function __pthread_sigmask
  27
  28     ;;
  29     (compile-file *compiler-input* :output-file *compiler-output* :print nil))
  30   (delete-file *compiler-output*)
  31   (let ((*standard-output* (make-broadcast-stream)))
  32     ;; This test shows that STOP-SAMPLING and START-SAMPLING on a thread do something.
  33     ;; Based on rev b6bf65d9 it would seem that the API got broken a little.
  34     ;; The thread doesn't do a whole lot, which is fine for what it is.
  35     #+sb-thread
  36     (let* ((sem (sb-thread:make-semaphore))
  37            (some-thread (sb-thread:make-thread #'sb-thread:wait-on-semaphore :arguments sem
  38                                                :name "donothing")))
  39       (sb-sprof:stop-sampling some-thread)
  40       (sb-sprof:start-sampling some-thread)
  41       (sb-thread:signal-semaphore sem)
  42       ;; Join because when run by run-tests.sh, it's an error to have random leftover threads
  43       (sb-thread:join-thread some-thread)))
  44   t)