src/code/target-unithread.lisp

   1 (in-package "SB!THREAD")
   2
   3 #!-sb-fluid (declaim (inline sb!vm::current-thread-offset-sap))
   4 (defun sb!vm::current-thread-offset-sap (n)
   5   (declare (type (unsigned-byte 27) n))
   6   (sb!sys:sap-ref-sap (alien-sap (extern-alien "all_threads" (* t)))
   7                (* n 4)))
   8
   9 (defun current-thread-id ()
  10   (sb!sys:sap-int
  11    (sb!vm::current-thread-offset-sap sb!vm::thread-pid-slot)))
  12
  13 ;;;; queues, locks
  14
  15 ;; spinlocks use 0 as "free" value: higher-level locks use NIL
  16 (defun get-spinlock (lock offset new-value) )
  17
  18 (defmacro with-spinlock ((queue) &body body)
  19   `(progn ,@body))
  20
  21 ;;;; the higher-level locking operations are based on waitqueues
  22
  23 (defstruct waitqueue
  24   (name nil :type (or null simple-base-string))
  25   (lock 0)
  26   (data nil))
  27
  28 (defstruct (mutex (:include waitqueue))
  29   (value nil))
  30
  31 #+nil
  32 (defun wait-on-queue (queue &optional lock)
  33   (let ((pid (current-thread-id)))
  34     ;; FIXME what should happen if we get interrupted when we've blocked
  35     ;; the sigcont?  For that matter, can we get interrupted?
  36     (block-sigcont)
  37     (when lock (release-mutex lock))
  38     (get-spinlock queue 2 pid)
  39     (pushnew pid (waitqueue-data queue))
  40     (setf (waitqueue-lock queue) 0)
  41     (unblock-sigcont-and-sleep)))
  42
  43 #+nil
  44 (defun dequeue (queue)
  45   (let ((pid (current-thread-id)))
  46     (get-spinlock queue 2 pid)
  47     (setf (waitqueue-data queue)
  48           (delete pid (waitqueue-data queue)))
  49     (setf (waitqueue-lock queue) 0)))
  50
  51 #+nil
  52 (defun signal-queue-head (queue)
  53   (let ((pid (current-thread-id)))
  54     (get-spinlock queue 2 pid)
  55     (let ((h (car (waitqueue-data queue))))
  56       (setf (waitqueue-lock queue) 0)
  57       (when h
  58         (sb!unix:unix-kill h :sigcont)))))
  59
  60 ;;;; mutex
  61
  62 #+nil
  63 (defun get-mutex (lock &optional new-value (wait-p t))
  64   (declare (type mutex lock))
  65   (let ((pid (current-thread-id)))
  66     (unless new-value (setf new-value pid))
  67     (assert (not (eql new-value (mutex-value lock))))
  68     (loop
  69      (unless
  70          ;; args are object slot-num old-value new-value
  71          (sb!vm::%instance-set-conditional lock 4 nil new-value)
  72        (dequeue lock)
  73        (return t))
  74      (unless wait-p (return nil))
  75      (wait-on-queue lock nil))))
  76
  77 #+nil
  78 (defun release-mutex (lock &optional (new-value nil))
  79   (declare (type mutex lock))
  80   (let ((old-value (mutex-value lock))
  81         (t1 nil))
  82     (loop
  83      (unless
  84          ;; args are object slot-num old-value new-value
  85          (eql old-value
  86               (setf t1
  87                     (sb!vm::%instance-set-conditional lock 4 old-value new-value)))
  88        (signal-queue-head lock)
  89        (return t))
  90      (setf old-value t1))))
  91
  92 (defmacro with-mutex ((mutex &key value (wait-p t))  &body body)
  93   (declare (ignore mutex value wait-p))
  94   `(progn ,@body))
  95
  96 ;;; what's the best thing to do with these on unithread?
  97 #+NIl
  98 (defun condition-wait (queue lock)
  99   "Atomically release LOCK and enqueue ourselves on QUEUE.  Another
 100 thread may subsequently notify us using CONDITION-NOTIFY, at which
 101 time we reacquire LOCK and return to the caller."
 102   (unwind-protect
 103        (wait-on-queue queue lock)
 104     ;; If we are interrupted while waiting, we should do these things
 105     ;; before returning.  Ideally, in the case of an unhandled signal,
 106     ;; we should do them before entering the debugger, but this is
 107     ;; better than nothing.
 108     (dequeue queue)
 109     (get-mutex lock)))
 110
 111 #+nil
 112 (defun condition-notify (queue)
 113   "Notify one of the processes waiting on QUEUE"
 114   (signal-queue-head queue))
 115
 116
 117 ;;;; multiple independent listeners
 118
 119 (defvar *session-lock* nil)
 120
 121 ;;;; job control
 122
 123 (defun debugger-wait-until-foreground-thread (stream) t)