-
Notifications
You must be signed in to change notification settings - Fork 313
/
target-thread.lisp
2804 lines (2580 loc) · 131 KB
/
target-thread.lisp
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
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
;;;; support for threads in the target machine
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB-THREAD")
;;; symbols to protect from tree-shaker, for some tests
(export '(%thread-local-references
current-thread-sap
get-spinlock
release-spinlock
spinlock
with-deathlok
with-session-lock
with-spinlock))
#+(or linux win32 freebsd darwin openbsd)
(defmacro my-kernel-thread-id ()
`(sb-ext:truly-the
(unsigned-byte 32)
(sap-int (sb-vm::current-thread-offset-sap sb-vm::thread-os-kernel-tid-slot))))
;;; CAS Lock
;;;
;;; Locks don't come any simpler -- or more lightweight than this. While
;;; this is probably a premature optimization for most users, we still
;;; need it internally for implementing condition variables outside Futex
;;; builds.
(defmacro with-cas-lock ((place) &body body)
"Runs BODY with interrupts disabled and *CURRENT-THREAD* compare-and-swapped
into PLACE instead of NIL. PLACE must be a place acceptable to
COMPARE-AND-SWAP, and must initially hold NIL.
WITH-CAS-LOCK is suitable mostly when the critical section needing protection
is very small, and cost of allocating a separate lock object would be
prohibitive. While it is the most lightweight locking constructed offered by
SBCL, it is also the least scalable if the section is heavily contested or
long.
WITH-CAS-LOCK can be entered recursively."
`(without-interrupts
(%with-cas-lock (,place) ,@body)))
(defmacro %with-cas-lock ((place) &body body &environment env)
(with-unique-names (owner self)
(multiple-value-bind (vars vals old new cas-form read-form)
(sb-ext:get-cas-expansion place env)
`(let* (,@(mapcar #'list vars vals)
(,owner (progn
(barrier (:read))
,read-form))
(,self *current-thread*)
(,old nil)
(,new ,self))
(unwind-protect
(progn
(unless (eq ,owner ,self)
(loop until (loop repeat 100
when (and (progn
(barrier (:read))
(not ,read-form))
(not (setf ,owner ,cas-form)))
return t
else
do (sb-ext:spin-loop-hint))
do (thread-yield)))
,@body)
(unless (eq ,owner ,self)
(let ((,old ,self)
(,new nil))
(unless (eq ,old ,cas-form)
(bug "Failed to release CAS lock!")))))))))
(defmacro grab-cas-lock (place &environment env)
(with-unique-names (owner self)
(multiple-value-bind (vars vals old new cas-form read-form)
(sb-ext:get-cas-expansion place env)
`(let* (,@(mapcar #'list vars vals)
(,owner (progn
(barrier (:read))
,read-form))
(,self *current-thread*)
(,old nil)
(,new ,self))
(unless (eq ,owner ,self)
(loop until (loop repeat 100
when (and (progn
(barrier (:read))
(not ,read-form))
(not (setf ,owner ,cas-form)))
return t
else
do (sb-ext:spin-loop-hint))
do (thread-yield)))))))
(defmacro release-cas-lock (place &environment env)
(with-unique-names (self)
(multiple-value-bind (vars vals old new cas-form read-form)
(sb-ext:get-cas-expansion place env)
(declare (ignore read-form))
`(let* (,@(mapcar #'list vars vals)
(,self *current-thread*))
(let ((,old ,self)
(,new nil))
(unless (eq ,old ,cas-form)
(bug "Failed to release CAS lock!")))))))
;;; Conditions
(define-condition thread-error (error)
((thread :reader thread-error-thread :initarg :thread))
(:documentation
"Conditions of type THREAD-ERROR are signalled when thread operations fail.
The offending thread is initialized by the :THREAD initialization argument and
read by the function THREAD-ERROR-THREAD."))
(define-condition simple-thread-error (thread-error simple-condition)
())
(define-condition thread-deadlock (thread-error)
((cycle :initarg :cycle :reader thread-deadlock-cycle))
(:report
(lambda (condition stream)
(let* ((*print-circle* t)
(cycle (thread-deadlock-cycle condition))
(start (caar cycle)))
(format stream "Deadlock cycle detected:~%")
(loop for part = (pop cycle)
while part
do (format stream " ~S~% waited for:~% ~S~% owned by:~%"
(car part)
(cdr part)))
(format stream " ~S~%" start)))))
(setf (documentation 'thread-error-thread 'function)
"Return the offending thread that the THREAD-ERROR pertains to.")
(define-condition symbol-value-in-thread-error (cell-error thread-error)
((info :reader symbol-value-in-thread-error-info :initarg :info))
(:report
(lambda (condition stream)
(destructuring-bind (op problem)
(symbol-value-in-thread-error-info condition)
(format stream "Cannot ~(~A~) value of ~S in ~S: ~S"
op
(cell-error-name condition)
(thread-error-thread condition)
(ecase problem
(:unbound-in-thread "the symbol is unbound in thread.")
(:no-tls-value "the symbol has no thread-local value.")
(:thread-dead "the thread has exited.")
(:invalid-tls-value "the thread-local value is not valid."))))))
(:documentation
"Signalled when SYMBOL-VALUE-IN-THREAD or its SETF version fails due to eg.
the symbol not having a thread-local value, or the target thread having
exited. The offending symbol can be accessed using CELL-ERROR-NAME, and the
offending thread using THREAD-ERROR-THREAD."))
(define-condition join-thread-error (thread-error)
((problem :initarg :problem :reader join-thread-problem))
(:report (lambda (c s)
(ecase (join-thread-problem c)
(:abort
(format s "Joining thread failed: thread ~A ~
did not return normally."
(thread-error-thread c)))
(:timeout
(format s "Joining thread timed out: thread ~A ~
did not exit in time."
(thread-error-thread c)))
(:foreign
(format s "Joining thread failed: thread ~A ~
is not a lisp thread."
(thread-error-thread c)))
(:self-join
(format s "In thread ~A, attempt to join the current ~
thread."
(thread-error-thread c))))))
(:documentation
"Signalled when joining a thread fails due to abnormal exit of the thread
to be joined. The offending thread can be accessed using
THREAD-ERROR-THREAD."))
(setf (documentation 'join-thread-problem 'function)
"Return the reason that a JOIN-THREAD-ERROR was signaled. Possible values are
:TIMEOUT, :ABORT, :FOREIGN, and :SELF-JOIN.")
(define-deprecated-function :late "1.0.29.17" join-thread-error-thread thread-error-thread
(condition)
(thread-error-thread condition))
(define-condition interrupt-thread-error (thread-error) ()
(:report (lambda (c s)
(format s "Interrupt thread failed: thread ~A has exited."
(thread-error-thread c))))
(:documentation
"Signalled when interrupting a thread fails because the thread has already
exited. The offending thread can be accessed using THREAD-ERROR-THREAD."))
(define-deprecated-function :late "1.0.29.17" interrupt-thread-error-thread thread-error-thread
(condition)
(thread-error-thread condition))
(defmacro try-set-os-thread-name (str)
#-sb-thread (declare (ignore str))
;; If NIL or non-base-string, just leave the OS thread name alone
#+sb-thread
`(with-alien ((sb-set-os-thread-name (function void system-area-pointer) :extern))
(when (simple-base-string-p ,str)
(with-pinned-objects (,str)
(alien-funcall sb-set-os-thread-name (vector-sap ,str))))))
(declaim (inline thread-name))
(defun thread-name (thread)
"Name of the thread. Can be assigned to using SETF. A thread name must be
a simple-string (not necessarily unique) or NIL."
(thread-%name thread))
(defun (setf thread-name) (name thread)
(setq name (possibly-base-stringize name))
(setf (thread-%name thread) name) ; will fail if non-simple
;; Not all native thread APIs can set the name of a random thread, so only try to do it
;; if changing your own name.
(when (eq thread *current-thread*) (try-set-os-thread-name name))
name)
(defmethod print-object ((thread thread) stream)
(print-unreadable-object (thread stream :type t :identity t)
(let* ((values (cond ((thread-alive-p thread) :running)
;; don't call JOIN-THREAD, just read the result if ALIVE-P is NIL
((listp (thread-result thread)) (thread-result thread))
(t :aborted)))
(state (cond ((eq values :running)
(let* ((thing (progn
(barrier (:read))
(thread-waiting-for thread))))
(typecase thing
(null '(:running))
(cons
;; It's a DX cons, can't look at it.
(list "waiting on a mutex with a timeout"))
(t
(list "waiting on:" thing)))))
((eq values :aborted) '(:aborted))
(t :finished)))
(*print-array* nil)
;; Don't want to see 10,000 strings or something
(*print-length* 2)
(*print-level* 4))
(format stream
;; if not finished, show the STATE as a list.
;; if finished, show the VALUES.
"~@[tid=~D ~]~@[~S ~]~:[~{~I~A~^~2I~_ ~}~_~;~A~:[ no values~; values: ~:*~{~S~^, ~}~]~]"
(or #+(or linux win32 freebsd darwin openbsd)
(thread-os-tid thread))
(thread-name thread)
(eq :finished state)
state
values))))
(defmethod print-object ((mutex mutex) stream)
(let ((name (mutex-name mutex)))
(print-unreadable-object (mutex stream :type t :identity (not name))
#+sb-futex
(format stream "~@[~S ~]~[free~;taken~;contested~:;err~] owner=~X"
name (mutex-state mutex) (vmthread-name (mutex-%owner mutex)))
#-sb-futex
(let ((owner (mutex-owner mutex))
(*print-circle* t))
(if owner
(format stream "~@[~S ~]~2I~_owner: ~S" name owner)
(format stream "~@[~S ~](free)" name))))))
;; NB: ephemeral threads must terminate strictly before the test of NTHREADS>1
;; in DEINIT, i.e. this is not a promise that the thread will terminate
;; just-in-time for the final call out to save, but rather by an earlier time.
(defun thread-ephemeral-p (thread)
"Return T if THREAD is `ephemeral', which indicates that this thread is
used by SBCL for internal purposes, and specifically that our runtime knows how
to terminate this thread cleanly prior to core file saving without signalling
an error in that case."
(thread-%ephemeral-p thread))
;;; Ensure that THREAD is in *ALL-THREADS*.
(defmacro update-all-threads (key thread)
`(let ((addr ,key))
(barrier (:read))
(let ((old *all-threads*))
(loop
;; If ADDR exists, then we have a bug in the thread exit handler.
;; The workaround here would be to delete the old thread first,
;; but I'd rather find out about the bug than bury it.
(aver (not (avl-find addr old)))
(let ((new (avl-insert old addr ,thread)))
(when (eq old (setq old (sb-ext:cas *all-threads* old new))) (return)))))))
(defun vmthread-name (vmthread)
(binding* ((node (avl-find (vmthread-id->addr vmthread) *all-threads*) :exit-if-null)
(thread (avlnode-data node) :exit-if-null)
(name (thread-name thread) :exit-if-null))
(return-from vmthread-name name))
vmthread) ; lacking a string, the identifier constitutes its name
;;; Translate a 'struct thread*' to a SB-THREAD:THREAD.
;;; I'd like to do this simply by reading the 'lisp_thread' field,
;;; but that's dangerous. Ultimately I think we will have to either store a
;;; refcount in the structure (freeing it only when its last referer is gone)
;;; or implement hazard pointers. Either one is going to be tricky because we can't
;;; store the refcount in the structure if it can go away while we're trying
;;; to increment the count. But having the ability to manipulate the structure
;;; of any thread from any thread would simplify other things in this file
;;; as well as making MUTEX-OWNER more efficient.
(defun mutex-owner-lookup (vmthread)
;; Convert the "fixnum-encoded" thread ID to a word.
;; It's possible that a race could cause find to fail. If the mutex
;; really has a dead thread as its owner, you've got bigger problems.
;; Moreover, because 'struct thread' can be recycled (very quickly)
;; it's possible for the following sequence to occur: thread T1 at address A1
;; grabs the mutex, then thread T2 reads MUTEX-%OWNER slot, then T1 exits
;; and T3 gets allocated at address A1, and grabs the mutex.
;; Thread T2 then performs AVL-FIND and concludes that T3 is the apparent owner.
;; Well, as the docstring at MUTEX-OWNER says, it is "racy by design".
(acond ((avl-find (vmthread-id->addr vmthread) *all-threads*) (avlnode-data it))
((= vmthread 0) nil)
;; This is the same keyword that SYMBOL-VALUE-IN-THREAD can return on error.
;; If people don't like seeing it, we could return instead
;; (LOAD-TIME-VALUE (%make-thread "dead-thread" nil nil))
;; indicating that you observed a value of %OWNER which no longer exists.
(t :thread-dead)))
(defun %list-all-threads ()
;; No lock needed, just an atomic read, since tree mutations can't happen.
;; Of course by the time we're done collecting nodes, the tree can have
;; been replaced by a different tree.
(barrier (:read))
(avltree-filter (lambda (node)
(let ((thread (avlnode-data node)))
(when (= (thread-%visible thread) 1)
thread)))
*all-threads*))
(defun list-all-threads ()
"Return a list of the live threads. Note that the return value is
potentially stale even before the function returns, as new threads may be
created and old ones may exit at any time."
(delete sb-impl::*finalizer-thread* (%list-all-threads)))
;;; used by debug-int.lisp to access interrupt contexts
(sb-ext:define-load-time-global *initial-thread* nil)
;;; *JOINABLE-THREADS* is a list of THREAD instances.
;;; I had attempted to construct the list using the thread's memory to create cons
;;; cells but that turned out to be flawed- the cells must be freshly heap-allocated,
;;; because ATOMIC-POP is vulnerable to the A/B/A problem if cells are reused.
;;; Example: initial state: *JOINABLE-THREADS* -> node1 -> node2 -> node3.
;;; After reading *JOINABLE-THREADS* we want to CAS it to node2.
;;; If, after reading the variable, all of node1, node2, and node3 are popped
;;; by another thread, and then node1 is reused, and made to point to node4,
;;; then the new state is: *JOINABLE-THREADS* -> node1 -> node4
;;; which looks like CAS(*joinable-threads*, node1, node2) should succeed,
;;; but it should not. The LL/SC model would detect that, but CAS can not.
;;;
;;; A thread is pushed into *JOINABLE-THREADS* while still using its lisp stack.
;;; This is fine, because the C code will perform a join, which will effectively
;;; wait until the lisp thread is off its stack. It won't have to wait long,
;;; because pushing into *JOINABLE-THREADS* is the last thing to happen in lisp.
;;; In theory we could support some mode of keeping the memory while joining
;;; the pthread, but we currently do not.
(sb-ext:define-load-time-global *joinable-threads* nil)
(declaim (list *joinable-threads*)) ; list of threads
;;; Copy some slots from the C 'struct thread' into the SB-THREAD:THREAD.
(defmacro copy-primitive-thread-fields (this)
`(progn
(setf (thread-primitive-thread ,this) (current-thread-sap-int))
#-win32
(setf (thread-os-thread ,this)
(sap-int (sb-vm::current-thread-offset-sap sb-vm::thread-os-thread-slot)))))
(defmacro set-thread-control-stack-slots (this)
`(setf (thread-control-stack-start ,this) (get-lisp-obj-address sb-vm:*control-stack-start*)
(thread-control-stack-end ,this) (get-lisp-obj-address sb-vm:*control-stack-end*)))
(defvar *session*)
;;; Not uncoincidentally, the variables assigned here are also
;;; listed in SB-KERNEL::*SAVE-LISP-CLOBBERED-GLOBALS*
(defun init-main-thread ()
(/show0 "Entering INIT-MAIN-THREAD")
(setf sb-impl::*exit-lock* (make-mutex :name "Exit Lock")
sb-vm::*allocator-mutex* (make-mutex :name "Allocator")
*make-thread-lock* (make-mutex :name "Make-Thread Lock"))
(let* ((name "main thread")
(thread (%make-thread name nil (make-semaphore :name name))))
(copy-primitive-thread-fields thread)
(set-thread-control-stack-slots thread)
;; Run the macro-generated function which writes some values into the TLS,
;; most especially *CURRENT-THREAD*.
(init-thread-local-storage thread)
(setf *initial-thread* thread)
(setf *joinable-threads* nil)
(setq *session* (new-session thread))
(setq *all-threads*
(avl-insert nil
(sb-thread::thread-primitive-thread sb-thread:*current-thread*)
thread))))
(defun main-thread ()
"Returns the main thread of the process."
*initial-thread*)
(defun main-thread-p (&optional (thread *current-thread*))
"True if THREAD, defaulting to current thread, is the main thread of the process."
(eq thread *initial-thread*))
(locally (declare (sb-c::tlab :system)) (defun sys-tlab-list (&rest args) args))
(defmacro return-from-thread (values-form &key allow-exit)
"Unwinds from and terminates the current thread, with values from
VALUES-FORM as the results visible to JOIN-THREAD.
If current thread is the main thread of the process (see
MAIN-THREAD-P), signals an error unless ALLOW-EXIT is true, as
terminating the main thread would terminate the entire process. If
ALLOW-EXIT is true, returning from the main thread is equivalent to
calling SB-EXT:EXIT with :CODE 0 and :ABORT NIL.
See also: ABORT-THREAD and SB-EXT:EXIT."
`(%return-from-thread (multiple-value-call #'sys-tlab-list ,values-form) ,allow-exit))
(defun %return-from-thread (values allow-exit)
(let ((self *current-thread*))
(cond ((main-thread-p self)
(unless allow-exit
(error 'simple-thread-error
:format-control "~@<Tried to return ~S as values from main thread, ~
but exit was not allowed.~:@>"
:format-arguments (list values)
:thread self))
(sb-ext:exit :code 0))
(t
(throw '%return-from-thread (values-list values))))))
(defun abort-thread (&key allow-exit)
"Unwinds from and terminates the current thread abnormally, causing
JOIN-THREAD on current thread to signal an error unless a
default-value is provided.
If current thread is the main thread of the process (see
MAIN-THREAD-P), signals an error unless ALLOW-EXIT is true, as
terminating the main thread would terminate the entire process. If
ALLOW-EXIT is true, aborting the main thread is equivalent to calling
SB-EXT:EXIT code 1 and :ABORT NIL.
Invoking the initial ABORT restart established by MAKE-THREAD is
equivalent to calling ABORT-THREAD in other than main threads.
However, whereas ABORT restart may be rebound, ABORT-THREAD always
unwinds the entire thread. (Behaviour of the initial ABORT restart for
main thread depends on the :TOPLEVEL argument to
SB-EXT:SAVE-LISP-AND-DIE.)
See also: RETURN-FROM-THREAD and SB-EXT:EXIT."
(let ((self *current-thread*))
(cond ((main-thread-p self)
(unless allow-exit
(error 'simple-thread-error
:format-control "~@<Tried to abort initial thread, but ~
exit was not allowed.~:@>"))
(sb-ext:exit :code 1))
(t
;; We /could/ use TOPLEVEL-CATCHER or %END-OF-THE-WORLD as well, but
;; this seems tidier. Those to are a bit too overloaded already.
(throw '%abort-thread t)))))
;;;; Aliens, low level stuff
;;; *STARTING-THREADS* receives special treatment by the garbage collector.
;;; The contents of it are pinned (in that respect it is like *PINNED-OBJECTS*)
;;; but also the STARTUP-INFO of each thread is pinned.
(sb-ext:define-load-time-global *starting-threads* nil)
(declaim (list *starting-threads*)) ; list of threads
#+sb-thread
(progn
#+sb-futex
(progn
(locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note))
(define-structure-slot-addressor mutex-state-address
;; """ (Futexes are 32 bits in size on all platforms, including 64-bit systems.) """
;; which means we need to add 4 bytes to get to the low 32 bits of the slot contents
;; where we store state. This would be prettier if we had 32-bit raw slots.
:structure mutex
:slot state
:byte-offset (+ #+(and 64-bit big-endian) 4))
(define-structure-slot-addressor waitqueue-token-address
:structure waitqueue
:slot token
:byte-offset (+ #+(and 64-bit big-endian) 4)))
(export 'futex-wake) ; for naughty users only
(declaim (inline futex-wait futex-wake))
(define-alien-routine "futex_wake" int (word-addr unsigned) (n unsigned-long))
(defun futex-wait (word-addr oldval to-sec to-usec)
(with-alien ((%wait (function int unsigned
(unsigned 32)
long unsigned-long)
:extern "futex_wait"))
(with-interrupts
(alien-funcall %wait word-addr oldval to-sec to-usec))))))
(defmacro with-deadlocks ((thread lock &optional (timeout nil timeoutp)) &body forms)
(with-unique-names (n-thread n-lock new n-timeout)
`(let* ((,n-thread ,thread)
(,n-lock ,lock)
(,n-timeout ,(when timeoutp
`(or ,timeout sb-impl::*deadline*)))
(,new (if ,n-timeout
;; Using CONS tells the rest of the system there's a
;; timeout in place, so it isn't considered a deadlock.
(cons ,n-timeout ,n-lock)
,n-lock)))
(declare (dynamic-extent ,new))
;; No WITHOUT-INTERRUPTS, since WITH-DEADLOCKS is used
;; in places where interrupts should already be disabled.
(unwind-protect
(progn
(setf (thread-waiting-for ,n-thread) ,new)
(barrier (:memory))
,@forms)
;; Interrupt handlers and GC save and restore any
;; previous wait marks using WITHOUT-THREAD-WAITING-FOR
(setf (thread-waiting-for ,n-thread) nil)
(barrier (:memory))))))
;;;; Mutexes
(setf (documentation 'make-mutex 'function) "Create a mutex."
(documentation 'mutex-name 'function) "The name of the mutex. Setfable.")
(sb-ext:define-load-time-global **deadlock-lock** nil)
;;; Signals an error if owner of LOCK is waiting on a lock whose release
;;; depends on the current thread. Does not detect deadlocks from sempahores.
;;; Limited to 10 threads because it may not terminate if the threads
;;; keep locking different locks in the meantime.
#+sb-thread
(defun check-deadlock ()
(let* ((self *current-thread*)
(origin (thread-waiting-for self))
unlock-deadlock-lock)
(labels ((detect-deadlock (lock limit)
(declare (fixnum limit))
(barrier (:read))
(let ((other-vmthread-id (mutex-%owner lock)))
(cond ((= limit 0) nil)
((= other-vmthread-id 0) nil)
((= (current-vmthread-id) other-vmthread-id)
;; We're now committed to signaling the
;; error and breaking the deadlock, so
;; mark us as no longer waiting on the
;; lock. This ensures that a single
;; deadlock is reported in only one
;; thread, and that we don't look like
;; we're waiting on the lock when print
;; stuff -- because that may lead to
;; further deadlock checking, in turn
;; possibly leading to a bogus vicious
;; metacycle on PRINT-OBJECT.
(grab-cas-lock **deadlock-lock**)
(setf unlock-deadlock-lock t)
(list (cons self origin)))
(t
(let* ((other-thread (mutex-owner-lookup other-vmthread-id))
(other-lock (when (thread-p other-thread)
(barrier (:read))
(thread-waiting-for other-thread))))
;; If the thread is waiting with a timeout OTHER-LOCK
;; is a cons, and we don't consider it a deadlock -- since
;; it will time out on its own sooner or later.
(when (mutex-p other-lock)
(let ((chain (detect-deadlock other-lock (1- limit))))
(when (and (consp chain)
;; Recheck that the mutex is still owned by the same thread.
(progn (barrier (:read))
(let ((owner (mutex-%owner lock)))
(= owner other-vmthread-id)))
;; See if it hasn't been set to NIL above by another thread.
(eq (progn (barrier (:read))
(thread-waiting-for other-thread))
other-lock))
(cons (cons other-thread other-lock)
chain))))))))))
;; Timeout means there is no deadlock
(when (mutex-p origin)
(let ((chain (detect-deadlock origin 10)))
(when (consp chain)
(setf (thread-waiting-for self) nil)
(sb-thread:barrier (:memory))
(release-cas-lock **deadlock-lock**)
(with-interrupts
(error 'thread-deadlock
:thread *current-thread*
:cycle (let ((last (last chain)))
(append last (butlast chain))))))
(when unlock-deadlock-lock
(release-cas-lock **deadlock-lock**)))
t))))
;;;; WAIT-FOR -- waiting on arbitrary conditions
(defun %%wait-for (test stop-sec stop-usec)
(declare (function test))
(declare (dynamic-extent test))
(labels ((try ()
(declare (optimize (safety 0)))
(awhen (funcall test)
(return-from %%wait-for it)))
(tick (sec usec)
(declare (type fixnum sec usec))
;; TICK is microseconds
(+ usec (* 1000000 sec)))
(get-tick ()
(multiple-value-call #'tick
(decode-internal-time (get-internal-real-time)))))
(let* ((timeout-tick (when stop-sec (tick stop-sec stop-usec)))
(start (get-tick))
;; Rough estimate of how long a single attempt takes.
(try-ticks (progn
(try) (try) (try)
(max 1 (truncate (- (get-tick) start) 3)))))
;; Scale sleeping between attempts:
;;
;; Start by sleeping for as many ticks as an average attempt
;; takes, then doubling for each attempt.
;;
;; Max out at 0.1 seconds, or the 2 x time of a single try,
;; whichever is longer -- with a hard cap of 10 seconds.
;;
;; FIXME: Maybe the API should have a :MAX-SLEEP argument?
(loop with max-ticks = (max 100000 (min (* 2 try-ticks)
(expt 10 7)))
for scale of-type fixnum = 1
then (let ((x (logand most-positive-fixnum (* 2 scale))))
(if (> scale x)
most-positive-fixnum
x))
do (try)
(let* ((now (get-tick))
(sleep-ticks (min (* try-ticks scale) max-ticks))
(sleep
(if timeout-tick
;; If sleep would take us past the
;; timeout, shorten it so it's just
;; right.
(if (>= (+ now sleep-ticks) timeout-tick)
(- timeout-tick now)
sleep-ticks)
sleep-ticks)))
(declare (type fixnum sleep))
(cond ((plusp sleep)
;; microseconds to seconds and nanoseconds
(multiple-value-bind (sec nsec)
(truncate (* 1000 sleep) (expt 10 9))
(with-interrupts
(sb-unix:nanosleep sec nsec))))
(t
(return-from %%wait-for nil))))))))
(defun %wait-for (test timeout)
(declare (function test))
(declare (dynamic-extent test))
(tagbody
:restart
(multiple-value-bind (to-sec to-usec stop-sec stop-usec deadlinep)
(decode-timeout timeout)
(declare (ignore to-sec to-usec))
(return-from %wait-for
(or (%%wait-for test stop-sec stop-usec)
(when deadlinep
(signal-deadline)
(go :restart)))))))
(defmacro sb-ext:wait-for (test-form &key timeout)
"Wait until TEST-FORM evaluates to true, then return its primary value.
If TIMEOUT is provided, waits at most approximately TIMEOUT seconds before
returning NIL.
If WITH-DEADLINE has been used to provide a global deadline, signals a
DEADLINE-TIMEOUT if TEST-FORM doesn't evaluate to true before the
deadline.
Experimental: subject to change without prior notice."
`(dx-flet ((wait-for-test () (progn ,test-form)))
(%wait-for #'wait-for-test ,timeout)))
(defmacro with-progressive-timeout ((name &key seconds)
&body body)
"Binds NAME as a local function for BODY. Each time #'NAME is called, it
returns SECONDS minus the time that has elapsed since BODY was entered, or
zero if more time than SECONDS has elapsed. If SECONDS is NIL, #'NAME
returns NIL each time."
(with-unique-names (deadline time-left sec)
`(let* ((,sec ,seconds)
(,deadline
(when ,sec
(+ (get-internal-real-time)
(round (* ,seconds internal-time-units-per-second))))))
(flet ((,name ()
(when ,deadline
(let ((,time-left (- ,deadline (get-internal-real-time))))
(if (plusp ,time-left)
(* (coerce ,time-left 'single-float)
(sb-xc:/ 1.0f0 internal-time-units-per-second))
0)))))
,@body))))
(defun %try-mutex (mutex)
(declare (type mutex mutex) (optimize (speed 3)))
(cond #+sb-futex
(t
;; From the Mutex 2 algorithm from "Futexes are Tricky" by Ulrich Drepper.
(let ((id (current-vmthread-id)))
(cond ((= (sb-ext:cas (mutex-state mutex) 0 1) 0)
(setf (mutex-%owner mutex) id)
t) ; GRAB-MUTEX wants %TRY-MUTEX to return boolean, not generalized boolean
((= (mutex-%owner mutex) id)
(error "Recursive lock attempt ~S." mutex)))))
#-sb-futex
(t
(barrier (:read))
(let ((old (mutex-%owner mutex)))
(when (= (current-vmthread-id) old)
(error "Recursive lock attempt ~S." mutex))
#-sb-thread
(when (/= old 0)
(error "Strange deadlock on ~S in an unithreaded build?" mutex))
(and (zerop old)
;; Don't even bother to try to CAS if it looks bad.
(zerop (sb-ext:compare-and-swap (mutex-%owner mutex) 0
(current-vmthread-id))))))))
;;; memory aid: this is "pthread_mutex_timedlock" without the pthread
;;; and no messing about with *DEADLINE* or deadlocks. It's just locking.
#+sb-thread
(defun %mutex-timedlock (mutex to-sec to-usec stop-sec stop-usec)
(declare (type mutex mutex) (optimize (speed 3)))
(declare (sb-ext:muffle-conditions sb-ext:compiler-note))
(declare (ignorable to-sec to-usec))
(cond
#+sb-futex
(t
;; This is a fairly direct translation of the Mutex 2 algorithm from
;; "Futexes are Tricky" by Ulrich Drepper.
;;
;; void lock () {
;; int c;
;; if ((c = cmpxchg(val, 0, 1)) != 0)
;; do {
;; if (c == 2 || cmpxchg(val, 1, 2) != 0)
;; futex_wait(&val, 2);
;; } while ((c = cmpxchg(val, 0, 2)) != 0);
;; }
;;
(symbol-macrolet ((val (mutex-state mutex)))
(let ((c (sb-ext:cas val 0 1))) ; available -> taken
(unless (= c 0) ; Got it right off the bat?
(nlx-protect
(if (not stop-sec)
(loop ; untimed
;; Mark it as contested, and sleep, unless it is now in state 0.
(when (or (eql c 2) (/= 0 (sb-ext:cas val 1 2)))
(with-pinned-objects (mutex)
(futex-wait (mutex-state-address mutex) 2 -1 0)))
;; Try to get it, still marking it as contested.
(when (= 0 (setq c (sb-ext:cas val 0 2))) (return))) ; win
(loop ; same as above but check for timeout
(when (or (eql c 2) (/= 0 (sb-ext:cas val 1 2)))
(if (eql 1 (with-pinned-objects (mutex)
(futex-wait (mutex-state-address mutex) 2 to-sec to-usec)))
;; -1 = EWOULDBLOCK, possibly spurious wakeup
;; 0 = normal wakeup
;; 1 = ETIMEDOUT ***DONE***
;; 2 = EINTR, a spurious wakeup
(return-from %mutex-timedlock nil)))
(when (= 0 (setq c (sb-ext:cas val 0 2))) (return)) ; win
;; Update timeout
(setf (values to-sec to-usec)
(sb-impl::relative-decoded-times stop-sec stop-usec))))
;; Unwinding because futex-wait allows interrupts, wake up another futex
(with-pinned-objects (mutex)
(futex-wake (mutex-state-address mutex) 1)))))
(setf (mutex-%owner mutex) (current-vmthread-id))
t))
#-sb-futex
(t
(flet ((cas ()
(loop repeat 100
when (and (progn (barrier (:read))
(zerop (mutex-%owner mutex)))
(zerop (sb-ext:compare-and-swap (mutex-%owner mutex) 0
(current-vmthread-id))))
do (return-from cas t)
else
do
(sb-ext:spin-loop-hint))
;; Check for pending interrupts.
(with-interrupts nil)))
(declare (dynamic-extent #'cas))
(%%wait-for #'cas stop-sec stop-usec)))))
#+ultrafutex
(progn
(declaim (inline fast-futex-wait))
(defun fast-futex-wait (word-addr oldval to-sec to-usec)
(with-alien ((%wait (function int unsigned
#+freebsd unsigned #-freebsd (unsigned 32)
long unsigned-long)
:extern "futex_wait"))
(alien-funcall %wait word-addr oldval to-sec to-usec)))
(declaim (sb-ext:maybe-inline %wait-for-mutex-algorithm-3))
(defun %wait-for-mutex-algorithm-3 (mutex)
#+nil ; in case I want to count calls to this function
(let ((sap (int-sap (thread-primitive-thread *current-thread*)))
(disp (ash sb-vm::thread-slow-path-allocs-slot sb-vm:word-shift)))
(incf (sap-ref-word sap disp)))
;; #+ultrafutex does not support deadlines for now. It might eventually,
;; but would have to fall back to the older code if there is a deadline.
(aver (null sb-impl::*deadline*))
(symbol-macrolet ((val (mutex-state mutex)))
(let* ((mutex (sb-ext:truly-the mutex mutex))
(c (sb-ext:cas val 0 1))) ; available -> taken
(unless (= c 0) ; Got it right off the bat?
(unless (= c 2)
(setq c (%raw-instance-xchg/word mutex (get-dsd-index mutex state) 2)))
(loop while (/= c 0)
do (with-pinned-objects (mutex)
(fast-futex-wait (mutex-state-address mutex) 2 -1 0))
(setq c (%raw-instance-xchg/word mutex (get-dsd-index mutex state) 2))))))))
#+mutex-benchmarks
(symbol-macrolet ((val (mutex-state mutex)))
(export '(wait-for-mutex-algorithm-2
wait-for-mutex-algorithm-3
wait-for-mutex-2-partial-inline
wait-for-mutex-3-partial-inline))
(declaim (sb-ext:maybe-inline %wait-for-mutex-algorithm-2
%wait-for-mutex-algorithm-3))
(sb-ext:define-load-time-global *grab-mutex-calls-performed* 0)
(defun %wait-for-mutex-algorithm-2 (mutex)
(incf *grab-mutex-calls-performed*)
(let* ((mutex (sb-ext:truly-the mutex mutex))
(c (sb-ext:cas val 0 1))) ; available -> taken
(unless (= c 0) ; Got it right off the bat?
(loop
;; Mark it as contested, and sleep, unless it is now in state 0.
(when (or (eql c 2) (/= 0 (sb-ext:cas val 1 2)))
(with-pinned-objects (mutex)
(fast-futex-wait (mutex-state-address mutex) 2 -1 0)))
;; Try to get it, still marking it as contested.
(when (= 0 (setq c (sb-ext:cas val 0 2))) (return)))))) ; win
(defun wait-for-mutex-algorithm-2 (mutex)
(declare (inline %wait-for-mutex-algorithm-2))
(let ((mutex (sb-ext:truly-the mutex mutex)))
(%wait-for-mutex-algorithm-2 mutex)
(setf (mutex-%owner mutex) (current-vmthread-id))))
;; The improvement with algorithm 3 is fairly negligible.
;; Code size is a little less. More improvement comes from doing the
;; partial-inline algorithms which perform one CAS without a function call.
(defun wait-for-mutex-algorithm-3 (mutex)
(declare (inline %wait-for-mutex-algorithm-3))
(let ((mutex (sb-ext:truly-the mutex mutex)))
(%wait-for-mutex-algorithm-3 mutex)
(setf (mutex-%owner mutex) (current-vmthread-id))))
(defmacro wait-for-mutex-2-partial-inline (mutex)
`(let ((m ,mutex))
(or (= (sb-ext:cas (mutex-state m) 0 1) 0) (%wait-for-mutex-algorithm-2 m))
(setf (mutex-%owner m) (current-vmthread-id))))
(defmacro wait-for-mutex-3-partial-inline (mutex)
`(let ((m ,mutex))
(or (= (sb-ext:cas (mutex-state m) 0 1) 0) (%wait-for-mutex-algorithm-3 m))
(setf (mutex-%owner m) (current-vmthread-id))))
;; This is like RELEASE-MUTEX but without keyword arg parsing
;; and all the different error modes.
(export 'fast-release-mutex)
(defun fast-release-mutex (mutex)
(let ((mutex (sb-ext:truly-the mutex mutex)))
(setf (mutex-%owner mutex) 0)
(unless (eql (sb-ext:atomic-decf (mutex-state mutex) 1) 1)
(setf (mutex-state mutex) 0)
(with-pinned-objects (mutex)
(futex-wake (mutex-state-address mutex) 1))))))
#+sb-thread
(macrolet ((guts ()
`(tagbody
:again
(return-from %wait-for-mutex
(or (%mutex-timedlock mutex to-sec to-usec stop-sec stop-usec)
(when deadlinep
(signal-deadline)
;; FIXME: substract elapsed time from timeout...
(setf (values to-sec to-usec stop-sec stop-usec deadlinep)
(decode-timeout timeout))
(go :again)))))))
(defun deadlock-aware-mutex-wait
(mutex timeout to-sec to-usec stop-sec stop-usec deadlinep &aux (self *current-thread*))
(block %wait-for-mutex
(with-deadlocks (self mutex timeout)
(with-interrupts (check-deadlock))
(guts))))
(defun mutex-wait (mutex timeout to-sec to-usec stop-sec stop-usec deadlinep)
(block %wait-for-mutex (guts))))
(define-deprecated-function :early "1.0.37.33" get-mutex (grab-mutex)
(mutex &optional new-owner (waitp t) (timeout nil))
(declare (ignorable waitp timeout))
(when (and new-owner (neq new-owner *current-thread*))
(error "GET-MUTEX won't get a mutex on behalf of a different thread"))
(or (%try-mutex mutex)
#+sb-thread
(when waitp
(multiple-value-call #'deadlock-aware-mutex-wait mutex timeout (decode-timeout timeout)))))
(declaim (ftype (sfunction (mutex &key (:waitp t) (:timeout (or null (real 0)))) boolean) grab-mutex))
(defun grab-mutex (mutex &key (waitp t) (timeout nil))
"Acquire MUTEX for the current thread. If WAITP is true (the default) and
the mutex is not immediately available, sleep until it is available.
If TIMEOUT is given, it specifies a relative timeout, in seconds, on how long
GRAB-MUTEX should try to acquire the lock in the contested case.
If GRAB-MUTEX returns T, the lock acquisition was successful. In case of WAITP
being NIL, or an expired TIMEOUT, GRAB-MUTEX may also return NIL which denotes
that GRAB-MUTEX did -not- acquire the lock.
Notes:
- GRAB-MUTEX is not interrupt safe. The correct way to call it is:
(WITHOUT-INTERRUPTS
...
(ALLOW-WITH-INTERRUPTS (GRAB-MUTEX ...))
...)
WITHOUT-INTERRUPTS is necessary to avoid an interrupt unwinding the call
while the mutex is in an inconsistent state while ALLOW-WITH-INTERRUPTS
allows the call to be interrupted from sleep.
- (GRAB-MUTEX <mutex> :timeout 0.0) differs from
(GRAB-MUTEX <mutex> :waitp nil) in that the former may signal a
DEADLINE-TIMEOUT if the global deadline was due already on entering
GRAB-MUTEX.
The exact interplay of GRAB-MUTEX and deadlines are reserved to change in
future versions.
- It is recommended that you use WITH-MUTEX instead of calling GRAB-MUTEX
directly.
"
(declare (ignorable waitp timeout))
(or (%try-mutex mutex)
#+sb-thread
(when waitp
(multiple-value-call #'deadlock-aware-mutex-wait mutex timeout (decode-timeout timeout)))))
(declaim (ftype (sfunction (mutex) boolean) grab-mutex-no-check-deadlock))
#+sb-thread ; WITH-MUTEX will never expand to call this if #-sb-thread
(defun grab-mutex-no-check-deadlock (mutex)
;; Always wait with infinite timeout, never examine the waiting-for graph.
;; This _does_ support *DEADLINE* hence the DECODE-TIMEOUT call.
(or (%try-mutex mutex)
(multiple-value-call #'mutex-wait mutex nil (decode-timeout nil))))
(declaim (ftype (sfunction (mutex &key (:if-not-owner (member :punt :warn :error :force))) null)
release-mutex))
(defun release-mutex (mutex &key (if-not-owner :punt))
"Release MUTEX by setting it to NIL. Wake up threads waiting for
this mutex.
RELEASE-MUTEX is not interrupt safe: interrupts should be disabled
around calls to it.
If the current thread is not the owner of the mutex then it silently
returns without doing anything (if IF-NOT-OWNER is :PUNT), signals a
WARNING (if IF-NOT-OWNER is :WARN), or releases the mutex anyway (if
IF-NOT-OWNER is :FORCE)."
(declare (type mutex mutex))
;; Order matters: set owner to NIL before releasing state.