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 sb!vm:n-word-bytes)))
  20
  21 ;;;; queues, locks
  22
  23 ;; spinlocks use 0 as "free" value: higher-level locks use NIL
  24 (defun get-spinlock (lock offset new-value)
  25   (declare (ignore lock offset new-value)))
  26
  27 (defmacro with-spinlock ((queue) &body body)
  28   (declare (ignore queue))
  29   `(progn ,@body))
  30
  31 ;;;; the higher-level locking operations are based on waitqueues
  32
  33 (defstruct waitqueue
  34   (name nil :type (or null simple-string))
  35   (lock 0)
  36   (data nil))
  37
  38 (defstruct (mutex (:include waitqueue))
  39   (value nil))
  40
  41 ;;;; mutex
  42
  43 (defun get-mutex (lock &optional new-value (wait-p t))
  44   (declare (type mutex lock))
  45   (let ((old-value (mutex-value lock)))
  46     (when (and old-value wait-p)
  47       (error "In unithread mode, mutex ~S was requested with WAIT-P ~S and ~
  48               new-value ~S, but has already been acquired (with value ~S)."
  49              lock wait-p new-value old-value))
  50     (setf (mutex-value lock) new-value)
  51     t))
  52
  53 (defun release-mutex (lock)
  54   (declare (type mutex lock))
  55   (setf (mutex-value lock) nil))
  56
  57
  58 ;; FIXME need suitable stub or ERROR-signaling definitions for
  59 ;; condition-wait (queue lock)
  60 ;; condition-notify (queue)
  61
  62 ;;;; job control
  63
  64 (defun init-job-control () t)
  65 (defun debugger-wait-until-foreground-thread (stream)
  66   (declare (ignore stream))
  67   t)
  68 (defun get-foreground () t)
  69 (defun release-foreground (&optional next)
  70   (declare (ignore next))
  71   t)
  72 (defun terminate-session ())