[991c14]: src / code / target-thread.lisp Maximize Restore History

Download this file

target-thread.lisp    1821 lines (1633 with data), 76.6 kB

   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
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
;;;; 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")
;;; 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)
#!+sb-doc
"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!")))))))))
;;; Conditions
(define-condition thread-error (error)
((thread :reader thread-error-thread :initarg :thread))
#!+sb-doc
(: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)))))
#!+sb-doc
(setf
(fdocumentation '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."))))))
#!+sb-doc
(: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))))))
#!+sb-doc
(: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."))
(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))))
#!+sb-doc
(: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))
;;; Of the WITH-PINNED-OBJECTS in this file, not every single one is
;;; necessary because threads are only supported with the conservative
;;; gencgc and numbers on the stack (returned by GET-LISP-OBJ-ADDRESS)
;;; are treated as references.
;;; set the doc here because in early-thread FDOCUMENTATION is not
;;; available, yet
#!+sb-doc
(setf (fdocumentation '*current-thread* 'variable)
"Bound in each thread to the thread itself.")
#!+sb-doc
(setf
(fdocumentation 'thread-name 'function)
"Name of the thread. Can be assigned to using SETF. Thread names can be
arbitrary printable objects, and need not be unique.")
(def!method print-object ((thread thread) stream)
(print-unreadable-object (thread stream :type t :identity t)
(let* ((cookie (list thread))
(info (if (thread-alive-p thread)
:running
(multiple-value-list
(join-thread thread :default cookie))))
(state (if (eq :running info)
(let* ((thing (progn
(barrier (:read))
(thread-waiting-for thread))))
(typecase thing
(cons
(list "waiting on:" (cdr thing)
"timeout: " (car thing)))
(null
(list info))
(t
(list "waiting on:" thing))))
(if (eq cookie (car info))
(list :aborted)
:finished)))
(values (when (eq :finished state)
info))
(*print-level* 4))
(format stream
"~@[~S ~]~:[~{~I~A~^~2I~_ ~}~_~;~A~:[ no values~; values: ~:*~{~S~^, ~}~]~]"
(thread-name thread)
(eq :finished state)
state
values))))
(defun print-lock (lock name owner stream)
(let ((*print-circle* t))
(print-unreadable-object (lock stream :type t :identity (not name))
(if owner
(format stream "~@[~S ~]~2I~_owner: ~S" name owner)
(format stream "~@[~S ~](free)" name)))))
(def!method print-object ((mutex mutex) stream)
(print-lock mutex (mutex-name mutex) (mutex-owner mutex) stream))
(defun thread-alive-p (thread)
#!+sb-doc
"Return T if THREAD is still alive. Note that the return value is
potentially stale even before the function returns, as the thread may exit at
any time."
(thread-%alive-p thread))
(defun thread-emphemeral-p (thread)
#!+sb-doc
"Return T if THREAD is `ephemeral', which indicates that this thread is
used by SBCL for internal purposes, and specifically that it knows how to
to terminate this thread cleanly prior to core file saving without signalling
an error in that case."
(thread-%ephemeral-p thread))
;; A thread is eligible for gc iff it has finished and there are no
;; more references to it. This list is supposed to keep a reference to
;; all running threads.
(defvar *all-threads* ())
(defvar *all-threads-lock* (make-mutex :name "all threads lock"))
(defvar *default-alloc-signal* nil)
(defmacro with-all-threads-lock (&body body)
`(with-system-mutex (*all-threads-lock*)
,@body))
(defun list-all-threads ()
#!+sb-doc
"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."
(with-all-threads-lock
(copy-list *all-threads*)))
(declaim (inline current-thread-sap))
(defun current-thread-sap ()
(sb!vm::current-thread-offset-sap sb!vm::thread-this-slot))
(declaim (inline current-thread-os-thread))
(defun current-thread-os-thread ()
#!+sb-thread
(sap-int (sb!vm::current-thread-offset-sap sb!vm::thread-os-thread-slot))
#!-sb-thread
0)
(defvar *initial-thread* nil)
(defvar *make-thread-lock*)
(defun init-initial-thread ()
(/show0 "Entering INIT-INITIAL-THREAD")
(setf sb!impl::*exit-lock* (make-mutex :name "Exit Lock")
*make-thread-lock* (make-mutex :name "Make-Thread Lock"))
(let ((initial-thread (%make-thread :name "main thread"
:%alive-p t
:os-thread (current-thread-os-thread))))
(setq *initial-thread* initial-thread
*current-thread* initial-thread)
(grab-mutex (thread-result-lock *initial-thread*))
;; Either *all-threads* is empty or it contains exactly one thread
;; in case we are in reinit since saving core with multiple
;; threads doesn't work.
(setq *all-threads* (list initial-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*))
(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-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 estabilished 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
(define-alien-routine "kill_safely"
integer
(os-thread #!-alpha unsigned-long #!+alpha unsigned-int)
(signal int))
(define-alien-routine "wake_thread"
integer
(os-thread #!-alpha unsigned-long #!+alpha unsigned-int))
#!+sb-thread
(progn
;; FIXME it would be good to define what a thread id is or isn't
;; (our current assumption is that it's a fixnum). It so happens
;; that on Linux it's a pid, but it might not be on posix thread
;; implementations.
(define-alien-routine ("create_thread" %create-thread)
unsigned-long (lisp-fun-address unsigned-long))
(declaim (inline %block-deferrable-signals))
(define-alien-routine ("block_deferrable_signals" %block-deferrable-signals)
void
(where sb!alien:unsigned-long)
(old sb!alien:unsigned-long))
(defun block-deferrable-signals ()
(%block-deferrable-signals 0 0))
#!+sb-futex
(progn
(declaim (inline futex-wait %futex-wait futex-wake))
(define-alien-routine ("futex_wait" %futex-wait)
int (word unsigned-long) (old-value unsigned-long)
(to-sec long) (to-usec unsigned-long))
(defun futex-wait (word old to-sec to-usec)
(with-interrupts
(%futex-wait word old to-sec to-usec)))
(define-alien-routine "futex_wake"
int (word unsigned-long) (n unsigned-long))))
;;; used by debug-int.lisp to access interrupt contexts
#!-(or sb-fluid sb-thread) (declaim (inline sb!vm::current-thread-offset-sap))
#!-sb-thread
(defun sb!vm::current-thread-offset-sap (n)
(declare (type (unsigned-byte 27) n))
(sap-ref-sap (alien-sap (extern-alien "all_threads" (* t)))
(* n sb!vm:n-word-bytes)))
#!+sb-thread
(defun sb!vm::current-thread-offset-sap (n)
(declare (type (unsigned-byte 27) n))
(sb!vm::current-thread-offset-sap n))
(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
(when sb!impl::*deadline*
sb!impl::*deadline-seconds*))))
(,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 (:write))
,@forms)
;; Interrupt handlers and GC save and restore any
;; previous wait marks using WITHOUT-DEADLOCKS below.
(setf (thread-waiting-for ,n-thread) nil)
(barrier (:write))))))
;;;; Mutexes
#!+sb-doc
(setf (fdocumentation 'make-mutex 'function)
"Create a mutex."
(fdocumentation 'mutex-name 'function)
"The name of the mutex. Setfable.")
#!+(and sb-thread sb-futex)
(progn
(define-structure-slot-addressor mutex-state-address
:structure mutex
:slot state)
;; Important: current code assumes these are fixnums or other
;; lisp objects that don't need pinning.
(defconstant +lock-free+ 0)
(defconstant +lock-taken+ 1)
(defconstant +lock-contested+ 2))
(defun mutex-owner (mutex)
"Current owner of the mutex, NIL if the mutex is free. Naturally,
this is racy by design (another thread may acquire the mutex after
this function returns), it is intended for informative purposes. For
testing whether the current thread is holding a mutex see
HOLDING-MUTEX-P."
;; Make sure to get the current value.
(sb!ext:compare-and-swap (mutex-%owner mutex) nil nil))
(sb!ext:defglobal **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.
(defun check-deadlock ()
(let* ((self *current-thread*)
(origin (progn
(barrier (:read))
(thread-waiting-for self))))
(labels ((detect-deadlock (lock)
(let ((other-thread (mutex-%owner lock)))
(cond ((not other-thread))
((eq self other-thread)
(let ((chain
(with-cas-lock ((symbol-value '**deadlock-lock**))
(prog1 (deadlock-chain self origin)
;; 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.
(setf (thread-waiting-for self) nil)))))
(error 'thread-deadlock
:thread *current-thread*
:cycle chain)))
(t
(let ((other-lock (progn
(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)
(detect-deadlock other-lock)))))))
(deadlock-chain (thread lock)
(let* ((other-thread (mutex-owner lock))
(other-lock (when other-thread
(barrier (:read))
(thread-waiting-for other-thread))))
(cond ((not other-thread)
;; The deadlock is gone -- maybe someone unwound
;; from the same deadlock already?
(return-from check-deadlock nil))
((consp other-lock)
;; There's a timeout -- no deadlock.
(return-from check-deadlock nil))
((waitqueue-p other-lock)
;; Not a lock.
(return-from check-deadlock nil))
((eq self other-thread)
;; Done
(list (list thread lock)))
(t
(if other-lock
(cons (cons thread lock)
(deadlock-chain other-thread other-lock))
;; Again, the deadlock is gone?
(return-from check-deadlock nil)))))))
;; Timeout means there is no deadlock
(when (mutex-p origin)
(detect-deadlock origin)
t))))
(defun %try-mutex (mutex new-owner)
(declare (type mutex mutex) (optimize (speed 3)))
(barrier (:read))
(let ((old (mutex-%owner mutex)))
(when (eq new-owner old)
(error "Recursive lock attempt ~S." mutex))
#!-sb-thread
(when old
(error "Strange deadlock on ~S in an unithreaded build?" mutex))
#!-(and sb-thread sb-futex)
(and (not old)
;; Don't even bother to try to CAS if it looks bad.
(not (sb!ext:compare-and-swap (mutex-%owner mutex) nil new-owner)))
#!+(and sb-thread sb-futex)
;; From the Mutex 2 algorithm from "Futexes are Tricky" by Ulrich Drepper.
(when (eql +lock-free+ (sb!ext:compare-and-swap (mutex-state mutex)
+lock-free+
+lock-taken+))
(let ((prev (sb!ext:compare-and-swap (mutex-%owner mutex) nil new-owner)))
(when prev
(bug "Old owner in free mutex: ~S" prev))
t))))
#!+sb-thread
(defun %%wait-for-mutex (mutex new-owner to-sec to-usec stop-sec stop-usec)
(declare (type mutex mutex) (optimize (speed 3)))
#!-sb-futex
(declare (ignore to-sec to-usec))
#!-sb-futex
(flet ((cas ()
(loop repeat 100
when (and (progn
(barrier (:read))
(not (mutex-%owner mutex)))
(not (sb!ext:compare-and-swap (mutex-%owner mutex) nil
new-owner)))
do (return-from cas t)
else
do
(sb!ext:spin-loop-hint))
;; Check for pending interrupts.
(with-interrupts nil)))
(declare (dynamic-extent #'cas))
(sb!impl::%%wait-for #'cas stop-sec stop-usec))
#!+sb-futex
;; This is a fairly direct translation of the Mutex 2 algorithm from
;; "Futexes are Tricky" by Ulrich Drepper.
(flet ((maybe (old)
(when (eql +lock-free+ old)
(let ((prev (sb!ext:compare-and-swap (mutex-%owner mutex)
nil new-owner)))
(when prev
(bug "Old owner in free mutex: ~S" prev))
(return-from %%wait-for-mutex t)))))
(prog ((old (sb!ext:compare-and-swap (mutex-state mutex)
+lock-free+ +lock-taken+)))
;; Got it right off the bat?
(maybe old)
:retry
;; Mark it as contested, and sleep. (Exception: it was just released.)
(when (or (eql +lock-contested+ old)
(not (eql +lock-free+
(sb!ext:compare-and-swap
(mutex-state mutex) +lock-taken+ +lock-contested+))))
(when (eql 1 (with-pinned-objects (mutex)
(futex-wait (mutex-state-address mutex)
(get-lisp-obj-address +lock-contested+)
(or to-sec -1)
(or to-usec 0))))
;; -1 = EWOULDBLOCK, possibly spurious wakeup
;; 0 = normal wakeup
;; 1 = ETIMEDOUT ***DONE***
;; 2 = EINTR, a spurious wakeup
(return-from %%wait-for-mutex nil)))
;; Try to get it, still marking it as contested.
(maybe
(sb!ext:compare-and-swap (mutex-state mutex) +lock-free+ +lock-contested+))
;; Update timeout if necessary.
(when stop-sec
(setf (values to-sec to-usec)
(sb!impl::relative-decoded-times stop-sec stop-usec)))
;; Spin.
(go :retry))))
#!+sb-thread
(defun %wait-for-mutex (mutex self timeout to-sec to-usec stop-sec stop-usec deadlinep)
(with-deadlocks (self mutex timeout)
(with-interrupts (check-deadlock))
(tagbody
:again
(return-from %wait-for-mutex
(or (%%wait-for-mutex mutex self 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)))))))
(define-deprecated-function :early "1.0.37.33" get-mutex (grab-mutex)
(mutex &optional new-owner (waitp t) (timeout nil))
(declare (ignorable waitp timeout))
(let ((new-owner (or new-owner *current-thread*)))
(or (%try-mutex mutex new-owner)
#!+sb-thread
(when waitp
(multiple-value-call #'%wait-for-mutex
mutex new-owner timeout (decode-timeout timeout))))))
(defun grab-mutex (mutex &key (waitp t) (timeout nil))
#!+sb-doc
"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))
(let ((self *current-thread*))
(or (%try-mutex mutex self)
#!+sb-thread
(when waitp
(multiple-value-call #'%wait-for-mutex
mutex self timeout (decode-timeout timeout))))))
(defun release-mutex (mutex &key (if-not-owner :punt))
#!+sb-doc
"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.
(let* ((self *current-thread*)
(old-owner (sb!ext:compare-and-swap (mutex-%owner mutex) self nil)))
(unless (eq self old-owner)
(ecase if-not-owner
((:punt) (return-from release-mutex nil))
((:warn)
(warn "Releasing ~S, owned by another thread: ~S" mutex old-owner))
((:force)))
(setf (mutex-%owner mutex) nil)
;; FIXME: Is a :memory barrier too strong here? Can we use a :write
;; barrier instead?
(barrier (:memory)))
#!+(and sb-thread sb-futex)
(when old-owner
;; FIXME: once ATOMIC-INCF supports struct slots with word sized
;; unsigned-byte type this can be used:
;;
;; (let ((old (sb!ext:atomic-incf (mutex-state mutex) -1)))
;; (unless (eql old +lock-free+)
;; (setf (mutex-state mutex) +lock-free+)
;; (with-pinned-objects (mutex)
;; (futex-wake (mutex-state-address mutex) 1))))
(let ((old (sb!ext:compare-and-swap (mutex-state mutex)
+lock-taken+ +lock-free+)))
(when (eql old +lock-contested+)
(sb!ext:compare-and-swap (mutex-state mutex)
+lock-contested+ +lock-free+)
(with-pinned-objects (mutex)
(futex-wake (mutex-state-address mutex) 1))))
nil)))
;;;; Waitqueues/condition variables
#!+(or (not sb-thread) sb-futex)
(defstruct (waitqueue (:constructor %make-waitqueue))
#!+sb-doc
"Waitqueue type."
(name nil :type (or null thread-name))
#!+(and sb-thread sb-futex)
(token nil))
#!+(and sb-thread (not sb-futex))
(progn
(defstruct (waitqueue (:constructor %make-waitqueue))
#!+sb-doc
"Waitqueue type."
(name nil :type (or null thread-name))
;; For WITH-CAS-LOCK: because CONDITION-WAIT must be able to call
;; %WAITQUEUE-WAKEUP without re-aquiring the mutex, we need a separate
;; lock. In most cases this should be uncontested thanks to the mutex --
;; the only case where that might not be true is when CONDITION-WAIT
;; unwinds and %WAITQUEUE-DROP is called.
%owner
%head
%tail)
(defun %waitqueue-enqueue (thread queue)
(setf (thread-waiting-for thread) queue)
(let ((head (waitqueue-%head queue))
(tail (waitqueue-%tail queue))
(new (list thread)))
(unless head
(setf (waitqueue-%head queue) new))
(when tail
(setf (cdr tail) new))
(setf (waitqueue-%tail queue) new)
nil))
(defun %waitqueue-drop (thread queue)
(setf (thread-waiting-for thread) nil)
(let ((head (waitqueue-%head queue)))
(do ((list head (cdr list))
(prev nil list))
((or (null list)
(eq (car list) thread))
(when list
(let ((rest (cdr list)))
(cond (prev
(setf (cdr prev) rest))
(t
(setf (waitqueue-%head queue) rest
prev rest)))
(unless rest
(setf (waitqueue-%tail queue) prev)))))))
nil)
(defun %waitqueue-wakeup (queue n)
(declare (fixnum n))
(loop while (plusp n)
for next = (let ((head (waitqueue-%head queue))
(tail (waitqueue-%tail queue)))
(when head
(if (eq head tail)
(setf (waitqueue-%head queue) nil
(waitqueue-%tail queue) nil)
(setf (waitqueue-%head queue) (cdr head)))
(car head)))
while next
do (when (eq queue (sb!ext:compare-and-swap
(thread-waiting-for next) queue nil))
(decf n)))
nil))
(def!method print-object ((waitqueue waitqueue) stream)
(print-unreadable-object (waitqueue stream :type t :identity t)
(format stream "~@[~A~]" (waitqueue-name waitqueue))))
(defun make-waitqueue (&key name)
#!+sb-doc
"Create a waitqueue."
(%make-waitqueue :name name))
#!+sb-doc
(setf (fdocumentation 'waitqueue-name 'function)
"The name of the waitqueue. Setfable.")
#!+(and sb-thread sb-futex)
(define-structure-slot-addressor waitqueue-token-address
:structure waitqueue
:slot token)
(defun condition-wait (queue mutex &key timeout)
#!+sb-doc
"Atomically release MUTEX and start waiting on QUEUE for till another thread
wakes us up using either CONDITION-NOTIFY or CONDITION-BROADCAST on that
queue, at which point we re-acquire MUTEX and return T.
Spurious wakeups are possible.
If TIMEOUT is given, it is the maximum number of seconds to wait, including
both waiting for the wakeup and the time to re-acquire MUTEX. Unless both
wakeup and re-acquisition do not occur within the given time, returns NIL
without re-acquiring the mutex.
If CONDITION-WAIT unwinds, it may do so with or without the mutex being held.
Important: Since CONDITION-WAIT may return without CONDITION-NOTIFY having
occurred the correct way to write code that uses CONDITION-WAIT is to loop
around the call, checking the the associated data:
(defvar *data* nil)
(defvar *queue* (make-waitqueue))
(defvar *lock* (make-mutex))
;; Consumer
(defun pop-data (&optional timeout)
(with-mutex (*lock*)
(loop until *data*
do (or (condition-wait *queue* *lock* :timeout timeout)
;; Lock not held, must unwind without touching *data*.
(return-from pop-data nil)))
(pop *data*)))
;; Producer
(defun push-data (data)
(with-mutex (*lock*)
(push data *data*)
(condition-notify *queue*)))
"
#!-sb-thread
(declare (ignore queue))
(assert mutex)
#!-sb-thread
(sb!ext:wait-for nil :timeout timeout) ; Yeah...
#!+sb-thread
(let ((me *current-thread*))
(barrier (:read))
(assert (eq me (mutex-%owner mutex)))
(multiple-value-bind (to-sec to-usec stop-sec stop-usec deadlinep)
(decode-timeout timeout)
(let ((status :interrupted))
;; Need to disable interrupts so that we don't miss grabbing the
;; mutex on our way out.
(without-interrupts
(unwind-protect
(progn
#!-sb-futex
(progn
(%with-cas-lock ((waitqueue-%owner queue))
(%waitqueue-enqueue me queue))
(release-mutex mutex)
(setf status
(or (flet ((wakeup ()
(barrier (:read))
(unless (eq queue (thread-waiting-for me))
:ok)))
(declare (dynamic-extent #'wakeup))
(allow-with-interrupts
(sb!impl::%%wait-for #'wakeup stop-sec stop-usec)))
:timeout)))
#!+sb-futex
(with-pinned-objects (queue me)
(setf (waitqueue-token queue) me)
(release-mutex mutex)
;; Now we go to sleep using futex-wait. If anyone else
;; manages to grab MUTEX and call CONDITION-NOTIFY during
;; this comment, it will change the token, and so futex-wait
;; returns immediately instead of sleeping. Ergo, no lost
;; wakeup. We may get spurious wakeups, but that's ok.
(setf status
(case (allow-with-interrupts
(futex-wait (waitqueue-token-address queue)
(get-lisp-obj-address me)
;; our way of saying "no
;; timeout":
(or to-sec -1)
(or to-usec 0)))
((1)
;; 1 = ETIMEDOUT
:timeout)
(t
;; -1 = EWOULDBLOCK, possibly spurious wakeup
;; 0 = normal wakeup
;; 2 = EINTR, a spurious wakeup
:ok)))))
#!-sb-futex
(%with-cas-lock ((waitqueue-%owner queue))
(if (eq queue (thread-waiting-for me))
(%waitqueue-drop me queue)
(unless (eq :ok status)
;; CONDITION-NOTIFY thinks we've been woken up, but really
;; we're unwinding. Wake someone else up.
(%waitqueue-wakeup queue 1))))
;; Update timeout for mutex re-aquisition.
(when (and (eq :ok status) to-sec)
(setf (values to-sec to-usec)
(sb!impl::relative-decoded-times stop-sec stop-usec)))
;; If we ran into deadline, try to get the mutex before
;; signaling. If we don't unwind it will look like a normal
;; return from user perspective.
(when (and (eq :timeout status) deadlinep)
(let ((got-it (%try-mutex mutex me)))
(allow-with-interrupts
(signal-deadline)
(cond (got-it
(return-from condition-wait t))
(t
;; The deadline may have changed.
(setf (values to-sec to-usec stop-sec stop-usec deadlinep)
(decode-timeout timeout))
(setf status :ok))))))
;; Re-acquire the mutex for normal return.
(when (eq :ok status)
(unless (or (%try-mutex mutex me)
(allow-with-interrupts
(%wait-for-mutex mutex me timeout
to-sec to-usec
stop-sec stop-usec deadlinep)))
(setf status :timeout)))))
(or (eq :ok status)
(unless (eq :timeout status)
;; The only case we return normally without re-acquiring the
;; mutex is when there is a :TIMEOUT that runs out.
(bug "CONDITION-WAIT: invalid status on normal return: ~S" status)))))))
(defun condition-notify (queue &optional (n 1))
#!+sb-doc
"Notify N threads waiting on QUEUE.
IMPORTANT: The same mutex that is used in the corresponding CONDITION-WAIT
must be held by this thread during this call."
#!-sb-thread
(declare (ignore queue n))
#!-sb-thread
(error "Not supported in unithread builds.")
#!+sb-thread
(declare (type (and fixnum (integer 1)) n))
(/show0 "Entering CONDITION-NOTIFY")
#!+sb-thread
(progn
#!-sb-futex
(with-cas-lock ((waitqueue-%owner queue))
(%waitqueue-wakeup queue n))
#!+sb-futex
(progn
;; No problem if >1 thread notifies during the comment in condition-wait:
;; as long as the value in queue-data isn't the waiting thread's id, it
;; matters not what it is -- using the queue object itself is handy.
;;
;; XXX we should do something to ensure that the result of this setf
;; is visible to all CPUs.
;;
;; ^-- surely futex_wake() involves a memory barrier?
(setf (waitqueue-token queue) queue)
(with-pinned-objects (queue)
(futex-wake (waitqueue-token-address queue) n)))))
(defun condition-broadcast (queue)
#!+sb-doc
"Notify all threads waiting on QUEUE.
IMPORTANT: The same mutex that is used in the corresponding CONDITION-WAIT
must be held by this thread during this call."
(condition-notify queue
;; On a 64-bit platform truncating M-P-F to an int
;; results in -1, which wakes up only one thread.
(ldb (byte 29 0)
most-positive-fixnum)))
;;;; Semaphores
(defstruct (semaphore (:constructor %make-semaphore (name %count)))
#!+sb-doc
"Semaphore type. The fact that a SEMAPHORE is a STRUCTURE-OBJECT
should be considered an implementation detail, and may change in the
future."
(name nil :type (or null thread-name))
(%count 0 :type (integer 0))
(waitcount 0 :type sb!vm:word)
(mutex (make-mutex))
(queue (make-waitqueue)))
(setf (fdocumentation 'semaphore-name 'function)
"The name of the semaphore INSTANCE. Setfable.")
(defstruct (semaphore-notification (:constructor make-semaphore-notification ())
(:copier nil))
#!+sb-doc
"Semaphore notification object. Can be passed to WAIT-ON-SEMAPHORE and
TRY-SEMAPHORE as the :NOTIFICATION argument. Consequences are undefined if
multiple threads are using the same notification object in parallel."
(%status nil :type boolean))
(setf (fdocumentation 'make-semaphore-notification 'function)
"Constructor for SEMAPHORE-NOTIFICATION objects. SEMAPHORE-NOTIFICATION-STATUS
is initially NIL.")
(declaim (inline semaphore-notification-status))
(defun semaphore-notification-status (semaphore-notification)
#!+sb-doc
"Returns T if a WAIT-ON-SEMAPHORE or TRY-SEMAPHORE using
SEMAPHORE-NOTICATION has succeeded since the notification object was created
or cleared."
(barrier (:read))
(semaphore-notification-%status semaphore-notification))
(declaim (inline clear-semaphore-notification))
(defun clear-semaphore-notification (semaphore-notification)
#!+sb-doc
"Resets the SEMAPHORE-NOTIFICATION object for use with another call to
WAIT-ON-SEMAPHORE or TRY-SEMAPHORE."
(barrier (:write)
(setf (semaphore-notification-%status semaphore-notification) nil)))
(declaim (inline semaphore-count))
(defun semaphore-count (instance)
#!+sb-doc
"Returns the current count of the semaphore INSTANCE."
(barrier (:read))
(semaphore-%count instance))
(defun make-semaphore (&key name (count 0))
#!+sb-doc
"Create a semaphore with the supplied COUNT and NAME."
(%make-semaphore name count))
(defun wait-on-semaphore (semaphore &key timeout notification)
#!+sb-doc
"Decrement the count of SEMAPHORE if the count would not be negative. Else
blocks until the semaphore can be decremented. Returns T on success.
If TIMEOUT is given, it is the maximum number of seconds to wait. If the count
cannot be decremented in that time, returns NIL without decrementing the
count.
If NOTIFICATION is given, it must be a SEMAPHORE-NOTIFICATION object whose
SEMAPHORE-NOTIFICATION-STATUS is NIL. If WAIT-ON-SEMAPHORE succeeds and
decrements the count, the status is set to T."
(when (and notification (semaphore-notification-status notification))
(with-simple-restart (continue "Clear notification status and continue.")
(error "~@<Semaphore notification object status not cleared on entry to ~S on ~S.~:@>"
'wait-on-semaphore semaphore))
(clear-semaphore-notification notification))
;; A more direct implementation based directly on futexes should be
;; possible.
;;
;; We need to disable interrupts so that we don't forget to
;; decrement the waitcount (which would happen if an asynch
;; interrupt should catch us on our way out from the loop.)
;;
;; FIXME: No timeout on initial mutex acquisition.
(with-system-mutex ((semaphore-mutex semaphore) :allow-with-interrupts t)
;; Quick check: is it positive? If not, enter the wait loop.
(let ((count (semaphore-%count semaphore)))
(cond ((plusp count)
(setf (semaphore-%count semaphore) (1- count))
(when notification
(setf (semaphore-notification-%status notification) t)))
(t
(unwind-protect
(progn
;; Need to use ATOMIC-INCF despite the lock, because on our
;; way out from here we might not be locked anymore -- so
;; another thread might be tweaking this in parallel using
;; ATOMIC-DECF. No danger over overflow, since there it
;; at most one increment per thread waiting on the semaphore.
(sb!ext:atomic-incf (semaphore-waitcount semaphore))
(loop until (plusp (setf count (semaphore-%count semaphore)))
do (or (condition-wait (semaphore-queue semaphore)
(semaphore-mutex semaphore)
:timeout timeout)
(return-from wait-on-semaphore nil)))
(setf (semaphore-%count semaphore) (1- count))
(when notification
(setf (semaphore-notification-%status notification) t)))
;; Need to use ATOMIC-DECF as we may unwind without the lock
;; being held!
(sb!ext:atomic-decf (semaphore-waitcount semaphore)))))))
t)
(defun try-semaphore (semaphore &optional (n 1) notification)
#!+sb-doc
"Try to decrement the count of SEMAPHORE by N. If the count were to
become negative, punt and return NIL, otherwise return true.
If NOTIFICATION is given it must be a semaphore notification object
with SEMAPHORE-NOTIFICATION-STATUS of NIL. If the count is decremented,
the status is set to T."
(declare (type (integer 1) n))
(when (and notification (semaphore-notification-status notification))
(with-simple-restart (continue "Clear notification status and continue.")
(error "~@<Semaphore notification object status not cleared on entry to ~S on ~S.~:@>"
'try-semaphore semaphore))
(clear-semaphore-notification notification))
(with-system-mutex ((semaphore-mutex semaphore) :allow-with-interrupts t)
(let ((new-count (- (semaphore-%count semaphore) n)))
(when (not (minusp new-count))
(setf (semaphore-%count semaphore) new-count)
(when notification
(setf (semaphore-notification-%status notification) t))
;; FIXME: We don't actually document this -- should we just
;; return T, or document new count as the return?
new-count))))
(defun signal-semaphore (semaphore &optional (n 1))
#!+sb-doc
"Increment the count of SEMAPHORE by N. If there are threads waiting
on this semaphore, then N of them is woken up."
(declare (type (integer 1) n))
;; Need to disable interrupts so that we don't lose a wakeup after
;; we have incremented the count.
(with-system-mutex ((semaphore-mutex semaphore) :allow-with-interrupts t)
(let ((waitcount (semaphore-waitcount semaphore))
(count (incf (semaphore-%count semaphore) n)))
(when (plusp waitcount)
(condition-notify (semaphore-queue semaphore) (min waitcount count))))))
;;;; Job control, independent listeners
(defstruct session
(lock (make-mutex :name "session lock"))
(threads nil)
(interactive-threads nil)
(interactive-threads-queue (make-waitqueue)))
(defvar *session* nil)
;;; The debugger itself tries to acquire the session lock, don't let
;;; funny situations (like getting a sigint while holding the session
;;; lock) occur. At the same time we need to allow interrupts while
;;; *waiting* for the session lock for things like GET-FOREGROUND to
;;; be interruptible.
;;;
;;; Take care: we sometimes need to obtain the session lock while
;;; holding on to *ALL-THREADS-LOCK*, so we must _never_ obtain it
;;; _after_ getting a session lock! (Deadlock risk.)
;;;
;;; FIXME: It would be good to have ordered locks to ensure invariants
;;; like the above.
(defmacro with-session-lock ((session) &body body)
`(with-system-mutex ((session-lock ,session) :allow-with-interrupts t)
,@body))
(defun new-session ()
(make-session :threads (list *current-thread*)
:interactive-threads (list *current-thread*)))
(defun init-job-control ()
(/show0 "Entering INIT-JOB-CONTROL")
(setf *session* (new-session))
(/show0 "Exiting INIT-JOB-CONTROL"))
(defun %delete-thread-from-session (thread session)
(with-session-lock (session)
(setf (session-threads session)
(delete thread (session-threads session))
(session-interactive-threads session)
(delete thread (session-interactive-threads session)))))
(defun call-with-new-session (fn)
(%delete-thread-from-session *current-thread* *session*)
(let ((*session* (new-session)))
(funcall fn)))
(defmacro with-new-session (args &body forms)
(declare (ignore args)) ;for extensibility
(sb!int:with-unique-names (fb-name)
`(labels ((,fb-name () ,@forms))
(call-with-new-session (function ,fb-name)))))
;;; Remove thread from its session, if it has one.
#!+sb-thread
(defun handle-thread-exit (thread)
(/show0 "HANDLING THREAD EXIT")
(when *exit-in-process*
(%exit))
;; Lisp-side cleanup
(with-all-threads-lock
(setf (thread-%alive-p thread) nil)
(setf (thread-os-thread thread) nil)
(setq *all-threads* (delete thread *all-threads*))
(when *session*
(%delete-thread-from-session thread *session*))))
(defun %exit-other-threads ()
;; Grabbing this lock prevents new threads from
;; being spawned, and guarantees that *ALL-THREADS*
;; is up to date.
(with-deadline (:seconds nil :override t)
(grab-mutex *make-thread-lock*)
(let ((timeout sb!ext:*exit-timeout*)
(code *exit-in-process*)
(current *current-thread*)
(joinees nil)
(main nil))
(dolist (thread (list-all-threads))
(cond ((eq thread current))
((main-thread-p thread)
(setf main thread))
(t
(handler-case
(progn
(terminate-thread thread)
(push thread joinees))
(interrupt-thread-error ())))))
(with-progressive-timeout (time-left :seconds timeout)
(dolist (thread joinees)
(join-thread thread :default t :timeout (time-left)))
;; Need to defer till others have joined, because when main
;; thread exits, we're gone. Can't use TERMINATE-THREAD -- would
;; get the exit code wrong.
(when main
(handler-case
(interrupt-thread
main
(lambda ()
(setf *exit-in-process* (list code))
(throw 'sb!impl::%end-of-the-world t)))
(interrupt-thread-error ()))
;; Normally this never finishes, as once the main-thread unwinds we
;; exit with the right code, but if times out before that happens,
;; we will exit after returning -- or rathe racing the main thread
;; to calling OS-EXIT.
(join-thread main :default t :timeout (time-left)))))))
(defun terminate-session ()
#!+sb-doc
"Kill all threads in session except for this one. Does nothing if current
thread is not the foreground thread."
;; FIXME: threads created in other threads may escape termination
(let ((to-kill
(with-session-lock (*session*)
(and (eq *current-thread*
(car (session-interactive-threads *session*)))
(session-threads *session*)))))
;; do the kill after dropping the mutex; unwind forms in dying
;; threads may want to do session things
(dolist (thread to-kill)
(unless (eq thread *current-thread*)
;; terminate the thread but don't be surprised if it has
;; exited in the meantime
(handler-case (terminate-thread thread)
(interrupt-thread-error ()))))))
;;; called from top of invoke-debugger
(defun debugger-wait-until-foreground-thread (stream)
"Returns T if thread had been running in background, NIL if it was
interactive."
(declare (ignore stream))
#!-sb-thread nil
#!+sb-thread
(prog1
(with-session-lock (*session*)
(not (member *current-thread*
(session-interactive-threads *session*))))
(get-foreground)))
(defun get-foreground ()
#!-sb-thread t
#!+sb-thread
(let ((was-foreground t))
(loop
(/show0 "Looping in GET-FOREGROUND")
(with-session-lock (*session*)
(let ((int-t (session-interactive-threads *session*)))
(when (eq (car int-t) *current-thread*)
(unless was-foreground
(format *query-io* "Resuming thread ~A~%" *current-thread*))
(return-from get-foreground t))
(setf was-foreground nil)
(unless (member *current-thread* int-t)
(setf (cdr (last int-t))
(list *current-thread*)))
(condition-wait
(session-interactive-threads-queue *session*)
(session-lock *session*)))))))
(defun release-foreground (&optional next)
#!+sb-doc
"Background this thread. If NEXT is supplied, arrange for it to
have the foreground next."
#!-sb-thread (declare (ignore next))
#!-sb-thread nil
#!+sb-thread
(with-session-lock (*session*)
(when (rest (session-interactive-threads *session*))
(setf (session-interactive-threads *session*)
(delete *current-thread* (session-interactive-threads *session*))))
(when next
(setf (session-interactive-threads *session*)
(list* next
(delete next (session-interactive-threads *session*)))))
(condition-broadcast (session-interactive-threads-queue *session*))))
(defun foreground-thread ()
(car (session-interactive-threads *session*)))
(defun make-listener-thread (tty-name)
(assert (probe-file tty-name))
(let* ((in (sb!unix:unix-open (namestring tty-name) sb!unix:o_rdwr #o666))
(out (sb!unix:unix-dup in))
(err (sb!unix:unix-dup in)))
(labels ((thread-repl ()
(sb!unix::unix-setsid)
(let* ((sb!impl::*stdin*
(make-fd-stream in :input t :buffering :line
:dual-channel-p t))
(sb!impl::*stdout*
(make-fd-stream out :output t :buffering :line
:dual-channel-p t))
(sb!impl::*stderr*
(make-fd-stream err :output t :buffering :line
:dual-channel-p t))
(sb!impl::*tty*
(make-fd-stream err :input t :output t
:buffering :line
:dual-channel-p t))
(sb!impl::*descriptor-handlers* nil))
(with-new-session ()
(unwind-protect
(sb!impl::toplevel-repl nil)
(sb!int:flush-standard-output-streams))))))
(make-thread #'thread-repl))))
;;;; The beef
(defun make-thread (function &key name arguments ephemeral)
#!+sb-doc
"Create a new thread of NAME that runs FUNCTION with the argument
list designator provided (defaults to no argument). Thread exits when
the function returns. The return values of FUNCTION are kept around
and can be retrieved by JOIN-THREAD.
Invoking the initial ABORT restart estabilished by MAKE-THREAD
terminates the thread.
See also: RETURN-FROM-THREAD, ABORT-THREAD."
#!-sb-thread (declare (ignore function name arguments ephemeral))
#!-sb-thread (error "Not supported in unithread builds.")
#!+sb-thread (assert (or (atom arguments)
(null (cdr (last arguments))))
(arguments)
"Argument passed to ~S, ~S, is an improper list."
'make-thread arguments)
#!+sb-thread
(let ((thread (%make-thread :name name :%ephemeral-p ephemeral)))
(with-mutex (*make-thread-lock*)
(let* ((setup-sem (make-semaphore :name "Thread setup semaphore"))
(real-function (coerce function 'function))
(arguments (if (listp arguments)
arguments
(list arguments)))
(initial-function
(named-lambda initial-thread-function ()
;; In time we'll move some of the binding presently done in C
;; here too.
;;
;; KLUDGE: Here we have a magic list of variables that are
;; not thread-safe for one reason or another. As people
;; report problems with the thread safety of certain
;; variables, (e.g. "*print-case* in multiple threads
;; broken", sbcl-devel 2006-07-14), we add a few more
;; bindings here. The Right Thing is probably some variant
;; of Allegro's *cl-default-special-bindings*, as that is at
;; least accessible to users to secure their own libraries.
;; --njf, 2006-07-15
;;
;; As it is, this lambda must not cons until we are ready
;; to run GC. Be very careful.
(let* ((*current-thread* thread)
(*restart-clusters* nil)
(*handler-clusters* (sb!kernel::initial-handler-clusters))
(*condition-restarts* nil)
(*exit-in-process* nil)
(sb!impl::*deadline* nil)
(sb!impl::*deadline-seconds* nil)
(sb!impl::*step-out* nil)
;; internal printer variables
(sb!impl::*previous-case* nil)
(sb!impl::*previous-readtable-case* nil)
(sb!impl::*internal-symbol-output-fun* nil)
(sb!impl::*descriptor-handlers* nil)) ; serve-event
;; Binding from C
(setf sb!vm:*alloc-signal* *default-alloc-signal*)
(setf (thread-os-thread thread) (current-thread-os-thread))
(with-mutex ((thread-result-lock thread))
(with-all-threads-lock
(push thread *all-threads*))
(with-session-lock (*session*)
(push thread (session-threads *session*)))
(setf (thread-%alive-p thread) t)
(signal-semaphore setup-sem)
;; Using handling-end-of-the-world would be a bit tricky
;; due to other catches and interrupts, so we essentially
;; re-implement it here. Once and only once more.
(catch 'sb!impl::toplevel-catcher
(catch 'sb!impl::%end-of-the-world
(catch '%abort-thread
(with-simple-restart
(abort "~@<Abort thread (~A)~@:>" *current-thread*)
(without-interrupts
(unwind-protect
(with-local-interrupts
(sb!unix::unblock-deferrable-signals)
(setf (thread-result thread)
(prog1
(cons t
(multiple-value-list
(unwind-protect
(catch '%return-from-thread
(apply real-function arguments))
(when *exit-in-process*
(sb!impl::call-exit-hooks)))))
#!+sb-safepoint
(sb!kernel::gc-safepoint))))
;; We're going down, can't handle interrupts
;; sanely anymore. GC remains enabled.
(block-deferrable-signals)
;; We don't want to run interrupts in a dead
;; thread when we leave WITHOUT-INTERRUPTS.
;; This potentially causes important
;; interupts to be lost: SIGINT comes to
;; mind.
(setq *interrupt-pending* nil)
#!+sb-thruption
(setq *thruption-pending* nil)
(handle-thread-exit thread)))))))))
(values))))
;; If the starting thread is stopped for gc before it signals the
;; semaphore then we'd be stuck.
(assert (not *gc-inhibit*))
;; Keep INITIAL-FUNCTION pinned until the child thread is
;; initialized properly. Wrap the whole thing in
;; WITHOUT-INTERRUPTS because we pass INITIAL-FUNCTION to another
;; thread.
(without-interrupts
(with-pinned-objects (initial-function)
(if (zerop
(%create-thread (get-lisp-obj-address initial-function)))
(setf thread nil)
(wait-on-semaphore setup-sem))))))
(or thread (error "Could not create a new thread."))))
(defun join-thread (thread &key (default nil defaultp) timeout)
#!+sb-doc
"Suspend current thread until THREAD exits. Return the result values
of the thread function.
If the thread does not exit normally within TIMEOUT seconds return
DEFAULT if given, or else signal JOIN-THREAD-ERROR.
Trying to join the main thread will cause JOIN-THREAD to block until
TIMEOUT occurs or the process exits: when main thread exits, the
entire process exits.
NOTE: Return convention in case of a timeout is exprimental and
subject to change."
(let ((lock (thread-result-lock thread))
(got-it nil)
(problem :timeout))
(without-interrupts
(unwind-protect
(if (setf got-it
(allow-with-interrupts
;; Don't use the timeout if the thread is not alive anymore.
(grab-mutex lock :timeout (and (thread-alive-p thread) timeout))))
(cond ((car (thread-result thread))
(return-from join-thread
(values-list (cdr (thread-result thread)))))
(defaultp
(return-from join-thread default))
(t
(setf problem :abort)))
(when defaultp
(return-from join-thread default)))
(when got-it
(release-mutex lock))))
(error 'join-thread-error :thread thread :problem problem)))
(defun destroy-thread (thread)
#!+sb-doc
"Deprecated. Same as TERMINATE-THREAD."
(terminate-thread thread))
(defmacro with-interruptions-lock ((thread) &body body)
`(with-system-mutex ((thread-interruptions-lock ,thread))
,@body))
;;; Called from the signal handler.
#!-(or sb-thruption win32)
(defun run-interruption ()
(let ((interruption (with-interruptions-lock (*current-thread*)
(pop (thread-interruptions *current-thread*)))))
;; If there is more to do, then resignal and let the normal
;; interrupt deferral mechanism take care of the rest. From the
;; OS's point of view the signal we are in the handler for is no
;; longer pending, so the signal will not be lost.
(when (thread-interruptions *current-thread*)
(kill-safely (thread-os-thread *current-thread*) sb!unix:sigpipe))
(when interruption
(funcall interruption))))
#!+sb-thruption
(defun run-interruption ()
(in-interruption () ;the non-thruption code does this in the signal handler
(let ((interruption (with-interruptions-lock (*current-thread*)
(pop (thread-interruptions *current-thread*)))))
(when interruption
(funcall interruption)
;; I tried implementing this function as an explicit LOOP, because
;; if we are currently processing the thruption queue, why not do
;; all of them in one go instead of one-by-one?
;;
;; I still think LOOPing would be basically the right thing
;; here. But suppose some interruption unblocked deferrables.
;; Will the next one be happy with that? The answer is "no", at
;; least in the sense that there are tests which check that
;; deferrables are blocked at the beginning of a thruption, and
;; races that make those tests fail. Whether the tests are
;; misguided or not, it seems easier/cleaner to loop implicitly
;; -- and it's also what AK had implemented in the first place.
;;
;; The implicit loop is achieved by returning to C, but having C
;; call back to us immediately. The runtime will reset the sigmask
;; in the mean time.
;; -- DFL
(setf *thruption-pending* t)))))
(defun interrupt-thread (thread function)
#!+sb-doc
"Interrupt THREAD and make it run FUNCTION.
The interrupt is asynchronous, and can occur anywhere with the exception of
sections protected using SB-SYS:WITHOUT-INTERRUPTS.
FUNCTION is called with interrupts disabled, under
SB-SYS:ALLOW-WITH-INTERRUPTS. Since functions such as GRAB-MUTEX may try to
enable interrupts internally, in most cases FUNCTION should either enter
SB-SYS:WITH-INTERRUPTS to allow nested interrupts, or
SB-SYS:WITHOUT-INTERRUPTS to prevent them completely.
When a thread receives multiple interrupts, they are executed in the order
they were sent -- first in, first out.
This means that a great degree of care is required to use INTERRUPT-THREAD
safely and sanely in a production environment. The general recommendation is
to limit uses of INTERRUPT-THREAD for interactive debugging, banning it
entirely from production environments -- it is simply exceedingly hard to use
correctly.
With those caveats in mind, what you need to know when using it:
* If calling FUNCTION causes a non-local transfer of control (ie. an
unwind), all normal cleanup forms will be executed.
However, if the interrupt occurs during cleanup forms of an UNWIND-PROTECT,
it is just as if that had happened due to a regular GO, THROW, or
RETURN-FROM: the interrupted cleanup form and those following it in the
same UNWIND-PROTECT do not get executed.
SBCL tries to keep its own internals asynch-unwind-safe, but this is
frankly an unreasonable expectation for third party libraries, especially
given that asynch-unwind-safety does not compose: a function calling
only asynch-unwind-safe function isn't automatically asynch-unwind-safe.
This means that in order for an asych unwind to be safe, the entire
callstack at the point of interruption needs to be asynch-unwind-safe.
* In addition to asynch-unwind-safety you must consider the issue of
re-entrancy. INTERRUPT-THREAD can cause function that are never normally
called recursively to be re-entered during their dynamic contour,
which may cause them to misbehave. (Consider binding of special variables,
values of global variables, etc.)
Take togather, these two restrict the \"safe\" things to do using
INTERRUPT-THREAD to a fairly minimal set. One useful one -- exclusively for
interactive development use is using it to force entry to debugger to inspect
the state of a thread:
(interrupt-thread thread #'break)
Short version: be careful out there."
#!+win32
(declare (ignore thread))
#!+win32
(with-interrupt-bindings
(with-interrupts (funcall function)))
#!-win32
(let ((os-thread (thread-os-thread thread)))
(cond ((not os-thread)
(error 'interrupt-thread-error :thread thread))
(t
(with-interruptions-lock (thread)
;; Append to the end of the interruptions queue. It's
;; O(N), but it does not hurt to slow interruptors down a
;; bit when the queue gets long.
(setf (thread-interruptions thread)
(append (thread-interruptions thread)
(list (lambda ()
(without-interrupts
(allow-with-interrupts
(funcall function))))))))
(when (minusp (wake-thread os-thread))
(error 'interrupt-thread-error :thread thread))))))
(defun terminate-thread (thread)
#!+sb-doc
"Terminate the thread identified by THREAD, by interrupting it and
causing it to call SB-EXT:ABORT-THREAD with :ALLOW-EXIT T.
The unwind caused by TERMINATE-THREAD is asynchronous, meaning that
eg. thread executing
(let (foo)
(unwind-protect
(progn
(setf foo (get-foo))
(work-on-foo foo))
(when foo
;; An interrupt occurring inside the cleanup clause
;; will cause cleanups from the current UNWIND-PROTECT
;; to be dropped.
(release-foo foo))))
might miss calling RELEASE-FOO despite GET-FOO having returned true if
the interrupt occurs inside the cleanup clause, eg. during execution
of RELEASE-FOO.
Thus, in order to write an asynch unwind safe UNWIND-PROTECT you need
to use WITHOUT-INTERRUPTS:
(let (foo)
(sb-sys:without-interrupts
(unwind-protect
(progn
(setf foo (sb-sys:allow-with-interrupts
(get-foo)))
(sb-sys:with-local-interrupts
(work-on-foo foo)))
(when foo
(release-foo foo)))))
Since most libraries using UNWIND-PROTECT do not do this, you should never
assume that unknown code can safely be terminated using TERMINATE-THREAD."
(interrupt-thread thread (lambda () (abort-thread :allow-exit t))))
(define-alien-routine "thread_yield" int)
#!+sb-doc
(setf (fdocumentation 'thread-yield 'function)
"Yield the processor to other threads.")
;;; internal use only. If you think you need to use these, either you
;;; are an SBCL developer, are doing something that you should discuss
;;; with an SBCL developer first, or are doing something that you
;;; should probably discuss with a professional psychiatrist first
#!+sb-thread
(progn
(defun %thread-sap (thread)
(let ((thread-sap (alien-sap (extern-alien "all_threads" (* t))))
(target (thread-os-thread thread)))
(loop
(when (sap= thread-sap (int-sap 0)) (return nil))
(let ((os-thread (sap-ref-word thread-sap
(* sb!vm:n-word-bytes
sb!vm::thread-os-thread-slot))))
(when (= os-thread target) (return thread-sap))
(setf thread-sap
(sap-ref-sap thread-sap (* sb!vm:n-word-bytes
sb!vm::thread-next-slot)))))))
(defun %symbol-value-in-thread (symbol thread)
;; Prevent the thread from dying completely while we look for the TLS
;; area...
(with-all-threads-lock
(if (thread-alive-p thread)
(let* ((offset (sb!kernel:get-lisp-obj-address
(sb!vm::symbol-tls-index symbol)))
(obj (sap-ref-lispobj (%thread-sap thread) offset))
(tl-val (sb!kernel:get-lisp-obj-address obj)))
(cond ((zerop offset)
(values nil :no-tls-value))
((or (eql tl-val sb!vm:no-tls-value-marker-widetag)
(eql tl-val sb!vm:unbound-marker-widetag))
(values nil :unbound-in-thread))
(t
(values obj :ok))))
(values nil :thread-dead))))
(defun %set-symbol-value-in-thread (symbol thread value)
(with-pinned-objects (value)
;; Prevent the thread from dying completely while we look for the TLS
;; area...
(with-all-threads-lock
(if (thread-alive-p thread)
(let ((offset (sb!kernel:get-lisp-obj-address
(sb!vm::symbol-tls-index symbol))))
(cond ((zerop offset)
(values nil :no-tls-value))
(t
(setf (sap-ref-lispobj (%thread-sap thread) offset)
value)
(values value :ok))))
(values nil :thread-dead)))))
(define-alien-variable tls-index-start unsigned-int)
;; Get values from the TLS area of the current thread.
(defun %thread-local-references ()
(without-gcing
(let ((sap (%thread-sap *current-thread*)))
(loop for index from tls-index-start
below (symbol-value 'sb!vm::*free-tls-index*)
for value = (sap-ref-word sap (* sb!vm:n-word-bytes index))
for (obj ok) = (multiple-value-list (sb!kernel:make-lisp-obj value nil))
unless (or (not ok)
(typep obj '(or fixnum character))
(member value
'(#.sb!vm:no-tls-value-marker-widetag
#.sb!vm:unbound-marker-widetag))
(member obj seen :test #'eq))
collect obj into seen
finally (return seen))))))
(defun symbol-value-in-thread (symbol thread &optional (errorp t))
"Return the local value of SYMBOL in THREAD, and a secondary value of T
on success.
If the value cannot be retrieved (because the thread has exited or because it
has no local binding for NAME) and ERRORP is true signals an error of type
SYMBOL-VALUE-IN-THREAD-ERROR; if ERRORP is false returns a primary value of
NIL, and a secondary value of NIL.
Can also be used with SETF to change the thread-local value of SYMBOL.
SYMBOL-VALUE-IN-THREAD is primarily intended as a debugging tool, and not as a
mechanism for inter-thread communication."
(declare (symbol symbol) (thread thread))
#!+sb-thread
(multiple-value-bind (res status) (%symbol-value-in-thread symbol thread)
(if (eq :ok status)
(values res t)
(if errorp
(error 'symbol-value-in-thread-error
:name symbol
:thread thread
:info (list :read status))
(values nil nil))))
#!-sb-thread
(if (boundp symbol)
(values (symbol-value symbol) t)
(if errorp
(error 'symbol-value-in-thread-error
:name symbol
:thread thread
:info (list :read :unbound-in-thread))
(values nil nil))))
(defun (setf symbol-value-in-thread) (value symbol thread &optional (errorp t))
(declare (symbol symbol) (thread thread))
#!+sb-thread
(multiple-value-bind (res status) (%set-symbol-value-in-thread symbol thread value)
(if (eq :ok status)
(values res t)
(if errorp
(error 'symbol-value-in-thread-error
:name symbol
:thread thread
:info (list :write status))
(values nil nil))))
#!-sb-thread
(if (boundp symbol)
(values (setf (symbol-value symbol) value) t)
(if errorp
(error 'symbol-value-in-thread-error
:name symbol
:thread thread
:info (list :write :unbound-in-thread))
(values nil nil))))
(defun sb!vm::locked-symbol-global-value-add (symbol-name delta)
(sb!vm::locked-symbol-global-value-add symbol-name delta))
;;;; Stepping
(defun thread-stepping ()
(make-lisp-obj
(sap-ref-word (current-thread-sap)
(* sb!vm::thread-stepping-slot sb!vm:n-word-bytes))))
(defun (setf thread-stepping) (value)
(setf (sap-ref-word (current-thread-sap)
(* sb!vm::thread-stepping-slot sb!vm:n-word-bytes))
(get-lisp-obj-address value)))