Preliminary work towards threads on win32

  * Implement SB-THREAD

  * Support WITH-TIMEOUT, etc.

Implementation details:

  * Implement pthreads, futex API on top of Win32.
  * Adds support for the timer facility using sb-wtimer.
  * Implement an interruptable `nanosleep' using waitable timers.
  * Threading on Windows uses safepoints to stop the world.
    On this platform, either all or none of :SB-THREAD, :SB-SAFEPOINT,
    :SB-THRUPT, and :SB-WTIMER need to be enabled together.
  * On this platform, INTERRUPT-THREAD will not run interruptions
    in a target thread that is executing foreign code, even though
    the POSIX version of sb-thrupt still allows this (potentially
    unsafe) form of signalling by default.

Does not yet include interruptible I/O, which will be made available
separately.  Slime users are requested to build SBCL without threads
until then.

Note that these changes alone are not yet sufficient to make SBCL on
Windows an ideal backend.  Users looking for a particularly stable
or thread-enabled version of SBCL for Windows are still advised to
use the well-known Windows branch instead.

This is a merge of features developed earlier by Dmitry Kalyanov and
Anton Kovalenko.

src/code/cold-init.lisp

@@ -230,7 +230,8 @@
  (show-and-call stream-cold-init-or-reset)
  (show-and-call !loader-cold-init)
  (show-and-call !foreign-cold-init)
- #!-win32 (show-and-call signal-cold-init-or-reinit)
+ #!-(and win32 (not sb-thread))
+ (show-and-call signal-cold-init-or-reinit)
  (/show0 "enabling internal errors")
  (setf (sb!alien:extern-alien "internal_errors_enabled" boolean) t)
 
@@ -351,7 +352,7 @@ process to continue normally."
  (os-cold-init-or-reinit)
  (thread-init-or-reinit)
  (stream-reinit t)
- #!-win32
+ #!-(and win32 (not sb-thread))
  (signal-cold-init-or-reinit)
  (setf (sb!alien:extern-alien "internal_errors_enabled" boolean) t)
  (float-cold-init-or-reinit))

src/code/run-program.lisp

@@ -145,19 +145,15 @@
  #+sb-doc
  "List of process structures for all active processes.")
 
-#-win32
 (defvar *active-processes-lock*
  (sb-thread:make-mutex :name "Lock for active processes."))
 
 ;;; *ACTIVE-PROCESSES* can be accessed from multiple threads so a
 ;;; mutex is needed. More importantly the sigchld signal handler also
 ;;; accesses it, that's why we need without-interrupts.
 (defmacro with-active-processes-lock (() &body body)
- #-win32
  `(sb-thread::with-system-mutex (*active-processes-lock*)
- ,@body)
- #+win32
- `(progn ,@body))
+ ,@body))
 
 (defstruct (process (:copier nil))
  pid ; PID of child process

src/code/target-exception.lisp

@@ -101,3 +101,103 @@
 ;;; I don't know if we still need this or not. Better safe for now.
 (defun receive-pending-interrupt ()
  (receive-pending-interrupt))
+
+(in-package "SB!UNIX")
+
+#!+sb-thread
+(progn
+ (defun receive-pending-interrupt ()
+ (receive-pending-interrupt))
+
+ (defmacro with-interrupt-bindings (&body body)
+ `(let*
+ ;; KLUDGE: Whatever is on the PCL stacks before the interrupt
+ ;; handler runs doesn't really matter, since we're not on the
+ ;; same call stack, really -- and if we don't bind these (esp.
+ ;; the cache one) we can get a bogus metacircle if an interrupt
+ ;; handler calls a GF that was being computed when the interrupt
+ ;; hit.
+ ((sb!pcl::*cache-miss-values-stack* nil)
+ (sb!pcl::*dfun-miss-gfs-on-stack* nil))
+ ,@body))
+
+;;; Evaluate CLEANUP-FORMS iff PROTECTED-FORM does a non-local exit.
+ (defmacro nlx-protect (protected-form &rest cleanup-froms)
+ (with-unique-names (completep)
+ `(let ((,completep nil))
+ (without-interrupts
+ (unwind-protect
+ (progn
+ (allow-with-interrupts
+ ,protected-form)
+ (setq ,completep t))
+ (unless ,completep
+ ,@cleanup-froms))))))
+
+ (declaim (inline %unblock-deferrable-signals))
+ (sb!alien:define-alien-routine ("unblock_deferrable_signals"
+ %unblock-deferrable-signals)
+ sb!alien:void
+ (where sb!alien:unsigned)
+ (old sb!alien:unsigned))
+
+ (defun block-deferrable-signals ()
+ (%block-deferrable-signals 0 0))
+
+ (defun unblock-deferrable-signals ()
+ (%unblock-deferrable-signals 0 0))
+
+ (declaim (inline %block-deferrables-and-return-mask %apply-sigmask))
+ (sb!alien:define-alien-routine ("block_deferrables_and_return_mask"
+ %block-deferrables-and-return-mask)
+ sb!alien:unsigned)
+ (sb!alien:define-alien-routine ("apply_sigmask"
+ %apply-sigmask)
+ sb!alien:void
+ (mask sb!alien:unsigned))
+
+ (defmacro without-interrupts/with-deferrables-blocked (&body body)
+ (let ((mask-var (gensym)))
+ `(without-interrupts
+ (let ((,mask-var (%block-deferrables-and-return-mask)))
+ (unwind-protect
+ (progn ,@body)
+ (%apply-sigmask ,mask-var))))))
+
+ (defun invoke-interruption (function)
+ (without-interrupts
+ ;; Reset signal mask: the C-side handler has blocked all
+ ;; deferrable signals before funcalling into lisp. They are to be
+ ;; unblocked the first time interrupts are enabled. With this
+ ;; mechanism there are no extra frames on the stack from a
+ ;; previous signal handler when the next signal is delivered
+ ;; provided there is no WITH-INTERRUPTS.
+ (let ((sb!unix::*unblock-deferrables-on-enabling-interrupts-p* t))
+ (with-interrupt-bindings
+ (let ((sb!debug:*stack-top-hint*
+ (nth-value 1 (sb!kernel:find-interrupted-name-and-frame))))
+ (allow-with-interrupts
+ (nlx-protect
+ (funcall function)
+ ;; We've been running with deferrables
+ ;; blocked in Lisp called by a C signal
+ ;; handler. If we return normally the sigmask
+ ;; in the interrupted context is restored.
+ ;; However, if we do an nlx the operating
+ ;; system will not restore it for us.
+ (when sb!unix::*unblock-deferrables-on-enabling-interrupts-p*
+ ;; This means that storms of interrupts
+ ;; doing an nlx can still run out of stack.
+ (unblock-deferrable-signals)))))))))
+
+ (defmacro in-interruption ((&key) &body body)
+ #!+sb-doc
+ "Convenience macro on top of INVOKE-INTERRUPTION."
+ `(dx-flet ((interruption () ,@body))
+ (invoke-interruption #'interruption)))
+
+ (defun sb!kernel:signal-cold-init-or-reinit ()
+ #!+sb-doc
+ "Enable all the default signals that Lisp knows how to deal with."
+ (unblock-deferrable-signals)
+ (values)))

src/code/target-thread.lisp

@@ -1605,12 +1605,12 @@ the state of a thread:
  (interrupt-thread thread #'break)
 
 Short version: be careful out there."
- #!+win32
+ #!+(and (not sb-thread) win32)
+ #!+(and (not sb-thread) win32)
  (declare (ignore thread))
- #!+win32
  (with-interrupt-bindings
  (with-interrupts (funcall function)))
- #!-win32
+ #!-(and (not sb-thread) win32)
  (let ((os-thread (thread-os-thread thread)))
  (cond ((not os-thread)
  (error 'interrupt-thread-error :thread thread))

src/code/toplevel.lisp

@@ -202,7 +202,7 @@ any non-negative real number."
  :format-arguments (list seconds)
  :datum seconds
  :expected-type '(real 0)))
- #!-win32
+ #!-(and win32 (not sb-thread))
  (multiple-value-bind (sec nsec)
  (if (integerp seconds)
  (values seconds 0)
@@ -216,7 +216,7 @@ any non-negative real number."
  do (decf sec (expt 10 8))
  (sb!unix:nanosleep (expt 10 8) 0))
  (sb!unix:nanosleep sec nsec))
- #!+win32
+ #!+(and win32 (not sb-thread))
  (sb!win32:millisleep (truncate (* seconds 1000)))
  nil)
 

src/code/win32.lisp

@@ -154,10 +154,21 @@
 
 ;;;; System Functions
 
-;;; Sleep for MILLISECONDS milliseconds.
+#!-sb-thread
 (define-alien-routine ("Sleep@4" millisleep) void
  (milliseconds dword))
 
+#!+sb-thread
+(defun sb!unix:nanosleep (sec nsec)
+ (let ((*allow-with-interrupts* *interrupts-enabled*))
+ (without-interrupts
+ (let ((timer (sb!impl::os-create-wtimer)))
+ (sb!impl::os-set-wtimer timer sec nsec)
+ (unwind-protect
+ (do () ((with-local-interrupts
+ (zerop (sb!impl::os-wait-for-wtimer timer)))))
+ (sb!impl::os-close-wtimer timer))))))
+
 #!+sb-unicode
 (progn
  (defvar *ansi-codepage* nil)

src/compiler/generic/objdef.lisp

@@ -398,6 +398,7 @@
  (control-stack-guard-page-protected)
  (alien-stack-start :c-type "lispobj *" :length #!+alpha 2 #!-alpha 1)
  (alien-stack-pointer :c-type "lispobj *" :length #!+alpha 2 #!-alpha 1)
+ #!+win32 (private-events :c-type "struct private_events" :length 2)
  (this :c-type "struct thread *" :length #!+alpha 2 #!-alpha 1)
  (prev :c-type "struct thread *" :length #!+alpha 2 #!-alpha 1)
  (next :c-type "struct thread *" :length #!+alpha 2 #!-alpha 1)

src/runtime/Config.x86-win32

@@ -14,7 +14,8 @@ TARGET=sbcl.exe
 ASSEM_SRC = x86-assem.S
 ARCH_SRC = x86-arch.c
 
-OS_SRC = win32-os.c x86-win32-os.c os-common.c
+OS_SRC = win32-os.c x86-win32-os.c os-common.c pthreads_win32.c
+
 # The "--Wl,--export-dynamic" flags are here to help people
 # experimenting with callbacks from C to SBCL, by allowing linkage to
 # SBCL src/runtime/*.c symbols from C. Work on this is good, but it's
@@ -35,7 +36,7 @@ endif
 
 GC_SRC = gencgc.c
 
-CFLAGS = -g -Wall -O3 -fno-omit-frame-pointer
+CFLAGS = -g -Wall -O3 -fno-omit-frame-pointer -mno-cygwin -march=i686 -DWINVER=0x0501
 ASFLAGS = $(CFLAGS)
 
 CPP = cpp

src/runtime/gencgc.c

@@ -26,10 +26,14 @@
 
 #include <stdlib.h>
 #include <stdio.h>
-#include <signal.h>
 #include <errno.h>
 #include <string.h>
 #include "sbcl.h"
+#if defined(LISP_FEATURE_WIN32) && defined(LISP_FEATURE_SB_THREAD)
+#include "pthreads_win32.h"
+#else
+#include <signal.h>
+#endif
 #include "runtime.h"
 #include "os.h"
 #include "interr.h"
@@ -3321,7 +3325,7 @@ preserve_context_registers (os_context_t *c)
  /* 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_DARWIN)||defined(LISP_FEATURE_WIN32)
 #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));
@@ -3350,9 +3354,11 @@ preserve_context_registers (os_context_t *c)
  #error "preserve_context_registers needs to be tweaked for non-x86 Darwin"
 #endif
 #endif
+#if !defined(LISP_FEATURE_WIN32)
  for(ptr = ((void **)(c+1))-1; ptr>=(void **)c; ptr--) {
  preserve_pointer(*ptr);
  }
+#endif
 }
 #endif