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