Declare types of *MACHINE-VERSION*, *{SHORT,LONG}-SITE-NAME*, *ED-FUNCTIONS*
[sbcl.git] / tests / profile.impure.lisp
blob4aea6a882a53700189d7c41c51b313858d6ccdef
1 ;;;; tests PROFILE with multiple threads
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.
14 (load "assertoid.lisp")
15 (load "test-util.lisp")
17 (defpackage :profile-test
18 (:use :cl :sb-thread))
20 (in-package :profile-test)
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))))))
40 (defun random-of-bit-size (n-bits)
41 "Returns a random number of maximum size `N-BITS'."
42 (random (ash 1 n-bits)))
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)))
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:print-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))))
81 (in-package :cl-user)
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))
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)))))