blob: e0a9ac34c60da04ed037888257597ac8df16cb2c (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
|
(defparameter *pkgname* "SOME-FINE-PACKAGE")
(unless (find-package *pkgname*)
(make-package *pkgname*))
(defglobal *count-found* 0)
(declaim (fixnum *count-found*))
;;; We most certainly don't want to synchronize all calls to FIND-PACKAGE
;;; and FIND-SYMBOL with mutators of the package name graph.
;;; Unfortunately there is an interesting and not too far-fetched use which
;;; involves one thread looking up a package by its primary name while some
;;; other thread adds a nickname to that package. This used to potentially
;;; fail in the looking-up thread because RENAME-PACKAGE started by deleting
;;; all names of the package being altered. That is no longer the case.
(defun renaming-experiment (n-trials n-threads)
(let* ((trigger-sem (sb-thread:make-semaphore))
(trial-completion-sem (sb-thread:make-semaphore))
(threadfun
(lambda ()
(dotimes (i n-trials)
(sb-thread:wait-on-semaphore trigger-sem)
(when (find-package *pkgname*) (atomic-incf *count-found*))
(sb-thread:signal-semaphore trial-completion-sem))))
(threads
(loop for i from 1 to n-threads
collect (sb-thread:make-thread threadfun
:name (format nil "thread ~d" i))))
(wins 0))
(dotimes (i n-trials)
(setq *count-found* 0)
(sb-thread:signal-semaphore trigger-sem n-threads)
(rename-package *pkgname* *pkgname* '("SFP"))
(sb-thread:wait-on-semaphore trial-completion-sem :n n-threads)
(rename-package *pkgname* *pkgname* nil)
;; (format t "~&Trial ~d: ~d~%" (1+ i) *count-found*)
(when (= *count-found* n-threads)
(incf wins)))
(mapc 'sb-thread:join-thread threads)
wins))
(with-test (:name :renamed-package-does-not-disappear
:skipped-on (:not :sb-thread))
(let* ((n-trials 100)
(wins (renaming-experiment n-trials 4)))
;; This was getting about 50% to 70% success prior to the fix.
;; (format t "~&Win percent: ~,,2f~%" (/ wins n-trials))
(assert (= wins n-trials))))
|
