1 ;;;; tests PROFILE with multiple threads
3 ;;;; This software is part of the SBCL system. See the README file for
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
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.
14 #+mark-region-gc
(invoke-restart 'run-tests
::skip-file
)
15 (use-package "SB-THREAD")
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
)
25 (when (and (= d
1) (/= x
1) (/= x
(- n
1)))
26 (return-from witness-p t
))
28 (setf d
(mod (* d a
) n
))))
29 finally
(return (/= d
1)))))
31 (let ((w (1+ (random (- n
1)))))
33 (return-from miller-rabin-prime-p nil
))))))
35 (defun random-of-bit-size (n-bits)
36 "Returns a random number of maximum size `N-BITS'."
37 (random (ash 1 n-bits
)))
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
)))
45 (defun waste-cpu-cycles (n-primes n-prime-bits n-workers
)
50 do
(prime-of-bit-size n-prime-bits
))
52 (serious-condition (s)
54 (let* ((r (make-semaphore))
57 (loop repeat n-workers
59 (let ((rs (make-random-state)))
62 (handler-bind ((serious-condition (lambda (c)
64 (sb-debug:print-backtrace
)
66 (let ((*random-state
* rs
))
70 do
(prime-of-bit-size n-prime-bits
))
72 (loop repeat n-workers do
(wait-on-semaphore r
))
73 (signal-semaphore w n-workers
)
74 (mapcar #'join-thread workers
))))
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.
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
)
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
)))
97 (with-test (:name
:profiling-counter
)
98 ;; Make sure our profiling counters don't miscount
99 (let ((c (sb-profile::make-counter
))
102 do
(let ((n (random (* 12 (ash 1 sb-vm
:n-word-bits
)))))
103 (sb-profile::incf-counter c n
)
105 (let ((n (random (ash 1 sb-vm
:n-word-bits
))))
106 (sb-profile::incf-counter c n
)
108 (assert (= i
(sb-profile::counter-count c
)))))