changeset 119: | 85f27597cf60 |
parent: | b828a3caa758 |
child: | cc74c0054bc1 |
author: | ellis <ellis@rwest.io> |
date: | Fri, 22 Dec 2023 18:43:53 -0500 |
permissions: | -rw-r--r-- |
description: | castable added, still testing |
5 | 1 | ;;; threads.lisp --- Multi-thread utilities |
2 | ||
3 | ;; Threading Macros |
|
4 | ||
5 | ;;; Commentary: |
|
6 | ||
7 | ;; mostly yoinked from sb-thread and friends |
|
8 | ||
9 | ;;; Code: |
|
96 | 10 | (in-package :std) |
5 | 11 | |
12 | (defun thread-support-p () (member :thread-support *features*)) |
|
13 | ||
14 | (defun print-thread-info (&optional (stream *standard-output*)) |
|
15 | (let* ((curr-thread sb-thread:*current-thread*) |
|
16 | (curr-thread-name (sb-thread:thread-name curr-thread)) |
|
17 | (all-threads (sb-thread:list-all-threads))) |
|
18 | (format stream "Current thread: ~a~%~%" curr-thread) |
|
19 | (format stream "Current thread name: ~a~%~%" curr-thread-name) |
|
20 | (format stream "All threads:~% ~{~a~%~}~%" all-threads))) |
|
21 | ||
22 | (eval-when (:compile-toplevel) |
|
23 | (defun print-thread-message-top-level (msg) |
|
24 | (sb-thread:make-thread |
|
25 | (lambda () |
|
26 | (format #.*standard-output* msg))) |
|
27 | nil)) |
|
118
b828a3caa758
object library stuff, removed DOT - api doesnt jive.
ellis <ellis@rwest.io>
parents:
96
diff
changeset
|
28 | |
b828a3caa758
object library stuff, removed DOT - api doesnt jive.
ellis <ellis@rwest.io>
parents:
96
diff
changeset
|
29 | ;; this is all very unsafe. don't touch the finalizer thread plz. |
119 | 30 | (defun find-thread-by-id (id) |
118
b828a3caa758
object library stuff, removed DOT - api doesnt jive.
ellis <ellis@rwest.io>
parents:
96
diff
changeset
|
31 | "Search for thread by ID which must be an u64. On success returns the thread itself or nil." |
b828a3caa758
object library stuff, removed DOT - api doesnt jive.
ellis <ellis@rwest.io>
parents:
96
diff
changeset
|
32 | (sb-thread::avlnode-data (sb-thread::avl-find id sb-thread::*all-threads*))) |
b828a3caa758
object library stuff, removed DOT - api doesnt jive.
ellis <ellis@rwest.io>
parents:
96
diff
changeset
|
33 | |
b828a3caa758
object library stuff, removed DOT - api doesnt jive.
ellis <ellis@rwest.io>
parents:
96
diff
changeset
|
34 | (defun thread-id-list () |
b828a3caa758
object library stuff, removed DOT - api doesnt jive.
ellis <ellis@rwest.io>
parents:
96
diff
changeset
|
35 | (sb-thread::avltree-filter #'sb-thread::avlnode-key sb-thread::*all-threads*)) |
b828a3caa758
object library stuff, removed DOT - api doesnt jive.
ellis <ellis@rwest.io>
parents:
96
diff
changeset
|
36 | |
b828a3caa758
object library stuff, removed DOT - api doesnt jive.
ellis <ellis@rwest.io>
parents:
96
diff
changeset
|
37 | (defun thread-count () |
b828a3caa758
object library stuff, removed DOT - api doesnt jive.
ellis <ellis@rwest.io>
parents:
96
diff
changeset
|
38 | (sb-thread::avl-count sb-thread::*all-threads*)) |
b828a3caa758
object library stuff, removed DOT - api doesnt jive.
ellis <ellis@rwest.io>
parents:
96
diff
changeset
|
39 | |
b828a3caa758
object library stuff, removed DOT - api doesnt jive.
ellis <ellis@rwest.io>
parents:
96
diff
changeset
|
40 | (defmacro def-thread (name) |
b828a3caa758
object library stuff, removed DOT - api doesnt jive.
ellis <ellis@rwest.io>
parents:
96
diff
changeset
|
41 | `(progn |
b828a3caa758
object library stuff, removed DOT - api doesnt jive.
ellis <ellis@rwest.io>
parents:
96
diff
changeset
|
42 | (defstruct (,name |
b828a3caa758
object library stuff, removed DOT - api doesnt jive.
ellis <ellis@rwest.io>
parents:
96
diff
changeset
|
43 | (:copier nil) |
b828a3caa758
object library stuff, removed DOT - api doesnt jive.
ellis <ellis@rwest.io>
parents:
96
diff
changeset
|
44 | (:include thread (%name ,(string-downcase (symbol-name name)))) |
b828a3caa758
object library stuff, removed DOT - api doesnt jive.
ellis <ellis@rwest.io>
parents:
96
diff
changeset
|
45 | (:constructor ,(symbolicate 'make- name)) |
b828a3caa758
object library stuff, removed DOT - api doesnt jive.
ellis <ellis@rwest.io>
parents:
96
diff
changeset
|
46 | (:conc-name "THREAD-"))))) |
b828a3caa758
object library stuff, removed DOT - api doesnt jive.
ellis <ellis@rwest.io>
parents:
96
diff
changeset
|
47 | |
119 | 48 | (defun make-threads (n fn &key (name "thread")) |
118
b828a3caa758
object library stuff, removed DOT - api doesnt jive.
ellis <ellis@rwest.io>
parents:
96
diff
changeset
|
49 | (loop for i from 1 to n |
b828a3caa758
object library stuff, removed DOT - api doesnt jive.
ellis <ellis@rwest.io>
parents:
96
diff
changeset
|
50 | collect (make-thread fn :name (format nil "~A-~D" name i)))) |
b828a3caa758
object library stuff, removed DOT - api doesnt jive.
ellis <ellis@rwest.io>
parents:
96
diff
changeset
|
51 | |
119 | 52 | (defmacro with-threads ((idx n) &body body) |
53 | `(make-threads ,n (lambda (,idx) (declare (ignorable ,idx)) ,@body))) |
|
54 | ||
55 | (defun finish-threads (&rest threads) |
|
56 | (let ((threads (flatten threads))) |
|
57 | (unwind-protect |
|
58 | (mapc #'join-thread threads) |
|
59 | (dolist (thread threads) |
|
60 | (when (thread-alive-p thread) |
|
61 | (destroy-thread thread)))))) |
|
62 | ||
63 | (defun timed-join-thread (thread timeout) |
|
118
b828a3caa758
object library stuff, removed DOT - api doesnt jive.
ellis <ellis@rwest.io>
parents:
96
diff
changeset
|
64 | (handler-case (sb-sys:with-deadline (:seconds timeout) |
b828a3caa758
object library stuff, removed DOT - api doesnt jive.
ellis <ellis@rwest.io>
parents:
96
diff
changeset
|
65 | (join-thread thread :default :aborted)) |
b828a3caa758
object library stuff, removed DOT - api doesnt jive.
ellis <ellis@rwest.io>
parents:
96
diff
changeset
|
66 | (sb-ext:timeout () |
b828a3caa758
object library stuff, removed DOT - api doesnt jive.
ellis <ellis@rwest.io>
parents:
96
diff
changeset
|
67 | :timeout))) |
b828a3caa758
object library stuff, removed DOT - api doesnt jive.
ellis <ellis@rwest.io>
parents:
96
diff
changeset
|
68 | |
b828a3caa758
object library stuff, removed DOT - api doesnt jive.
ellis <ellis@rwest.io>
parents:
96
diff
changeset
|
69 | (defun hang () |
b828a3caa758
object library stuff, removed DOT - api doesnt jive.
ellis <ellis@rwest.io>
parents:
96
diff
changeset
|
70 | (join-thread *current-thread*)) |
b828a3caa758
object library stuff, removed DOT - api doesnt jive.
ellis <ellis@rwest.io>
parents:
96
diff
changeset
|
71 | |
b828a3caa758
object library stuff, removed DOT - api doesnt jive.
ellis <ellis@rwest.io>
parents:
96
diff
changeset
|
72 | (defun kill-thread (thread) |
b828a3caa758
object library stuff, removed DOT - api doesnt jive.
ellis <ellis@rwest.io>
parents:
96
diff
changeset
|
73 | (when (thread-alive-p thread) |
b828a3caa758
object library stuff, removed DOT - api doesnt jive.
ellis <ellis@rwest.io>
parents:
96
diff
changeset
|
74 | (ignore-errors |
b828a3caa758
object library stuff, removed DOT - api doesnt jive.
ellis <ellis@rwest.io>
parents:
96
diff
changeset
|
75 | (terminate-thread thread)))) |
119 | 76 | |
77 | ;; from sb-thread |
|
78 | (defun dump-thread () |
|
79 | (let* ((primobj (sb-vm::primitive-object 'sb-vm::thread)) |
|
80 | (slots (sb-vm::primitive-object-slots primobj)) |
|
81 | (sap (current-thread-sap)) |
|
82 | (thread-obj-len (sb-vm::primitive-object-length primobj)) |
|
83 | (names (make-array thread-obj-len :initial-element ""))) |
|
84 | (loop for slot across slots |
|
85 | do |
|
86 | (setf (aref names (sb-vm::slot-offset slot)) (sb-vm::slot-name slot))) |
|
87 | (flet ((safely-read (sap offset &aux (bits (sb-vm::sap-ref-word sap offset))) |
|
88 | (cond ((eql bits sb-vm:no-tls-value-marker) :no-tls-value) |
|
89 | ((eql (logand bits sb-vm:widetag-mask) sb-vm:unbound-marker-widetag) :unbound) |
|
90 | (t (sb-vm::sap-ref-lispobj sap offset)))) |
|
91 | (show (sym val) |
|
92 | (let ((*print-right-margin* 128) |
|
93 | (*print-lines* 4)) |
|
94 | (format t " ~3d ~30a : ~s~%" |
|
95 | #+sb-thread (ash sym (- sb-vm:word-shift)) |
|
96 | #-sb-thread 0 |
|
97 | #+sb-thread (sb-vm:symbol-from-tls-index sym) |
|
98 | #-sb-thread sym |
|
99 | val)))) |
|
100 | (format t "~&TLS: (base=~x)~%" (sb-vm::sap-int sap)) |
|
101 | (loop for tlsindex from sb-vm:n-word-bytes below |
|
102 | #+sb-thread (ash sb-vm::*free-tls-index* sb-vm:n-fixnum-tag-bits) |
|
103 | #-sb-thread (ash thread-obj-len sb-vm:word-shift) |
|
104 | by sb-vm:n-word-bytes |
|
105 | do |
|
106 | (unless (<= sb-vm::thread-allocator-histogram-slot |
|
107 | (ash tlsindex (- sb-vm:word-shift)) |
|
108 | (1- sb-vm::thread-lisp-thread-slot)) |
|
109 | (let ((thread-slot-name |
|
110 | (if (< tlsindex (ash thread-obj-len sb-vm:word-shift)) |
|
111 | (aref names (ash tlsindex (- sb-vm:word-shift)))))) |
|
112 | (if (and thread-slot-name (sb-vm::neq thread-slot-name 'sb-vm::lisp-thread)) |
|
113 | (format t " ~3d ~30a : #x~x~%" (ash tlsindex (- sb-vm:word-shift)) |
|
114 | thread-slot-name (sb-vm::sap-ref-word sap tlsindex)) |
|
115 | (let ((val (safely-read sap tlsindex))) |
|
116 | (unless (eq val :no-tls-value) |
|
117 | (show tlsindex val))))))) |
|
118 | (let ((from (sb-vm::descriptor-sap sb-vm:*binding-stack-start*)) |
|
119 | (to (sb-vm::binding-stack-pointer-sap))) |
|
120 | (format t "~%Binding stack: (depth ~d)~%" |
|
121 | (/ (sb-vm::sap- to from) (* sb-vm:binding-size sb-vm:n-word-bytes))) |
|
122 | (loop |
|
123 | (when (sb-vm::sap>= from to) (return)) |
|
124 | (let ((val (safely-read from 0)) |
|
125 | (sym #+sb-thread (sb-vm::sap-ref-word from sb-vm:n-word-bytes) ; a TLS index |
|
126 | #-sb-thread (sb-vm::sap-ref-lispobj from sb-vm:n-word-bytes))) |
|
127 | (show sym val)) |
|
128 | (setq from (sb-vm::sap+ from (* sb-vm:binding-size sb-vm:n-word-bytes)))))))) |