Condensed thread changes

make-config.sh

@@ -261,6 +261,7 @@ case "$sbcl_os" in
         ;;
     win32)
         printf ' :win32' >> $ltf
+        printf ' :sb-pthread-futex' >> $ltf
         link_or_copy Config.$sbcl_arch-win32 Config
         link_or_copy $sbcl_arch-win32-os.h target-arch-os.h
         link_or_copy win32-os.h target-os.h

package-data-list.lisp-expr

@@ -2711,6 +2711,7 @@ structure representations"
                #!+linkage-table "LINKAGE-TABLE-SPACE-START"
                #!+linkage-table "LINKAGE-TABLE-SPACE-END"
                #!+linkage-table "LINKAGE-TABLE-ENTRY-SIZE"
+               #!+(and sb-thread win32) "GC-SAFEPOINT-PAGE-ADDR"
                "TLS-SIZE"
                "TRACE-TABLE-CALL-SITE"
                "TRACE-TABLE-FUN-EPILOGUE" "TRACE-TABLE-FUN-PROLOGUE"

src/code/cold-init.lisp

@@ -229,7 +229,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)
 
@@ -305,7 +306,7 @@ systems, UNIX-STATUS is used as the status code."
     (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/early-impl.lisp

@@ -38,6 +38,12 @@
                   sb!unix::*unblock-deferrables-on-enabling-interrupts-p*
                   *interrupts-enabled*
                   *interrupt-pending*
+                  #!+(and win32 sb-thread)
+                  *gc-safe*
+                  #!+(and win32 sb-thread)
+                  *in-safepoint*
+                  #!+(and win32 sb-thread)
+                  *disable-safepoints*
                   *free-interrupt-context-index*
                   sb!kernel::*gc-epoch*
                   sb!vm::*unwind-to-frame-function*

src/code/gc.lisp

@@ -231,6 +231,8 @@ run in any thread.")
                        ;; turn is a type-error.
                        (when (plusp run-time)
                          (incf *gc-run-time* run-time))))
+                   #!+win32
+                   (setf *stop-for-gc-pending* nil)
                    (setf *gc-pending* nil
                          new-usage (dynamic-usage))
                    #!+sb-thread

src/code/target-exception.lisp

@@ -101,3 +101,111 @@
 ;;;   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 %unblock-gc-signals))
+  (sb!alien:define-alien-routine ("unblock_deferrable_signals"
+                                  %unblock-deferrable-signals)
+      sb!alien:void
+    (where sb!alien:unsigned-long)
+    (old sb!alien:unsigned-long))
+  (sb!alien:define-alien-routine ("unblock_gc_signals" %unblock-gc-signals)
+      sb!alien:void
+    (where sb!alien:unsigned-long)
+    (old sb!alien:unsigned-long))
+
+  (defun block-deferrable-signals ()
+    (%block-deferrable-signals 0 0))
+
+  (defun unblock-deferrable-signals ()
+    (%unblock-deferrable-signals 0 0))
+
+  (defun unblock-gc-signals ()
+    (%unblock-gc-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-long)
+  (sb!alien:define-alien-routine ("apply_sigmask"
+                                  %apply-sigmask)
+      sb!alien:void
+      (mask sb!alien:unsigned-long))
+
+  (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/with-deferrables-blocked
+      ;; 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-gc-signals)
+    (unblock-deferrable-signals)
+    (values)))

src/code/target-thread.lisp

@@ -367,6 +367,7 @@ HOLDING-MUTEX-P."
   "Deprecated in favor of GRAB-MUTEX."
   (declare (type mutex mutex) (optimize (speed 3))
            #!-sb-thread (ignore waitp timeout))
+  (let (#!+(and win32 sb-thread) (sb!impl::*disable-safepoints* t))
   (unless new-owner
     (setq new-owner *current-thread*))
   (barrier (:read))
@@ -442,7 +443,7 @@ HOLDING-MUTEX-P."
                  (bug "Old owner in free mutex: ~S" prev))
                t))
             (waitp
-             (bug "Failed to acquire lock with WAITP."))))))
+             (bug "Failed to acquire lock with WAITP.")))))))
 
 (defun grab-mutex (mutex &key (waitp t) (timeout nil))
   #!+sb-doc
@@ -500,6 +501,8 @@ IF-NOT-OWNER is :FORCE)."
   (declare (type mutex mutex))
   ;; Order matters: set owner to NIL before releasing state.
   (let* ((self *current-thread*)
+         #!+(and win32 sb-thread)
+         (sb!impl::*disable-safepoints* t)
          (old-owner (sb!ext:compare-and-swap (mutex-%owner mutex) self nil)))
     (unless (eql self old-owner)
       (ecase if-not-owner
@@ -566,6 +569,7 @@ time we reacquire MUTEX and return to the caller.
 Note that if CONDITION-WAIT unwinds (due to eg. a timeout) instead of
 returning normally, it may do so without holding the mutex."
   #!-sb-thread (declare (ignore queue))
+  (let (#!+(and win32 sb-thread) (sb!impl::*disable-safepoints* t))
   (assert mutex)
   #!-sb-thread (error "Not supported in unithread builds.")
   #!+sb-thread
@@ -636,7 +640,7 @@ returning normally, it may do so without holding the mutex."
             ((2))
             ;; EWOULDBLOCK, -1 here, is the possible spurious wakeup
             ;; case. 0 is the normal wakeup.
-            (otherwise (return))))))))
+            (otherwise (return)))))))))
 
 (defun condition-notify (queue &optional (n 1))
   #!+sb-doc
@@ -647,6 +651,7 @@ this call."
   #!-sb-thread (error "Not supported in unithread builds.")
   #!+sb-thread
   (declare (type (and fixnum (integer 1)) n))
+  (let (#!+(and win32 sb-thread) (sb!impl::*disable-safepoints* t))
   (/show0 "Entering CONDITION-NOTIFY")
   #!+sb-thread
   (progn
@@ -665,7 +670,7 @@ this call."
     (progn
       (setf (waitqueue-token queue) queue)
       (with-pinned-objects (queue)
-        (futex-wake (waitqueue-token-address queue) n)))))
+        (futex-wake (waitqueue-token-address queue) n))))))
 
 (defun condition-broadcast (queue)
   #!+sb-doc
@@ -929,6 +934,8 @@ have the foreground next."
 
 
 ;;;; The beef
+#!+(and win32 sb-thread)
+(sb!alien:define-alien-routine ("gc_safepoint" gc-safepoint) sb!alien:void)
 
 (defun make-thread (function &key name)
   #!+sb-doc
@@ -998,10 +1005,12 @@ around and can be retrieved by JOIN-THREAD."
                                ;; other threads, it's time to enable
                                ;; signals.
                                (sb!unix::unblock-deferrable-signals)
-                               (setf (thread-result thread)
-                                     (cons t
+                               (let ((r (cons t
                                            (multiple-value-list
-                                            (funcall real-function))))
+                                            (funcall real-function)))))
+                                  #!+win32
+                                  (gc-safepoint)
+                                  (setf (thread-result thread) r))
                                ;; Try to block deferrables. An
                                ;; interrupt may unwind it, but for a
                                ;; normal exit it prevents interrupt
@@ -1070,6 +1079,11 @@ return DEFAULT if given or else signal JOIN-THREAD-ERROR."
       (kill-safely (thread-os-thread *current-thread*) sb!unix:sigpipe))
     (when interruption
       (funcall interruption))))
+
+#!+(and sb-thread win32)
+(sb!alien:define-alien-routine interrupt-lisp-thread sb!alien:int
+  (thread sb!alien:int)
+  (fn sb!alien:int))
 
 (defun interrupt-thread (thread function)
   #!+sb-doc
@@ -1083,11 +1097,18 @@ enable interrupts (GET-MUTEX when contended, for instance) so the
 first thing to do is usually a WITH-INTERRUPTS or a
 WITHOUT-INTERRUPTS. Within a thread interrupts are queued, they are
 run in same the order they were sent."
-  #!+win32
-  (declare (ignore thread))
-  #!+win32
-  (with-interrupt-bindings
-    (with-interrupts (funcall function)))
+  #!+(and sb-thread win32)
+  (let ((r (interrupt-lisp-thread
+            (sap-int (%thread-sap thread))
+            (get-lisp-obj-address
+             (lambda ()
+               (sb!unix::invoke-interruption function))))))
+    (zerop r))
+  #!+(and (not sb-thread) win32)
+  (progn
+    (declare (ignore thread))
+    (with-interrupt-bindings
+      (with-interrupts (funcall function))))
   #!-win32
   (let ((os-thread (thread-os-thread thread)))
     (cond ((not os-thread)

src/compiler/generic/genesis.lisp

@@ -2880,6 +2880,10 @@ core and return a descriptor to it."
   ;; possibly this is another candidate for a rename (to
   ;; pseudo-atomic-trap-number or pseudo-atomic-magic-constant
   ;; [possibly applicable to other platforms])
+
+  #!+(and win32 sb-thread)
+  (format t "#define GC_SAFEPOINT_PAGE_ADDR ((void*)0x~XUL) /* ~:*~A */~%"
+            sb!vm:gc-safepoint-page-addr)
 
   (dolist (symbol '(sb!vm::float-traps-byte
                     sb!vm::float-exceptions-byte

src/compiler/generic/parms.lisp

@@ -81,6 +81,9 @@
     *gc-pending*
     #!-sb-thread
     *stepping*
+    #!+(and win32 sb-thread) sb!impl::*gc-safe*
+    #!+(and win32 sb-thread) sb!impl::*in-safepoint*
+    #!+(and win32 sb-thread) sb!impl::*disable-safepoints*
 
     ;; threading support
     #!+sb-thread *stop-for-gc-pending*

src/compiler/ir2tran.lisp

@@ -1207,7 +1207,9 @@
 
     (let ((lab (gen-label)))
       (setf (ir2-physenv-environment-start env) lab)
-      (vop note-environment-start node block lab)))
+      (vop note-environment-start node block lab)
+      #!+(and win32 sb-thread)
+      (vop sb!vm::insert-gc-safepoint node block)))
 
   (values))
 
@@ -1729,6 +1731,22 @@
                        2block
                        #!+sb-dyncount *dynamic-counts-tn* #!-sb-dyncount nil
                        num))))
+              #!+(and win32 sb-thread)
+              (let ((first-node (block-start-node block)))
+                (unless (or (and (bind-p first-node)
+                                 (xep-p (bind-lambda first-node)))
+                            (and (valued-node-p first-node)
+                                 (node-lvar first-node)
+                                 (eq (lvar-fun-name
+                                      (node-lvar first-node))
+                                     '%nlx-entry)))
+                  (when (and (rest (block-pred block))
+                             (member (loop-kind (block-loop block))
+                                     '(:natural :strange))
+                             (eq block (loop-head (block-loop block))))
+                    (vop sb!vm::insert-gc-safepoint
+                         first-node
+                         2block))))
             (ir2-convert-block block)
             (incf num))))))
   (values))