tests/profile.impure.lisp

   1 ;;;; tests PROFILE with multiple threads
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 (load "assertoid.lisp")
  15 (load "test-util.lisp")
  16
  17 (defpackage :profile-test
  18   (:use :cl :sb-thread))
  19
  20 (in-package :profile-test)
  21
  22 (defun miller-rabin-prime-p (n &optional (s 50))
  23  "Miller-Rabin primality test written by R. Matthew Emerson."
  24  (flet ((witness-p (a n)
  25           (loop with b = (- n 1)
  26                 for i from (integer-length b) downto 0
  27                 for d = 1 then (mod (* d d) n)
  28                 for x = d
  29                 do (progn
  30                      (when (and (= d 1) (/= x 1) (/= x (- n 1)))
  31                        (return-from witness-p t))
  32                      (when (logbitp i b)
  33                        (setf d (mod (* d a) n))))
  34                 finally (return (/= d 1)))))
  35    (dotimes (i s n)
  36      (let ((w (1+ (random (- n 1)))))
  37        (when (witness-p w n)
  38          (return-from miller-rabin-prime-p nil))))))
  39
  40 (defun random-of-bit-size (n-bits)
  41  "Returns a random number of maximum size `N-BITS'."
  42  (random (ash 1 n-bits)))
  43
  44 (defun prime-of-bit-size (n-bits)
  45  "Returns a prime number of maximum size `N-BITS'."
  46  (loop for maybe-prime = (random-of-bit-size n-bits)
  47        when (miller-rabin-prime-p maybe-prime)
  48          do (return maybe-prime)))
  49
  50 (defun waste-cpu-cycles (n-primes n-prime-bits n-workers)
  51   (if (= n-workers 1)
  52       (handler-case
  53           (progn
  54             (loop repeat n-primes
  55                   do (prime-of-bit-size n-prime-bits))
  56             (list t))
  57         (serious-condition (s)
  58           s))
  59       (let* ((r (make-semaphore))
  60              (w (make-semaphore))
  61              (workers
  62               (loop repeat n-workers
  63                     collect (sb-thread:make-thread
  64                              (let ((rs (make-random-state)))
  65                                (lambda ()
  66                                  (block nil
  67                                      (handler-bind ((serious-condition (lambda (c)
  68                                                                          (princ c)
  69                                                                          (sb-debug:backtrace)
  70                                                                          (return c))))
  71                                        (let ((*random-state* rs))
  72                                          (signal-semaphore r)
  73                                          (wait-on-semaphore w)
  74                                          (loop repeat n-primes
  75                                                do (prime-of-bit-size n-prime-bits))
  76                                          t)))))))))
  77         (loop repeat n-workers do (wait-on-semaphore r))
  78         (signal-semaphore w n-workers)
  79         (mapcar #'sb-thread:join-thread workers))))
  80
  81 (in-package :cl-user)
  82
  83 (with-test (:name (profile :threads))
  84   (profile "PROFILE-TEST")
  85   ;; This used to signal an error with threads
  86   (let* ((n #+sb-thread 5 #-sb-thread 1)
  87          (res (profile-test::waste-cpu-cycles 10 256 n))
  88          (want (make-list n :initial-element t)))
  89     (unless (equal res want)
  90       (error "wanted ~S, got ~S" want res)))
  91   (report))
  92
  93 (with-test (:name :profiling-counter)
  94   ;; Make sure our profiling counters don't miscount
  95   (let ((c (sb-profile::make-counter))
  96         (i 0))
  97     (loop repeat 1000000
  98           do (let ((n (random (* 12 (ash 1 sb-vm:n-word-bits)))))
  99                (sb-profile::incf-counter c n)
 100                (incf i n))
 101              (let ((n (random (ash 1 sb-vm:n-word-bits))))
 102                (sb-profile::incf-counter c n)
 103                (incf i n)))
 104     (assert (= i (sb-profile::counter-count c)))))