sbcl.sbcl/src/code/thread-structs.lisp

;;;; support for threads needed at cross-compile time

;;;; 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")

;;; An AVL tree of threads keyed by 'struct thread'. NIL is the empty tree.
(sb-ext:define-load-time-global *all-threads* ())
;;; Next TLS index to use. This is shifted by n-fixnum-tag-bits because it holds
;;; a word-aligned raw integer, not a fixnum (but it looks like a fixnum)
(sb-ext:define-load-time-global sb-vm::*free-tls-index* 0)

;;; It's possible to make futex/non-futex switchable at runtime by ensuring that
;;; these synchronization primitive structs contain all the slots for the union
;;; of any kind of backing object.  Some of the #+sb-futex/#-sb-futex cases in
;;; target-thread also have to be changed to a COND rather than a compile-time test.
;;; Among the uses of this would be to test real posix mutexes (with a finalizer on
;;; each lisp-side proxy) or support older C APIs. Posix mutexes work nicely now
;;; because finalizers are more efficient than they were, and when many threads
;;; compete for a mutex, the pthread code seems to do a better job at reducing
;;; cycles spent in the OS.

;;; Mutexes could be equipped with telemetry compatible with absl::Mutex.
;;; Specifically, we'd like to know the "Induced wait" which is the sum of CPU cycles
;;; a lock owner caused other threads to wait. It's tricky to report because measurement
;;; is performed in the waiting thread (the "victim" of wait) but reporting should occur
;;; in the "culprit" thread so that the call stack accurately reflects the function
;;; whose fault it is that there was induced wait time. absl mutex can do this because
;;; it is acutely aware of the queue of waiters, and it knows which waiter it wakes.
;;; SBCL mutex can't, because we defer everything to the OS. But the delay time can be
;;; handed off to -some- waker using a slot of the mutex, which stastically should result
;;; in the right effect. To keep struct size unchanged, the owner ID and futex word
;;; must be packed into a single raw slot. (None of this is implemented yet!)

(sb-xc:defstruct (mutex (:constructor make-mutex (&key name))
                        (:copier nil))
  "Mutex type."
  #+sb-futex (state 0 :type sb-vm:word)
  ;; If adding slots between STATE and NAME, please see futex_name() in linux_os.c
  ;; which attempts to divine a string from a futex word address.
  (name   nil :type (or null simple-string))
  ;; The owner is a non-pointer so that GC pages containing mutexes do not get dirtied
  ;; with mutex ownership change. The natural representation of this is SB-VM:WORD
  ;; but the "funny fixnum" representation - i.e. N_WORD_BITS bits of significance, but
  ;; cast as fixnum when read - avoids consing on 32-bit builds, and also not all of them
  ;; implement RAW-INSTANCE-CAS which would be otherwise needed.
  (%owner 0 :type fixnum))

(sb-xc:defstruct (waitqueue (:copier nil) (:constructor make-waitqueue (&key name)))
  "Waitqueue type."
  ;; futex words are actually 32-bits, but it needs to be a raw slot and we don't have
  ;; 32-bit raw slots on 64-bit machines.
  #+sb-futex (token 0 :type sb-ext:word)
  ;; If adding slots between TOKEN and NAME, please see futex_name() in linux_os.c
  ;; which attempts to divine a string from a futex word address.
  (name nil :type (or null string))
  ;; 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.
  . #+sb-futex nil
    #-sb-futex (%owner %head %tail))

(sb-xc:defstruct (semaphore (:copier nil)
                            (:constructor %make-semaphore (%count mutex queue)))
  "Semaphore type. The fact that a SEMAPHORE is a STRUCTURE-OBJECT
should be considered an implementation detail, and may change in the
future."
  (%count    0 :type (and (integer 0) fixnum))
  (waitcount 0 :type sb-vm:word)
  (mutex nil :read-only t :type mutex)
  (queue nil :read-only t :type waitqueue))

(declaim (sb-ext:freeze-type waitqueue semaphore))

(sb-ext:define-load-time-global *profiled-threads* :all)
(declaim (type (or (eql :all) list) *profiled-threads*))

;; allocator histogram capacity
(defconstant n-histogram-bins-small 32)
(defconstant n-histogram-bins-large 32)
;; small bins store just a count, large bins store a count and total size
(defconstant alloc-histogram-words
  (+ n-histogram-bins-small (* 2 n-histogram-bins-large)))

;;; the #+allocation-size-histogram has an exact count of objects allocated
;;; for all sizes up to (* cons-size n-word-bytes n-histogram-bins-small).
;;; Larger allocations are grouped by the binary log of the size.
;;; The small bins account for at least 99% of all allocations.
(defconstant first-large-histogram-bin-log2size
  (integer-length (* n-histogram-bins-small 16)))

(sb-xc:defstruct (thread (:constructor %make-thread (%name ephemeral-p semaphore))
                         (:copier nil))
  "Thread type. Do not rely on threads being structs as it may change
in future versions."
  (%name         nil :type (or null simple-string)) ; C code could read this
  ;; When true, the thread is (supposedy) internal, and the runtime knows how to start/stop
  ;; it around certain operations like SB-POSIX:FORK. There are two other important aspects:
  ;; - it promises to cleanly exit prior to core saving, never causing an error about
  ;;   more than 1 thread running.
  ;; - returning from it never commences forcible termination of other threads.
  ;; At present only 1 thread ever has this slot being T by default, namely the finalizer.
  ;; Allegedly users could specify it too, but git rev a5511496 removed the option
  ;; and no complaints have arisen due to its absence.
  (ephemeral-p  nil :type boolean :read-only t)
  ;; This is one of a few different views of a lisp thread:
  ;;  1. the memory space (thread->os_addr in C)
  ;;  2. 'struct thread' at some offset into the memory space, coinciding
  ;;     with the SB-VM::THREAD primitive object
  ;;  3. a pthread, which may reside anywhere, possibly the high end of the lisp stack
  ;;     (above the SP given to your entrypoint), whatever the pthread library chooses.
  ;;  4. the THREAD instance (this structure)
  ;; This value is 0 if the thread is not considered alive, though the pthread
  ;; may be running its termination code (unlinking from all_threads etc)
  (primitive-thread 0 :type sb-vm:word)
  ;; It is absolutely critical that our OS thread identifiers take no more than 32 bits
  ;; if #+sb-futex is present. So don't go changing this slot just because you feel like.
  ;; * macOS (mach_port_t): unsigned int
  ;; * FreeBSD (thr_self): thr_self writes a long to its its pointer arg,
  ;;     however LWP IDs occupy a smaller range that can be cast to int
  ;; * NetBSD (_lwp_self): lwpid_t which is int32_t
  ;; * Linux (gettid): 32-bit pid_t
  ;; * Windows (GetCurrentThreadId): 32-bit DWORD
  ;; Caution: the identified thread may have exited by the time you've read this slot
  (os-tid 0 :type (unsigned-byte 32) :read-only t)
  ;; This is a redundant copy of the pthread identifier from the primitive thread.
  ;; It's needed in the SB-THREAD:THREAD as well because there are valid reasons to
  ;; manipulate the new thread before it has assigned 'th->os_thread = pthread_self()'.
  ;; While we always have access to the C struct thread from Lisp, apparently the C
  ;; code can't pass "&th->os_thread" as the first argument to pthread_create() for the
  ;; incredible reason that the word might be written *after* the memory pointed at
  ;; by 'th' has already been freed. Such action might seem to violate:
  ;;  "Before returning, a successful call to pthread_create() stores the ID of the
  ;;   new thread in the buffer pointed to by thread"
  ;;  (https://man7.org/linux/man-pages/man3/pthread_create.3.html)
  ;; but that's not exactly what POSIX says, which is only:
  ;;  "Upon successful completion, pthread_create() stores the ID of the created thread
  ;;   in the location referenced by thread."
  ;; (https://pubs.opengroup.org/onlinepubs/007908799/xsh/pthread_create.html)
  ;; so there seems to be some leeway, and linux + glibc provides more of a guarantee.
  ;; Technically we should have only one authoritative source of the pthread identifier,
  ;; but it's not too critical, it's just annoying that there are two sources of
  ;; the same value.
  ;; The slot is somewhat poorly named (for consistency with C) because though it may
  ;; correspond to an OS thread, it could be the case that the threading model has
  ;; user-visible threads that do not map directly to OSs threads (or LWPs).
  ;; Any use of THREAD-OS-THREAD from lisp should take care to ensure validity of
  ;; the thread id by holding THREAD-STORAGE-LOCK.
  ;; Not needed for win32 threads.
  #-win32 (os-thread 0 :type sb-vm:word)
  ;; Keep a copy of the stack range for use in SB-EXT:STACK-ALLOCATED-P so that
  ;; we don't have to read it from the primitive thread which is unsafe for any
  ;; thread other than the current thread.
  ;; Usually this is a fixed amount below PRIMITIVE-THREAD, but the exact offset
  ;; varies by build configuration, and if #+win32 it is not related in any way.
  (control-stack-start 0 :type sb-vm:word)
  (control-stack-end 0 :type sb-vm:word)
  ;; At the beginning of the thread's life, this is a vector of data required
  ;; to start the user code. At the end, is it pointer to the 'struct thread'
  ;; so that it can be either freed or reused.
  (startup-info 0 :type (or fixnum (simple-vector 7)))
  ;; Whether this thread should be returned in LIST-ALL-THREADS.
  ;; This is almost-but-not-quite the same as what formerly
  ;; might have been known as the %ALIVE-P flag.
  (%visible 1 :type fixnum)
  (interruptions nil :type list)
  ;; This lock ensures that accessing the so-called "primitive thread" for this
  ;; instance from a different thread does not engender a use-after-free error,
  ;; as the lock must be acquired to free the mmapped backing store..
  ;; It also protects the queue of interruptions from concurrent access,
  ;; though that could potentially become a lockfree list.
  (storage-lock (make-mutex :name "thread memory") :type mutex :read-only t)

  ;; Per-thread memoization of GET-INTERNAL-REAL-TIME, for race-free update.
  ;; This might be a bignum, which is why we bother.
  #-64-bit (observed-internal-real-time-delta-sec 0 :type sb-vm:word)
  #-64-bit (observed-internal-real-time-delta-millisec
            ;; This needs a sentinel that can not possibly match an actual delta.
            ;; I have seen threads start up where 0 and 0 do match sec,msec
            ;; respectively, and then we'd return the cached NIL as if it were
            ;; the time. Forcing mismatch avoids putting in an extra test for NIL.
            (ash sb-ext:most-positive-word -1)
            :type sb-vm:signed-word)
  #-64-bit (internal-real-time)

  (alloc-histogram (or #+allocation-size-histogram
                       (make-array alloc-histogram-words :element-type 'sb-vm:word))
                   :type (or (simple-array sb-vm:word 1) null))
  (tot-bytes-alloc-boxed 0 :type sb-vm:word)
  (tot-bytes-alloc-unboxed 0 :type sb-vm:word)
  (max-stw-pause 0 :type sb-vm:word) ; microseconds
  (sum-stw-pause 0 :type sb-vm:word) ; "
  (ct-stw-pauses 0 :type sb-vm:word) ; to compute the avg
  ;; Measure elapsed time in GC in the resolution that clock_gettime returns
  ;; (nanoseconds) for 64-bit, or microseconds for 32-bit.
  ;; This can indicate >584 years if 64-bit or slightly over an hour if 32-bit.
  ;; Consider restarting your SBCL before wraparound occurs, if you care.
  (gc-virtual-time 0 :type sb-vm:word)

  ;; On succesful execution of the thread's lambda, a list of values.
  (result 0)
  ;; The completion condition _could_ be manifested as a condition var, but a difficulty
  ;; in doing so is that condition vars can always experience a spurious wakeup.
  ;; Dealing with timeouts becomes troublesome then. But we can utilize the fact that
  ;; WAIT-ON-SEMPAHORE implements a timeout, though as its comment says, the timeout
  ;; doesn't account for re-acquiring the internal mutex if that takes nontrivial time,
  ;; which it shouldn't since it guards very little work.
  ;; At any rate, the semaphore abstraction is never subject to spurious wakeup.
  (semaphore nil :type (or null semaphore))
  waiting-for)

(sb-xc:defstruct (foreign-thread
                  (:copier nil)
                  (:include thread (%name "callback"))
                  (:constructor !make-foreign-thread
                      (primitive-thread #+unix os-thread os-tid startup-info))
                  (:conc-name "THREAD-"))
  "Type of native threads which are attached to the runtime as Lisp threads
temporarily.")

(declaim (sb-ext:freeze-type mutex thread))
#-sb-xc-host
(progn
  (defvar *current-thread*)
  (declaim (type thread *current-thread*)))