src/code/target-unithread.lisp

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