tests/profile.pure.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 #+mark-region-gc (invoke-restart 'run-tests::skip-file)
  15 (use-package "SB-THREAD")
  16
  17 (defun miller-rabin-prime-p (n &optional (s 50))
  18  "Miller-Rabin primality test written by R. Matthew Emerson."
  19  (flet ((witness-p (a n)
  20           (loop with b = (- n 1)
  21                 for i from (integer-length b) downto 0
  22                 for d = 1 then (mod (* d d) n)
  23                 for x = d
  24                 do (progn
  25                      (when (and (= d 1) (/= x 1) (/= x (- n 1)))
  26                        (return-from witness-p t))
  27                      (when (logbitp i b)
  28                        (setf d (mod (* d a) n))))
  29                 finally (return (/= d 1)))))
  30    (dotimes (i s n)
  31      (let ((w (1+ (random (- n 1)))))
  32        (when (witness-p w n)
  33          (return-from miller-rabin-prime-p nil))))))
  34
  35 (defun random-of-bit-size (n-bits)
  36  "Returns a random number of maximum size `N-BITS'."
  37  (random (ash 1 n-bits)))
  38
  39 (defun prime-of-bit-size (n-bits)
  40  "Returns a prime number of maximum size `N-BITS'."
  41  (loop for maybe-prime = (random-of-bit-size n-bits)
  42        when (miller-rabin-prime-p maybe-prime)
  43          do (return maybe-prime)))
  44
  45 (defun waste-cpu-cycles (n-primes n-prime-bits n-workers)
  46   (if (= n-workers 1)
  47       (handler-case
  48           (progn
  49             (loop repeat n-primes
  50                   do (prime-of-bit-size n-prime-bits))
  51             (list t))
  52         (serious-condition (s)
  53           s))
  54       (let* ((r (make-semaphore))
  55              (w (make-semaphore))
  56              (workers
  57               (loop repeat n-workers
  58                     collect (make-thread
  59                              (let ((rs (make-random-state)))
  60                                (lambda ()
  61                                  (block nil
  62                                      (handler-bind ((serious-condition (lambda (c)
  63                                                                          (princ c)
  64                                                                          (sb-debug:print-backtrace)
  65                                                                          (return c))))
  66                                        (let ((*random-state* rs))
  67                                          (signal-semaphore r)
  68                                          (wait-on-semaphore w)
  69                                          (loop repeat n-primes
  70                                                do (prime-of-bit-size n-prime-bits))
  71                                          t)))))))))
  72         (loop repeat n-workers do (wait-on-semaphore r))
  73         (signal-semaphore w n-workers)
  74         (mapcar #'join-thread workers))))
  75
  76 ;;; 9 times out of 10 with #+(and cheneygc ppc) this seems to get:
  77 ;;;    CORRUPTION WARNING in SBCL pid 61861:
  78 ;;;    Memory fault at 0x4fc60000 (pc=0xfd7119c)
  79 ;;;    The integrity of this image is possibly compromised.
  80 ;;;    Exiting.
  81 ;;;       0: [I*]0xdf6a1088 pc=0xfd7119c {0x403f7b8+bd319e4} {code_serialno=343f}
  82 ;;;       1: [*] 0xdf6a0fe8 pc=0x40496b8 {0x403f7b8+9f00} (FLET "WITHOUT-GCING-BODY-112" :IN SB-BIGNUM::BIGNUM-TRUNCATE)
  83 ;;; and I really don't care why but since this file is allegedly "pure",
  84 ;;; its death kills all the remaining tests.
  85 (with-test (:name (profile :threads)
  86                   :skipped-on :cheneygc
  87                   :broken-on :win32)
  88   (profile #.(package-name cl:*package*))
  89   ;; This used to signal an error with threads
  90   (let* ((n #+sb-thread 5 #-sb-thread 1)
  91          (res (waste-cpu-cycles 10 256 n))
  92          (want (make-list n :initial-element t)))
  93     (unless (equal res want)
  94       (error "wanted ~S, got ~S" want res)))
  95   (report))
  96
  97 (with-test (:name :profiling-counter)
  98   ;; Make sure our profiling counters don't miscount
  99   (let ((c (sb-profile::make-counter))
 100         (i 0))
 101     (loop repeat 1000000
 102           do (let ((n (random (* 12 (ash 1 sb-vm:n-word-bits)))))
 103                (sb-profile::incf-counter c n)
 104                (incf i n))
 105              (let ((n (random (ash 1 sb-vm:n-word-bits))))
 106                (sb-profile::incf-counter c n)
 107                (incf i n)))
 108     (assert (= i (sb-profile::counter-count c)))))