X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fthread.lisp;h=1e622ce9e51f88a82419bc074a2b238b8444d137;hb=dfa8294a1580e8aa099a92baebba7d9caddb2fcb;hp=c5c71049a0ab58ddef761f13d25e5dc85ec98e38;hpb=be76f6319dcb41477209676e6f26e0030e4659ba;p=sbcl.git diff --git a/src/code/thread.lisp b/src/code/thread.lisp index c5c7104..1e622ce 100644 --- a/src/code/thread.lisp +++ b/src/code/thread.lisp @@ -1,31 +1,56 @@ -(in-package :sb!thread) +;;;; support for threads needed at cross-compile time -#+sb-xc-host -(defun make-mutex (&key name value) nil) +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. -#+sb-xc-host -(defmacro with-recursive-lock ((mutex) &body body) - `(progn ,@body)) +(in-package "SB!THREAD") -#-sb-xc-host -(defmacro with-recursive-lock ((mutex) &body body) - (let ((cfp (gensym "CFP"))) - `(let ((,cfp (ash (sb!sys:sap-int (sb!vm::current-fp) ) -2))) +(sb!xc:defmacro with-mutex ((mutex &key value (wait-p t)) &body body) + #!-sb-thread (declare (ignore mutex value wait-p)) + #!+sb-thread + (with-unique-names (got) + `(let ((,got (get-mutex ,mutex ,value ,wait-p))) + (when ,got + (unwind-protect + (locally ,@body) + (release-mutex ,mutex))))) + ;; KLUDGE: this separate expansion for (NOT SB-THREAD) is not + ;; strictly necessary; GET-MUTEX and RELEASE-MUTEX are implemented. + ;; However, there would be a (possibly slight) performance hit in + ;; using them. + #!-sb-thread + `(locally ,@body)) + +(sb!xc:defmacro with-recursive-lock ((mutex) &body body) + #!-sb-thread (declare (ignore mutex)) + #!+sb-thread + (with-unique-names (cfp) + `(let ((,cfp (sb!kernel:current-fp))) (unless (and (mutex-value ,mutex) - (SB!DI::control-stack-pointer-valid-p - (sb!sys:int-sap (ash (mutex-value ,mutex) 2)))) - (get-mutex ,mutex ,cfp)) + (sb!vm:control-stack-pointer-valid-p + (sb!sys:int-sap + (sb!kernel:get-lisp-obj-address (mutex-value ,mutex))))) + ;; this punning with MAKE-LISP-OBJ depends for its safety on + ;; the frame pointer being a lispobj-aligned integer. While + ;; it is, then MAKE-LISP-OBJ will always return a FIXNUM, so + ;; we're safe to do that. Should this ever change, this + ;; MAKE-LISP-OBJ could return something that looks like a + ;; pointer, but pointing into neverneverland, which will + ;; confuse GC completely. -- CSR, 2003-06-03 + (get-mutex ,mutex (sb!kernel:make-lisp-obj (sb!sys:sap-int ,cfp)))) (unwind-protect - (progn ,@body) - (when (eql (mutex-value ,mutex) ,cfp) (release-mutex ,mutex)))))) - -(defun get-foreground () - (when (not (eql (mutex-value *session-lock*) (CURRENT-THREAD-ID))) - (get-mutex *session-lock*)) - (sb!sys:enable-interrupt :sigint #'sb!unix::sigint-handler) - t) + (locally ,@body) + (when (sb!sys:sap= (sb!sys:int-sap + (sb!kernel:get-lisp-obj-address + (mutex-value ,mutex))) + ,cfp) + (release-mutex ,mutex))))) + #!-sb-thread + `(locally ,@body)) -(defun release-foreground () - (sb!sys:enable-interrupt :sigint :ignore) - (release-mutex *session-lock*) - t)