;;;; -*- coding: utf-8; -*-
changes in sbcl-0.9.14 relative to sbcl-0.9.13:
+ * feature: thread support on Solaris/x86, and experimental thread support
+ on OS X/x86.
* minor incompatible change: prevent the user from specializing the
new-value argument to SB-MOP:SLOT-VALUE-USING-CLASS. It's
somewhat counter to the intent of the protocol, I (CSR) think, and
;; so caveat executor.
; :sb-thread
+ ;; lutex support
+ ;;
+ ;; While on linux we are able to use futexes for our locking
+ ;; primitive, on other platforms we don't have this luxury. NJF's
+ ;; lutexes present a locking API similar to the futex-based API that
+ ;; allows for sb-thread support on x86 OS X, Solaris and
+ ;; FreeBSD.
+ ;;
+ ; :sb-lutex
+
+ ;; On some operating systems the FS segment register (used for SBCL's
+ ;; thread local storage) is not reliably preserved in signal
+ ;; handlers, so we need to restore its value from the pthread thread
+ ;; local storage.
+ ; :restore-tls-segment-register-from-tls
+
;; Support for detection of unportable code (when applied to the
;; COMMON-LISP package, or SBCL-internal pacakges) or bad-neighbourly
;; code (when applied to user-level packages), relating to material
freebsd)
printf ' :elf' >> $ltf
printf ' :freebsd' >> $ltf
+ if [ $sbcl_arch = "x86" ]; then
+ printf ' :sb-lutex :restore-tls-segment-register-from-tls' >> $ltf
+ fi
link_or_copy Config.$sbcl_arch-freebsd Config
;;
openbsd)
darwin)
printf ' :mach-o' >> $ltf
printf ' :bsd' >> $ltf
+ printf ' :darwin' >> $ltf
+ if [ $sbcl_arch = "x86" ]; then
+ printf ' :sb-lutex :restore-fs-segment-register-from-tls' >> $ltf
+ fi
link_or_copy $sbcl_arch-darwin-os.h target-arch-os.h
link_or_copy bsd-os.h target-os.h
- printf ' :darwin' >> $ltf
link_or_copy Config.$sbcl_arch-darwin Config
;;
sunos)
printf ' :elf' >> $ltf
printf ' :sunos' >> $ltf
+ if [ $sbcl_arch = "x86" ]; then
+ printf ' :sb-lutex' >> $ltf
+ fi
link_or_copy Config.$sbcl_arch-sunos Config
link_or_copy $sbcl_arch-sunos-os.h target-arch-os.h
link_or_copy sunos-os.h target-os.h
"INITIAL-FUN-CORE-ENTRY-TYPE-CODE"
"*!LOAD-TIME-VALUES*"
"LOAD-TYPE-PREDICATE"
+ #!+(and sb-thread sb-lutex) "LUTEX-TABLE-CORE-ENTRY-TYPE-CODE"
"NEW-DIRECTORY-CORE-ENTRY-TYPE-CODE"
"OPEN-FASL-OUTPUT" "PAGE-TABLE-CORE-ENTRY-TYPE-CODE"
"READ-ONLY-CORE-SPACE-ID"
#!+long-float "LONG-STACK-SC-NUMBER"
"LOWTAG-LIMIT" "LOWTAG-MASK"
"LRA-SAVE-OFFSET"
+ #!+(and sb-thread sb-lutex) "LUTEX-WIDETAG"
"MEMORY-USAGE" "MOST-POSITIVE-COST"
"N-LOWTAG-BITS"
"N-FIXNUM-TAG-BITS"
(def-type-predicate-wrapper integerp)
(def-type-predicate-wrapper listp)
(def-type-predicate-wrapper long-float-p)
+ #!+(and sb-thread sb-lutex)
+ (def-type-predicate-wrapper lutexp)
(def-type-predicate-wrapper lra-p)
(def-type-predicate-wrapper null)
(def-type-predicate-wrapper numberp)
(sb!vm::current-thread-offset-sap sb!vm::thread-os-thread-slot)))
(defun init-initial-thread ()
+ (/show0 "Entering INIT-INITIAL-THREAD")
(let ((initial-thread (%make-thread :name "initial thread"
:%alive-p t
:os-thread (current-thread-sap-id))))
(define-alien-routine "block_blockable_signals"
void)
- (declaim (inline futex-wait futex-wake))
-
- (sb!alien:define-alien-routine "futex_wait"
- int (word unsigned-long) (old-value unsigned-long))
-
- (sb!alien:define-alien-routine "futex_wake"
- int (word unsigned-long) (n unsigned-long)))
+ #!+sb-lutex
+ (progn
+ (declaim (inline %lutex-init %lutex-wait %lutex-wake
+ %lutex-lock %lutex-unlock))
+
+ (sb!alien:define-alien-routine ("lutex_init" %lutex-init)
+ int (lutex unsigned-long))
+
+ (sb!alien:define-alien-routine ("lutex_wait" %lutex-wait)
+ int (queue-lutex unsigned-long) (mutex-lutex unsigned-long))
+
+ (sb!alien:define-alien-routine ("lutex_wake" %lutex-wake)
+ int (lutex unsigned-long) (n int))
+
+ (sb!alien:define-alien-routine ("lutex_lock" %lutex-lock)
+ int (lutex unsigned-long))
+
+ (sb!alien:define-alien-routine ("lutex_unlock" %lutex-unlock)
+ int (lutex unsigned-long))
+
+ (sb!alien:define-alien-routine ("lutex_destroy" %lutex-destroy)
+ int (lutex unsigned-long))
+
+ ;; FIXME: Defining a whole bunch of alien-type machinery just for
+ ;; passing primitive lutex objects directly to foreign functions
+ ;; doesn't seem like fun right now. So instead we just manually
+ ;; pin the lutex, get its address, and let the callee untag it.
+ (defmacro with-lutex-address ((name lutex) &body body)
+ `(let ((,name ,lutex))
+ (with-pinned-objects (,name)
+ (let ((,name (sb!kernel:get-lisp-obj-address ,name)))
+ ,@body))))
+
+ (defun make-lutex ()
+ (/show0 "Entering MAKE-LUTEX")
+ ;; Suppress GC until the lutex has been properly registered with
+ ;; the GC.
+ (without-gcing
+ (let ((lutex (sb!vm::%make-lutex)))
+ (/show0 "LUTEX=..")
+ (/hexstr lutex)
+ (with-lutex-address (lutex lutex)
+ (%lutex-init lutex))
+ lutex))))
+
+ #!-sb-lutex
+ (progn
+ (declaim (inline futex-wait futex-wake))
+
+ (sb!alien:define-alien-routine "futex_wait"
+ int (word unsigned-long) (old-value unsigned-long))
+
+ (sb!alien:define-alien-routine "futex_wake"
+ int (word unsigned-long) (n unsigned-long))))
;;; used by debug-int.lisp to access interrupt contexts
#!-(and sb-fluid sb-thread) (declaim (inline sb!vm::current-thread-offset-sap))
(sb!kernel:fdocumentation 'mutex-value 'function)
"The value of the mutex. NIL if the mutex is free. Setfable.")
-#!+sb-thread
-(declaim (inline mutex-value-address))
-#!+sb-thread
-(defun mutex-value-address (mutex)
- (declare (optimize (speed 3)))
- (sb!ext:truly-the
- sb!vm:word
- (+ (sb!kernel:get-lisp-obj-address mutex)
- (- (* 3 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag))))
+#!+(and sb-thread (not sb-lutex))
+(progn
+ (declaim (inline mutex-value-address))
+ (defun mutex-value-address (mutex)
+ (declare (optimize (speed 3)))
+ (sb!ext:truly-the
+ sb!vm:word
+ (+ (sb!kernel:get-lisp-obj-address mutex)
+ (- (* 3 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag)))))
(defun get-mutex (mutex &optional (new-value *current-thread*) (wait-p t))
#!+sb-doc
value if NIL. If WAIT-P is non-NIL and the mutex is in use, sleep
until it is available"
(declare (type mutex mutex) (optimize (speed 3)))
+ (/show0 "Entering GET-MUTEX")
(unless new-value
(setq new-value *current-thread*))
#!-sb-thread
(setf (mutex-value mutex) new-value)
t)
#!+sb-thread
- (let (old)
+ (progn
(when (eql new-value (mutex-value mutex))
(warn "recursive lock attempt ~S~%" mutex)
(format *debug-io* "Thread: ~A~%" *current-thread*)
(sb!debug:backtrace most-positive-fixnum *debug-io*)
(force-output *debug-io*))
- (loop
- (unless
- (setf old (sb!vm::%instance-set-conditional mutex 2 nil new-value))
- (return t))
- (unless wait-p (return nil))
- (with-pinned-objects (mutex old)
- (futex-wait (mutex-value-address mutex)
- (sb!kernel:get-lisp-obj-address old))))))
+ ;; FIXME: sb-lutex and (not wait-p)
+ #!+sb-lutex
+ (when wait-p
+ (with-lutex-address (lutex (mutex-lutex mutex))
+ (%lutex-lock lutex))
+ (setf (mutex-value mutex) new-value))
+ #!-sb-lutex
+ (let (old)
+ (loop
+ (unless
+ (setf old (sb!vm::%instance-set-conditional mutex 2 nil
+ new-value))
+ (return t))
+ (unless wait-p (return nil))
+ (with-pinned-objects (mutex old)
+ (futex-wait (mutex-value-address mutex)
+ (sb!kernel:get-lisp-obj-address old)))))))
(defun release-mutex (mutex)
#!+sb-doc
"Release MUTEX by setting it to NIL. Wake up threads waiting for
this mutex."
(declare (type mutex mutex))
+ (/show0 "Entering RELEASE-MUTEX")
(setf (mutex-value mutex) nil)
#!+sb-thread
- (futex-wake (mutex-value-address mutex) 1))
+ (progn
+ #!+sb-lutex
+ (with-lutex-address (lutex (mutex-lutex mutex))
+ (%lutex-unlock lutex))
+ #!-sb-lutex
+ (futex-wake (mutex-value-address mutex) 1)))
;;;; waitqueues/condition variables
#!+sb-doc
"Waitqueue type."
(name nil :type (or null simple-string))
+ #!+(and sb-lutex sb-thread)
+ (lutex (make-lutex))
+ #!-sb-lutex
(data nil))
(defun make-waitqueue (&key name)
(setf (sb!kernel:fdocumentation 'waitqueue-name 'function)
"The name of the waitqueue. Setfable.")
-#!+sb-thread
-(declaim (inline waitqueue-data-address))
-#!+sb-thread
-(defun waitqueue-data-address (waitqueue)
- (declare (optimize (speed 3)))
- (sb!ext:truly-the
- sb!vm:word
- (+ (sb!kernel:get-lisp-obj-address waitqueue)
- (- (* 3 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag))))
+#!+(and sb-thread (not sb-lutex))
+(progn
+ (declaim (inline waitqueue-data-address))
+ (defun waitqueue-data-address (waitqueue)
+ (declare (optimize (speed 3)))
+ (sb!ext:truly-the
+ sb!vm:word
+ (+ (sb!kernel:get-lisp-obj-address waitqueue)
+ (- (* 3 sb!vm:n-word-bytes) sb!vm:instance-pointer-lowtag)))))
(defun condition-wait (queue mutex)
#!+sb-doc
#!-sb-thread (error "Not supported in unithread builds.")
#!+sb-thread
(let ((value (mutex-value mutex)))
+ (/show0 "CONDITION-WAITing")
+ #!+sb-lutex
+ (progn
+ (setf (mutex-value mutex) nil)
+ (with-lutex-address (queue-lutex-address (waitqueue-lutex queue))
+ (with-lutex-address (mutex-lutex-address (mutex-lutex mutex))
+ (%lutex-wait queue-lutex-address mutex-lutex-address)))
+ (setf (mutex-value mutex) value))
+ #!-sb-lutex
(unwind-protect
(let ((me *current-thread*))
;; XXX we should do something to ensure that the result of this setf
#!-sb-thread (error "Not supported in unithread builds.")
#!+sb-thread
(declare (type (and fixnum (integer 1)) n))
+ (/show0 "Entering CONDITION-NOTIFY")
#!+sb-thread
- (let ((me *current-thread*))
+ (progn
+ #!+sb-lutex
+ (with-lutex-address (lutex (waitqueue-lutex queue))
+ (%lutex-wake lutex n))
;; no problem if >1 thread notifies during the comment in
;; condition-wait: as long as the value in queue-data isn't the
;; waiting thread's id, it matters not what it is
;; XXX we should do something to ensure that the result of this setf
;; is visible to all CPUs
- (setf (waitqueue-data queue) me)
- (with-pinned-objects (queue)
- (futex-wake (waitqueue-data-address queue) n))))
+ #!-sb-lutex
+ (let ((me *current-thread*))
+ (progn
+ (setf (waitqueue-data queue) me)
+ (with-pinned-objects (queue)
+ (futex-wake (waitqueue-data-address queue) n))))))
(defun condition-broadcast (queue)
#!+sb-doc
"Notify all threads waiting on QUEUE."
- (condition-notify queue most-positive-fixnum))
+ (condition-notify queue
+ ;; On a 64-bit platform truncating M-P-F to an int results
+ ;; in -1, which wakes up only one thread.
+ (ldb (byte 29 0)
+ most-positive-fixnum)))
;;;; semaphores
`(locally ,@body)
#!+sb-thread
`(without-interrupts
- (with-mutex ((session-lock ,session))
- ,@body)))
+ (with-mutex ((session-lock ,session))
+ ,@body)))
(defun new-session ()
(make-session :threads (list *current-thread*)
:interactive-threads (list *current-thread*)))
(defun init-job-control ()
- (setf *session* (new-session)))
+ (/show0 "Entering INIT-JOB-CONTROL")
+ (setf *session* (new-session))
+ (/show0 "Exiting INIT-JOB-CONTROL"))
(defun %delete-thread-from-session (thread session)
(with-session-lock (session)
#!+sb-thread
(defun handle-thread-exit (thread)
(with-mutex (*all-threads-lock*)
+ (/show0 "HANDLING THREAD EXIT")
+ #!+sb-lutex
+ (when (thread-interruptions-lock thread)
+ (/show0 "FREEING MUTEX LUTEX")
+ (with-lutex-address (lutex (mutex-lutex (thread-interruptions-lock thread)))
+ (%lutex-destroy lutex)))
(setq *all-threads* (delete thread *all-threads*)))
(when *session*
(%delete-thread-from-session thread *session*)))
#!+sb-thread
(let ((was-foreground t))
(loop
+ (/show0 "Looping in GET-FOREGROUND")
(with-session-lock (*session*)
(let ((int-t (session-interactive-threads *session*)))
(when (eq (car int-t) *current-thread*)
(sb!unix::unix-setsid)
(let* ((sb!impl::*stdin*
(make-fd-stream in :input t :buffering :line
- :dual-channel-p t))
+ :dual-channel-p t))
(sb!impl::*stdout*
(make-fd-stream out :output t :buffering :line
:dual-channel-p t))
;; Called from the signal handler.
(defun run-interruption ()
(in-interruption ()
- (let ((interruption (with-interruptions-lock (*current-thread*)
- (pop (thread-interruptions *current-thread*)))))
- (with-interrupts
- (funcall interruption)))))
+ (loop
+ (let ((interruption (with-interruptions-lock (*current-thread*)
+ (pop (thread-interruptions *current-thread*)))))
+ (if interruption
+ (with-interrupts
+ (funcall interruption))
+ (return))))))
;; The order of interrupt execution is peculiar. If thread A
;; interrupts thread B with I1, I2 and B for some reason receives I1
#!+sb-doc
"Mutex type."
(name nil :type (or null simple-string))
- (value nil))
+ (value nil)
+ #!+(and sb-lutex sb-thread)
+ (lutex (make-lutex)))
(def!struct spinlock
#!+sb-doc
(with-unique-names (got mutex1)
`(let ((,mutex1 ,mutex)
,got)
+ (/show0 "WITH-MUTEX")
(unwind-protect
;; FIXME: async unwind in SETQ form
(when (setq ,got (get-mutex ,mutex1 ,value ,wait-p))
;; (in the ordinary build procedure anyway) essentially everything
;; which is reachable at this point will remain reachable for the
;; entire run.
- #+sbcl (sb-ext:purify)
+ ;;
+ ;; (Except that purifying actually slows down GENCGC). -- JES, 2006-05-30
+ #+(and sbcl (not gencgc))
+ (sb-ext:purify)
(values))
fdefn ; 01010110
no-tls-value-marker ; 01011010
- unused01 ; 01011110
+ #!-sb-lutex
+ unused01
+ #!+sb-lutex
+ lutex ; 01011110
unused02 ; 01100010
unused03 ; 01100110
unused04 ; 01101010
(defconstant new-directory-core-entry-type-code 3861)
(defconstant initial-fun-core-entry-type-code 3863)
(defconstant page-table-core-entry-type-code 3880)
+#!+sb-lutex
+(defconstant lutex-table-core-entry-type-code 3887)
(defconstant end-core-entry-type-code 3840)
(declaim (ftype (function (sb!vm:word) sb!vm:word) write-word))
(!define-type-vops fdefn-p nil nil nil
(fdefn-widetag))
+#!+(and sb-thread sb-lutex)
+(!define-type-vops lutexp nil nil nil
+ (lutex-widetag))
+
(!define-type-vops funcallable-instance-p nil nil nil
(funcallable-instance-header-widetag))
(real :c-type "double" :length #!-x86-64 2 #!+x86-64 1)
(imag :c-type "double" :length #!-x86-64 2 #!+x86-64 1))
+#!+(and sb-thread sb-lutex)
+(define-primitive-object (lutex
+ :lowtag other-pointer-lowtag
+ :widetag lutex-widetag
+ :alloc-trans %make-lutex)
+ (gen :c-type "long" :length 1)
+ (live :c-type "long" :length 1)
+ (next :c-type "struct lutex *" :length 1)
+ (prev :c-type "struct lutex *" :length 1)
+ (mutex :c-type "pthread_mutex_t *"
+ :length 1)
+ (condition-variable :c-type "pthread_cond_t *"
+ :length 1))
+
;;; this isn't actually a lisp object at all, it's a c structure that lives
;;; in c-land. However, we need sight of so many parts of it from Lisp that
;;; it makes sense to define it here anyway, so that the GENESIS machinery
(defknown make-value-cell (t) t
(flushable movable))
+;;;; threading
+
+#!+(and sb-thread sb-lutex)
+(progn
+ (defknown sb!vm::%make-lutex () sb!vm::lutex ())
+ (defknown sb!vm::lutexp (t) boolean (foldable flushable)))
+
(defknown (dynamic-space-free-pointer binding-stack-pointer-sap
control-stack-pointer-sap) ()
system-area-pointer
# files for more information.
CFLAGS = -g -Wall -O2 -fdollars-in-identifiers
-OS_SRC = bsd-os.c x86-bsd-os.c darwin-os.c ppc-darwin-dlshim.c x86-darwin-langinfo.c
+OS_SRC = bsd-os.c x86-bsd-os.c darwin-os.c x86-darwin-os.c ppc-darwin-dlshim.c x86-darwin-langinfo.c
OS_LIBS = -lSystem -lc -ldl
OS_OBJS = x86-darwin-rospace.o
# dlopen() etc., which in turn depend on dynamic linking of the
# runtime.
LINKFLAGS += -dynamic -export-dynamic
+LINKFLAGS += $(shell if grep LISP_FEATURE_SB_THREAD genesis/config.h \
+ > /dev/null 2>&1; \
+ then echo "-lpthread"; fi)
CC=gcc
-CFLAGS = -O2 -Wall -DSVR4
-ASFLAGS = -Wall -DSVR4
+CFLAGS = -g3 -O2 -Wall -D__EXTENSIONS__ -D_POSIX_C_SOURCE=199506L -DSVR4
+ASFLAGS = -Wall
LD = ld
NM = nm -xgp
GREP = ggrep
COMMON_SRC = alloc.c backtrace.c breakpoint.c coreparse.c \
dynbind.c gc-common.c globals.c interr.c interrupt.c \
- monitor.c os-common.c parse.c print.c purify.c \
+ monitor.c os-common.c parse.c print.c purify.c pthread-lutex.c \
regnames.c run-program.c runtime.c save.c search.c \
- thread.c time.c util.c validate.c vars.c wrap.c
+ thread.c time.c util.c validate.c vars.c wrap.c
C_SRC = $(COMMON_SRC) ${ARCH_SRC} ${OS_SRC} ${GC_SRC}
#include <sys/file.h>
#include <unistd.h>
#include <assert.h>
+#include <errno.h>
#include "sbcl.h"
#include "./signal.h"
#include "os.h"
os_context_t *context = arch_os_get_context(&void_context);
void *fault_addr = arch_get_bad_addr(signal, siginfo, context);
-#if defined(MEMORY_FAULT_DEBUG)
- fprintf(stderr, "Memory fault at: %p, PC: %x\n", fault_addr, *os_context_pc_addr(context));
-#if defined(ARCH_HAS_STACK_POINTER)
- fprintf(stderr, "Stack pointer: %x\n", *os_context_sp_addr(context));
-#endif
+#if defined(LISP_FEATURE_RESTORE_TLS_SEGMENT_REGISTER_FROM_CONTEXT)
+ FSHOW_SIGNAL((stderr, "/ TLS: restoring fs: %p in memory_fault_handler\n",
+ *CONTEXT_ADDR_FROM_STEM(fs)));
+ os_restore_tls_segment_register(context);
#endif
+ FSHOW((stderr, "Memory fault at: %p, PC: %x\n", fault_addr, *os_context_pc_addr(context)));
+
if (!gencgc_handle_wp_violation(fault_addr))
if(!handle_guard_page_triggered(context,fault_addr)) {
#ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
undoably_install_low_level_interrupt_handler(SIG_MEMORY_FAULT2,
memory_fault_handler);
#endif
+
+#ifdef LISP_FEATURE_SB_THREAD
+ undoably_install_low_level_interrupt_handler(SIG_INTERRUPT_THREAD,
+ interrupt_thread_handler);
+ undoably_install_low_level_interrupt_handler(SIG_STOP_FOR_GC,
+ sig_stop_for_gc_handler);
+#ifdef SIG_RESUME_FROM_GC
+ undoably_install_low_level_interrupt_handler(SIG_RESUME_FROM_GC,
+ sig_stop_for_gc_handler);
+#endif
+#endif
+
SHOW("leaving os_install_interrupt_handlers()");
}
-#else /* Currently Darwin only */
+#else /* Currently PPC/Darwin/Cheney only */
static void
sigsegv_handler(int signal, siginfo_t *info, void* void_context)
#endif /* LISP_FEATURE_X86 */
}
#endif /* __FreeBSD__ */
-\f
-/* threads */
-
-/* no threading in any *BSD variant on any CPU (yet? in sbcl-0.8.0 anyway) */
-#ifdef LISP_FEATURE_SB_THREAD
-#error "Define threading support functions"
-#else
-int arch_os_thread_init(struct thread *thread) {
- stack_t sigstack;
-#ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
- /* Signal handlers are run on the control stack, so if it is exhausted
- * we had better use an alternate stack for whatever signal tells us
- * we've exhausted it */
- sigstack.ss_sp=((void *) thread)+dynamic_values_bytes;
- sigstack.ss_flags=0;
- sigstack.ss_size = 32*SIGSTKSZ;
- sigaltstack(&sigstack,0);
-#endif
- return 1; /* success */
-}
-int arch_os_thread_cleanup(struct thread *thread) {
- return 1; /* success */
-}
-#endif
#ifdef LISP_FEATURE_DARWIN
/* defined in ppc-darwin-os.c instead */
*/
#define SIG_MEMORY_FAULT2 SIGBUS
+#define SIG_INTERRUPT_THREAD (SIGINFO)
+#define SIG_STOP_FOR_GC (SIGUSR1)
+#define SIG_RESUME_FROM_GC (SIGUSR2)
+
#elif defined __OpenBSD__
typedef struct sigcontext os_context_t;
#define SIG_MEMORY_FAULT SIGSEGV
#elif defined LISP_FEATURE_DARWIN
- /* man pages claim that the third argument is a sigcontext struct,
- but ucontext_t is defined, matches sigcontext where sensible,
- offers better access to mcontext, and is of course the SUSv2-
- mandated type of the third argument, so we use that instead.
- If Apple is going to break ucontext_t out of spite, I'm going
- to be cross with them ;) -- PRM */
-
-#if defined(LISP_FEATURE_X86)
-#include <sys/ucontext.h>
-#include <sys/_types.h>
-typedef struct ucontext os_context_t;
-#else
-#include <ucontext.h>
-typedef ucontext_t os_context_t;
-#endif
-
-#define SIG_MEMORY_FAULT SIGBUS
-
+#include "darwin-os.h"
#else
#error unsupported BSD variant
#endif
#include "validate.h"
#include "gc-internal.h"
+/* lutex stuff */
+#if defined(LISP_FEATURE_SB_THREAD) && defined(LISP_FEATURE_SB_LUTEX)
+#include "genesis/sap.h"
+#endif
+
+
unsigned char build_id[] =
#include "../../output/build-id.tmp"
;
initial_function = (lispobj)*ptr;
break;
+#if defined(LISP_FEATURE_SB_THREAD) && defined(LISP_FEATURE_SB_LUTEX)
+ case LUTEX_TABLE_CORE_ENTRY_TYPE_CODE:
+ SHOW("LUTEX_TABLE_CORE_ENTRY_TYPE_CODE case");
+ {
+ size_t n_lutexes = *ptr;
+ size_t fdoffset = (*(ptr + 1) + 1) * (os_vm_page_size);
+ size_t data_length = n_lutexes * sizeof(struct sap *);
+ struct lutex **lutexes_to_resurrect = malloc(data_length);
+ long bytes_read;
+
+ lseek(fd, fdoffset + file_offset, SEEK_SET);
+
+ FSHOW((stderr, "attempting to read %ld lutexes from core\n", n_lutexes));
+ bytes_read = read(fd, lutexes_to_resurrect, data_length);
+
+ /* XXX */
+ if (bytes_read != data_length) {
+ lose("Could not read the lutex table");
+ }
+ else {
+ int i;
+
+ for (i=0; i<n_lutexes; ++i) {
+ struct lutex *lutex = lutexes_to_resurrect[i];
+
+ FSHOW((stderr, "re-init'ing lutex @ %p\n", lutex));
+ lutex_init(lutex);
+ }
+
+ free(lutexes_to_resurrect);
+ }
+ break;
+ }
+#endif
+
#ifdef LISP_FEATURE_GENCGC
case PAGE_TABLE_CORE_ENTRY_TYPE_CODE:
{
#include <limits.h>
#include <mach-o/dyld.h>
#include "bsd-os.h"
+#include <errno.h>
char *
os_get_runtime_executable_path()
return copied_string(path);
}
+
--- /dev/null
+#ifndef _DARWIN_OS_H
+#define _DARWIN_OS_H
+
+/* this is meant to be included from bsd-os.h */
+
+#include <mach/mach_init.h>
+#include <mach/task.h>
+
+/* man pages claim that the third argument is a sigcontext struct,
+ but ucontext_t is defined, matches sigcontext where sensible,
+ offers better access to mcontext, and is of course the SUSv2-
+ mandated type of the third argument, so we use that instead.
+ If Apple is going to break ucontext_t out of spite, I'm going
+ to be cross with them ;) -- PRM */
+
+#if defined(LISP_FEATURE_X86)
+#include <sys/ucontext.h>
+#include <sys/_types.h>
+typedef struct ucontext os_context_t;
+
+#else
+#include <ucontext.h>
+typedef ucontext_t os_context_t;
+#endif
+
+#define SIG_MEMORY_FAULT SIGBUS
+
+#define SIG_INTERRUPT_THREAD (SIGINFO)
+#define SIG_STOP_FOR_GC (SIGUSR1)
+#define SIG_RESUME_FROM_GC (SIGUSR2)
+
+#endif /* _DARWIN_OS_H */
#include "genesis/instance.h"
#include "genesis/layout.h"
+#ifdef LUTEX_WIDETAG
+#include "genesis/lutex.h"
+#endif
+
/* forward declarations */
page_index_t gc_find_freeish_pages(long *restart_page_ptr, long nbytes,
int unboxed);
* prevent a GC when a large number of new live objects have been
* added, in which case a GC could be a waste of time */
double min_av_mem_age;
+
+ /* A linked list of lutex structures in this generation, used for
+ * implementing lutex finalization. */
+#ifdef LUTEX_WIDETAG
+ struct lutex *lutexes;
+#else
+ void *lutexes;
+#endif
};
/* an array of generation structures. There needs to be one more
page_index_t last_page;
long bytes_found;
page_index_t i;
+ int ret;
/*
FSHOW((stderr,
gc_assert((alloc_region->first_page == 0)
&& (alloc_region->last_page == -1)
&& (alloc_region->free_pointer == alloc_region->end_addr));
- thread_mutex_lock(&free_pages_lock);
+ ret = thread_mutex_lock(&free_pages_lock);
+ gc_assert(ret == 0);
if (unboxed) {
first_page =
generations[gc_alloc_generation].alloc_unboxed_start_page;
/* do we only want to call this on special occasions? like for boxed_region? */
set_alloc_pointer((lispobj)(((char *)heap_base) + last_free_page*PAGE_BYTES));
}
- thread_mutex_unlock(&free_pages_lock);
+ ret = thread_mutex_unlock(&free_pages_lock);
+ gc_assert(ret == 0);
/* we can do this after releasing free_pages_lock */
if (gencgc_zero_check) {
long orig_first_page_bytes_used;
long region_size;
long byte_cnt;
+ int ret;
first_page = alloc_region->first_page;
next_page = first_page+1;
- thread_mutex_lock(&free_pages_lock);
+ ret = thread_mutex_lock(&free_pages_lock);
+ gc_assert(ret == 0);
if (alloc_region->free_pointer != alloc_region->start_addr) {
/* some bytes were allocated in the region */
orig_first_page_bytes_used = page_table[first_page].bytes_used;
page_table[next_page].allocated = FREE_PAGE_FLAG;
next_page++;
}
- thread_mutex_unlock(&free_pages_lock);
+ ret = thread_mutex_unlock(&free_pages_lock);
+ gc_assert(ret == 0);
+
/* alloc_region is per-thread, we're ok to do this unlocked */
gc_set_region_empty(alloc_region);
}
int more;
long bytes_used;
page_index_t next_page;
+ int ret;
- thread_mutex_lock(&free_pages_lock);
+ ret = thread_mutex_lock(&free_pages_lock);
+ gc_assert(ret == 0);
if (unboxed) {
first_page =
last_free_page = last_page+1;
set_alloc_pointer((lispobj)(((char *)heap_base) + last_free_page*PAGE_BYTES));
}
- thread_mutex_unlock(&free_pages_lock);
+ ret = thread_mutex_unlock(&free_pages_lock);
+ gc_assert(ret == 0);
#ifdef READ_PROTECT_FREE_PAGES
os_protect(page_address(first_page),
\f
/*
+ * Lutexes. Using the normal finalization machinery for finalizing
+ * lutexes is tricky, since the finalization depends on working lutexes.
+ * So we track the lutexes in the GC and finalize them manually.
+ */
+
+#if defined(LUTEX_WIDETAG)
+
+/*
+ * Start tracking LUTEX in the GC, by adding it to the linked list of
+ * lutexes in the nursery generation. The caller is responsible for
+ * locking, and GCs must be inhibited until the registration is
+ * complete.
+ */
+void
+gencgc_register_lutex (struct lutex *lutex) {
+ int index = find_page_index(lutex);
+ generation_index_t gen;
+ struct lutex *head;
+
+ /* This lutex is in static space, so we don't need to worry about
+ * finalizing it.
+ */
+ if (index == -1)
+ return;
+
+ gen = page_table[index].gen;
+
+ gc_assert(gen >= 0);
+ gc_assert(gen < NUM_GENERATIONS);
+
+ head = generations[gen].lutexes;
+
+ lutex->gen = gen;
+ lutex->next = head;
+ lutex->prev = NULL;
+ if (head)
+ head->prev = lutex;
+ generations[gen].lutexes = lutex;
+}
+
+/*
+ * Stop tracking LUTEX in the GC by removing it from the appropriate
+ * linked lists. This will only be called during GC, so no locking is
+ * needed.
+ */
+void
+gencgc_unregister_lutex (struct lutex *lutex) {
+ if (lutex->prev) {
+ lutex->prev->next = lutex->next;
+ } else {
+ generations[lutex->gen].lutexes = lutex->next;
+ }
+
+ if (lutex->next) {
+ lutex->next->prev = lutex->prev;
+ }
+
+ lutex->next = NULL;
+ lutex->prev = NULL;
+ lutex->gen = -1;
+}
+
+/*
+ * Mark all lutexes in generation GEN as not live.
+ */
+static void
+unmark_lutexes (generation_index_t gen) {
+ struct lutex *lutex = generations[gen].lutexes;
+
+ while (lutex) {
+ lutex->live = 0;
+ lutex = lutex->next;
+ }
+}
+
+/*
+ * Finalize all lutexes in generation GEN that have not been marked live.
+ */
+static void
+reap_lutexes (generation_index_t gen) {
+ struct lutex *lutex = generations[gen].lutexes;
+
+ while (lutex) {
+ struct lutex *next = lutex->next;
+ if (!lutex->live) {
+ lutex_destroy(lutex);
+ gencgc_unregister_lutex(lutex);
+ }
+ lutex = next;
+ }
+}
+
+/*
+ * Mark LUTEX as live.
+ */
+static void
+mark_lutex (lispobj tagged_lutex) {
+ struct lutex *lutex = (struct lutex*) native_pointer(tagged_lutex);
+
+ lutex->live = 1;
+}
+
+/*
+ * Move all lutexes in generation FROM to generation TO.
+ */
+static void
+move_lutexes (generation_index_t from, generation_index_t to) {
+ struct lutex *tail = generations[from].lutexes;
+
+ /* Nothing to move */
+ if (!tail)
+ return;
+
+ /* Change the generation of the lutexes in FROM. */
+ while (tail->next) {
+ tail->gen = to;
+ tail = tail->next;
+ }
+ tail->gen = to;
+
+ /* Link the last lutex in the FROM list to the start of the TO list */
+ tail->next = generations[to].lutexes;
+
+ /* And vice versa */
+ if (generations[to].lutexes) {
+ generations[to].lutexes->prev = tail;
+ }
+
+ /* And update the generations structures to match this */
+ generations[to].lutexes = generations[from].lutexes;
+ generations[from].lutexes = NULL;
+}
+
+static long
+scav_lutex(lispobj *where, lispobj object)
+{
+ mark_lutex((lispobj) where);
+
+ return CEILING(sizeof(struct lutex)/sizeof(lispobj), 2);
+}
+
+static lispobj
+trans_lutex(lispobj object)
+{
+ struct lutex *lutex = native_pointer(object);
+ lispobj copied;
+ size_t words = CEILING(sizeof(struct lutex)/sizeof(lispobj), 2);
+ gc_assert(is_lisp_pointer(object));
+ copied = copy_object(object, words);
+
+ /* Update the links, since the lutex moved in memory. */
+ if (lutex->next) {
+ lutex->next->prev = native_pointer(copied);
+ }
+
+ if (lutex->prev) {
+ lutex->prev->next = native_pointer(copied);
+ } else {
+ generations[lutex->gen].lutexes = native_pointer(copied);
+ }
+
+ return copied;
+}
+
+static long
+size_lutex(lispobj *where)
+{
+ return CEILING(sizeof(struct lutex)/sizeof(lispobj), 2);
+}
+#endif /* LUTEX_WIDETAG */
+
+\f
+/*
* weak pointers
*/
#endif
case SAP_WIDETAG:
case WEAK_POINTER_WIDETAG:
+#ifdef LUTEX_WIDETAG
+ case LUTEX_WIDETAG:
+#endif
break;
default:
#endif
case SAP_WIDETAG:
case WEAK_POINTER_WIDETAG:
+#ifdef LUTEX_WIDETAG
+ case LUTEX_WIDETAG:
+#endif
count = (sizetab[widetag_of(*start)])(start);
break;
#endif
+static void
+preserve_context_registers (os_context_t *c)
+{
+ void **ptr;
+ /* On Darwin the signal context isn't a contiguous block of memory,
+ * so just preserve_pointering its contents won't be sufficient.
+ */
+#if defined(LISP_FEATURE_DARWIN)
+#if defined LISP_FEATURE_X86
+ preserve_pointer((void*)*os_context_register_addr(c,reg_EAX));
+ preserve_pointer((void*)*os_context_register_addr(c,reg_ECX));
+ preserve_pointer((void*)*os_context_register_addr(c,reg_EDX));
+ preserve_pointer((void*)*os_context_register_addr(c,reg_EBX));
+ preserve_pointer((void*)*os_context_register_addr(c,reg_ESI));
+ preserve_pointer((void*)*os_context_register_addr(c,reg_EDI));
+ preserve_pointer((void*)*os_context_pc_addr(c));
+#else
+ #error "preserve_context_registers needs to be tweaked for non-x86 Darwin"
+#endif
+#endif
+ for(ptr = (void **)(c+1); ptr>=(void **)c; ptr--) {
+ preserve_pointer(*ptr);
+ }
+}
+
/* Garbage collect a generation. If raise is 0 then the remains of the
* generation are not raised to the next generation. */
static void
/* Initialize the weak pointer list. */
weak_pointers = NULL;
+#ifdef LUTEX_WIDETAG
+ unmark_lutexes(generation);
+#endif
+
/* When a generation is not being raised it is transported to a
* temporary generation (NUM_GENERATIONS), and lowered when
* done. Set up this new generation. There should be no pages
if (esp1>=(void **)th->control_stack_start &&
esp1<(void **)th->control_stack_end) {
if(esp1<esp) esp=esp1;
- for(ptr = (void **)(c+1); ptr>=(void **)c; ptr--) {
- preserve_pointer(*ptr);
- }
+ preserve_context_registers(c);
}
}
}
generations[generation].num_gc = 0;
else
++generations[generation].num_gc;
+
+#ifdef LUTEX_WIDETAG
+ reap_lutexes(generation);
+ if (raise)
+ move_lutexes(generation, generation+1);
+#endif
}
/* Update last_free_page, then SymbolValue(ALLOCATION_POINTER). */
generations[page].gc_trigger = 2000000;
generations[page].num_gc = 0;
generations[page].cum_sum_bytes_allocated = 0;
+ generations[page].lutexes = NULL;
}
if (gencgc_verbose > 1)
scavtab[WEAK_POINTER_WIDETAG] = scav_weak_pointer;
transother[SIMPLE_ARRAY_WIDETAG] = trans_boxed_large;
+#ifdef LUTEX_WIDETAG
+ scavtab[LUTEX_WIDETAG] = scav_lutex;
+ transother[LUTEX_WIDETAG] = trans_lutex;
+ sizetab[LUTEX_WIDETAG] = size_lutex;
+#endif
+
heap_base = (void*)DYNAMIC_SPACE_START;
/* Initialize each page structure. */
generations[i].bytes_consed_between_gc = 2000000;
generations[i].trigger_age = 1;
generations[i].min_av_mem_age = 0.75;
+ generations[i].lutexes = NULL;
}
/* Initialize gc_alloc. */
page++;
} while ((long)page_address(page) < alloc_ptr);
+#ifdef LUTEX_WIDETAG
+ /* Lutexes have been registered in generation 0 by coreparse, and
+ * need to be moved to the right one manually.
+ */
+ move_lutexes(0, PSEUDO_STATIC_GENERATION);
+#endif
+
last_free_page = page;
generations[gen].bytes_allocated = PAGE_BYTES*page;
sigaddset(s, SIGVTALRM);
sigaddset(s, SIGPROF);
sigaddset(s, SIGWINCH);
+
+#if !((defined(LISP_FEATURE_DARWIN) || defined(LISP_FEATURE_FREEBSD)) && defined(LISP_FEATURE_SB_THREAD))
sigaddset(s, SIGUSR1);
sigaddset(s, SIGUSR2);
+#endif
+
#ifdef LISP_FEATURE_SB_THREAD
sigaddset(s, SIG_INTERRUPT_THREAD);
#endif
{
sigaddset_deferrable(s);
#ifdef LISP_FEATURE_SB_THREAD
+#ifdef SIG_RESUME_FROM_GC
+ sigaddset(s, SIG_RESUME_FROM_GC);
+#endif
sigaddset(s, SIG_STOP_FOR_GC);
#endif
}
struct thread *thread;
struct interrupt_data *data;
- check_blockables_blocked_or_lose();
+ FSHOW_SIGNAL((stderr, "/entering interrupt_handle_pending\n"));
+ check_blockables_blocked_or_lose();
thread=arch_os_get_current_thread();
data=thread->interrupt_data;
/* If pseudo_atomic_interrupted is set then the interrupt is going
* to be handled now, ergo it's safe to clear it. */
-
- /* CLH: 20060220 FIXME This sould probably be arch_clear_p_a_i but
- * the behavior of arch_clear_p_a_i and clear_p_a_i are slightly
- * different on PPC. */
arch_clear_pseudo_atomic_interrupted(context);
if (SymbolValue(GC_INHIBIT,thread)==NIL) {
boolean were_in_lisp;
#endif
union interrupt_handler handler;
+
check_blockables_blocked_or_lose();
+
+
#ifndef LISP_FEATURE_WIN32
if (sigismember(&deferrable_sigset,signal))
check_interrupts_enabled_or_lose(context);
#endif
-#ifdef LISP_FEATURE_LINUX
+#if defined(LISP_FEATURE_LINUX) || defined(RESTORE_FP_CONTROL_FROM_CONTEXT)
/* Under Linux on some architectures, we appear to have to restore
the FPU control word from the context, as after the signal is
delivered we appear to have a null FPU control word. */
os_restore_fp_control(context);
#endif
+
+
handler = interrupt_handlers[signal];
if (ARE_SAME_HANDLER(handler.c, SIG_IGN)) {
sigset_t unblock;
sigemptyset(&unblock);
sigaddset(&unblock, SIG_STOP_FOR_GC);
+#ifdef SIG_RESUME_FROM_GC
+ sigaddset(&unblock, SIG_RESUME_FROM_GC);
+#endif
thread_sigmask(SIG_UNBLOCK, &unblock, 0);
}
#endif
* pending handler before calling it. Trust the handler to finish
* with the siginfo before enabling interrupts. */
void (*pending_handler) (int, siginfo_t*, void*)=data->pending_handler;
+ os_context_t *context = arch_os_get_context(&v_context);
+
data->pending_handler=0;
(*pending_handler)(data->pending_signal,&(data->pending_info), v_context);
}
data->pending_signal = signal;
if(info)
memcpy(&(data->pending_info), info, sizeof(siginfo_t));
+
+ FSHOW_SIGNAL((stderr, "/store_signal_data_for_later: signal: %d\n", signal));
+
if(context) {
/* the signal mask in the context (from before we were
* interrupted) is copied to be restored when
maybe_now_maybe_later(int signal, siginfo_t *info, void *void_context)
{
os_context_t *context = arch_os_get_context(&void_context);
- struct thread *thread=arch_os_get_current_thread();
- struct interrupt_data *data=thread->interrupt_data;
-#ifdef LISP_FEATURE_LINUX
+
+ struct thread *thread;
+ struct interrupt_data *data;
+
+ thread=arch_os_get_current_thread();
+ data=thread->interrupt_data;
+
+#if defined(LISP_FEATURE_LINUX) || defined(RESTORE_FP_CONTROL_FROM_CONTEXT)
os_restore_fp_control(context);
#endif
+
if(maybe_defer_handler(interrupt_handle_now,data,signal,info,context))
return;
interrupt_handle_now(signal, info, context);
{
os_context_t *context = (os_context_t*)void_context;
-#ifdef LISP_FEATURE_LINUX
+#if defined(LISP_FEATURE_LINUX) || defined(RESTORE_FP_CONTROL_FROM_CONTEXT)
os_restore_fp_control(context);
#endif
+
check_blockables_blocked_or_lose();
check_interrupts_enabled_or_lose(context);
interrupt_low_level_handlers[signal](signal, info, void_context);
low_level_maybe_now_maybe_later(int signal, siginfo_t *info, void *void_context)
{
os_context_t *context = arch_os_get_context(&void_context);
- struct thread *thread=arch_os_get_current_thread();
- struct interrupt_data *data=thread->interrupt_data;
-#ifdef LISP_FEATURE_LINUX
+ struct thread *thread;
+ struct interrupt_data *data;
+
+ thread=arch_os_get_current_thread();
+ data=thread->interrupt_data;
+
+#if defined(LISP_FEATURE_LINUX) || defined(RESTORE_FP_CONTROL_FROM_CONTEXT)
os_restore_fp_control(context);
#endif
+
if(maybe_defer_handler(low_level_interrupt_handle_now,data,
signal,info,context))
return;
sig_stop_for_gc_handler(int signal, siginfo_t *info, void *void_context)
{
os_context_t *context = arch_os_get_context(&void_context);
+
struct thread *thread=arch_os_get_current_thread();
sigset_t ss;
- if ((arch_pseudo_atomic_atomic(context) ||
+ if ((arch_pseudo_atomic_atomic(context) ||
SymbolValue(GC_INHIBIT,thread) != NIL)) {
SetSymbolValue(STOP_FOR_GC_PENDING,T,thread);
if (SymbolValue(GC_INHIBIT,thread) == NIL)
thread->state=STATE_SUSPENDED;
FSHOW_SIGNAL((stderr,"thread=%lu suspended\n",thread->os_thread));
+#if defined(SIG_RESUME_FROM_GC)
+ sigemptyset(&ss); sigaddset(&ss,SIG_RESUME_FROM_GC);
+#else
sigemptyset(&ss); sigaddset(&ss,SIG_STOP_FOR_GC);
+#endif
+
/* It is possible to get SIGCONT (and probably other
* non-blockable signals) here. */
+#ifdef SIG_RESUME_FROM_GC
+ {
+ int sigret;
+ do { sigwait(&ss, &sigret); }
+ while (sigret != SIG_RESUME_FROM_GC);
+ }
+#else
while (sigwaitinfo(&ss,0) != SIG_STOP_FOR_GC);
+#endif
+
FSHOW_SIGNAL((stderr,"thread=%lu resumed\n",thread->os_thread));
if(thread->state!=STATE_RUNNING) {
lose("sig_stop_for_gc_handler: wrong thread state on wakeup: %ld\n",
extern lispobj call_into_lisp(lispobj fun, lispobj *args, int nargs);
extern void post_signal_tramp(void);
+extern void call_into_lisp_tramp(void);
void
arrange_return_to_lisp_function(os_context_t *context, lispobj function)
{
u32 *sp=(u32 *)*os_context_register_addr(context,reg_ESP);
+#if defined(LISP_FEATURE_DARWIN)
+ u32 *register_save_area = (u32 *)os_validate(0, 0x40);
+
+ FSHOW_SIGNAL((stderr, "/arrange_return_to_lisp_function: preparing to go to function %x, sp: %x\n", function, sp));
+ FSHOW_SIGNAL((stderr, "/arrange_return_to_lisp_function: context: %x, &context %x\n", context, &context));
+
+ /* 1. os_validate (malloc/mmap) register_save_block
+ * 2. copy register state into register_save_block
+ * 3. put a pointer to register_save_block in a register in the context
+ * 4. set the context's EIP to point to a trampoline which:
+ * a. builds the fake stack frame from the block
+ * b. frees the block
+ * c. calls the function
+ */
+
+ *register_save_area = *os_context_pc_addr(context);
+ *(register_save_area + 1) = function;
+ *(register_save_area + 2) = *os_context_register_addr(context,reg_EDI);
+ *(register_save_area + 3) = *os_context_register_addr(context,reg_ESI);
+ *(register_save_area + 4) = *os_context_register_addr(context,reg_EDX);
+ *(register_save_area + 5) = *os_context_register_addr(context,reg_ECX);
+ *(register_save_area + 6) = *os_context_register_addr(context,reg_EBX);
+ *(register_save_area + 7) = *os_context_register_addr(context,reg_EAX);
+ *(register_save_area + 8) = *context_eflags_addr(context);
+
+ *os_context_pc_addr(context) = call_into_lisp_tramp;
+ *os_context_register_addr(context,reg_ECX) = register_save_area;
+#else
+
/* return address for call_into_lisp: */
*(sp-15) = (u32)post_signal_tramp;
*(sp-14) = function; /* args for call_into_lisp : function*/
*(sp-2)=*os_context_register_addr(context,reg_EBP);
*(sp-1)=*os_context_pc_addr(context);
+#endif
+
#elif defined(LISP_FEATURE_X86_64)
u64 *sp=(u64 *)*os_context_register_addr(context,reg_RSP);
/* return address for call_into_lisp: */
#endif
#ifdef LISP_FEATURE_X86
+
+#if !defined(LISP_FEATURE_DARWIN)
*os_context_pc_addr(context) = (os_context_register_t)call_into_lisp;
*os_context_register_addr(context,reg_ECX) = 0;
*os_context_register_addr(context,reg_EBP) = (os_context_register_t)(sp-2);
(os_context_register_t)(sp-15);
#else
*os_context_register_addr(context,reg_ESP) = (os_context_register_t)(sp-15);
-#endif
+#endif /* __NETBSD__ */
+#endif /* LISP_FEATURE_DARWIN */
+
#elif defined(LISP_FEATURE_X86_64)
*os_context_pc_addr(context) = (os_context_register_t)call_into_lisp;
*os_context_register_addr(context,reg_RCX) = 0;
interrupt_thread_handler(int num, siginfo_t *info, void *v_context)
{
os_context_t *context = (os_context_t*)arch_os_get_context(&v_context);
+
/* let the handler enable interrupts again when it sees fit */
sigaddset_deferrable(os_context_sigmask_addr(context));
arrange_return_to_lisp_function(context, SymbolFunction(RUN_INTERRUPTION));
else {
sigset_t new;
sigemptyset(&new);
+#if defined(SIG_RESUME_FROM_GC)
+ sigaddset(&new,SIG_RESUME_FROM_GC);
+#endif
sigaddset(&new,SIG_STOP_FOR_GC);
thread_sigmask(SIG_UNBLOCK,&new,0);
}
unblock_me_trampoline(int signal, siginfo_t *info, void *void_context)
{
sigset_t unblock;
+
sigemptyset(&unblock);
sigaddset(&unblock, signal);
thread_sigmask(SIG_UNBLOCK, &unblock, 0);
low_level_unblock_me_trampoline(int signal, siginfo_t *info, void *void_context)
{
sigset_t unblock;
+
sigemptyset(&unblock);
sigaddset(&unblock, signal);
thread_sigmask(SIG_UNBLOCK, &unblock, 0);
#define _INCLUDE_INTERRUPT_H_
#include <signal.h>
+#include <string.h>
/*
* This is a workaround for some slightly silly Linux/GNU Libc
#include "runtime.h"
#include "genesis/static-symbols.h"
#include "genesis/fdefn.h"
+
#include <sys/socket.h>
#include <sys/utsname.h>
#include <errno.h>
size_t os_vm_page_size;
-#ifdef LISP_FEATURE_SB_THREAD
+#if defined(LISP_FEATURE_SB_THREAD) && !defined(LISP_FEATURE_SB_LUTEX)
#include <sys/syscall.h>
#include <unistd.h>
#include <errno.h>
\f
int linux_sparc_siginfo_bug = 0;
-int linux_no_threads_p = 0;
#ifdef LISP_FEATURE_SB_THREAD
int
{
/* Conduct various version checks: do we have enough mmap(), is
* this a sparc running 2.2, can we do threads? */
-#ifdef LISP_FEATURE_SB_THREAD
+#if defined(LISP_FEATURE_SB_THREAD) && !defined(LISP_FEATURE_SB_LUTEX)
int *futex=0;
#endif
struct utsname name;
#endif
}
#ifdef LISP_FEATURE_SB_THREAD
+#if !defined(LISP_FEATURE_SB_LUTEX)
futex_wait(futex,-1);
if(errno==ENOSYS) {
lose("This version of SBCL is compiled with threading support, but your kernel\n"
"is too old to support this. Please use a more recent kernel or\n"
"a version of SBCL without threading support.\n");
}
+#endif
if(! isnptl()) {
lose("This version of SBCL only works correctly with the NPTL threading\n"
"library. Please use a newer glibc, use an older SBCL, or stop using\n"
#include <sys/syscall.h>
#include <asm/unistd.h>
#include <linux/version.h>
+
#include "target-arch-os.h"
#include "target-arch.h"
-
#define linuxversion(a, b, c) (((a)<<16)+((b)<<8)+(c))
typedef caddr_t os_vm_address_t;
--- /dev/null
+/* An approximation of Linux futexes implemented using pthread mutexes
+ * and pthread condition variables.
+ */
+
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * The software is in the public domain and is provided with
+ * absolutely no warranty. See the COPYING and CREDITS files for more
+ * information.
+ */
+
+#include "sbcl.h"
+
+#if defined(LISP_FEATURE_SB_THREAD) && defined(LISP_FEATURE_SB_LUTEX)
+
+#include <stdlib.h>
+
+#include "runtime.h"
+#include "arch.h"
+#include "target-arch-os.h"
+#include "os.h"
+
+#include "genesis/lutex.h"
+
+typedef unsigned long tagged_lutex_t;
+
+#if 1
+# define lutex_assert(ex) \
+do { \
+ if (!(ex)) lutex_abort(); \
+} while (0)
+# define lutex_assert_verbose(ex, fmt, ...) \
+do { \
+ if (!(ex)) { \
+ fprintf(stderr, fmt, ## __VA_ARGS__); \
+ lutex_abort(); \
+ } \
+} while (0)
+#else
+# define lutex_assert(ex)
+# define lutex_assert_verbose(ex, fmt, ...)
+#endif
+
+#define lutex_abort() \
+ lose("Lutex assertion failure, file \"%s\", line %d\n", __FILE__, __LINE__)
+
+
+pthread_mutex_t lutex_register_lock = PTHREAD_MUTEX_INITIALIZER;
+
+int
+lutex_init (tagged_lutex_t tagged_lutex)
+{
+ int ret;
+ struct lutex *lutex = (struct lutex*) native_pointer(tagged_lutex);
+
+ lutex->mutex = malloc(sizeof(pthread_mutex_t));
+ lutex_assert(lutex->mutex != 0);
+
+ ret = pthread_mutex_init(lutex->mutex, NULL);
+ lutex_assert(ret == 0);
+
+ lutex->condition_variable = malloc(sizeof(pthread_cond_t));
+ lutex_assert(lutex->condition_variable != 0);
+
+ ret = pthread_cond_init(lutex->condition_variable, NULL);
+ lutex_assert(ret == 0);
+
+ ret = thread_mutex_lock(&lutex_register_lock); lutex_assert(ret == 0);
+
+ gencgc_register_lutex(lutex);
+
+ ret = thread_mutex_unlock(&lutex_register_lock); lutex_assert(ret == 0);
+
+ return ret;
+}
+
+int
+lutex_wait (tagged_lutex_t tagged_queue_lutex, tagged_lutex_t tagged_mutex_lutex)
+{
+ int ret;
+ struct lutex *queue_lutex = (struct lutex*) native_pointer(tagged_queue_lutex);
+ struct lutex *mutex_lutex = (struct lutex*) native_pointer(tagged_mutex_lutex);
+
+ ret = pthread_cond_wait(queue_lutex->condition_variable, mutex_lutex->mutex);
+ lutex_assert(ret == 0);
+
+ return ret;
+}
+
+int
+lutex_wake (tagged_lutex_t tagged_lutex, int n)
+{
+ int ret = 0;
+ struct lutex *lutex = (struct lutex*) native_pointer(tagged_lutex);
+
+ /* The lisp-side code passes N=2**29-1 for a broadcast. */
+ if (n >= ((1 << 29) - 1)) {
+ /* CONDITION-BROADCAST */
+ ret = pthread_cond_broadcast(lutex->condition_variable);
+ lutex_assert(ret == 0);
+ } else{
+ /* We're holding the condition variable mutex, so a thread
+ * we're waking can't re-enter the wait between to calls to
+ * pthread_cond_signal. Thus we'll wake N different threads,
+ * instead of the same thread N times.
+ */
+ while (n--) {
+ ret = pthread_cond_signal(lutex->condition_variable);
+ lutex_assert(ret == 0);
+ }
+ }
+
+ return ret;
+}
+
+int
+lutex_lock (tagged_lutex_t tagged_lutex)
+{
+ int ret = 0;
+ struct lutex *lutex = (struct lutex*) native_pointer(tagged_lutex);
+
+ ret = thread_mutex_lock(lutex->mutex);
+ lutex_assert(ret == 0);
+
+ return ret;
+}
+
+int
+lutex_unlock (tagged_lutex_t tagged_lutex)
+{
+ int ret = 0;
+ struct lutex *lutex = (struct lutex*) native_pointer(tagged_lutex);
+
+ ret = thread_mutex_unlock(lutex->mutex);
+ lutex_assert(ret == 0);
+
+ return ret;
+}
+
+int
+lutex_destroy (tagged_lutex_t tagged_lutex)
+{
+ struct lutex *lutex = (struct lutex*) native_pointer(tagged_lutex);
+
+ if (lutex->condition_variable) {
+ pthread_cond_destroy(lutex->condition_variable);
+ free(lutex->condition_variable);
+ lutex->condition_variable = NULL;
+ }
+
+ if (lutex->mutex) {
+ pthread_mutex_destroy(lutex->mutex);
+ free(lutex->mutex);
+ lutex->mutex = NULL;
+ }
+
+ return 0;
+}
+#endif
#endif
case SAP_WIDETAG:
case WEAK_POINTER_WIDETAG:
+#ifdef LUTEX_WIDETAG
+ case LUTEX_WIDETAG:
+#endif
break;
default:
#endif
case SAP_WIDETAG:
return ptrans_unboxed(thing, header);
+#ifdef LUTEX_WIDETAG
+ case LUTEX_WIDETAG:
+ gencgc_unregister_lutex(native_pointer(thing));
+ return ptrans_unboxed(thing, header);
+#endif
case RATIO_WIDETAG:
case COMPLEX_WIDETAG:
#include "genesis/static-symbols.h"
#include "genesis/symbol.h"
+#ifdef LISP_FEATURE_SB_LUTEX
+#include "genesis/lutex.h"
+#endif
+
static void
write_lispobj(lispobj obj, FILE *file)
{
return ((data - file_offset) / os_vm_page_size) - 1;
}
+#if defined(LISP_FEATURE_SB_THREAD) && defined(LISP_FEATURE_SB_LUTEX)
+/* saving lutexes in the core */
+static void **lutex_addresses;
+static long n_lutexes = 0;
+static long max_lutexes = 0;
+
+static long
+default_scan_action(lispobj *obj)
+{
+ return (sizetab[widetag_of(*obj)])(obj);
+}
+
+static long
+lutex_scan_action(lispobj *obj)
+{
+ /* note the address of the lutex */
+ if(n_lutexes >= max_lutexes) {
+ max_lutexes *= 2;
+ lutex_addresses = realloc(lutex_addresses, max_lutexes * sizeof(void *));
+ gc_assert(lutex_addresses);
+ }
+
+ lutex_addresses[n_lutexes++] = obj;
+
+ return (*sizetab[widetag_of(*obj)])(obj);
+}
+
+typedef long (*scan_table[256])(lispobj *obj);
+
+static void
+scan_objects(lispobj *start, long n_words, scan_table table)
+{
+ lispobj *end = start + n_words;
+ lispobj *object_ptr;
+ long n_words_scanned;
+ for (object_ptr = start;
+ object_ptr < end;
+ object_ptr += n_words_scanned) {
+ lispobj obj = *object_ptr;
+
+ n_words_scanned = (table[widetag_of(obj)])(object_ptr);
+ }
+}
+
+static void
+scan_for_lutexes(lispobj *addr, long n_words)
+{
+ static int initialized = 0;
+ static scan_table lutex_scan_table;
+
+ if (!initialized) {
+ int i;
+
+ /* allocate a little space to get started */
+ lutex_addresses = malloc(16*sizeof(void *));
+ gc_assert(lutex_addresses);
+ max_lutexes = 16;
+
+ /* initialize the mapping table */
+ for(i = 0; i < ((sizeof lutex_scan_table)/(sizeof lutex_scan_table[0])); ++i) {
+ lutex_scan_table[i] = default_scan_action;
+ }
+
+ lutex_scan_table[LUTEX_WIDETAG] = lutex_scan_action;
+
+ initialized = 1;
+ }
+
+ /* do the scan */
+ scan_objects(addr, n_words, lutex_scan_table);
+}
+#endif
+
static void
output_space(FILE *file, int id, lispobj *addr, lispobj *end, os_vm_offset_t file_offset)
{
bytes = words * sizeof(lispobj);
+#if defined(LISP_FEATURE_SB_THREAD) && defined(LISP_FEATURE_SB_LUTEX)
+ printf("scanning space for lutexes...\n");
+ scan_for_lutexes((char *)addr, words);
+#endif
+
printf("writing %ld bytes from the %s space at 0x%08lx\n",
bytes, names[id], (unsigned long)addr);
}
#endif
+#if defined(LISP_FEATURE_SB_THREAD) && defined(LISP_FEATURE_SB_LUTEX)
+ if(n_lutexes > 0) {
+ long offset;
+ printf("writing %d lutexes to the core...\n", n_lutexes);
+ write_lispobj(LUTEX_TABLE_CORE_ENTRY_TYPE_CODE, file);
+ /* word count of the entry */
+ write_lispobj(4, file);
+ /* indicate how many lutexes we saved */
+ write_lispobj(n_lutexes, file);
+ /* save the lutexes */
+ offset = write_bytes(file, (char *) lutex_addresses,
+ n_lutexes * sizeof(*lutex_addresses),
+ core_start_pos);
+
+ write_lispobj(offset, file);
+ }
+#endif
+
write_lispobj(END_CORE_ENTRY_TYPE_CODE, file);
/* Write a trailing header, ignored when parsing the core normally.
{
os_context_t *context = arch_os_get_context(&void_context);
void* fault_addr = (void*)info->si_addr;
- if(info->si_code == 1)
- {
- perror("error: SEGV_MAPERR\n");
- exit(1);
- }
if (!gencgc_handle_wp_violation(fault_addr))
if(!handle_guard_page_triggered(context, fault_addr))
arrange_return_to_lisp_function(context,
SymbolFunction(MEMORY_FAULT_ERROR));
#else
- interrupt_handle_now(signal, info, context);
+ interrupt_handle_now(signal, info, context);
#endif
}
{
undoably_install_low_level_interrupt_handler(SIG_MEMORY_FAULT,
sigsegv_handler);
+
+#ifdef LISP_FEATURE_SB_THREAD
+ undoably_install_low_level_interrupt_handler(SIG_INTERRUPT_THREAD,
+ interrupt_thread_handler);
+ undoably_install_low_level_interrupt_handler(SIG_STOP_FOR_GC,
+ sig_stop_for_gc_handler);
+#endif
}
char *
return copied_string(path);
}
+
#define SIG_MEMORY_FAULT SIGSEGV
+#define SIG_INTERRUPT_THREAD (SIGRTMIN)
+#define SIG_STOP_FOR_GC (SIGRTMIN+1)
+#define SIG_RESUME_FROM_GC (SIGRTMIN+2)
+
/* Yaargh?! */
typedef int os_context_register_t ;
+
#define SIGSTKSZ 1024
#endif
+#if defined(LISP_FEATURE_DARWIN) && defined(LISP_FEATURE_SB_THREAD)
+#define QUEUE_FREEABLE_THREAD_STACKS
+#endif
+
#define ALIEN_STACK_SIZE (1*1024*1024) /* 1Mb size chosen at random */
struct freeable_stack {
+#ifdef QUEUE_FREEABLE_THREAD_STACKS
+ struct freeable_stack *next;
+#endif
os_thread_t os_thread;
os_vm_address_t stack;
};
+
+#ifdef QUEUE_FREEABLE_THREAD_STACKS
+static struct freeable_stack * volatile freeable_stack_queue = 0;
+static int freeable_stack_count = 0;
+pthread_mutex_t freeable_stack_lock = PTHREAD_MUTEX_INITIALIZER;
+#else
static struct freeable_stack * volatile freeable_stack = 0;
+#endif
int dynamic_values_bytes=4096*sizeof(lispobj); /* same for all threads */
struct thread * volatile all_threads;
extern struct interrupt_data * global_interrupt_data;
-extern int linux_no_threads_p;
#ifdef LISP_FEATURE_SB_THREAD
pthread_mutex_t all_threads_lock = PTHREAD_MUTEX_INITIALIZER;
#ifdef LISP_FEATURE_SB_THREAD
+#ifdef QUEUE_FREEABLE_THREAD_STACKS
+
+queue_freeable_thread_stack(struct thread *thread_to_be_cleaned_up)
+{
+ if (thread_to_be_cleaned_up) {
+ pthread_mutex_lock(&freeable_stack_lock);
+ if (freeable_stack_queue) {
+ struct freeable_stack *new_freeable_stack = 0, *next;
+ next = freeable_stack_queue;
+ while (next->next) {
+ next = next->next;
+ }
+ new_freeable_stack = (struct freeable_stack *)
+ os_validate(0, sizeof(struct freeable_stack));
+ new_freeable_stack->next = NULL;
+ new_freeable_stack->os_thread = thread_to_be_cleaned_up->os_thread;
+ new_freeable_stack->stack = (os_vm_address_t)
+ thread_to_be_cleaned_up->control_stack_start;
+ next->next = new_freeable_stack;
+ freeable_stack_count++;
+ } else {
+ struct freeable_stack *new_freeable_stack = 0;
+ new_freeable_stack = (struct freeable_stack *)
+ os_validate(0, sizeof(struct freeable_stack));
+ new_freeable_stack->next = NULL;
+ new_freeable_stack->os_thread = thread_to_be_cleaned_up->os_thread;
+ new_freeable_stack->stack = (os_vm_address_t)
+ thread_to_be_cleaned_up->control_stack_start;
+ freeable_stack_queue = new_freeable_stack;
+ freeable_stack_count++;
+ }
+ pthread_mutex_unlock(&freeable_stack_lock);
+ }
+}
+
+#define FREEABLE_STACK_QUEUE_SIZE 4
+
+static void
+free_freeable_stacks() {
+ if (freeable_stack_queue && (freeable_stack_count > FREEABLE_STACK_QUEUE_SIZE)) {
+ struct freeable_stack* old;
+ pthread_mutex_lock(&freeable_stack_lock);
+ old = freeable_stack_queue;
+ freeable_stack_queue = old->next;
+ freeable_stack_count--;
+ gc_assert(pthread_join(old->os_thread, NULL) == 0);
+ FSHOW((stderr, "freeing thread %x stack\n", old->os_thread));
+ os_invalidate(old->stack, THREAD_STRUCT_SIZE);
+ os_invalidate((os_vm_address_t)old, sizeof(struct freeable_stack));
+ pthread_mutex_unlock(&freeable_stack_lock);
+ }
+}
+
+#else
static void
free_thread_stack_later(struct thread *thread_to_be_cleaned_up)
{
swap_lispobjs((lispobj *)(void *)&freeable_stack,
(lispobj)new_freeable_stack);
if (new_freeable_stack) {
- FSHOW((stderr,"/reaping %lu\n", new_freeable_stack->os_thread));
+ FSHOW((stderr,"/reaping %p\n", (void*) new_freeable_stack->os_thread));
/* Under NPTL pthread_join really waits until the thread
* exists and the stack can be safely freed. This is sadly not
* mandated by the pthread spec. */
sizeof(struct freeable_stack));
}
}
+#endif
/* this is the first thing that runs in the child (which is why the
* silly calling convention). Basically it calls the user's requested
new_thread_trampoline(struct thread *th)
{
lispobj function;
- int result;
+ int result, lock_ret;
FSHOW((stderr,"/creating thread %lu\n", thread_self()));
function = th->no_tls_value_marker;
th->no_tls_value_marker = NO_TLS_VALUE_MARKER_WIDETAG;
* list and we're just adding this thread to it there is no danger
* of deadlocking even with SIG_STOP_FOR_GC blocked (which it is
* not). */
- pthread_mutex_lock(&all_threads_lock);
+ lock_ret = pthread_mutex_lock(&all_threads_lock);
+ gc_assert(lock_ret == 0);
link_thread(th);
- pthread_mutex_unlock(&all_threads_lock);
+ lock_ret = pthread_mutex_unlock(&all_threads_lock);
+ gc_assert(lock_ret == 0);
result = funcall0(function);
th->state=STATE_DEAD;
/* SIG_STOP_FOR_GC is blocked and GC might be waiting for this
* thread, but since we are already dead it won't wait long. */
- pthread_mutex_lock(&all_threads_lock);
+ lock_ret = pthread_mutex_lock(&all_threads_lock);
+ gc_assert(lock_ret == 0);
+
gc_alloc_update_page_tables(0, &th->alloc_region);
unlink_thread(th);
pthread_mutex_unlock(&all_threads_lock);
+ gc_assert(lock_ret == 0);
if(th->tls_cookie>=0) arch_os_thread_cleanup(th);
os_invalidate((os_vm_address_t)th->interrupt_data,
(sizeof (struct interrupt_data)));
+
+#ifdef QUEUE_FREEABLE_THREAD_STACKS
+ queue_freeable_thread_stack(th);
+#else
free_thread_stack_later(th);
- FSHOW((stderr,"/exiting thread %lu\n", thread_self()));
+#endif
+
+ FSHOW((stderr,"/exiting thread %p\n", thread_self()));
return result;
}
pthread_attr_t attr;
sigset_t newset,oldset;
boolean r=1;
+ int retcode, initcode, sizecode, addrcode;
+
+ FSHOW_SIGNAL((stderr,"/create_os_thread: creating new thread\n"));
+
sigemptyset(&newset);
/* Blocking deferrable signals is enough, no need to block
* SIG_STOP_FOR_GC because the child process is not linked onto
sigaddset_deferrable(&newset);
thread_sigmask(SIG_BLOCK, &newset, &oldset);
- if((pthread_attr_init(&attr)) ||
+#if defined(LISP_FEATURE_DARWIN)
+#define CONTROL_STACK_ADJUST 8192 /* darwin wants page-aligned stacks */
+#else
+#define CONTROL_STACK_ADJUST 16
+#endif
+
+ if((initcode = pthread_attr_init(&attr)) ||
+ /* FIXME: why do we even have this in the first place? */
(pthread_attr_setstack(&attr,th->control_stack_start,
- THREAD_CONTROL_STACK_SIZE-16)) ||
- (pthread_create
- (kid_tid,&attr,(void *(*)(void *))new_thread_trampoline,th)))
+ THREAD_CONTROL_STACK_SIZE-CONTROL_STACK_ADJUST)) ||
+#undef CONTROL_STACK_ADJUST
+ (retcode = pthread_create
+ (kid_tid,&attr,(void *(*)(void *))new_thread_trampoline,th))) {
+ FSHOW_SIGNAL((stderr, "init, size, addr = %d, %d, %d\n", initcode, sizecode, addrcode));
+ FSHOW_SIGNAL((stderr, printf("pthread_create returned %d, errno %d\n", retcode, errno)));
+ FSHOW_SIGNAL((stderr, "wanted stack size %d, min stack size %d\n",
+ THREAD_CONTROL_STACK_SIZE-16, PTHREAD_STACK_MIN));
+ if(retcode < 0) {
+ perror("create_os_thread");
+ }
r=0;
+ }
+#ifdef QUEUE_FREEABLE_THREAD_STACKS
+ free_freeable_stacks();
+#endif
thread_sigmask(SIG_SETMASK,&oldset,0);
return r;
}
struct thread *th;
os_thread_t kid_tid;
- if(linux_no_threads_p) return 0;
-
/* Assuming that a fresh thread struct has no lisp objects in it,
* linking it to all_threads can be left to the thread itself
* without fear of gc lossage. initial_function violates this
void gc_stop_the_world()
{
struct thread *p,*th=arch_os_get_current_thread();
- int status;
+ int status, lock_ret;
FSHOW_SIGNAL((stderr,"/gc_stop_the_world:waiting on lock, thread=%lu\n",
th->os_thread));
/* keep threads from starting while the world is stopped. */
- pthread_mutex_lock(&all_threads_lock); \
+ lock_ret = pthread_mutex_lock(&all_threads_lock); \
+ gc_assert(lock_ret == 0);
+
FSHOW_SIGNAL((stderr,"/gc_stop_the_world:got lock, thread=%lu\n",
th->os_thread));
/* stop all other threads by sending them SIG_STOP_FOR_GC */
for(p=all_threads; p; p=p->next) {
gc_assert(p->os_thread != 0);
+ FSHOW_SIGNAL((stderr,"/gc_stop_the_world: p->state: %x\n", p->state));
if((p!=th) && ((p->state==STATE_RUNNING))) {
- FSHOW_SIGNAL((stderr,"/gc_stop_the_world: suspending %lu\n",
- p->os_thread));
+ FSHOW_SIGNAL((stderr,"/gc_stop_the_world: suspending %x, os_thread %x\n",
+ p, p->os_thread));
status=kill_thread_safely(p->os_thread,SIG_STOP_FOR_GC);
if (status==ESRCH) {
/* This thread has exited. */
FSHOW_SIGNAL((stderr,"/gc_stop_the_world:signals sent\n"));
/* wait for the running threads to stop or finish */
for(p=all_threads;p;) {
+ FSHOW_SIGNAL((stderr,"/gc_stop_the_world: th: %p, p: %p\n", th, p));
if((p!=th) && (p->state==STATE_RUNNING)) {
sched_yield();
} else {
void gc_start_the_world()
{
struct thread *p,*th=arch_os_get_current_thread();
- int status;
+ int status, lock_ret;
/* if a resumed thread creates a new thread before we're done with
* this loop, the new thread will get consed on the front of
* all_threads, but it won't have been stopped so won't need
FSHOW_SIGNAL((stderr, "/gc_start_the_world: resuming %lu\n",
p->os_thread));
p->state=STATE_RUNNING;
+
+#if defined(SIG_RESUME_FROM_GC)
+ status=kill_thread_safely(p->os_thread,SIG_RESUME_FROM_GC);
+#else
status=kill_thread_safely(p->os_thread,SIG_STOP_FOR_GC);
+#endif
if (status) {
lose("cannot resume thread=%lu: %d, %s\n",
p->os_thread,status,strerror(status));
* SIG_STOP_FOR_GC wouldn't need to be a rt signal. That has some
* performance implications, but does away with the 'rt signal
* queue full' problem. */
- pthread_mutex_unlock(&all_threads_lock); \
+
+ lock_ret = pthread_mutex_unlock(&all_threads_lock);
+ gc_assert(lock_ret == 0);
+
FSHOW_SIGNAL((stderr,"/gc_start_the_world:end\n"));
}
#endif
#if defined(LISP_FEATURE_SB_THREAD)
#if defined(LISP_FEATURE_X86)
register struct thread *me=0;
- if(all_threads)
+ if(all_threads) {
+#if defined(LISP_FEATURE_DARWIN) && defined(LISP_FEATURE_RESTORE_FS_SEGMENT_REGISTER_FROM_TLS)
+ sel_t sel;
+ struct thread *th = pthread_getspecific(specials);
+ sel.index = th->tls_cookie;
+ sel.rpl = USER_PRIV;
+ sel.ti = SEL_LDT;
+ __asm__ __volatile__ ("movw %w0, %%fs" : : "r"(sel));
+#endif
__asm__ __volatile__ ("movl %%fs:%c1,%0" : "=r" (me)
: "i" (offsetof (struct thread,this)));
+ }
return me;
#else
return pthread_getspecific(specials);
#define thread_self getpid
#define thread_kill kill
#define thread_sigmask sigprocmask
-#define thread_mutex_lock(l)
-#define thread_mutex_unlock(l)
+#define thread_mutex_lock(l) 0
+#define thread_mutex_unlock(l) 0
#endif
extern void create_initial_thread(lispobj);
single-stepping (as far as I can tell) this is somewhat moot,
but it might be worth either moving this code up or deleting
the single-stepping code entirely. -- CSR, 2002-07-15 */
-#ifdef LISP_FEATURE_LINUX
+#if defined(LISP_FEATURE_LINUX) || defined(RESTORE_FP_CONTROL_FROM_CONTEXT)
os_restore_fp_control(context);
#endif
sigill_handler(int signal, siginfo_t *siginfo, void *void_context) {
os_context_t *context = (os_context_t*)void_context;
+ /* Triggering SIGTRAP using int3 is unreliable on OS X/x86, so
+ * we need to use illegal instructions for traps.
+ */
#if defined(LISP_FEATURE_DARWIN)
if (*((unsigned short *)*os_context_pc_addr(context)) == 0x0b0f) {
*os_context_pc_addr(context) += 2;
if(*word==value)
lose("recursive get_spinlock: 0x%x,%ld\n",word,value);
do {
+#if defined(LISP_FEATURE_DARWIN)
+ asm ("xor %0,%0;\n\
+ lock/cmpxchg %1,%2"
+ : "=a" (eax)
+ : "r" (value), "m" (*word)
+ : "memory", "cc");
+#else
asm ("xor %0,%0\n\
lock cmpxchg %1,%2"
: "=a" (eax)
: "r" (value), "m" (*word)
: "memory", "cc");
+#endif
+
} while(eax!=0);
#else
*word=value;
swap_lispobjs(volatile lispobj *dest, lispobj value)
{
lispobj old_value;
+#if defined(LISP_FEATURE_DARWIN)
+ asm ("lock/xchg %0,(%1)"
+ : "=r" (old_value)
+ : "r" (dest), "0" (value)
+ : "memory");
+#else
asm ("lock xchg %0,(%1)"
: "=r" (old_value)
: "r" (dest), "0" (value)
: "memory");
+#endif
return old_value;
}
ret
SIZE(GNAME(alloc_overflow_edi))
+
+#ifdef LISP_FEATURE_DARWIN
+ .align align_4byte
+ .globl GNAME(call_into_lisp_tramp)
+ TYPE(GNAME(call_into_lisp_tramp))
+GNAME(call_into_lisp_tramp):
+ /* 1. build the stack frame from the block that's pointed to by ECX
+ 2. free the block
+ 3. set ECX to 0
+ 4. call the function via call_into_lisp
+ */
+ pushl 0(%ecx) /* return address */
+
+ pushl %ebp
+ movl %esp, %ebp
+
+ pushl 32(%ecx) /* eflags */
+ pushl 28(%ecx) /* EAX */
+ pushl 20(%ecx) /* ECX */
+ pushl 16(%ecx) /* EDX */
+ pushl 24(%ecx) /* EBX */
+ pushl $0 /* popal is going to ignore esp */
+ pushl %ebp /* is this right?? */
+ pushl 12(%ecx) /* ESI */
+ pushl 8(%ecx) /* EDI */
+ pushl $0 /* args for call_into_lisp */
+ pushl $0
+ pushl 4(%ecx) /* function to call */
+
+ /* free our save block */
+ pushl %ecx /* reserve sufficient space on stack for args */
+ pushl %ecx
+ andl $0xfffffff0, %esp /* align stack */
+ movl $0x40, 4(%esp)
+ movl %ecx, (%esp)
+ call GNAME(os_invalidate)
+
+ /* call call_into_lisp */
+ leal -48(%ebp), %esp
+ call GNAME(call_into_lisp)
+
+ /* Clean up our mess */
+ leal -36(%ebp), %esp
+ popal
+ popfl
+ leave
+ ret
+
+ SIZE(call_into_lisp_tramp)
+#endif
+
.align align_4byte,0x90
.globl GNAME(post_signal_tramp)
TYPE(GNAME(post_signal_tramp))
addl $12,%esp /* clear call_into_lisp args from stack */
popal /* restore registers */
popfl
+#ifdef LISP_FEATURE_DARWIN
+ /* skip two padding words */
+ addl $8,%esp
+#endif
leave
ret
SIZE(GNAME(post_signal_tramp))
#include <signal.h>
#include "sbcl.h"
#include "runtime.h"
-#include "target-os.h"
+#include "thread.h"
+
+
+#ifdef LISP_FEATURE_SB_THREAD
+#ifdef LISP_FEATURE_DARWIN
+#include <architecture/i386/table.h>
+#include <i386/user_ldt.h>
+#include <mach/mach_init.h>
+#else
+#include <machine/segments.h>
+#include <machine/sysarch.h>
+#endif /* LISP_FEATURE_DARWIN */
+#endif
+
+#if defined(LISP_FEATURE_FREEBSD)
+#include "machine/npx.h"
+#endif
/* KLUDGE: There is strong family resemblance in the signal context
* stuff in FreeBSD and OpenBSD, but in detail they're different in
#endif /* __NetBSD__ */
-
/* FIXME: If this can be a no-op on BSD/x86, then it
* deserves a more precise name.
*
os_flush_icache(os_vm_address_t address, os_vm_size_t length)
{
}
+
+/* Note: the Darwin versions of arch_os_thread_init found in
+ * x86-darwin-os.c
+*/
+#if !defined(LISP_FEATURE_DARWIN)
+
+#ifdef LISP_FEATURE_SB_THREAD
+
+void set_data_desc_size(struct segment_descriptor* desc, unsigned long size)
+{
+ desc->sd_lolimit = (size - 1) & 0xffff;
+ desc->sd_hilimit = ((size - 1) >> 16) &0xf;
+}
+
+void set_data_desc_addr(struct segment_descriptor* desc, void* addr)
+{
+ desc->sd_lobase = (unsigned int)addr & 0xffffff;
+ desc->sd_hibase = ((unsigned int)addr & 0xff000000) >> 24;
+}
+
+#endif
+
+int arch_os_thread_init(struct thread *thread) {
+
+#ifdef LISP_FEATURE_SB_THREAD
+ int n;
+ int sel;
+
+ struct segment_descriptor ldt_entry = { 0, 0, SDT_MEMRW, SEL_UPL, 1,
+ 0, 0, 1, 0, 0 };
+
+ set_data_desc_addr(&ldt_entry, (unsigned long) thread);
+ set_data_desc_size(&ldt_entry, dynamic_values_bytes);
+
+ n = i386_set_ldt(LDT_AUTO_ALLOC, (union descriptor*) &ldt_entry, 1);
+ if (n < 0) {
+ perror("i386_set_ldt");
+ lose("unexpected i386_set_ldt(..) failure\n");
+ }
+ FSHOW_SIGNAL((stderr, "/ TLS: Allocated LDT %x\n", n));
+ sel = LSEL(n, SEL_UPL);
+ __asm__ __volatile__ ("mov %0, %%fs" : : "r"(sel));
+
+ thread->tls_cookie=n;
+ pthread_setspecific(specials,thread);
+#endif
+
+#ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
+ stack_t sigstack;
+
+ /* Signal handlers are run on the control stack, so if it is exhausted
+ * we had better use an alternate stack for whatever signal tells us
+ * we've exhausted it */
+ sigstack.ss_sp=((void *) thread)+dynamic_values_bytes;
+ sigstack.ss_flags=0;
+ sigstack.ss_size = 32*SIGSTKSZ;
+ sigaltstack(&sigstack,0);
+#endif
+
+ return 1; /* success */
+}
+
+int arch_os_thread_cleanup(struct thread *thread) {
+
+#if defined(LISP_FEATURE_SB_THREAD)
+ int n = thread->tls_cookie;
+
+ /* Set the %%fs register back to 0 and free the the ldt
+ * by setting it to NULL.
+ */
+ FSHOW_SIGNAL((stderr, "/ TLS: Freeing LDT %x\n", n));
+
+ __asm__ __volatile__ ("mov %0, %%fs" : : "r"(0));
+ i386_set_ldt(n, NULL, 1);
+#endif
+
+ return 1; /* success */
+}
+
+#endif /* !LISP_FEATURE_DARWIN */
+
+#if defined(LISP_FEATURE_FREEBSD)
+void
+os_restore_fp_control(os_context_t *context)
+{
+ struct envxmm *ex = (struct envxmm*)(&context->uc_mcontext.mc_fpstate);
+ asm ("fldcw %0" : : "m" (ex->en_cw));
+}
+#endif
#error unsupported BSD variant
#endif
+#if defined(LISP_FEATURE_SB_THREAD)
+
+#if defined LISP_FEATURE_FREEBSD
+/* FIXME: why is this only done for SB-THREAD? */
+#define RESTORE_FP_CONTROL_FROM_CONTEXT
+void os_restore_fp_control(os_context_t *context);
+#endif
+
+#endif
+
#endif /* _X86_BSD_OS_H */
--- /dev/null
+
+
+#ifdef LISP_FEATURE_SB_THREAD
+#include <architecture/i386/table.h>
+#include <i386/user_ldt.h>
+#include <mach/mach_init.h>
+#endif
+
+#include "thread.h"
+#include "x86-darwin-os.h"
+
+#ifdef LISP_FEATURE_SB_THREAD
+
+pthread_mutex_t modify_ldt_lock = PTHREAD_MUTEX_INITIALIZER;
+
+void set_data_desc_size(data_desc_t* desc, unsigned long size)
+{
+ desc->limit00 = (size - 1) & 0xffff;
+ desc->limit16 = ((size - 1) >> 16) &0xf;
+}
+
+void set_data_desc_addr(data_desc_t* desc, void* addr)
+{
+ desc->base00 = (unsigned int)addr & 0xffff;
+ desc->base16 = ((unsigned int)addr & 0xff0000) >> 16;
+ desc->base24 = ((unsigned int)addr & 0xff000000) >> 24;
+}
+
+#endif
+
+int arch_os_thread_init(struct thread *thread) {
+#ifdef LISP_FEATURE_SB_THREAD
+ int n;
+ sel_t sel;
+
+ data_desc_t ldt_entry = { 0, 0, 0, DESC_DATA_WRITE,
+ 3, 1, 0, DESC_DATA_32B, DESC_GRAN_BYTE, 0 };
+
+ set_data_desc_addr(&ldt_entry, (unsigned long) thread);
+ set_data_desc_size(&ldt_entry, dynamic_values_bytes);
+
+ thread_mutex_lock(&modify_ldt_lock);
+ n = i386_set_ldt(LDT_AUTO_ALLOC, (union ldt_entry*) &ldt_entry, 1);
+
+ if (n < 0) {
+ perror("i386_set_ldt");
+ lose("unexpected i386_set_ldt(..) failure\n");
+ }
+ thread_mutex_unlock(&modify_ldt_lock);
+
+ FSHOW_SIGNAL((stderr, "/ TLS: Allocated LDT %x\n", n));
+ sel.index = n;
+ sel.rpl = USER_PRIV;
+ sel.ti = SEL_LDT;
+
+ __asm__ __volatile__ ("mov %0, %%fs" : : "r"(sel));
+
+ thread->tls_cookie=n;
+ pthread_setspecific(specials,thread);
+#endif
+
+#ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
+ stack_t sigstack;
+
+ /* Signal handlers are run on the control stack, so if it is exhausted
+ * we had better use an alternate stack for whatever signal tells us
+ * we've exhausted it */
+ sigstack.ss_sp=((void *) thread)+dynamic_values_bytes;
+ sigstack.ss_flags=0;
+ sigstack.ss_size = 32*SIGSTKSZ;
+ sigaltstack(&sigstack,0);
+#endif
+ return 1; /* success */
+}
+
+int arch_os_thread_cleanup(struct thread *thread) {
+#if defined(LISP_FEATURE_SB_THREAD)
+ int n = thread->tls_cookie;
+
+ /* Set the %%fs register back to 0 and free the the ldt
+ * by setting it to NULL.
+ */
+ FSHOW_SIGNAL((stderr, "/ TLS: Freeing LDT %x\n", n));
+
+ __asm__ __volatile__ ("mov %0, %%fs" : : "r"(0));
+ thread_mutex_lock(&modify_ldt_lock);
+ i386_set_ldt(n, NULL, 1);
+ thread_mutex_unlock(&modify_ldt_lock);
+#endif
+ return 1; /* success */
+}
+
#ifndef _X86_DARWIN_OS_H
#define _X86_DARWIN_OS_H
+#include <architecture/i386/table.h>
+#include <i386/user_ldt.h>
+
+#include "darwin-os.h"
+
static inline os_context_t *arch_os_get_context(void **void_context) {
return (os_context_t *) *void_context;
}
+void set_data_desc_size(data_desc_t* desc, unsigned long size);
+void set_data_desc_addr(data_desc_t* desc, void* addr);
+
#define CONTEXT_ADDR_FROM_STEM(stem) &context->uc_mcontext->ss.stem
#define DARWIN_FIX_CONTEXT(context)
#include <sys/stat.h>
#include <unistd.h>
+#ifdef LISP_FEATURE_SB_THREAD
+#include <sys/segment.h>
+#include <sys/sysi86.h>
+#endif
+
#include "validate.h"
+
#ifdef LISP_FEATURE_SB_THREAD
-#error "Define threading support functions"
-#else
+pthread_mutex_t modify_ldt_lock = PTHREAD_MUTEX_INITIALIZER;
+#endif
+
+static int
+ldt_index_selector (int index) {
+ return index << 3 | 7;
+}
+
+static int
+find_free_ldt_index () {
+ struct ssd ssd;
+ int usage[65536/sizeof(int)];
+ int i;
+ FILE *fp;
+
+ memset(usage, 0, sizeof(usage));
+
+ fp = fopen("/proc/self/ldt", "r");
+
+ if (fp == NULL) {
+ lose("Couldn't open /proc/self/ldt");
+ }
+
+ while (fread(&ssd, sizeof(ssd), 1, fp) == 1) {
+ int index = ssd.sel >> 3;
+ if (index >= 65536) {
+ lose("segment selector index too large: %d", index);
+ }
+
+ usage[index / sizeof(int)] |= 1 << (index & (sizeof(int)-1));
+ }
+
+ fclose(fp);
+
+ /* Magic number 7 is the first LDT index that Solaris leaves free. */
+ for (i = 7; i < 65536; i++) {
+ if (~usage[i / sizeof(int)] & (1 << (i & (sizeof(int)-1)))) {
+ return i;
+ }
+ }
+
+ lose("Couldn't find a free LDT index");
+}
+
+static int
+install_segment (unsigned long start, unsigned long size) {
+ int selector;
+
+ thread_mutex_lock(&modify_ldt_lock);
+
+ selector = ldt_index_selector(find_free_ldt_index());
+ struct ssd ssd = { selector,
+ start,
+ size,
+ 0xf2,
+ 0x4};
+ if (sysi86(SI86DSCR, &ssd) < 0) {
+ lose("Couldn't install segment for thread-local data");
+ }
+
+ thread_mutex_unlock(&modify_ldt_lock);
+
+ return selector;
+}
+
int arch_os_thread_init(struct thread *thread) {
stack_t sigstack;
+
+#ifdef LISP_FEATURE_SB_THREAD
+ int sel = install_segment((unsigned long) thread, dynamic_values_bytes);
+
+ FSHOW_SIGNAL((stderr, "/ TLS: Allocated LDT %x\n", sel));
+ __asm__ __volatile__ ("mov %0, %%fs" : : "r"(sel));
+
+ thread->tls_cookie = sel;
+ pthread_setspecific(specials,thread);
+#endif
+
#ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
/* Signal handlers are run on the control stack, so if it is exhausted
* we had better use an alternate stack for whatever signal tells us
#endif
return 1; /* success */
}
+
int arch_os_thread_cleanup(struct thread *thread) {
+#if defined(LISP_FEATURE_SB_THREAD)
+ int n = thread->tls_cookie;
+ struct ssd delete = { n, 0, 0, 0, 0};
+
+ /* Set the %%fs register back to 0 and free the the ldt
+ * by setting it to NULL.
+ */
+ FSHOW_SIGNAL((stderr, "/ TLS: Freeing LDT %x\n", n));
+
+ __asm__ __volatile__ ("mov %0, %%fs" : : "r"(0));
+
+ thread_mutex_lock(&modify_ldt_lock);
+ if (sysi86(SI86DSCR, &delete) < 0) {
+ lose("Couldn't remove segment\n");
+ }
+ thread_mutex_unlock(&modify_ldt_lock);
+#endif
return 1; /* success */
}
-#endif
os_context_register_t *
os_context_register_addr(os_context_t *context, int offset)
+
;;;; miscellaneous tests of thread stuff
;;;; This software is part of the SBCL system. See the README file for
(with-open-file (o "threads-foreign.c" :direction :output :if-exists :supersede)
(format o "void loop_forever() { while(1) ; }~%"))
(sb-ext:run-program
- "cc"
- (or #+linux '("-shared" "-o" "threads-foreign.so" "threads-foreign.c")
+ #-sunos "cc" #+sunos "gcc"
+ (or #+(or linux freebsd sunos) '("-shared" "-o" "threads-foreign.so" "threads-foreign.c")
+ #+darwin '("-dynamiclib" "-o" "threads-foreign.so" "threads-foreign.c")
(error "Missing shared library compilation options for this platform"))
:search t)
(sb-alien:load-shared-object "threads-foreign.so")
| (mp:make-process #'roomy)
| (mp:make-process #'roomy)))
|#
+
+(with-test (:name (:condition-variable :notify-multiple))
+ (flet ((tester (notify-fun)
+ (let ((queue (make-waitqueue :name "queue"))
+ (lock (make-mutex :name "lock"))
+ (data nil))
+ (labels ((test (x)
+ (loop
+ (with-mutex (lock)
+ (format t "condition-wait ~a~%" x)
+ (force-output)
+ (condition-wait queue lock)
+ (format t "woke up ~a~%" x)
+ (force-output)
+ (push x data)))))
+ (let ((threads (loop for x from 1 to 10
+ collect
+ (let ((x x))
+ (sb-thread:make-thread (lambda ()
+ (test x)))))))
+ (sleep 5)
+ (with-mutex (lock)
+ (funcall notify-fun queue))
+ (sleep 5)
+ (mapcar #'terminate-thread threads)
+ ;; Check that all threads woke up at least once
+ (assert (= (length (remove-duplicates data)) 10)))))))
+ (tester (lambda (queue)
+ (format t "~&(condition-notify queue 10)~%")
+ (force-output)
+ (condition-notify queue 10)))
+ (tester (lambda (queue)
+ (format t "~&(condition-broadcast queue)~%")
+ (force-output)
+ (condition-broadcast queue)))))
+
+(with-test (:name (:mutex :finalization))
+ (let ((a nil))
+ (dotimes (i 500000)
+ (setf a (make-mutex)))))
+
+
+
+
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.9.13.21"
+"0.9.13.22"
projects / sbcl.git / commitdiff