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