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 (defun reap-dead-threads ())
  26
  27 ;;;; queues, locks
  28
  29 ;; spinlocks use 0 as "free" value: higher-level locks use NIL
  30 (defun get-spinlock (lock offset new-value)
  31   (declare (ignore lock offset new-value)))
  32
  33 (defmacro with-spinlock ((queue) &body body)
  34   (declare (ignore queue))
  35   `(progn ,@body))
  36
  37 ;;;; the higher-level locking operations are based on waitqueues
  38
  39 (defstruct waitqueue
  40   (name nil :type (or null simple-string))
  41   (lock 0)
  42   (data nil))
  43
  44 (defstruct (mutex (:include waitqueue))
  45   (value nil))
  46
  47 #+nil
  48 (defun wait-on-queue (queue &optional lock)
  49   (let ((pid (current-thread-id)))
  50     ;; FIXME what should happen if we get interrupted when we've blocked
  51     ;; the sigcont?  For that matter, can we get interrupted?
  52     (block-sigcont)
  53     (when lock (release-mutex lock))
  54     (get-spinlock queue 2 pid)
  55     (pushnew pid (waitqueue-data queue))
  56     (setf (waitqueue-lock queue) 0)
  57     (unblock-sigcont-and-sleep)))
  58
  59 #+nil
  60 (defun dequeue (queue)
  61   (let ((pid (current-thread-id)))
  62     (get-spinlock queue 2 pid)
  63     (setf (waitqueue-data queue)
  64           (delete pid (waitqueue-data queue)))
  65     (setf (waitqueue-lock queue) 0)))
  66
  67 #+nil
  68 (defun signal-queue-head (queue)
  69   (let ((pid (current-thread-id)))
  70     (get-spinlock queue 2 pid)
  71     (let ((h (car (waitqueue-data queue))))
  72       (setf (waitqueue-lock queue) 0)
  73       (when h
  74         (sb!unix:unix-kill h sb!unix:sigcont)))))
  75
  76 ;;;; mutex
  77
  78 #+nil
  79 (defun get-mutex (lock &optional new-value (wait-p t))
  80   (declare (type mutex lock))
  81   (let ((pid (current-thread-id)))
  82     (unless new-value (setf new-value pid))
  83     (assert (not (eql new-value (mutex-value lock))))
  84     (loop
  85      (unless
  86          ;; args are object slot-num old-value new-value
  87          (sb!vm::%instance-set-conditional lock 4 nil new-value)
  88        (dequeue lock)
  89        (return t))
  90      (unless wait-p (return nil))
  91      (wait-on-queue lock nil))))
  92
  93 #+nil
  94 (defun release-mutex (lock &optional (new-value nil))
  95   (declare (type mutex lock))
  96   (let ((old-value (mutex-value lock))
  97         (t1 nil))
  98     (loop
  99      (unless
 100          ;; args are object slot-num old-value new-value
 101          (eql old-value
 102               (setf t1
 103                     (sb!vm::%instance-set-conditional lock 4 old-value new-value)))
 104        (signal-queue-head lock)
 105        (return t))
 106      (setf old-value t1))))
 107
 108 (defun get-mutex (lock &optional new-value (wait-p t))
 109   (declare (type mutex lock))
 110   (let ((old-value (mutex-value lock)))
 111     (when (and old-value wait-p)
 112       (error "In unithread mode, mutex ~S was requested with WAIT-P ~S and ~
 113               new-value ~S, but has already been acquired (with value ~S)."
 114              lock wait-p new-value old-value))
 115     (setf (mutex-value lock) new-value)
 116     t))
 117
 118 (defun release-mutex (lock)
 119   (declare (type mutex lock))
 120   (setf (mutex-value lock) nil))
 121
 122 ;;; what's the best thing to do with these on unithread?  commented
 123 ;;; functions are the thread versions, just to remind me what they do
 124 ;;; there
 125 #+nil
 126 (defun condition-wait (queue lock)
 127   "Atomically release LOCK and enqueue ourselves on QUEUE.  Another
 128 thread may subsequently notify us using CONDITION-NOTIFY, at which
 129 time we reacquire LOCK and return to the caller."
 130   (unwind-protect
 131        (wait-on-queue queue lock)
 132     ;; If we are interrupted while waiting, we should do these things
 133     ;; before returning.  Ideally, in the case of an unhandled signal,
 134     ;; we should do them before entering the debugger, but this is
 135     ;; better than nothing.
 136     (dequeue queue)
 137     (get-mutex lock)))
 138
 139 #+nil
 140 (defun condition-notify (queue)
 141   "Notify one of the processes waiting on QUEUE"
 142   (signal-queue-head queue))
 143
 144 (defun maybe-install-futex-functions () nil)
 145
 146 ;;;; job control
 147
 148 (defun init-job-control () t)
 149 (defun debugger-wait-until-foreground-thread (stream)
 150   (declare (ignore stream))
 151   t)
 152 (defun get-foreground () t)
 153 (defun release-foreground (&optional next)
 154   (declare (ignore next))
 155   t)
 156 (defun terminate-session ())