src/code/target-thread.lisp

   1 ;;;; support for threads in the target machine common to uni- and
   2 ;;;; multithread systems
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; This software is derived from the CMU CL system, which was
   8 ;;;; written at Carnegie Mellon University and released into the
   9 ;;;; public domain. The software is in the public domain and is
  10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  11 ;;;; files for more information.
  12
  13 (in-package "SB!THREAD")
  14
  15 (defstruct (thread (:constructor %make-thread))
  16   name
  17   %sap)
  18
  19 (def!method print-object ((thread thread) stream)
  20   (if (thread-name thread)
  21       (print-unreadable-object (thread stream :type t :identity t)
  22         (prin1 (thread-name thread) stream))
  23       (print-unreadable-object (thread stream :type t :identity t)
  24         ;; body is empty => there is only one space between type and
  25         ;; identity
  26         ))
  27   thread)
  28
  29 (defun thread-state (thread)
  30   (let ((state
  31          (sb!kernel:make-lisp-obj
  32           (sb!sys:sap-int
  33            (sb!sys:sap-ref-sap (thread-%sap thread)
  34                                (* sb!vm::thread-state-slot
  35                                   sb!vm::n-word-bytes))))))
  36     (ecase state
  37       (0 :starting)
  38       (1 :running)
  39       (2 :suspended)
  40       (3 :dead))))
  41
  42 (defun %set-thread-state (thread state)
  43   (setf (sb!sys:sap-ref-sap (thread-%sap thread)
  44                             (* sb!vm::thread-state-slot
  45                                sb!vm::n-word-bytes))
  46         (sb!sys:int-sap
  47          (sb!kernel:get-lisp-obj-address
  48           (ecase state
  49             (:starting 0)
  50             (:running 1)
  51             (:suspended 2)
  52             (:dead 3))))))
  53
  54 (defun thread-alive-p (thread)
  55   (not (eq :dead (thread-state thread))))
  56
  57 ;; A thread is eligible for gc iff it has finished and there are no
  58 ;; more references to it. This list is supposed to keep a reference to
  59 ;; all running threads.
  60 (defvar *all-threads* ())
  61 (defvar *all-threads-lock* (make-mutex :name "all threads lock"))
  62
  63 (defun list-all-threads ()
  64   (with-mutex (*all-threads-lock*)
  65     (copy-list *all-threads*)))
  66
  67 (declaim (inline current-thread-sap))
  68 (defun current-thread-sap ()
  69   (sb!vm::current-thread-offset-sap sb!vm::thread-this-slot))
  70
  71 (declaim (inline current-thread-sap-id))
  72 (defun current-thread-sap-id ()
  73   (sb!sys:sap-int
  74    (sb!vm::current-thread-offset-sap sb!vm::thread-os-thread-slot)))
  75
  76 (defun init-initial-thread ()
  77   (let ((initial-thread (%make-thread :name "initial thread"
  78                                       :%sap (current-thread-sap))))
  79     (setq *current-thread* initial-thread)
  80     ;; Either *all-threads* is empty or it contains exactly one thread
  81     ;; in case we are in reinit since saving core with multiple
  82     ;; threads doesn't work.
  83     (setq *all-threads* (list initial-thread))))