changeset 698: |
96958d3eb5b0 |
parent: |
4d8451fe5423
|
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Fri, 04 Oct 2024 22:04:59 -0400 |
permissions: |
-rw-r--r-- |
description: |
fixes |
1 ;;; threads.lisp --- Multi-thread utilities 7 ;; mostly yoinked from sb-thread and friends 10 (in-package :std/thread) 12 ;; (sb-thread:thread-os-tid sb-thread:*current-thread*) 13 ;; sb-thread:interrupt-thread 16 (define-condition std-thread-error (thread-error) ()) 19 (defun thread-support-p () (member :thread-support *features*)) 21 (eval-when (:compile-toplevel) 22 (defun print-top-level (msg) 23 (sb-thread:make-thread 25 (format #.*standard-output* msg))) 28 (defun find-thread-by-id (id) 29 "Search for thread by ID which must be an u64. On success returns the thread itself or nil." 30 (find id (sb-thread::list-all-threads) :test '= :key 'thread-os-tid)) 32 (defun find-thread (name) 33 "Find a thread by name." 34 (find name (sb-thread::list-all-threads) :test 'equal :key 'thread-name)) 36 (defun thread-key-list () 37 (sb-thread::avltree-filter #'sb-thread::avlnode-key sb-thread::*all-threads*)) 39 (defun thread-id-list () 40 (sb-thread::avltree-filter (lambda (th) (thread-os-tid (sb-thread::avlnode-data th))) sb-thread::*all-threads*)) 42 (defun thread-count () 43 (sb-thread::avl-count sb-thread::*all-threads*)) 45 (defun make-threads (n fn &key (name "thread")) 46 (declare (type fixnum n)) 48 collect (make-thread fn :name (format nil "~A-~D" name i)))) 50 (defun parse-lambda-list-names (ll) 51 (multiple-value-bind (idx _ args) (sb-int:parse-lambda-list ll) 52 (declare (ignore idx _)) 59 (defmacro with-threads ((n &key args) &body body) 60 `(make-threads ,n (lambda (,@args) (declare (ignorable ,@(parse-lambda-list-names args))) ,@body))) 62 (defun finish-threads (&rest threads) 63 (let ((threads (flatten threads))) 65 (mapc #'join-thread threads) 66 (dolist (thread threads) 67 (when (thread-alive-p thread) 68 (terminate-thread thread)))))) 70 (defun timed-join-thread (thread timeout) 71 (declare (type thread thread) (type float timeout)) 72 (handler-case (sb-sys:with-deadline (:seconds timeout) 73 (join-thread thread :default :aborted)) 78 (join-thread *current-thread*)) 80 (defun kill-thread (thread) 81 (when (thread-alive-p thread) 83 (terminate-thread thread)))) 85 ;; (sb-vm::primitive-object-slots (sb-vm::primitive-object 'sb-vm::thread)) 86 (defun init-session (&optional (thread *current-thread*)) (sb-thread::new-session thread)) 88 ;; (sb-thread::with-progressive-timeout (timet :seconds 4) (dotimes (i 4000) (print (timet)))) 90 ;; (describe sb-thread::*session*) 92 ;; make-listener-thread 94 ;; with-progressive-timeout 98 (let* ((slots (sb-vm::primitive-object-slots #1=(sb-vm::primitive-object 'sb-vm::thread))) 99 (sap (current-thread-sap)) 100 (thread-obj-len (sb-vm::primitive-object-length #1#)) 101 (names (make-array thread-obj-len :initial-element ""))) 102 (loop for slot across slots 104 (setf (aref names (sb-vm::slot-offset slot)) (sb-vm::slot-name slot))) 105 (flet ((safely-read (sap offset &aux (bits (sb-vm::sap-ref-word sap offset))) 106 (cond ((eql bits sb-vm:no-tls-value-marker) :no-tls-value) 107 ((eql (logand bits sb-vm:widetag-mask) sb-vm:unbound-marker-widetag) :unbound) 108 (t (sb-vm::sap-ref-lispobj sap offset)))) 110 (declare (type fixnum sym)) 111 (let ((*print-right-margin* 128) 113 (format t " ~3d ~30a : ~s~%" 114 #+sb-thread (ash sym (- sb-vm:word-shift)) 116 #+sb-thread (sb-vm:symbol-from-tls-index sym) 119 (format t "~&TLS: (base=~x)~%" (sb-vm::sap-int sap)) 120 (loop for tlsindex from sb-vm:n-word-bytes below 121 #+sb-thread (ash sb-vm::*free-tls-index* sb-vm:n-fixnum-tag-bits) 122 #-sb-thread (ash thread-obj-len sb-vm:word-shift) 123 by sb-vm:n-word-bytes 125 (unless (<= sb-vm::thread-allocator-histogram-slot 126 (ash tlsindex (- sb-vm:word-shift)) 127 (1- sb-vm::thread-lisp-thread-slot)) 128 (let ((thread-slot-name 129 (if (< tlsindex (ash thread-obj-len sb-vm:word-shift)) 130 (aref names (ash tlsindex (- sb-vm:word-shift)))))) 131 (if (and thread-slot-name (sb-vm::neq thread-slot-name 'sb-vm::lisp-thread)) 132 (format t " ~3d ~30a : #x~x~%" (ash tlsindex (- sb-vm:word-shift)) 133 thread-slot-name (sb-vm::sap-ref-word sap tlsindex)) 134 (let ((val (safely-read sap tlsindex))) 135 (unless (eq val :no-tls-value) 136 (show tlsindex val))))))) 137 (let ((from (sb-vm::descriptor-sap sb-vm:*binding-stack-start*)) 138 (to (sb-vm::binding-stack-pointer-sap))) 139 (format t "~%Binding stack: (depth ~d)~%" 140 (/ (sb-vm::sap- to from) (* sb-vm:binding-size sb-vm:n-word-bytes))) 142 (when (sb-vm::sap>= from to) (return)) 143 (let ((val (safely-read from 0)) 144 (sym #+sb-thread (sb-vm::sap-ref-word from sb-vm:n-word-bytes) ; a TLS index 145 #-sb-thread (sb-vm::sap-ref-lispobj from sb-vm:n-word-bytes))) 147 (setq from (sb-vm::sap+ from (* sb-vm:binding-size sb-vm:n-word-bytes)))))))) 149 (defun wait-for-threads (threads) 150 (map 'list (lambda (thread) (sb-thread:join-thread thread :default nil)) threads) 151 (not (some #'sb-thread:thread-alive-p threads))) 152 (defun process-all-interrupts (&optional (thread sb-thread:*current-thread*)) 153 (sb-ext:wait-for (null (sb-thread::thread-interruptions thread))))