mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
44 lines
1.7 KiB
Common Lisp
44 lines
1.7 KiB
Common Lisp
#-sb-thread (invoke-restart 'run-tests::skip-file)
|
|
|
|
(use-package "SB-THREAD")
|
|
|
|
(defun alloc-stuff () (copy-list '(1 2 3 4 5)))
|
|
|
|
(with-test (:name (:interrupt-thread :interrupt-consing-child))
|
|
(let* ((thread (make-thread (lambda () (loop (alloc-stuff)))))
|
|
(killer (make-thread
|
|
(lambda ()
|
|
(loop repeat 100 do
|
|
(sleep (random 0.1d0))
|
|
(princ ".")
|
|
(force-output)
|
|
(process-all-interrupts thread)
|
|
(interrupt-thread thread (lambda ())))))))
|
|
(wait-for-threads (list killer))
|
|
(process-all-interrupts thread)
|
|
(terminate-thread thread)
|
|
(wait-for-threads (list thread)))
|
|
(sb-ext:gc :full t))
|
|
|
|
#+(or x86 x86-64) ;; x86oid-only, see internal commentary.
|
|
(with-test (:name (:interrupt-thread :interrupt-consing-child :again))
|
|
(symbol-macrolet ((pseudoatomic-bits
|
|
(sb-sys:sap-int (sb-vm::current-thread-offset-sap
|
|
sb-vm::thread-pseudo-atomic-bits-slot))))
|
|
(let ((c (make-thread (lambda () (loop (alloc-stuff))))))
|
|
;; NB this only works on x86: other ports don't have a symbol for
|
|
;; pseudo-atomic atomicity
|
|
(dotimes (i 100)
|
|
(sleep (random 0.1d0))
|
|
(process-all-interrupts c)
|
|
(interrupt-thread c
|
|
(lambda ()
|
|
(princ ".")
|
|
(force-output)
|
|
(assert (thread-alive-p *current-thread*))
|
|
(assert
|
|
(not (logbitp 0 pseudoatomic-bits))))))
|
|
(process-all-interrupts c)
|
|
(terminate-thread c)
|
|
(wait-for-threads (list c)))))
|