src/code/target-unithread.lisp

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