src/code/target-unithread.lisp

   1 ;;;; unithread stub support for threads in the target machine
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!THREAD")
  13
  14 ;;; used bu debug-int.lisp to access interrupt contexts
  15 #!-sb-fluid (declaim (inline sb!vm::current-thread-offset-sap))
  16 (defun sb!vm::current-thread-offset-sap (n)
  17   (declare (type (unsigned-byte 27) n))
  18   (sb!sys:sap-ref-sap (alien-sap (extern-alien "all_threads" (* t)))
  19                (* n 4)))
  20
  21 (defun current-thread-id ()
  22   (sb!sys:sap-ref-32 (alien-sap (extern-alien "all_threads" (* t)))
  23                (* sb!vm::thread-pid-slot 4)))
  24
  25 ;;;; queues, locks
  26
  27 ;; spinlocks use 0 as "free" value: higher-level locks use NIL
  28 (defun get-spinlock (lock offset new-value)
  29   (declare (ignore lock offset new-value)))
  30
  31 (defmacro with-spinlock ((queue) &body body)
  32   (declare (ignore queue))
  33   `(progn ,@body))
  34
  35 ;;;; the higher-level locking operations are based on waitqueues
  36
  37 (defstruct waitqueue
  38   (name nil :type (or null simple-base-string))
  39   (lock 0)
  40   (data nil))
  41
  42 (defstruct (mutex (:include waitqueue))
  43   (value nil))
  44
  45 #+nil
  46 (defun wait-on-queue (queue &optional lock)
  47   (let ((pid (current-thread-id)))
  48     ;; FIXME what should happen if we get interrupted when we've blocked
  49     ;; the sigcont?  For that matter, can we get interrupted?
  50     (block-sigcont)
  51     (when lock (release-mutex lock))
  52     (get-spinlock queue 2 pid)
  53     (pushnew pid (waitqueue-data queue))
  54     (setf (waitqueue-lock queue) 0)
  55     (unblock-sigcont-and-sleep)))
  56
  57 #+nil
  58 (defun dequeue (queue)
  59   (let ((pid (current-thread-id)))
  60     (get-spinlock queue 2 pid)
  61     (setf (waitqueue-data queue)
  62           (delete pid (waitqueue-data queue)))
  63     (setf (waitqueue-lock queue) 0)))
  64
  65 #+nil
  66 (defun signal-queue-head (queue)
  67   (let ((pid (current-thread-id)))
  68     (get-spinlock queue 2 pid)
  69     (let ((h (car (waitqueue-data queue))))
  70       (setf (waitqueue-lock queue) 0)
  71       (when h
  72         (sb!unix:unix-kill h sb!unix:sigcont)))))
  73
  74 ;;;; mutex
  75
  76 #+nil
  77 (defun get-mutex (lock &optional new-value (wait-p t))
  78   (declare (type mutex lock))
  79   (let ((pid (current-thread-id)))
  80     (unless new-value (setf new-value pid))
  81     (assert (not (eql new-value (mutex-value lock))))
  82     (loop
  83      (unless
  84          ;; args are object slot-num old-value new-value
  85          (sb!vm::%instance-set-conditional lock 4 nil new-value)
  86        (dequeue lock)
  87        (return t))
  88      (unless wait-p (return nil))
  89      (wait-on-queue lock nil))))
  90
  91 #+nil
  92 (defun release-mutex (lock &optional (new-value nil))
  93   (declare (type mutex lock))
  94   (let ((old-value (mutex-value lock))
  95         (t1 nil))
  96     (loop
  97      (unless
  98          ;; args are object slot-num old-value new-value
  99          (eql old-value
 100               (setf t1
 101                     (sb!vm::%instance-set-conditional lock 4 old-value new-value)))
 102        (signal-queue-head lock)
 103        (return t))
 104      (setf old-value t1))))
 105
 106 (defun get-mutex (lock &optional new-value (wait-p t))
 107   (declare (type mutex lock))
 108   (let ((old-value (mutex-value lock)))
 109     (when (and old-value wait-p)
 110       (error "In unithread mode, mutex ~S was requested with WAIT-P ~S and ~
 111               new-value ~S, but has already been acquired (with value ~S)."
 112              lock wait-p new-value old-value))
 113     (setf (mutex-value lock) new-value)
 114     t))
 115
 116 (defun release-mutex (lock)
 117   (declare (type mutex lock))
 118   (setf (mutex-value lock) nil))
 119
 120 ;;; what's the best thing to do with these on unithread?  commented
 121 ;;; functions are the thread versions, just to remind me what they do
 122 ;;; there
 123 #+nil
 124 (defun condition-wait (queue lock)
 125   "Atomically release LOCK and enqueue ourselves on QUEUE.  Another
 126 thread may subsequently notify us using CONDITION-NOTIFY, at which
 127 time we reacquire LOCK and return to the caller."
 128   (unwind-protect
 129        (wait-on-queue queue lock)
 130     ;; If we are interrupted while waiting, we should do these things
 131     ;; before returning.  Ideally, in the case of an unhandled signal,
 132     ;; we should do them before entering the debugger, but this is
 133     ;; better than nothing.
 134     (dequeue queue)
 135     (get-mutex lock)))
 136
 137 #+nil
 138 (defun condition-notify (queue)
 139   "Notify one of the processes waiting on QUEUE"
 140   (signal-queue-head queue))
 141
 142 (defun maybe-install-futex-functions () nil)
 143
 144 ;;;; job control
 145
 146 (defun init-job-control () t)
 147 (defun debugger-wait-until-foreground-thread (stream)
 148   (declare (ignore stream))
 149   t)
 150 (defun get-foreground () t)
 151 (defun release-foreground (&optional next)
 152   (declare (ignore next))
 153   t)
 154 (defun terminate-session ())