New yieldpoints for SBCL25 dev meeting

Add "--with-yieldpoints --with-ultrafutex" to test-drive this patch.

src/assembly/x86-64/alloc.lisp

@@ -146,7 +146,7 @@
     ;; to receive an interrupt causing it to do a slow operation between
     ;; acquisition and release of the spinlock. Preventing GC is irrelevant,
     ;; but would not be if we recycled tls indices of garbage symbols.
-    (pseudo-atomic ()
+    (pseudo-atomic () ; allocating a TLS index
      RETRY
        (inst bts :qword :lock free-tls-index-ea lock-bit)
        (inst jmp :nc got-tls-index-lock)

src/assembly/x86-64/arith.lisp

@@ -53,7 +53,7 @@
   (let ((header (logior (ash 1 n-widetag-bits) bignum-widetag))
         (nbytes #+bignum-assertions 32 #-bignum-assertions 16))
     (instrument-alloc bignum-widetag nbytes nil alloc-tn)
-    (pseudo-atomic ()
+    (with-allocator ()
       (allocation bignum-widetag nbytes 0 alloc-tn nil nil nil)
       (storew* header alloc-tn 0 0 t)
       (storew source alloc-tn bignum-digits-offset 0)

src/assembly/x86-64/assem-rtns.lisp

@@ -32,6 +32,7 @@
      (:temp temp unsigned-reg r8-offset)
      (:temp loop-index unsigned-reg r9-offset))
 
+  (emit-safepoint)
   ;; Pick off the cases where everything fits in register args.
   (inst cmp :dword rcx (fixnumize 1))
   (inst jmp :e ONE-VALUE)
@@ -313,6 +314,7 @@
                           (:temp value unsigned-reg r10-offset)
                           (:temp bsp-temp unsigned-reg r11-offset)
                           (:temp zero complex-double-reg float0-offset))
+  (emit-safepoint)
   AGAIN
   (let ((error (generate-error-code nil 'invalid-unwind-error)))
     (inst test block block)             ; check for NULL pointer
@@ -404,6 +406,7 @@
      (:temp null unsigned-reg r8-offset)
      (:temp temp unsigned-reg r9-offset)
      (:temp return unsigned-reg r10-offset))
+  (emit-safepoint)
   (flet ((check (label)
            (assemble ()
              (%test-lowtag list temp skip nil list-pointer-lowtag)

src/assembly/x86-64/tramps.lisp

@@ -86,7 +86,7 @@
 (define-assembly-routine (switch-to-arena (:return-style :raw)) ()
   ;; RSI and RDI are vop temps, so don't bother preserving them
   (with-registers-preserved (c :except (rsi rdi))
-    (pseudo-atomic ()
+    (pseudo-atomic () ; arena switcher
       #-system-tlabs (inst break halt-trap)
       #+system-tlabs (call-c "switch_to_arena" #+win32 rdi-tn #+win32 rsi-tn))))
 
@@ -103,30 +103,35 @@
                     ,vars ,@code)))))
 
 (def-routine-pair (alloc-tramp) ()
-  (with-registers-preserved (c)
+  ;(emit-safepoint)
+  (with-registers-preserved (#+yieldpoints lisp)
     (call-c "alloc" (ea 16 rbp-tn) system-tlab-p)
     (inst mov (ea 16 rbp-tn) rax-tn))) ; result onto stack
 
 (def-routine-pair (list-alloc-tramp) () ; CONS, ACONS, LIST, LIST*
-  (with-registers-preserved (c)
+  ;(emit-safepoint)
+  (with-registers-preserved (#+yieldpoints lisp)
     (call-c "alloc_list" (ea 16 rbp-tn) system-tlab-p)
     (inst mov (ea 16 rbp-tn) rax-tn))) ; result onto stack
 
 (def-routine-pair (listify-&rest (:return-style :none)) ()
-  (with-registers-preserved (c)
+  ;(emit-safepoint)
+  (with-registers-preserved (#+yieldpoints lisp)
     (call-c "listify_rest_arg" (ea 16 rbp-tn) (ea 24 rbp-tn) system-tlab-p)
     (inst mov (ea 24 rbp-tn) rax-tn))   ; result
   (inst ret 8)) ; pop one argument; the unpopped word now holds the result
 
 (def-routine-pair (make-list (:return-style :none)) ()
-  (with-registers-preserved (c)
+  ;(emit-safepoint)
+  (with-registers-preserved (#+yieldpoints lisp)
     (call-c "make_list" (ea 16 rbp-tn) (ea 24 rbp-tn) system-tlab-p)
     (inst mov (ea 24 rbp-tn) rax-tn)) ; result
   (inst ret 8)) ; pop one argument; the unpopped word now holds the result
 )
 
 (define-assembly-routine (alloc-funinstance) ()
-  (with-registers-preserved (c)
+  ;(emit-safepoint)
+  (with-registers-preserved (#+yieldpoints lisp)
     (call-c "alloc_funinstance" (ea 16 rbp-tn))
     (inst mov (ea 16 rbp-tn) rax-tn)))
 
@@ -135,13 +140,13 @@
 (define-assembly-routine (enable-alloc-counter) ()
   (with-registers-preserved (c)
     #+sb-thread
-    (pseudo-atomic ()
+    (pseudo-atomic () ; (not sure why this is pseudo-atomic)
       (call-c "allocation_tracker_counted" (* (ea 8 rbp-tn))))))
 
 (define-assembly-routine (enable-sized-alloc-counter) ()
   (with-registers-preserved (c)
     #+sb-thread
-    (pseudo-atomic ()
+    (pseudo-atomic () ; (not sure why this is pseudo-atomic)
       (call-c "allocation_tracker_sized" (* (ea 8 rbp-tn))))))
 
 #+win32
@@ -243,7 +248,7 @@
                     (rax rax-tn)
                     (rdx rdx-tn)
                     (rdi rdi-tn))
-    (pseudo-atomic ()
+    (pseudo-atomic () ; setting a code header slot
       #+immobile-space
       (progn
         #-sb-thread
@@ -291,4 +296,24 @@
   (inst call (make-fixup 'mutex-wake-waiter :assembly-routine))
   uncontested
   (inst pop rax-tn))
+
+(define-assembly-routine (mutex-unlock-if-held (:return-style :raw)) ()
+  ;; There are no registers reserved for this asm routine
+  (inst push rax-tn)
+  (inst mov rax-tn (thread-tls-ea (load-time-tls-offset '*current-mutex*)))
+  (inst cmp (mutex-slot rax-tn %owner) thread-tn)
+  (inst jmp :ne uncontested) ; "not mine"
+  (inst mov :qword (mutex-slot rax-tn %owner) 0)
+  (inst dec :lock :byte (mutex-slot rax-tn state))
+  (inst jmp :z uncontested) ; if ZF then previous value was 1, no waiters
+  (inst call (make-fixup 'mutex-wake-waiter :assembly-routine))
+  uncontested
+  (inst pop rax-tn))
 ) ; end PROGN
+
+#+yieldpoints
+(define-assembly-routine (handle-deferred-signal) ()
+  (inst pushf)
+  (with-registers-preserved (lisp)
+    (call-static-fun 'sb-unix::handle-deferred-signal 0))
+  (inst popf))

src/code/final.lisp

@@ -427,7 +427,8 @@ Examples:
 ;;; Nested invocations (from a GC forced by a finalizer) are not ok.
 ;;; See the trace at the bottom of this file.
 (define-load-time-global *bg-compiler-function* nil)
-(defun run-pending-finalizers (&aux (system-finalizer-scratchpad (list 0)))
+(defun run-pending-finalizers (&aux (system-finalizer-scratchpad (list 0))
+                                    (n-ran 0))
   (declare (dynamic-extent system-finalizer-scratchpad))
   (finalizers-rehash)
   (loop
@@ -446,9 +447,16 @@ Examples:
           (sb-vm::immobile-code-dealloc-1 system-finalizer-scratchpad))
          (ran-a-user-finalizer ; Try to run 1 user finalizer
           (run-user-finalizer)))
+     (incf n-ran (+ (if ran-a-system-finalizer 1 0)
+                    (if ran-a-user-finalizer 1 0)))
      ;; Did this iteration do anything at all?
      (unless (or ran-bg-compile ran-a-system-finalizer ran-a-user-finalizer)
-       (return)))))
+       (return))))
+  #+nil
+  (alien-funcall (extern-alien "printf" (function void system-area-pointer unsigned))
+                 (vector-sap #.(format nil "Finalizer ran %d things~%"))
+                 n-ran)
+  )
 
 (define-load-time-global *finalizer-thread* nil)
 (declaim (type (or sb-thread:thread (eql :start) null) *finalizer-thread*))
@@ -475,6 +483,9 @@ Examples:
            (sb-thread::make-system-thread
             "finalizer"
             (lambda ()
+              ;; This lambda is in the lexical scope of (INSERT-SAFEPOINT 0) due to
+              ;; the system mutex. But the finalizer-thread-wait must have a yieldpoint.
+              #+yieldpoints (declare (optimize (sb-c::insert-safepoints 1)))
               (setf *finalizer-thread* sb-thread:*current-thread*)
               (loop (run-pending-finalizers)
                     (alien-funcall (extern-alien "finalizer_thread_wait" (function void)))

src/code/gc.lisp

@@ -283,6 +283,9 @@ run in any thread.")
           (call-hooks "after-GC" *after-gc-hooks* :on-error :warn))))
   nil)
 
+(with-alien ((request-garbage-collection (function void int) :extern)
+             (gc-inhibitor-control (function void int) :extern))
+
 ;;; This is the user-advertised garbage collection function.
 (defun gc (&key (full nil) (gen 0) &allow-other-keys)
   "Initiate a garbage collection.
@@ -292,9 +295,35 @@ trigger a collection of one or more older generations as well. If FULL
 is true, all generations are collected. If GEN is provided, it can be
 used to specify the oldest generation guaranteed to be collected."
   (let ((gen (if full sb-vm:+pseudo-static-generation+ gen)))
+    #+yieldpoints
+    (let ((inhibit *gc-inhibit*))
+      (if inhibit
+          (setq *gc-inhibit* (max inhibit gen))
+          (alien-funcall request-garbage-collection gen)))
+    #-yieldpoints
     (when (eq t (sub-gc gen))
       (post-gc))))
 
+(defun call-with-gc-disabled (thunk)
+  (if *gc-inhibit*
+      (funcall thunk)
+      ;; If GC was was deferred, NLX through this will NOT gc but normal exit will.
+      ;; (And if NLX, what the f*** are you doing anyway? Inhibiting GC is for
+      ;; small code fragments, not massive swaths of application logic)
+      (let (gen)
+        (multiple-value-prog1
+            (let ((*gc-inhibit* -1))
+              (unwind-protect
+                   (multiple-value-prog1
+                       (progn (alien-funcall gc-inhibitor-control 1)
+                              ;(format t "~&doing a without-gcing thunk~%")
+                              (funcall thunk))
+                     (setq gen *gc-inhibit*))
+                  (alien-funcall gc-inhibitor-control 0)))
+          (when (>= gen 0)
+            (alien-funcall request-garbage-collection gen))))))
+) ; end WITH-ALIEN
+
 (define-alien-routine scrub-control-stack void)
 
 (defglobal sb-unicode::*name->char-buffers* nil)

src/code/sysmacs.lisp

@@ -52,6 +52,8 @@ maintained."
   (with-unique-names (without-gcing-body)
     `(dx-flet ((,without-gcing-body ()
               ,@body))
+       #+yieldpoints (sb-kernel::call-with-gc-disabled #',without-gcing-body)
+       #-yieldpoints
        (if *gc-inhibit*
            (,without-gcing-body)
            ;; We need to disable interrupts before disabling GC, so
@@ -258,7 +260,9 @@ maintained."
 ;;; System mutexes will always be our own mutex-based-on-futex (if available).
 (defmacro with-system-mutex ((mutex &key without-gcing allow-with-interrupts)
                                     &body body)
-  `(dx-flet ((with-system-mutex-thunk () ,@body))
+  `(dx-flet ((with-system-mutex-thunk ()
+               #+yieldpoints (declare (optimize (sb-c::insert-safepoints 0)))
+               ,@body))
      (,(cond (without-gcing
                'call-with-system-mutex/without-gcing)
              (allow-with-interrupts
@@ -269,5 +273,7 @@ maintained."
        ,mutex)))
 
 (defmacro with-recursive-system-lock ((lock) &body body)
-  `(dx-flet ((recursive-system-lock-thunk () ,@body))
+  `(dx-flet ((recursive-system-lock-thunk ()
+               #+yieldpoints (declare (optimize (sb-c::insert-safepoints 0)))
+               ,@body))
      (call-with-recursive-system-lock #'recursive-system-lock-thunk ,lock)))

src/code/target-signal.lisp

@@ -56,7 +56,7 @@
 ;;; doing things the SBCL way and moving this kind of C-level work
 ;;; down to C wrapper functions.)
 
-#-sb-safepoint
+#-(or sb-safepoint yieldpoints)
 (defun unblock-stop-for-gc-signal ()
   (with-alien ((%unblock (function void) :extern "unblock_gc_stop_signal"))
     (alien-funcall %unblock)
@@ -81,13 +81,13 @@
   ;; are opaque. We use our own explicit translation of 0 and 1 to them
   ;; in the C install_handler() argument passing convention.
   (with-alien ((%sigaction (function void int unsigned) :extern "install_handler"))
-    #+sb-safepoint
+    #+(or sb-safepoint yieldpoints)
     (alien-funcall %sigaction signal
                    (case handler
                      (:default 0)
                      (:ignore 1)
                      (t (sb-kernel:get-lisp-obj-address handler))))
-    #-sb-safepoint
+    #-(or sb-safepoint yieldpoints)
     (flet ((run-handler (signo info-sap context-sap)
              #-(or c-stack-is-control-stack sb-safepoint) ;; able to do that in interrupt_handle_now()
              (unblock-stop-for-gc-signal)
@@ -146,7 +146,9 @@
                  (signal int)
                  ;; Then enter the debugger like BREAK.
                  (%break 'sigint int))))))
-    #+sb-safepoint
+    ;; The comment below is confusing AF but the behavior of the
+    ;; #+sb-safepoint code is correct for #+yieldpoints as well.
+    #+(or sb-safepoint yieldpoints)
     (let ((target (sb-thread::foreground-thread)))
       ;; Note that INTERRUPT-THREAD on *CURRENT-THREAD* doesn't actually
       ;; interrupt right away, because deferrables are blocked.  Rather,
@@ -161,7 +163,7 @@
       (if (eq target sb-thread:*current-thread*)
           (interrupt-it)
           (sb-thread:interrupt-thread target #'interrupt-it)))
-    #-sb-safepoint
+    #-(or sb-safepoint yieldpoints)
     (sb-thread:interrupt-thread (sb-thread::foreground-thread)
                                 #'interrupt-it)))
 
@@ -250,3 +252,24 @@
                                           (ash num sb-vm:word-shift))))
                 (when (functionp fun)
                   (funcall fun num nil nil)))))))))
+
+#+yieldpoints
+(with-alien ((show-interrupt-data (function void) :extern)
+             (getcontext (function int system-area-pointer) :extern)
+             (get-pending-signal-number (function int) :extern)
+             (lisp-sig-handlers (array unsigned 32) :extern)
+             (flush-pending-signal-and-restore (function void) :extern))
+  (export 'showint)
+  (defun showint ()
+    (alien-funcall show-interrupt-data))
+  (defun handle-deferred-signal ()
+    (alien-funcall show-interrupt-data)
+    (let* ((c-context (make-array sb-unix::sizeof-ucontext_t :element-type '(unsigned-byte 8)))
+           (sig (alien-funcall get-pending-signal-number))
+           (fun (sb-kernel:%make-lisp-obj (deref lisp-sig-handlers sig))))
+      (aver (functionp fun))
+      (with-pinned-objects (c-context)
+        (let ((context-sap (vector-sap c-context)))
+          (alien-funcall getcontext context-sap)
+          (funcall fun sig (sb-sys:int-sap 0) context-sap)
+          (alien-funcall flush-pending-signal-and-restore))))))

src/code/target-thread.lisp

@@ -510,11 +510,11 @@ See also: RETURN-FROM-THREAD and SB-EXT:EXIT."
 
     (define-alien-routine "futex_wake" int (word-addr unsigned) (n unsigned-long))
 
-    (defun futex-wait (word-addr oldval to-sec to-usec)
+    (with-alien ((%wait (function int unsigned (unsigned 32) long unsigned-long)
-      (with-alien ((%wait (function int unsigned
+                        :extern "futex_wait"))
-                                    (unsigned 32)
+      (defun fast-futex-wait (word-addr oldval to-sec to-usec)
-                                    long unsigned-long)
+        (alien-funcall %wait word-addr oldval to-sec to-usec))
-                          :extern "futex_wait"))
+      (defun futex-wait (word-addr oldval to-sec to-usec)
         (with-interrupts
           (alien-funcall %wait word-addr oldval to-sec to-usec))))))
 
@@ -820,13 +820,6 @@ returns NIL each time."
 
 #+ultrafutex
 (progn
-(declaim (inline fast-futex-wait))
-(defun fast-futex-wait (word-addr oldval to-sec to-usec)
-  (with-alien ((%wait (function int unsigned
-                                #+freebsd unsigned #-freebsd (unsigned 32)
-                                long unsigned-long)
-                      :extern "futex_wait"))
-    (alien-funcall %wait word-addr oldval to-sec to-usec)))
 (declaim (sb-ext:maybe-inline %wait-for-mutex-algorithm-3))
 (defun %wait-for-mutex-algorithm-3 (mutex)
   #+nil ; in case I want to count calls to this function
@@ -845,7 +838,12 @@ returns NIL each time."
         (loop while (/= c 0)
               do (with-pinned-objects (mutex)
                    (fast-futex-wait (mutex-state-address mutex) 2 -1 0))
-                 (setq c (%raw-instance-xchg/word mutex (get-dsd-index mutex state) 2))))))))
+                 (setq c (%raw-instance-xchg/word mutex (get-dsd-index mutex state) 2)))))))
+(defun wait-for-mutex-algorithm-3 (mutex)
+    ;(declare (inline %wait-for-mutex-algorithm-3))
+    (let ((mutex (sb-ext:truly-the mutex mutex)))
+      (%wait-for-mutex-algorithm-3 mutex)
+      (setf (mutex-%owner mutex) (current-vmthread-id)))))
 
 #+mutex-benchmarks
 (symbol-macrolet ((val (mutex-state mutex)))
@@ -879,7 +877,7 @@ returns NIL each time."
   ;; Code size is a little less. More improvement comes from doing the
   ;; partial-inline algorithms which perform one CAS without a function call.
   (defun wait-for-mutex-algorithm-3 (mutex)
-    (declare (inline %wait-for-mutex-algorithm-3))
+    ;(declare (inline %wait-for-mutex-algorithm-3))
     (let ((mutex (sb-ext:truly-the mutex mutex)))
       (%wait-for-mutex-algorithm-3 mutex)
       (setf (mutex-%owner mutex) (current-vmthread-id))))
@@ -1268,14 +1266,10 @@ associated data:
 
 IMPORTANT: The same mutex that is used in the corresponding CONDITION-WAIT
 must be held by this thread during this call."
-  #-sb-thread
+  (declare (ignorable queue n))
-  (declare (ignore queue n))
+  #-sb-thread (error "Not supported in unithread builds.")
-  #-sb-thread
+  #+sb-futex ; implies sb-thread per feature-compatibility-tests
-  (error "Not supported in unithread builds.")
+  (progn
-  #+sb-thread
-  (cond
-   #+sb-futex
-   (t
       ;; 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. We rely on kernel thread ID being nonzero.
@@ -1288,10 +1282,9 @@ must be held by this thread during this call."
       (with-pinned-objects (queue)
         (futex-wake (waitqueue-token-address queue) n))
       nil)
-   #-sb-futex
+  #+(and sb-thread (not sb-futex))
-   (t
+  (with-cas-lock ((waitqueue-%owner queue))
-    (with-cas-lock ((waitqueue-%owner queue))
+      (%waitqueue-wakeup queue n)))
-      (%waitqueue-wakeup queue n)))))
 
 
 (declaim (ftype (sfunction (waitqueue) null) condition-broadcast))
@@ -1885,6 +1878,10 @@ session."
           (prot "protect_alien_stack_guard_page")))
       (unless (= (sap-int thread-sap) 0) thread-sap))))
 
+(sb-ext:defglobal *lisp-yps-executed* 0)
+(sb-ext:defglobal *c-yps-executed* 0)
+(declaim (fixnum *lisp-yps-executed* *c-yps-executed*))
+
 ;;; Remove thread from its session, if it has one, and from *all-threads*.
 ;;; Also clobber the pointer to the primitive thread
 ;;; which makes THREAD-ALIVE-P return false hereafter.
@@ -1925,7 +1922,9 @@ session."
         (setf (sap-ref-8 (current-thread-sap) ; state_word.sprof_enable
                          (1+ (ash sb-vm:thread-state-word-slot sb-vm:word-shift)))
               0)
-        ;; Take ownership of our statistical profiling data and transfer the results to
+        (sb-ext:atomic-incf *lisp-yps-executed* (sb-sys:sap-int (sb-vm::current-thread-offset-sap sb-vm::thread-lisp-yps-executed-slot)))
+        (sb-ext:atomic-incf *c-yps-executed* (sb-sys:sap-int (sb-vm::current-thread-offset-sap sb-vm::thread-c-yps-executed-slot)))
+        ;; take ownership of our statistical profiling data and transfer the results to
         ;; the global pool. This doesn't need to synchronize with the signal handler,
         ;; which is effectively disabled now, but does synchronize via the interruptions
         ;; mutex with any other thread trying to read this thread's data.
@@ -2062,6 +2061,7 @@ session."
   0)
 ) ; end PROGN for #+sb-thread
 
+(sb-ext:defglobal *anon-thread-name-generator* 0)
 (defun make-thread (function &key name arguments)
   "Create a new thread of NAME that runs FUNCTION with the argument
 list designator provided (defaults to no argument). Thread exits when
@@ -2075,7 +2075,10 @@ See also: RETURN-FROM-THREAD, ABORT-THREAD."
   #-sb-thread (declare (ignore function name arguments))
   #-sb-thread (error "Not supported in unithread builds.")
   #+sb-thread
-  (let ((name (when name (possibly-base-stringize name))))
+  (let ((name (if name
+                  (possibly-base-stringize name)
+                  (with-system-mutex (*make-thread-lock*)
+                    (format nil "Thr~D" (incf *anon-thread-name-generator*))))))
     (assert (or (atom arguments) (null (cdr (last arguments))))
             (arguments)
             "Argument passed to ~S, ~S, is an improper list."
@@ -2399,6 +2402,11 @@ Short version: be careful out there."
   ;;  the behavior is undefined."
   ;; so we use the death lock to keep the thread alive, unless it already isn't.
   ;;
+  (let ((str (let ((*print-pretty* nil))
+               (format nil "~s interrupts ~S with ~s~%"
+                       (thread-name *current-thread*) (thread-name thread) function))))
+    (with-pinned-objects (str)
+      (sb-unix:unix-write 2 str 0 (length str))))
   (when (with-deathlok (thread c-thread)
           ;; Return T if couldn't interrupt.
           (cond ((eql c-thread 0) t)
@@ -2647,14 +2655,12 @@ mechanism for inter-thread communication."
 
 ;;;; Stepping
 
-(defun thread-stepping ()
+#+sb-thread
-  (sap-ref-lispobj (current-thread-sap)
+(macrolet ((access-it ()
-                   (* sb-vm::thread-stepping-slot sb-vm:n-word-bytes)))
+             `(sap-ref-8 (current-thread-sap)
-
+                         (* sb-vm::thread-stepping-slot sb-vm:n-word-bytes))))
-(defun (setf thread-stepping) (value)
+  (defun thread-stepping () (access-it))
-  (setf (sap-ref-lispobj (current-thread-sap)
+  (defun (setf thread-stepping) (value) (setf (access-it) value)))
-                         (* sb-vm::thread-stepping-slot sb-vm:n-word-bytes))
-        value))
 
 ;;;; Diagnostic tool
 

src/code/thread-structs.lisp

@@ -62,7 +62,7 @@
   "Semaphore type. The fact that a SEMAPHORE is a STRUCTURE-OBJECT
 should be considered an implementation detail, and may change in the
 future."
-  (%count    0 :type (integer 0))
+  (%count    0 :type (and (integer 0) fixnum))
   (waitcount 0 :type sb-vm:word)
   (mutex nil :read-only t :type mutex)
   (queue nil :read-only t :type waitqueue))

src/code/thread.lisp

@@ -174,7 +174,7 @@ HOLDING-MUTEX-P."
      ;; Well if either HOLDING-MUTEX-P *or* if the OWNER is 0, there's no chance that
      ;; a different thread owns it.
      (unless (sb-vm::quick-try-mutex m)
-       (%wait-for-mutex-algorithm-3 m))
+       (wait-for-mutex-algorithm-3 m))
      ;; unbinding the special = releasing the mutex
      (let ((sb-vm::*current-mutex* m))
        (setf (mutex-%owner m) (current-vmthread-id))
@@ -268,11 +268,11 @@ held mutex, WITH-RECURSIVE-LOCK allows recursive lock attempts to succeed."
             (t
              `(fast-call-with-recursive-lock #'with-recursive-lock-thunk ,mutex)))))
 
+;#-ultrafutex
 (macrolet ((def (name &optional variant)
              `(defun ,(if variant (symbolicate name "/" variant) name)
                   (function mutex)
-                (declare (function function))
+                (declare (function function) (dynamic-extent function))
-                (declare (dynamic-extent function))
                 (flet ((%call-with-system-mutex ()
                          (let (got-it)
                            (unwind-protect
@@ -363,16 +363,16 @@ held mutex, WITH-RECURSIVE-LOCK allows recursive lock attempts to succeed."
           (funcall function)
           (with-ultrafutex (mutex) (funcall function)))))
 
-  (defun call-with-recursive-system-lock (function lock)
+  (defun call-with-recursive-system-lock (function mutex)
     (declare (function function))
     (declare (dynamic-extent function))
     (without-interrupts
-      (let ((had-it (holding-mutex-p lock))
+      (let ((had-it (holding-mutex-p mutex))
             (got-it nil))
         (unwind-protect
-             (when (or had-it (setf got-it (grab-mutex lock)))
+             (when (or had-it (setf got-it (grab-mutex mutex)))
                (funcall function))
           (when got-it
-            (release-mutex lock)))))))
+            (release-mutex mutex)))))))
 
 (sb-ext:define-load-time-global *make-thread-lock* nil)

src/cold/compile-cold-sbcl.lisp

@@ -233,6 +233,9 @@
                                     internal-time-units-per-second)))
                     (format t " (~5,3f sec)~%" elapsed)
                     (incf total-time elapsed)))
+                (format t "~&Total yieldpoints: ~D, deleted: ~D ~%"
+                        sb-x86-64-asm::*original-total-n-yieldpoints*
+                        sb-x86-64-asm::*total-n-yieldpoints-deleted*)
                 ;(sb-kernel::show-ctype-ctor-cache-metrics)
                 (when sb-impl::*profile-hash-cache*
                   ;;  avoid "make-host-2 stopped due to unexpected STYLE-WARNING raised from the host."

src/cold/exports.lisp

@@ -1935,7 +1935,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries.")
            "%VECTOR-RAW-BITS"
            "%SCALB" "%SCALBN"
            "%RAW-INSTANCE-ATOMIC-INCF/WORD"
-           "%RAW-INSTANCE-CAS/WORD" "%RAW-INSTANCE-XCHG/WORD"
+           "%RAW-INSTANCE-CAS/WORD" "%RAW-INSTANCE-XCHG/BYTE" "%RAW-INSTANCE-XCHG/WORD"
            "%RAW-INSTANCE-REF/WORD" "%RAW-INSTANCE-SET/WORD"
            "%RAW-INSTANCE-CAS/SIGNED-WORD"
            "%RAW-INSTANCE-REF/SIGNED-WORD" "%RAW-INSTANCE-SET/SIGNED-WORD"

src/cold/shared.lisp

@@ -327,6 +327,9 @@
           (push :salted-symbol-hash sb-xc:*features*))
         (when (target-featurep '(:and :sb-thread (:or (:and :darwin (:not (:or :ppc :x86))) :openbsd)))
           (push :os-thread-stack sb-xc:*features*))
+        (when (target-featurep '(:and (:not :sb-safepoint) (:not :yieldpoints)))
+          ;; signal-based stop-the-world (_other_ than memory-fault on a trap page)
+          (push :gc-stw-signal sb-xc:*features*))
         (when (target-featurep '(:and :x86 :int4-breakpoints))
           ;; 0xCE is a perfectly good 32-bit instruction,
           ;; unlike on x86-64 where it is illegal. It's therefore

src/cold/warm.lisp

@@ -173,6 +173,7 @@ sb-kernel::
                                     (sb-c:insert-step-conditions 0)
                                     (sb-c:alien-funcall-saves-fp-and-pc #+x86 3 #-x86 0)))
                         (compile-file (concatenate 'string *sbclroot* stem)
+                                      ;:trace-file t :print t
                                       :output-file output)))
                      ((nil) output))
                   (cond ((not output-truename)

src/compiler/assem.lisp

@@ -292,10 +292,10 @@
 (declaim (freeze-type stmt))
 (defmethod print-object ((stmt stmt) stream)
   (print-unreadable-object (stmt stream :type t :identity t)
-    (awhen (stmt-labels stmt)
+    (format t stream "~@[~A ~]~A ~:S"
-      (princ it stream)
+            (stmt-labels stmt)
-      (write-char #\space stream))
+            (stmt-mnemonic stmt)
-    (princ (stmt-mnemonic stmt) stream)))
+            (stmt-operands stmt))))
 
 ;;; A section is just a doubly-linked list of statements with a head and
 ;;; tail pointer to allow insertion anywhere,
@@ -1394,9 +1394,9 @@
   (defun extract-prefix-keywords (x) x)
   (defun decode-prefix (args) args))
 
-(defun dump-symbolic-asm (section stream &aux last-vop all-labels (n 0))
+(defun dump-symbolic-asm (start stream &aux last-vop all-labels (n 0))
   (format stream "~2&Assembler input:~%")
-  (do ((statement (stmt-next (section-start section)) (stmt-next statement))
+  (do ((statement start (stmt-next statement))
        (*print-pretty* nil))
       ((null statement))
     (incf n)
@@ -2002,7 +2002,8 @@
                (entry (list opcodes1 opcodes2  applicator index name)))
           (push entry *asm-pattern-matchers*)))))
 
-(defun combine-instructions (section)
+(defun combine-instructions (code-section elsewhere-section)
+  (declare (ignorable elsewhere-section))
   ;; Triply nested loop:
   ;;   - repeatedly scan until no further changes
   ;;   -   looking for a pattern that starts at each instruction
@@ -2013,7 +2014,7 @@
   (loop
     (let* ((any-changes)
            (stmt nil)
-           (next (section-start section)))
+           (next (section-start code-section)))
       (loop
         (setq stmt next next (stmt-next stmt))
         (unless next (return))
@@ -2046,13 +2047,19 @@
       (unless any-changes (return))))
   #+x86-64
   ;; Build the label -> stmt map
-  (let ((label->stmt (make-hash-table)))
+  (let ((label->stmt (make-hash-table))
-    (do ((stmt (section-start section) (stmt-next stmt)))
+        (elsewhere-labels (alloc-xset)))
-        ((null stmt))
+    (dolist (section `((nil . ,code-section)
-      (dolist (label (ensure-list (stmt-labels stmt)))
+                       (t   . ,elsewhere-section)))
-        (aver (not (gethash label label->stmt)))
+      (do ((stmt (section-start (cdr section)) (stmt-next stmt)))
-        (setf (gethash label label->stmt) stmt)))
+          ((null stmt))
-    (perform-jump-to-jump-elimination (section-start section) label->stmt)))
+        (dolist (label (ensure-list (stmt-labels stmt)))
+          (aver (not (gethash label label->stmt)))
+          (when (car section) ; is "elsewhere"
+            (add-to-xset label elsewhere-labels))
+          (setf (gethash label label->stmt) stmt))))
+    (perform-jump-to-jump-elimination (section-start code-section)
+                                      label->stmt elsewhere-labels)))
 
 ;; Remove macros that users should not invoke
 (push '("SB-ASSEM" define-instruction define-instruction-macro)

src/compiler/codegen.lisp

@@ -308,7 +308,8 @@
 
     (when *do-instcombine-pass*
       #+(or arm64 x86-64)
-      (sb-assem::combine-instructions (asmstream-code-section asmstream)))
+      (sb-assem::combine-instructions (asmstream-code-section asmstream)
+                                      (asmstream-elsewhere-section asmstream)))
 
     (emit (asmstream-data-section asmstream)
           (sb-assem::asmstream-data-origin-label asmstream))

src/compiler/fndb.lisp

@@ -2226,7 +2226,7 @@
 (defknown sb-vm:%write-barrier () (values) ())
 (defknown sb-vm:%data-dependency-barrier () (values) ())
 
-#+sb-safepoint
+#+(or sb-safepoint yieldpoints)
 ;;; Note: This known function does not have an out-of-line definition;
 ;;; and if such a definition were needed, it would not need to "call"
 ;;; itself inline, but could be a no-op, because the compiler inserts a

src/compiler/generic/genesis.lisp

@@ -3044,6 +3044,9 @@ Legal values for OFFSET are -4, -8, -12, ..."
   (dolist (target-feature-name (sort (mapcar #'c-symbol-name sb-xc:*features*)
                                      #'string<))
     (format t "#define LISP_FEATURE_~A~%" target-feature-name))
+  ;; A random one derived from sb-xc:*features* but not spelled in the usual way,
+  ;; and to easy to accidentaly fail to define if used in multiple files.
+  #+(and sb-thread gc-stw-signal) (format t "#define THREADS_USING_GCSIGNAL~%")
   (terpri)
   ;; and miscellaneous constants
   (format t "#define SBCL_TARGET_ARCHITECTURE_STRING ~S~%"
@@ -3376,6 +3379,7 @@ lispobj symbol_package(struct symbol*);~%" (genesis-header-prefix))
   ;; but it gets cast to HANDLE upon use.
   #+(and unix sb-thread) (format t "#include <pthread.h>~%")
   (format t "#include ~S
+#include ~S
 
 #define N_HISTOGRAM_BINS_LARGE 32
 #define N_HISTOGRAM_BINS_SMALL 32
@@ -3395,6 +3399,7 @@ struct thread_state_word {
           ;; autogenerated files can use full paths to other inclusions
           ;; (in case your build system disfavors use of -I compiler options)
           (namestring (merge-pathnames "gencgc-alloc-region.h" (lispobj-dot-h)))
+          (namestring (merge-pathnames "tiny-lock.h" (lispobj-dot-h)))
           #+64-bit "  char padding[4];" #-64-bit ""))
 
 (defun write-weak-pointer-manipulators ()

src/compiler/generic/objdef.lisp

@@ -553,7 +553,7 @@ during backtrace.
   ;; of a symbol is initialized to zero
   (no-tls-value-marker)
 
-  (stepping)
+  (stepping :c-type "struct {int step; int suspend;}")
 
   ;; Keep this first bunch of slots from binding-stack-pointer through alloc-region
   ;; near the beginning of the structure so that x86[-64] assembly code
@@ -616,6 +616,9 @@ during backtrace.
   ;; a struct containing {starting, running, suspended, dead}
   ;; and some other state fields.
   (state-word :c-type "struct thread_state_word")
+  (yieldpoint-spinlock :c-type "lock_t")
+  (yieldpoint-page-access)
+  (interrupt-reason)
   ;; Statistical CPU profiler data recording buffer
   (sprof-data)
   ;;
@@ -647,6 +650,13 @@ during backtrace.
   (symbol-tlab :c-type "struct alloc_region" :length 3)
   (sys-mixed-tlab :c-type "struct alloc_region" :length 3)
   (sys-cons-tlab :c-type "struct alloc_region" :length 3)
+  (spill-cons-tlab-end)
+  (spill-mixed-tlab-end)
+  (spill-sys-cons-tlab-end)
+  (spill-sys-mixed-tlab-end)
+  (lisp-yps-executed)
+  (c-yps-executed)
+  ;;(spill-boxed-tlab-end)
   ;; allocation instrumenting
   (tot-bytes-alloc-boxed)
   (tot-bytes-alloc-unboxed)

src/compiler/generic/parms.lisp

@@ -251,13 +251,14 @@
     ;; the C function is in a dynamic shared object or not)
     +required-foreign-symbols+
 
+     ;; arbitrary object that changes after each GC
+     sb-kernel::*gc-epoch*
+
     ;;; The following symbols aren't strictly required to be static
     ;;; - they are not accessed from C - but we make them static in order
     ;;; to (perhaps) micro-optimize access in Lisp.
     ;;; However there is no efficiency gain if we have #+immobile-space.
     #-immobile-space ,@'(
-     ;; arbitrary object that changes after each GC
-     sb-kernel::*gc-epoch*
      ;; Dispatch tables for generic array access
      %%data-vector-reffers%%
      %%data-vector-reffers/check-bounds%%
@@ -366,10 +367,10 @@
 (defconstant thread-header-slots
   ;; This seems to need to be an even number.
   ;; I'm not sure what the constraint on that stems from.
-  #+(and x86-64 sb-safepoint) 14 ; the safepoint trap page is at word index -15
+  #+x86-64 (or #+(or sb-safepoint yieldpoints) 14 ; the safepoint trap page is at word index -15
-  #+(and x86-64 (not sb-safepoint)) 16
+                                               16)
-  #+(and (not x86-64) immobile-space) 14 ; the safepoint trap page is at word index -15
+  #-x86-64 (or #+immobile-space 14 ; the safepoint trap page is at word index -15
-  #+(and (not x86-64) (not immobile-space)) 0)
+                                0))
 
 (progn
   (defconstant +highest-normal-generation+ 5)

src/compiler/generic/utils.lisp

@@ -529,7 +529,7 @@
   ;; occurs at the end. In that case, we can not prevent stop-for-GC
   ;; from occurring in the C code, because foreign code is allowed
   ;; to run during GC; it just can't go back into Lisp until GC is over.
-  #-sb-safepoint
+  #-(or sb-safepoint yieldpoints)
   (loop for e = (sb-c::node-lexenv (sb-c::vop-node vop))
         then (sb-c::lexenv-parent e)
         while e

src/compiler/generic/vm-fndb.lisp

@@ -241,6 +241,7 @@
 #+(or arm64 riscv x86 x86-64)
 (defknown %raw-instance-cas/signed-word (instance index sb-vm:signed-word sb-vm:signed-word)
   sb-vm:signed-word ())
+(defknown %raw-instance-xchg/byte (instance index (unsigned-byte 8)) (unsigned-byte 8) ())
 (defknown %raw-instance-xchg/word (instance index sb-vm:word) sb-vm:word ())
 
 (macrolet ((define-raw-slot-defknowns ()

src/compiler/ir2opt.lisp

@@ -1230,7 +1230,7 @@
          ;; but the slot setters don't all have to be updated to understand how to
          ;; terminate the pseudo-atomic sequence. It's a separate vop to do that.
          (emit-and-insert-vop (vop-node last) (vop-block last)
-                              (template-or-lose 'end-pseudo-atomic)
+                              (template-or-lose 'end-allocation)
                               nil nil (vop-next last)))
        (process-closure-inits (vop)
          (let* ((result-ref (vop-results vop))

src/compiler/ir2tran.lisp

@@ -1635,7 +1635,7 @@
     (let ((lab (gen-label)))
       (setf (ir2-environment-environment-start env) lab)
       (vop note-environment-start node block lab)
-      #+sb-safepoint
+      #+(or sb-safepoint yieldpoints)
       (when (policy fun (/= insert-safepoints 0))
         (vop sb-vm::insert-safepoint node block))))
 
@@ -2362,7 +2362,7 @@
                        2block
                        *dynamic-counts-tn*
                        num))))
-              #+sb-safepoint
+              #+(or sb-safepoint yieldpoints)
               (let ((first-node (block-start-node block)))
                 (unless (or (and (bind-p first-node)
                                  ;; Bind-nodes already have safepoints

src/compiler/policies.lisp

@@ -142,7 +142,6 @@ debugger.")
     1
   ("no" "no" "yes" "yes"))
 
-#+sb-safepoint
 (define-optimization-quality insert-safepoints
     1
   ("no" "yes" "yes" "yes")

src/compiler/pseudo-vops.lisp

@@ -39,7 +39,7 @@
   (:generator 0
      (emit-label the-label)))
 
-#+sb-safepoint
+#+(or sb-safepoint yieldpoints)
 (define-vop (sb-vm::insert-safepoint)
   (:policy :fast-safe)
   (:translate sb-kernel::gc-safepoint)

src/compiler/x86-64/alloc.lisp

@@ -185,8 +185,9 @@
 ;;; the allocator to use cons_tlab.
 (defconstant +cons-primtype+ list-pointer-lowtag)
 
-(define-vop (sb-c::end-pseudo-atomic)
+(define-vop (sb-c::end-allocation)
-  (:generator 1 (emit-end-pseudo-atomic)))
+  (:generator 1
+    #-sb-safepoint (emit-end-pseudo-atomic)))
 
 ;;; Emit code to allocate an object with a size in bytes given by
 ;;; SIZE into ALLOC-TN. The size may be an integer of a TN.
@@ -249,7 +250,7 @@
              ;; alloc-tn <- old free ptr and temp <- new free ptr
              (inst xadd temp alloc-tn)
              (inst cmp temp end-addr)
-             (inst jmp :a NOT-INLINE)
+             (note-yieldpoint (inst jmp :a NOT-INLINE))
              (inst mov free-pointer temp)
              (emit-label DONE)
              (when (/= lowtag 0) (inst or :byte alloc-tn lowtag))
@@ -268,14 +269,14 @@
                     (when (tn-p size) (aver (not (location= size temp))))
                     (inst lea temp (ea size alloc-tn))
                     (inst cmp temp end-addr)
-                    (inst jmp :a NOT-INLINE)
+                    (note-yieldpoint (inst jmp :a NOT-INLINE))
                     (inst mov free-pointer temp)
                     (emit-label DONE)
                     (when (/= lowtag 0) (inst or :byte alloc-tn lowtag)))
                    (t
                     (inst add alloc-tn size)
                     (inst cmp alloc-tn end-addr)
-                    (inst jmp :a NOT-INLINE)
+                    (note-yieldpoint (inst jmp :a NOT-INLINE))
                     (inst mov free-pointer alloc-tn)
                     (cond ((tn-p size)
                            (inst sub alloc-tn size)
@@ -310,7 +311,7 @@
   (instrument-alloc widetag bytes node (cons result-tn (ensure-list alloc-temps)) thread-temp)
   (let ((header (compute-object-header nwords widetag))
         (alloc-temp (if (listp alloc-temps) (car alloc-temps) alloc-temps)))
-    (pseudo-atomic ()
+    (with-allocator ()
       (cond (alloc-temp
              (allocation widetag bytes 0 result-tn node alloc-temp thread-temp)
              (storew* header result-tn 0 0 t)
@@ -413,7 +414,7 @@
              (zeroed #+mark-region-gc t)
              (prev-constant temp)) ;; a non-eq initial value
          (instrument-alloc +cons-primtype+ nbytes node (list temp alloc) thread-tn)
-         (pseudo-atomic (:thread-tn thread-tn)
+         (with-allocator (:thread-tn thread-tn)
            (allocation +cons-primtype+ nbytes 0 alloc node temp thread-tn)
            (store-slot car alloc cons-car-slot 0)
            (store-slot cdr alloc cons-cdr-slot 0)
@@ -437,7 +438,7 @@
           (zeroed #+mark-region-gc t)
           (prev-constant temp))
       (instrument-alloc +cons-primtype+ nbytes node (list temp alloc) thread-tn)
-      (pseudo-atomic (:thread-tn thread-tn)
+      (with-allocator (:thread-tn thread-tn)
         (allocation +cons-primtype+ nbytes 0 alloc node temp thread-tn)
         (store-slot tail alloc cons-cdr-slot 0)
         (inst lea temp (ea (+ 16 list-pointer-lowtag) alloc))
@@ -482,7 +483,7 @@
              (zeroed #+mark-region-gc t)
              (prev-constant temp))
          (instrument-alloc +cons-primtype+ nbytes node (list temp alloc) thread-tn)
-         (pseudo-atomic (:thread-tn thread-tn)
+         (with-allocator (:thread-tn thread-tn)
            (allocation +cons-primtype+ nbytes 0 alloc node temp thread-tn)
            (store-slot car alloc cons-car-slot 0)
            (store-slot cadr alloc (+ 2 cons-car-slot) 0)
@@ -509,7 +510,7 @@
            (prev-constant temp))
       (unless stack-allocate-p
         (instrument-alloc +cons-primtype+ size node (list ptr temp) thread-tn))
-      (pseudo-atomic (:elide-if stack-allocate-p :thread-tn thread-tn)
+      (with-allocator (:elide-if stack-allocate-p :thread-tn thread-tn)
         (if stack-allocate-p
             (stack-allocation size list-pointer-lowtag res)
             (allocation +cons-primtype+ size list-pointer-lowtag res node temp thread-tn))
@@ -676,7 +677,7 @@
         ;; It would be possible to do this and the array proper
         ;; in a single pseudo-atomic section, but I don't care to do that.
         (let ((nbytes (calc-shadow-bits-size result)))
-          (pseudo-atomic ()
+          (with-allocator ()
             ;; Allocate the bits into RESULT
             (allocation simple-bit-vector-widetag nbytes 0 result node temp nil)
             (inst mov :byte (ea result) simple-bit-vector-widetag)
@@ -715,7 +716,7 @@
                                 (t 'unboxed-array))
                               type)
                           size-tn node instrumentation-temp thread-tn)
-        (pseudo-atomic (:thread-tn thread-tn)
+        (with-allocator (:thread-tn thread-tn)
          (allocation type size-tn 0 result node alloc-temp thread-tn)
          (put-header result 0 type length t alloc-temp)
          (inst or :byte result other-pointer-lowtag)))
@@ -901,7 +902,7 @@
             (loop (gen-label))
             (leave-pa (gen-label)))
         (instrument-alloc +cons-primtype+ size node (list next limit) thread-tn)
-        (pseudo-atomic (:thread-tn thread-tn)
+        (with-allocator (:thread-tn thread-tn)
          (allocation +cons-primtype+ size list-pointer-lowtag result node limit thread-tn
                      :overflow
                      (lambda ()
@@ -957,10 +958,11 @@
            (header (logior (ash (1- words) n-widetag-bits) closure-widetag))
            (remain-pseudo-atomic
             (eq (car (last (vop-codegen-info vop))) :pseudo-atomic)))
+      (declare (ignorable remain-pseudo-atomic))
       (unless stack-allocate-p
         (instrument-alloc closure-widetag bytes node (list result temp) thread-tn))
-      (pseudo-atomic (:default-exit (not remain-pseudo-atomic)
+      (with-allocator (:default-exit (not remain-pseudo-atomic)
-                      :elide-if stack-allocate-p :thread-tn thread-tn)
+                       :elide-if stack-allocate-p :thread-tn thread-tn)
         (if stack-allocate-p
             (stack-allocation bytes fun-pointer-lowtag result stack-allocate-p)
             (allocation closure-widetag bytes fun-pointer-lowtag result node temp thread-tn))
@@ -1030,13 +1032,14 @@
                     &aux (bytes (pad-data-block words))
                          (remain-pseudo-atomic
                           (eq (car (last (vop-codegen-info vop))) :pseudo-atomic)))
+    (declare (ignorable remain-pseudo-atomic))
     #+bignum-assertions
     (when (eq type bignum-widetag) (setq bytes (* bytes 2))) ; use 2x the space
     (progn name) ; possibly not used
     (unless stack-allocate-p
       (instrument-alloc type bytes node (list result alloc-temp) thread-tn))
-    (pseudo-atomic (:default-exit (not remain-pseudo-atomic)
+    (with-allocator (:default-exit (not remain-pseudo-atomic)
-                    :elide-if stack-allocate-p :thread-tn thread-tn)
+                     :elide-if stack-allocate-p :thread-tn thread-tn)
       ;; If storing a header word, defer ORing in the lowtag until after
       ;; the header is written so that displacement can be 0.
       (cond (stack-allocate-p
@@ -1106,6 +1109,7 @@
      ;; But it seems we never need this! (so is it FIXME or isn't it?)
      (error "can't %MAKE-FUNCALLABLE-INSTANCE of unknown length"))
    (let ((remain-pseudo-atomic (eq (car (last (vop-codegen-info vop))) :pseudo-atomic)))
+     (declare (ignorable remain-pseudo-atomic))
    ;; With the exception of bignums, these objects have effectively
    ;; 32-bit headers because the high 4 byes contain a layout pointer.
      (let ((operand-size (if (= type bignum-widetag) :qword :dword)))
@@ -1127,8 +1131,8 @@
              ;; because it might be in the same physical reg as BYTES.
              ;; Yup, the lifetime specs in this vop are pretty confusing.
              (instrument-alloc type bytes node alloc-temp thread-tn)
-             (pseudo-atomic (:default-exit (not remain-pseudo-atomic)
+             (with-allocator (:default-exit (not remain-pseudo-atomic)
-                             :thread-tn thread-tn)
+                              :thread-tn thread-tn)
               (allocation type bytes lowtag result node alloc-temp thread-tn)
               (storew header result 0 lowtag)))))))
 
@@ -1149,7 +1153,7 @@
     (move c-arg-1 total-words)
     (move c-arg-2 boxed-words)
     (with-registers-preserved (c :except #-win32 rdi #+win32 rcx :frame-reg r15)
-      (pseudo-atomic () (call-c "alloc_code_object"))
+      (with-allocator () (call-c "alloc_code_object"))
       (move c-arg-1 rax-tn))
     (move res c-arg-1)))
 
@@ -1178,7 +1182,7 @@
    ;; RSP needn't be restored because the allocators all return immediately
    ;; which has that effect
    (inst and rsp-tn -16)
-   (pseudo-atomic ()
+   (with-allocator ()
      (call-c (c-fun "alloc_immobile_fixedobj"))
      (move result rax))))
 
@@ -1215,7 +1219,7 @@
     ;; because it is no longer a page of symbols but rather a free page.
     ;; There is no way to inform GC that we are currently looking at a page
     ;; in anticipation of allocating to it.
-    (pseudo-atomic ()
+    (with-allocator ()
        (inst mov :dword rax (ea 4 rax)) ; rax := fixedobj_page_hint[1] (sizeclass=SYMBOL)
        (inst test :dword rax rax)
        (inst jmp :z FAIL) ; fail if hint page is 0

src/compiler/x86-64/array.lisp

@@ -85,7 +85,7 @@
     (inst or  :dword header type)
     (inst shr :dword header n-fixnum-tag-bits)
     (instrument-alloc nil bytes node temp thread-tn)
-    (pseudo-atomic (:thread-tn thread-tn)
+    (with-allocator (:thread-tn thread-tn)
      (allocation type bytes 0 result node temp thread-tn)
      (storew header result 0 0)
      (inst or :byte result other-pointer-lowtag))))

src/compiler/x86-64/c-call.lisp

@@ -264,17 +264,14 @@
            (inst mov res (thread-slot-ea thread-alien-linkage-table-base-slot))
            (inst mov res (ea (make-fixup foreign-symbol :alien-data-linkage-index) res))))))
 
-#+sb-safepoint
-(defconstant thread-saved-csp-offset (- (1+ sb-vm::thread-header-slots)))
-
 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
   (defun destroyed-c-registers ()
     ;; Safepoints do not save interrupt contexts to be scanned during
     ;; GCing, it only looks at the stack, so if a register isn't
     ;; spilled it won't be visible to the GC.
-    #+sb-safepoint
+    #+(or sb-safepoint yieldpoints)
     '((:save-p t))
-    #-sb-safepoint
+    #-(or sb-safepoint yieldpoints)
     (let ((gprs (list '#:rcx '#:rdx #-win32 '#:rsi #-win32 '#:rdi
                       '#:r8 '#:r9 '#:r10 '#:r11))
           (vars))
@@ -389,8 +386,8 @@
   ;; the UNDEFINED-ALIEN-TRAMP lisp asm routine to recognize the various shapes
   ;; this instruction sequence can take.
   #-win32
-  (pseudo-atomic (:elide-if (not (call-out-pseudo-atomic-p vop)))
+  (let ((operand
-    (inst call (if (tn-p fun)
+         (if (tn-p fun)
                  fun
                  #-immobile-space (ea (make-fixup fun :foreign 8))
                  #+immobile-space
@@ -401,6 +398,24 @@
                         ;; spilled by Lisp because a C function has to save it if used)
                         (inst mov r10-tn (thread-slot-ea thread-alien-linkage-table-base-slot))
                         (ea (make-fixup fun :alien-code-linkage-index 8) r10-tn))))))
+    (cond ((or (call-out-pseudo-atomic-p vop)
+               (policy (sb-c::vop-node vop) (= sb-c:insert-safepoints 0)))
+           #+yieldpoints (inst call operand)
+           #-yieldpoints (pseudo-atomic () (inst call operand)))
+          #+yieldpoints
+          (t
+           ;; GC can run without pausing this thread so long as the thread indicates that
+           ;; it is in foreign code by the saved-csp being nonzero. The PC of the call site
+           ;; can be read from the word below the stack pointer that is saved here,
+           ;; which is important if that PC needs to pin a Lisp function.
+           ;; Possibly TODO: the pre/post-call instructions could be incorporated into the
+           ;; linkage table entry.
+           (inst yieldpoint :call-out)
+           (inst call operand)
+           (inst yieldpoint :call-out-done))
+          #-yieldpoints
+          (t
+           (inst call operand))))
 
   ;; On win64, we don't support immobile space (yet) and calls go through one of
   ;; the thunks defined in set_up_win64_seh_data(). If the linkage table is

src/compiler/x86-64/call.lisp

@@ -887,7 +887,8 @@
   (when (static-fdefn-offset name)
     (let ((fixup (make-fixup name :static-call)))
       (return-from emit-direct-call
-        (inst* instruction (if (sb-c::code-immobile-p node) fixup (ea fixup))))))
+        (note-yieldpoint (inst* instruction
+                                (if (sb-c::code-immobile-p node) fixup (ea fixup)))))))
   (let* ((fixup (make-fixup name :fdefn-call))
          (target
               (if (and (sb-c::code-immobile-p node)
@@ -902,7 +903,7 @@
                     ;; RAX will get loaded regardless.
                     (inst mov rax-tn fixup)
                     rax-tn))))
-    (inst* instruction target)))
+    (note-yieldpoint (inst* instruction target))))
 
 ;;; Invoke the function-designator FUN.
 (defun tail-call-unnamed (fun type vop)
@@ -1341,7 +1342,7 @@
            (inst jmp :z done)))
     (unless (node-stack-allocate-p node)
       (instrument-alloc +cons-primtype+ rcx node (list value dst) thread-tn))
-    (pseudo-atomic (:elide-if (node-stack-allocate-p node) :thread-tn thread-tn)
+    (with-allocator (:elide-if (node-stack-allocate-p node) :thread-tn thread-tn)
        ;; Produce an untagged pointer into DST
        (if (node-stack-allocate-p node)
            (stack-allocation rcx 0 dst)

src/compiler/x86-64/cell.lisp

@@ -54,7 +54,7 @@
            ;; But funcallable-instances are on PAGE_TYPE_CODE, and code pages do not use
            ;; MMU-based protection regardless of this feature.
            ;; So we have to alter the card mark differently.
-           (pseudo-atomic ()
+           (pseudo-atomic () ; setting funinstance-fun
              (emit-code-page-gengc-barrier object val-temp)
              (emit-store (object-slot-ea object offset lowtag) value val-temp)))
           (t
@@ -507,7 +507,7 @@
     ;;      refer to doc/internals-notes/fdefn-gc-safety
     ;; No barrier here, because fdefns in immobile space rely on the SIGSEGV signal
     ;; to manage the card marks.
-    (pseudo-atomic ()
+    (pseudo-atomic () ; setting fdefn-fun
       (storew function fdefn fdefn-fun-slot other-pointer-lowtag)
       (storew raw-word fdefn fdefn-raw-addr-slot other-pointer-lowtag)
       ;; Ensure that the header contains a JMP instruction, not INT3.
@@ -627,13 +627,7 @@
           do
           #+ultrafutex
           (when (eq symbol '*current-mutex*)
-            (let ((uncontested (gen-label)))
+            (invoke-asm-routine 'call 'mutex-unlock-if-held vop))
-              (inst mov temp tls-cell) ; load the current value
-              (inst mov :qword (mutex-slot temp %owner) 0)
-              (inst dec :lock :byte (mutex-slot temp state))
-              (inst jmp :z uncontested) ; if ZF then previous value was 1, no waiters
-              (invoke-asm-routine 'call 'mutex-wake-waiter vop)
-              (emit-label uncontested)))
 
           (inst sub bsp (* binding-size n-word-bytes))
 
@@ -680,7 +674,7 @@
       (let ((notmutex (gen-label)))
         (inst cmp :dword symbol (make-fixup '*current-mutex* :symbol-tls-index))
         (inst jmp :ne notmutex)
-        (inst call (ea (make-fixup 'mutex-unlock :assembly-routine*)))
+        (inst call (ea (make-fixup 'mutex-unlock-if-held :assembly-routine*)))
         (emit-label notmutex))
       (inst test :dword symbol symbol))
     #-sb-thread
@@ -744,7 +738,7 @@
   (:generator 4
    (let ((ea (ea (- (* funcallable-instance-info-offset n-word-bytes) fun-pointer-lowtag)
                  object index (index-scale n-word-bytes index))))
-     (pseudo-atomic ()
+     (pseudo-atomic () ; setting funinstance-info
        (emit-code-page-gengc-barrier object val-temp)
        (emit-store ea value val-temp))))))
 
@@ -895,9 +889,11 @@
   instance-slots-offset instance-pointer-lowtag
   (signed-reg) signed-num %raw-instance-cas/signed-word)
 
-(define-vop ()
+(define-vop (%raw-instance-xchg/word)
   (:translate %raw-instance-xchg/word)
   (:policy :fast-safe)
+  (:variant-vars operand-size)
+  (:variant :qword)
   (:args (instance :scs (descriptor-reg))
          (newval :scs (unsigned-reg immediate constant) :target result))
   (:info index)
@@ -905,6 +901,7 @@
   (:results (result :scs (unsigned-reg)))
   (:result-types unsigned-num)
   (:temporary (:sc unsigned-reg) temp)
+  (:vop-var vop)
   (:generator 3
     ;; Use RESULT as the source of the exchange, unless doing so
     ;; would clobber NEWVAL
@@ -912,11 +909,15 @@
       (if (sc-is newval immediate)
           (inst mov source (constantize (tn-value newval)))
           (move source newval))
-      (inst xchg (ea (- (ash (+ instance-slots-offset index) word-shift)
+      (inst xchg operand-size
-                        instance-pointer-lowtag) instance)
+            (ea (- (ash (+ instance-slots-offset index) word-shift) instance-pointer-lowtag)
+                instance)
             source)
       (unless (eq source result)
         (move result temp)))))
+(define-vop (%raw-instance-xchg/byte %raw-instance-xchg/word)
+  (:translate %raw-instance-xchg/byte)
+  (:variant :byte))
 
 ;;;; code object frobbing
 

src/compiler/x86-64/insts.lisp

@@ -23,7 +23,7 @@
   #+sb-simd-pack-256
   (import '(sb-vm::int-avx2-reg sb-vm::double-avx2-reg sb-vm::single-avx2-reg))
   (import '(sb-vm::tn-byte-offset sb-vm::tn-reg sb-vm::reg-name
-            sb-vm::frame-byte-offset sb-vm::rip-tn sb-vm::rbp-tn
+            sb-vm::frame-byte-offset sb-vm::rip-tn sb-vm::rbp-tn sb-vm::rsp-tn
             sb-vm::gpr-tn-p sb-vm::stack-tn-p sb-c::tn-reads sb-c::tn-writes
             sb-vm::ymm-reg
             sb-vm::registers sb-vm::float-registers sb-vm::stack))) ; SB names
@@ -1200,7 +1200,7 @@
          (let ((ss (1- (integer-length scale)))
                (index (if (null index)
                           #b100
-                          (if (location= index sb-vm::rsp-tn)
+                          (if (location= index rsp-tn)
                               (error "can't index off of RSP")
                               (reg-encoding (if xmm-index
                                                 (get-fpr :xmm (tn-offset index))
@@ -2356,6 +2356,32 @@
   (:emitter
    (emit-byte segment byte)))
 
+#+nil
+(defun sb-c::emit-patchable-yieldpoint-nop (name) ; 4-byte NOP
+  (cond ((eql (string/= "TWO-WORD-BIGNUM" name) 15)
+         ;; these routines need the carry flag so we don't want
+         ;; to mess it up by doing a TEST instruction.
+         ;; I guess we could emit the 6-byte MOV yieldpoint.
+         ;; For the time being, I'm doing the yieldpoint at the end,
+         ;; inside the routine, and not overwriting with a NOP.
+         )
+        ((member name '(sb-vm::enable-alloc-counter ; not sure about this or the next
+                        sb-vm::enable-sized-alloc-counter
+                        sb-vm::undefined-tramp ; don't need one here
+                        sb-vm::undefined-alien-tramp ; or here
+                        sb-vm::handle-deferred-signal ; don't want
+                        sb-vm::tail-call-variable ; don't need - calls a function
+                        sb-vm::tail-call-callable-variable ; "
+                        sb-vm::call-symbol ; "
+                        sb-kernel:update-object-layout ; "
+                        sb-impl::install-hash-table-lock ; "
+                        sb-vm::fpr-save ; internal use only for other ASM routines
+                        sb-vm::fpr-restore)) ; "
+         nil)
+        (t ; otherwise emit a 4-byte NOP
+         (dolist (b '(#x0f #x1f #x40 #x00))
+           (inst byte b)))))
+
 ;;; Compute the distance backward to the base address of the code component
 ;;; containing this simple-fun header, measured in words.
 (defun emit-header-data (segment type)
@@ -3587,6 +3613,138 @@
       (delete-stmt next)
       stmt)))
 
+(defconstant-eqx yieldpoint-asm-routines
+    '(sb-c:return-multiple
+      sb-c:tail-call-variable
+      sb-vm::tail-call-callable-variable
+      sb-vm::call-symbol
+      throw sb-c:unwind
+      sb-kernel:update-object-layout
+      sb-vm::return-values-list)
+  #'equal)
+
+#+nil
+(defun copy-asm-statements (start)
+  (let* ((new-head (copy-structure start))
+         (new-prev new-head)
+         (stmt start))
+    (loop
+      (let ((next (stmt-next stmt)))
+        (when (null next) (return new-head))
+        (let ((copy-of-next (copy-structure next)))
+          (setf (stmt-next new-prev) copy-of-next
+                (stmt-prev copy-of-next) new-prev)
+          (setq new-prev copy-of-next
+                stmt next))))))
+
+(defvar *original-total-n-yieldpoints* 0)
+(defvar *total-n-yieldpoints-deleted* 0)
+(defun delete-redundant-yieldpoints (start label->stmt-map elsewhere-labels &aux (n-deleted 0) original)
+  (declare (ignorable original))
+  #+nil (setq original (copy-asm-statements start))
+  ;; Given straight-line code: POINT1 .. anything .. POINT2
+  ;; then POINT1 is redundant because POINT2 is eventually hit.
+  (labels ((yieldpoint-inst-p (x) (eq (stmt-mnemonic x) 'yieldpoint))
+           (straight-line-to-yieldpoint-p (from follow-branches)
+             ;; Return true if there is no control flow to the next yieldpoint starting at FROM,
+             ;; i.e. if it is certain that a yieldpoint is hit; NIL otherwise.
+             (do ((s from (stmt-next s)))
+                 ((null s) nil)
+               ;;(format t "~&Consider s-l-to-yp ~s ~S~%" s)
+               (when (or (yieldpoint-inst-p s)
+                         ;; CALL and unconditional JMP can be annotated as yieldpoints
+                         ;; and this shortcut is easier than deducing based on the operands
+                         (eq (stmt-plist s) :yieldpoint)
+                           ;; BREAK invokes a signal handler, and signal handlers yield
+                         (eq (stmt-mnemonic s) 'break))
+                 (return t))
+               (when (eq (stmt-mnemonic s) 'ret)
+                 (return nil))
+               (when (member (stmt-mnemonic s) '(jmp call))
+                 (case (categorize-branch (car (last (stmt-operands s)))
+                                          (keywordp (car (stmt-operands s))) ; conditional
+                                          s
+                                          follow-branches)
+                   (:yieldpoint (return t)) ; consider the jmp/call a yieldpoint
+                   (:ignore ; just continue looking for a yieldpoint
+                    ;(format t "~A ~S = :IGNORE~%" (stmt-mnemonic s) (stmt-operands s))
+                    )
+                   (t
+                    ;(format t "~A ~S can't ignore~%" (stmt-mnemonic s) (stmt-operands s))
+                    (return nil)))))) ; no good
+           (categorize-branch (target conditional stmt follow-branches)
+             ;; JMP and CALL are tricky:
+             ;; - CALL to any Lisp function is a yieldpoint per se, as every
+             ;;   function can be assumed to yield in its prologue.
+             ;; - foreign call is preceded by a yieldpoint.
+             ;; JMP depends on a few things:
+             ;; - JMP to a lisp function is a tail-call. The called function will
+             ;;   commence with a yieldpoint. This goes for named or un-named call.
+             ;; - JMP to a BREAK is not a yieldpoint per se, unless it's unconditional.
+             ;    If conditional it does not disrupt straight-line code.
+             ;; CALL to assembly routine is generally considered straight-line code
+             ;; though a few routines can be treated as yieldpoints.
+             (when (label-p target)
+               (when (and conditional (xset-member-p target elsewhere-labels))
+                 ;; Branching to the elsewhere segment is like straight-line code
+                 ;; because the exceptional path contains a yieldpoint.
+                 (return-from categorize-branch :ignore))
+               (return-from categorize-branch
+                 (let ((target (gethash target label->stmt-map)))
+                   (cond ((and follow-branches conditional
+                               ;; If, no matter which way you branch, it is straight-line to a yieldpoint,
+                               ;; then this branch is as good as a yieldpoint.
+                               (straight-line-to-yieldpoint-p (stmt-next stmt) nil)
+                               (straight-line-to-yieldpoint-p target nil))
+                          :yieldpoint)
+                         ((and follow-branches (not conditional)) ; maybe this does nothing now?
+                          (straight-line-to-yieldpoint-p target nil))
+                         (t ; also this, is it helpful? Branching to ELSEWHERE was already handled,
+                          ;; but sometimes we have error breaks in non-elsewhere
+                          (do ((stmt target (stmt-next stmt))) ; quick check
+                              (nil)
+                            (aver stmt)
+                            (when (eq (stmt-mnemonic stmt) 'break)
+                              (return (if conditional :ignore :yieldpoint)))
+                            (unless (eq (stmt-mnemonic stmt) 'mov)
+                              (return nil))))))))
+             (let ((fixup (cond ((and (fixup-p target)
+                                      (eq (fixup-flavor target) :assembly-routine))
+                                 target)
+                                ((and (ea-p target)
+                                      (fixup-p (ea-disp target))
+                                      (eq (fixup-flavor (ea-disp target)) :assembly-routine*))
+                                 (ea-disp target)))))
+               (when fixup
+                 (return-from categorize-branch
+                   (if (member (fixup-name fixup) yieldpoint-asm-routines) :yieldpoint :ignore))))
+             (when (and (ea-p target)
+                        (ea-base target)
+                        (eql (ea-disp target) (- sb-vm:n-word-bytes sb-vm:fun-pointer-lowtag))
+                        (location= (ea-base target) sb-vm::rax-tn))
+               (return-from categorize-branch :yieldpoint))))
+    (let ((stmt start))
+      (loop
+        (when (null stmt) (return))
+        (let ((next (stmt-next stmt)))
+          ;; A call-out yieldpoint can't be deleted, but a call-out can count as
+          ;; the subsequent yieldpoint for a preceding Lisp yieldpoint.
+          (when (and (yieldpoint-inst-p stmt) (eq (car (stmt-operands stmt)) :lisp))
+            (incf *original-total-n-yieldpoints*)
+            (when (straight-line-to-yieldpoint-p next t)
+              (incf n-deleted)
+              (awhen (stmt-labels stmt) (add-stmt-labels next it))
+              (delete-stmt stmt)))
+          (setq stmt next)))))
+  #+nil
+  (when (plusp n-deleted)
+    (with-open-file (f "/tmp/asmdump.txt" :direction :output :if-exists :append :if-does-not-exist :create)
+      (format f "~&Deleted ~D yieldpoints. Original code:~%" n-deleted)
+      (sb-assem::dump-symbolic-asm original f)
+      (terpri f)
+      (sb-assem::dump-symbolic-asm start f)))
+  (incf *total-n-yieldpoints-deleted* n-deleted))
+
 ;;; Return :TAKEN if taking the conditional branch COND1 implies that COND2's
 ;;; branch will be taken, or :NOT-TAKEN if COND2 will fallthrough,
 ;;; or NIL it can't be determined.
@@ -3609,10 +3767,7 @@
           ((conditions :a :ne) :taken) ; above to not-equal
           (t nil))))
 
-;;; Possible enhancement: it should be possible to eliminate more jumps-to-jumps
+(defun sb-assem::perform-jump-to-jump-elimination (starting-stmt label->stmt-map elsewhere-labels)
-;;; by knowing something about implication of one condition upon another, e.g.
-;;; either JC or JZ jumping to JBE would take the second jump, since JBE is (CF=1 or ZF=1).
-(defun sb-assem::perform-jump-to-jump-elimination (starting-stmt label->stmt-map)
   (flet ((jmp-cond (stmt)
            (if (cdr (stmt-operands stmt))
                (encoded-condition (car (stmt-operands stmt)))
@@ -3639,4 +3794,5 @@
                          (let ((label (gen-label))) ; maake a new label
                            (setf (gethash label label->stmt-map) fallthrough)
                            (add-stmt-labels fallthrough label)))))
-               (setf (car (last (stmt-operands stmt))) label)))))))))
+               (setf (car (last (stmt-operands stmt))) label))))))))
+  (delete-redundant-yieldpoints starting-stmt label->stmt-map elsewhere-labels))

src/compiler/x86-64/macros.lisp

@@ -195,14 +195,64 @@
 (defmacro %clear-pseudo-atomic ()
   '(inst mov :qword (thread-slot-ea thread-pseudo-atomic-bits-slot) 0))
 
-#+sb-safepoint
+;;; This is sort of a macro instruction but also not. Macro instructions
+;;; don't know the instruction that was emitted by the vop because expansion
+;;; occurs early. But we need to test for yieldpoint instructions
+;;; in a post-processing step.
+;;; I can't remember why it's not in "insts"
+(sb-assem:define-instruction yieldpoint (segment kind)
+  (:emitter
+   (assemble (segment)
+    (let ((ea (thread-slot-ea thread-saved-csp-offset)))
+      (ecase kind
+        (:lisp
+         (inst vmovntdqa float15-tn ea)
+         ;(inst prefetch :nta ea)
+;         (inst pushf)
+;         (inst inc :dword (thread-slot-ea thread-lisp-yps-executed-slot))
+;         (inst popf)
+;         (inst test :byte ea thread-tn)
+         ;(inst test :dword (ea (+ (ash thread-stepping-slot word-shift) 4) thread-tn) thread-tn)
+         ;(inst byte #x74) (inst byte 1)
+         ;(inst icebp)
+         )
+        (:call-out
+         ;(inst inc :qword (thread-slot-ea thread-c-yps-executed-slot))
+         (inst mov ea rsp-tn))
+        (:call-out-done
+         (inst xor ea rsp-tn)))))))
+
+(defun note-yieldpoint (stmt) (setf (stmt-plist stmt) :yieldpoint))
+
+#+nil
+(defun sb-c::emit-patchable-yieldpoint-nop (name) ; 4-byte NOP
+  (cond ((eql (string/= "TWO-WORD-BIGNUM" name) 15)
+         ;; these routines need the carry flag so we don't want
+         ;; to mess it up by doing a TEST instruction.
+         ;; I guess we could emit the 6-byte MOV yieldpoint.
+         ;; For the time being, I'm doing the yieldpoint at the end,
+         ;; inside the routine, and not overwriting with a NOP.
+         )
+        ((member name '(sb-vm::enable-alloc-counter ; not sure about this or the next
+                        sb-vm::enable-sized-alloc-counter
+                        sb-vm::undefined-tramp ; don't need one here
+                        sb-vm::undefined-alien-tramp ; or here
+                        sb-vm::handle-deferred-signal ; don't want
+                        sb-vm::tail-call-variable ; don't need - calls a function
+                        sb-vm::tail-call-callable-variable ; "
+                        sb-vm::call-symbol ; "
+                        sb-kernel:update-object-layout ; "
+                        sb-impl::install-hash-table-lock ; "
+                        sb-vm::fpr-save ; internal use only for other ASM routines
+                        sb-vm::fpr-restore)) ; "
+         nil)
+        (t ; otherwise emit a 4-byte NOP
+         (dolist (b '(#x0f #x1f #x40 #x00))
+           (inst byte b)))))
+
 (defun emit-safepoint ()
-  ;; FIXME: need to get the node and policy to decide not to emit this safepoint.
+  #+yieldpoints (inst yieldpoint :lisp)
-  ;; Also, it would be good to emit only the last of consecutive safepoints in
+  #+sb-safepoint (inst test :byte rax-tn (ea -8 gc-card-table-reg-tn)))
-  ;; straight-line code, e.g. (LIST (LIST X Y) (LIST Z W)) should emit 1 safepoint
-  ;; not 3, even if we consider it 3 separate pointer bumps.
-  ;; (Ideally we'd only do 1 pointer bump, but that's a separate issue)
-  (inst test :byte rax-tn (ea -8 gc-card-table-reg-tn)))
 
 (macrolet ((pa-bits-ea ()
              #+sb-thread `(thread-slot-ea
@@ -216,10 +266,10 @@
              #+(and sb-thread (not gs-seg)) 'thread-tn
              #-(and sb-thread (not gs-seg)) 'rbp-tn))
   (defun emit-begin-pseudo-atomic ()
-    #-sb-safepoint (inst mov (pa-bits-ea) (nonzero-bits)))
+    #-(or sb-safepoint yieldpoints) (inst mov (pa-bits-ea) (nonzero-bits)))
   (defun emit-end-pseudo-atomic ()
     #+sb-safepoint (emit-safepoint)
-    #-sb-safepoint
+    #-(or sb-safepoint yieldpoints)
     (assemble ()
       (inst xor (pa-bits-ea) (nonzero-bits))
       (inst jmp :z OUT)
@@ -232,6 +282,11 @@
 ;;; This macro is purposely unhygienic with respect to THREAD-TN,
 ;;; which is either a global symbol macro, or a LET-bound variable,
 ;;; depending on #+gs-seg.
+(defmacro with-allocator (options &body body)
+  (declare (ignorable options))
+  #+(or sb-safepoint yieldpoints) `(assemble () ,@body)
+  #-(or sb-safepoint yieldpoints) `(pseudo-atomic ,options ,@body))
+
 (defmacro pseudo-atomic ((&key ((:thread-tn thread)) elide-if (default-exit t))
                          &body forms)
   (declare (ignorable thread))

src/compiler/x86-64/parms.lisp

@@ -160,7 +160,9 @@
   #'equalp)
 
 (defconstant-eqx +static-fdefns+
-    `#(sb-impl::install-hash-table-lock update-object-layout
+    `#(sb-impl::install-hash-table-lock
+       update-object-layout
+       #+yieldpoints sb-unix::handle-deferred-signal
        ,@common-static-fdefns)
   #'equalp)
 
@@ -197,3 +199,6 @@
   ;; The 'disp' field will aready be correct.
   (logior (ash undefined-function-trap 8)
           (+ #x100000 (or #+int4-breakpoints #xCE #xCC))))
+
+#+yieldpoints
+(defconstant sb-vm::thread-saved-csp-offset (- (+ 2 sb-vm::thread-header-slots)))

src/compiler/x86-64/system.lisp

@@ -540,4 +540,23 @@ number of CPU cycles elapsed as secondary value. EXPERIMENTAL."
   (:generator 1
     (inst mov :byte new 1)
     (zeroize old)
-    (inst cmpxchg :lock :byte (mutex-slot m state) new)))
+    (inst cmpxchg :lock :byte (mutex-slot m state) new)
+    (inst jmp :nz NOPE)
+    (inst mov (mutex-slot m %owner) thread-tn)
+    NOPE))
+
+(eval-when (:compile-toplevel :load-toplevel)
+  (define-vop (messup-all-regs)
+    (:generator 1
+     (inst mov rax-tn #xaaaaaaaa)
+     (inst mov rcx-tn #xcccccccc)
+     (inst mov rdx-tn #xdddddddd)
+     (inst mov rdi-tn #xd1d1d1d1)
+     (inst mov rsi-tn #x31313131b00f0000)
+     (inst mov r8-tn #x8888888888888888)
+     (inst mov r9-tn #x9999999999999999)
+     (inst mov r10-tn #xc0c0c0c0c0c0c0c0)
+     (inst movq float0-tn r10-tn)
+     (inst inc r10-tn)
+     (inst movq float1-tn r10-tn)
+     )))

src/compiler/x86-64/target-insts.lisp

@@ -436,6 +436,11 @@
     ;; Always try to add an end-of-line comment about the EA.
     ;; Assembler routines were already handled above (not really sure why)
     ;; so now we have to figure out everything else.
+    #+yieldpoints
+    (when (and (eql (machine-ea-base value) sb-vm::thread-reg)
+               (eql (machine-ea-disp value) (ash sb-vm::thread-saved-csp-offset sb-vm:word-shift)))
+      (return-from print-mem-ref (note "yieldpoint" dstate)))
+
     #+sb-safepoint
     (when (and (eql (machine-ea-base value) sb-vm::card-table-reg)
                (eql (machine-ea-disp value) -8))

src/compiler/x86-64/vm.lisp

@@ -154,7 +154,7 @@
   (defreg float14 14 :float)
   (defreg float15 15 :float)
   (defregset *float-regs* float0 float1 float2 float3 float4 float5 float6 float7
-             float8 float9 float10 float11 float12 float13 float14 float15)
+             float8 float9 float10 float11 float12 float13 float14 #|float15|#)
 
   ;; registers used to pass arguments
   ;;

src/runtime/GNUmakefile

@@ -77,7 +77,7 @@ COMMON_SRC = alloc.c arena.c backtrace.c breakpoint.c coalesce.c	\
 	perfecthash.c print.c                                           \
 	regnames.c runtime.c safepoint.c save.c                         \
 	sc-offset.c search.c stringspace.c thread.c time.c              \
-	validate.c var-io.c vars.c wrap.c
+	validate.c var-io.c vars.c wrap.c  yieldpoints.c
 
 ifndef LISP_FEATURE_WIN32
 COMMON_SRC += run-program.c sprof.c
@@ -99,7 +99,7 @@ endif
 
 targets: $(TARGET) $(OBJTARGET) $(LDB_TARGET) sbcl.mk
 
-LDB_OBJS = $(filter-out main.o interr.o runtime.o monitor.o thread.o safepoint.o,$(OBJS))
+LDB_OBJS = $(filter-out main.o interr.o runtime.o monitor.o thread.o safepoint.o yieldpoints.o,$(OBJS))
 ldb: $(LIBSBCL)
 	$(CC) -g $(CPPFLAGS) $(CFLAGS) -DSTANDALONE_LDB -c -o standalone-monitor.o monitor.c
 	$(CC) -g $(CPPFLAGS) $(CFLAGS) -DSTANDALONE_LDB -c -o standalone-interr.o interr.c

src/runtime/alloc.c

@@ -213,11 +213,25 @@ void gc_close_thread_regions(__attribute__((unused)) struct thread* th,
       { main_thread_cons_region, PAGE_TYPE_CONS },
 #endif
     };
+#if 0
+    fprintf(stderr, "about to close region for %ps:\n", th);
+    int i;
+    for (i=0;i<4;++i) {
+      struct alloc_region* r = argv[i].r;
+      fprintf(stderr, " %p:%p (free=%p)\n", r->start_addr, r->end_addr, r->free_pointer);
+    }
+#endif
     sync_close_regions(0, locking, argv, N_THREAD_TLABS(argv));
+
 }
 
 extern lispobj* lisp_alloc(int, struct alloc_region *, sword_t,
                            int, struct thread *);
+extern void maybe_suspend_for_gc(struct thread*);
+extern struct alloc_region alloc_cooperate_before(struct alloc_region*, struct thread*);
+// argument order is like memcpy() - to, from
+extern void alloc_cooperate_after(struct alloc_region*, struct alloc_region*,
+                                  struct thread*);
 
 /* alloc() and alloc_list() are external interfaces for memory allocation.
  * They allocate to generation 0 and are not called from within the garbage
@@ -227,14 +241,21 @@ extern lispobj* lisp_alloc(int, struct alloc_region *, sword_t,
 
 #if defined(LISP_FEATURE_SYSTEM_TLABS) || defined(LISP_FEATURE_X86_64)
 
-// The asm routines have been modified so that alloc() and alloc_list()
+/* The asm routines have been modified so that alloc() and alloc_list()
-// each receive the size an a single-bit flag affecting locality of the result.
+ * each receive the size an a single-bit flag affecting locality of the result.
+ * Note that we make a copy by value of the TLAB which avoids having GC steal
+ * it while in lisp_alloc. cooperate_with_gc contains the logic to synchronize
+ * with GC. */
 #define DEFINE_LISP_ENTRYPOINT(name, largep, TLAB, page_type) \
 NO_SANITIZE_MEMORY lispobj *name(sword_t nbytes, int sys) { \
     struct thread *self = get_sb_vm_thread(); \
-    return lisp_alloc(largep | sys, \
+    struct alloc_region* tlab \
-                      sys ? &self->sys_##TLAB##_tlab : THREAD_ALLOC_REGION(self,TLAB), \
+        = sys ? &self->sys_##TLAB##_tlab : THREAD_ALLOC_REGION(self,TLAB); \
-                      nbytes, page_type, self); }
+    struct alloc_region region = alloc_cooperate_before(tlab, self);   \
+    lispobj* res = lisp_alloc(largep | sys, &region, nbytes, page_type, self); \
+    alloc_cooperate_after(tlab, &region, self); \
+    return res; \
+}
 
 DEFINE_LISP_ENTRYPOINT(alloc, (nbytes >= LARGE_OBJECT_SIZE), mixed, PAGE_TYPE_MIXED)
 DEFINE_LISP_ENTRYPOINT(alloc_list, 0, cons, PAGE_TYPE_CONS)
@@ -262,6 +283,7 @@ DEFINE_LISP_ENTRYPOINT(alloc_list, 0, mixed, PAGE_TYPE_MIXED)
 lispobj alloc_code_object(unsigned total_words, unsigned boxed)
 {
     struct thread *th = get_sb_vm_thread();
+    maybe_suspend_for_gc(th);
     // x86-64 uses pseudo-atomic. Others should too, but instead use WITHOUT-GCING
 #ifndef LISP_FEATURE_X86_64
     if (read_TLS(GC_INHIBIT, th) == NIL)
@@ -297,9 +319,10 @@ lispobj alloc_code_object(unsigned total_words, unsigned boxed)
 
 #ifdef LISP_FEATURE_SYSTEM_TLABS
 #define PREPARE_LIST_ALLOCATION() \
-    struct alloc_region *region = sys ? &self->sys_cons_tlab : &self->cons_tlab; \
+    struct alloc_region* tlab = sys ? &self->sys_cons_tlab : &self->cons_tlab; \
+    struct alloc_region region = alloc_cooperate_before(tlab, self); \
     int partial_request = (self->arena && !sys) ? \
-                          nbytes : (char*)region->end_addr - (char*)region->free_pointer; \
+                          nbytes : (char*)region.end_addr - (char*)region.free_pointer; \
     gc_assert(nbytes >= (sword_t)partial_request); \
     if (partial_request == 0) partial_request = CONS_PAGE_USABLE_BYTES
 #else /* no system tlabs */
@@ -314,6 +337,7 @@ lispobj alloc_code_object(unsigned total_words, unsigned boxed)
 NO_SANITIZE_MEMORY lispobj alloc_funinstance(sword_t nbytes)
 {
     struct thread *th = get_sb_vm_thread();
+    maybe_suspend_for_gc(th);
     __attribute__((unused)) int result = mutex_acquire(&code_allocator_lock);
     gc_assert(result);
     void* mem = lisp_alloc(0, code_region, nbytes, PAGE_TYPE_CODE, th);
@@ -334,7 +358,7 @@ make_list(lispobj element, sword_t nbytes, int sys) {
     lispobj result, *tail = &result;
     do {
         if (nbytes < partial_request) partial_request = nbytes;
-        struct cons* c = (void*)lisp_alloc(sys, region, partial_request, PAGE_TYPE_CONS, self);
+        struct cons* c = (void*)lisp_alloc(sys, &region, partial_request, PAGE_TYPE_CONS, self);
         *tail = make_lispobj((void*)c, LIST_POINTER_LOWTAG);
         int ncells = partial_request >> (1+WORD_SHIFT);
         nbytes -= N_WORD_BYTES * 2 * ncells;
@@ -347,6 +371,7 @@ make_list(lispobj element, sword_t nbytes, int sys) {
         partial_request = CONS_PAGE_USABLE_BYTES;
     } while (nbytes);
     *tail = NIL;
+    alloc_cooperate_after(tlab, &region, self);
     return result;
 }
 #endif
@@ -361,7 +386,7 @@ listify_rest_arg(lispobj* context, sword_t nbytes, int sys) {
     lispobj result, *tail = &result;
     do {
         if (nbytes < partial_request) partial_request = nbytes;
-        struct cons* c = (void*)lisp_alloc(sys, region, partial_request, PAGE_TYPE_CONS, self);
+        struct cons* c = (void*)lisp_alloc(sys, &region, partial_request, PAGE_TYPE_CONS, self);
         *tail = make_lispobj((void*)c, LIST_POINTER_LOWTAG);
         int ncells = partial_request >> (1+WORD_SHIFT);
         nbytes -= N_WORD_BYTES * 2 * ncells;
@@ -374,6 +399,7 @@ listify_rest_arg(lispobj* context, sword_t nbytes, int sys) {
         partial_request = CONS_PAGE_USABLE_BYTES;
     } while (nbytes);
     *tail = NIL;
+    alloc_cooperate_after(tlab, &region, self);
     return result;
 }
 #else

src/runtime/breakpoint.c

@@ -113,7 +113,7 @@ void handle_breakpoint(os_context_t *context)
 
     fake_foreign_function_call(context);
 
-#ifndef LISP_FEATURE_SB_SAFEPOINT
+#ifdef USE_GC_STOP_SIGNAL
     unblock_gc_stop_signal();
 #endif
     code = find_code(context);
@@ -140,7 +140,7 @@ void *handle_fun_end_breakpoint(os_context_t *context)
 
     fake_foreign_function_call(context);
 
-#ifndef LISP_FEATURE_SB_SAFEPOINT
+#ifdef USE_GC_STOP_SIGNAL
     unblock_gc_stop_signal();
 #endif
 

src/runtime/gc-common.c

@@ -1415,7 +1415,7 @@ bool test_weak_triggers(bool (*predicate)(lispobj), void (*mark)(lispobj))
 }
 
 int finalizer_thread_runflag = 1;
-#ifdef LISP_FEATURE_SB_THREAD
+#if defined LISP_FEATURE_SB_THREAD && !defined LISP_FEATURE_YIELDPOINTS
 
 #ifdef LISP_FEATURE_WIN32
 CRITICAL_SECTION finalizer_mutex;
@@ -2195,7 +2195,7 @@ bool maybe_gc(os_context_t *context)
      * A kludgy alternative is to propagate the sigmask change to the
      * outer context.
      */
-#ifndef LISP_FEATURE_SB_SAFEPOINT
+#ifdef USE_GC_STOP_SIGNAL
     check_gc_signals_unblocked_or_lose(os_context_sigmask_addr(context));
     unblock_gc_stop_signal();
 #endif
@@ -2233,7 +2233,7 @@ bool maybe_gc(os_context_t *context)
              * post-GC code. Except that we do it while the interrupt context
              * is still on the stack */
             thread_sigmask(SIG_SETMASK, context_sigmask, 0);
-#ifndef LISP_FEATURE_SB_SAFEPOINT
+#ifdef USE_GC_STOP_SIGNAL
             check_gc_signals_unblocked_or_lose(0);
 #endif
 #endif

src/runtime/gc.h

@@ -23,10 +23,6 @@
 #include <stdint.h>
 #include <string.h>
 
-#if defined LISP_FEATURE_SB_THREAD && !defined LISP_FEATURE_SB_SAFEPOINT
-# define THREADS_USING_GCSIGNAL 1
-#endif
-
 #if defined LISP_FEATURE_GENERATIONAL && !defined LISP_FEATURE_C_STACK_IS_CONTROL_STACK
 # define GENCGC_IS_PRECISE 1
 #else

src/runtime/gencgc-alloc-region.h

@@ -15,12 +15,13 @@ struct alloc_region {
     void  *start_addr;
 };
 
+#define REGION_END_EMPTY_VALUE (void*)0x1000
 static inline void gc_set_region_empty(struct alloc_region *region)
 {
     /* Free-pointer has to be not equal to 0 because it's undefined behavior
      * to add any value whatsoever to the null pointer.
      * Annoying, isn't it.  http://c-faq.com/null/machexamp.html */
-    region->free_pointer = region->end_addr = (void*)0x1000;
+    region->free_pointer = region->end_addr = REGION_END_EMPTY_VALUE;
     /* Start 0 is the indicator of closed-ness. */
     region->start_addr = 0;
 }

src/runtime/gencgc.c

@@ -324,22 +324,24 @@ static page_index_t
 get_alloc_start_page(unsigned int page_type)
 {
     if (page_type > 7) lose("bad page_type: %d", page_type);
-    struct thread* th = get_sb_vm_thread();
     page_index_t global_start = alloc_start_pages[page_type];
-    page_index_t hint;
+    struct thread* th = get_sb_vm_thread();
-    switch (page_type) {
+    if (th) {
-    case PAGE_TYPE_MIXED:
+        page_index_t hint;
-        if ((hint = thread_extra_data(th)->mixed_page_hint) > 0 && hint <= global_start) {
+        switch (page_type) {
-            thread_extra_data(th)->mixed_page_hint = - 1;
+        case PAGE_TYPE_MIXED:
-            return hint;
+            if ((hint = thread_extra_data(th)->mixed_page_hint) > 0 && hint <= global_start) {
+                thread_extra_data(th)->mixed_page_hint = - 1;
+                return hint;
+            }
+            break;
+        case PAGE_TYPE_CONS:
+            if ((hint = thread_extra_data(th)->cons_page_hint) > 0 && hint <= global_start) {
+                thread_extra_data(th)->cons_page_hint = - 1;
+                return hint;
+            }
+            break;
         }
-        break;
-    case PAGE_TYPE_CONS:
-        if ((hint = thread_extra_data(th)->cons_page_hint) > 0 && hint <= global_start) {
-            thread_extra_data(th)->cons_page_hint = - 1;
-            return hint;
-        }
-        break;
     }
     return global_start;
 }
@@ -3175,6 +3177,7 @@ conservative_stack_scan(struct thread* th,
 #  ifndef LISP_FEATURE_WIN32
     if (th != get_sb_vm_thread()) {
         int k = fixnum_value(read_TLS(FREE_INTERRUPT_CONTEXT_INDEX,th));
+        //fprintf(stderr, "scanning context, thread %p index %d\n", th, k);
         while (k > 0) {
             os_context_t* context = nth_interrupt_context(--k, th);
             if (context)
@@ -3184,10 +3187,11 @@ conservative_stack_scan(struct thread* th,
 #  endif
 # elif defined(LISP_FEATURE_SB_THREAD)
     int i;
-    /* fprintf(stderr, "Thread %p, ici=%d stack[%p:%p] (%dw)",
+    if (th->control_stack_pointer != 0) esp = th->control_stack_pointer;
-            th, fixnum_value(read_TLS(FREE_INTERRUPT_CONTEXT_INDEX,th)),
+    /* fprintf(stderr, "Thread %p, ici=%d stack[%p:%p] (%dw)\n",
+            th, (int)fixnum_value(read_TLS(FREE_INTERRUPT_CONTEXT_INDEX,th)),
             th->control_stack_start, th->control_stack_end,
-            th->control_stack_end - th->control_stack_start); */
+            (int)(th->control_stack_end - th->control_stack_start)); */
     for (i = fixnum_value(read_TLS(FREE_INTERRUPT_CONTEXT_INDEX,th))-1; i>=0; i--) {
         os_context_t *c = nth_interrupt_context(i, th);
         visit_context_registers(context_method, c, (void*)1);
@@ -3981,6 +3985,13 @@ collect_garbage(generation_index_t last_gen)
 
     large_allocation = 0;
  finish:
+    {
+    struct cons* cons = gc_general_alloc(cons_region, 2*N_WORD_BYTES, PAGE_TYPE_CONS);
+    cons->car = cons->cdr = 0;
+    SYMBOL(GC_EPOCH)->value = make_lispobj(cons, LIST_POINTER_LOWTAG);
+    ensure_region_closed(cons_region, PAGE_TYPE_CONS);
+    }
+
     write_protect_immobile_space();
     gc_active_p = 0;
 
@@ -4020,6 +4031,10 @@ gc_init(void)
                      32 /* logical bin count */, 0 /* default range */);
 #ifdef LISP_FEATURE_WIN32
     InitializeCriticalSection(&free_pages_lock);
+#endif
+    extern void safepoint_init(void);
+#if defined LISP_FEATURE_SB_SAFEPOINT || defined LISP_FEATURE_YIELDPOINTS
+    safepoint_init();
 #endif
 }
 
@@ -4104,6 +4119,10 @@ lisp_alloc(int flags, struct alloc_region *region, sword_t nbytes,
      * should GC in the near future
      */
     if (auto_gc_trigger && (bytes_allocated+trigger_bytes > auto_gc_trigger)) {
+#ifdef LISP_FEATURE_YIELDPOINTS
+        extern void request_garbage_collection(int);
+        request_garbage_collection(-1);
+#else
         /* Don't flood the system with interrupts if the need to gc is
          * already noted. This can happen for example when SUB-GC
          * allocates or after a gc triggered in a WITHOUT-GCING. */
@@ -4125,6 +4144,7 @@ lisp_alloc(int flags, struct alloc_region *region, sword_t nbytes,
 #endif
             }
         }
+#endif
     }
 
     /* For the architectures which do NOT use a trap instruction for allocation,
@@ -4792,8 +4812,10 @@ static int verify_range(lispobj* start, lispobj* end, struct verify_state* state
 #endif
             if (widetag != FILLER_WIDETAG && pg >= 0) {
                     // Assert proper page type
-                    if (state->object_header) // is not a cons
+                    if (state->object_header) { // is not a cons
-                        gc_assert(page_table[pg].type != PAGE_TYPE_CONS);
+                        if (page_table[pg].type == PAGE_TYPE_CONS)
+                            lose("headered object @ %p on cons page", state->object_addr);
+                    }
 #ifdef LISP_FEATURE_USE_CONS_REGION
                     else if (page_table[pg].type != PAGE_TYPE_CONS) {
                       if (is_cons_half(where[0]))

src/runtime/immobile-space.c

@@ -1096,6 +1096,7 @@ sweep_text_pages(int raise)
     if (freelist_tail) {
         freelist_tail[1] = codeblob_freelist;
         codeblob_freelist = (lispobj)freelist;
+        // fprintf(stderr, "New items in codeblob freelist\n");
     }
 }
 

src/runtime/interrupt.c

@@ -123,7 +123,6 @@ int internal_errors_enabled = 0; // read in cold-init
 // SIGRTMAX is not usable in an array size declaration because it might be
 // a variable expression, so use NSIG which is at least as large as SIGRTMAX.
 #ifndef LISP_FEATURE_WIN32
-static
 void (*interrupt_low_level_handlers[NSIG]) (int, siginfo_t*, os_context_t*);
 struct sigaction old_ll_sigactions[NSIG];
 #endif
@@ -420,7 +419,11 @@ sigaddset_blockable(sigset_t *sigset)
 {
 #ifdef LISP_FEATURE_SB_SAFEPOINT
     sigaddset_async(sigset);
-#else
+#endif
+#ifdef LISP_FEATURE_YIELDPOINTS
+    sigaddset_deferrable(sigset);
+#endif
+#ifdef LISP_FEATURE_GC_STW_SIGNAL
     sigaddset_deferrable(sigset);
     sigaddset_gc(sigset);
 #endif
@@ -578,7 +581,7 @@ static void assert_blockables_blocked()
 #endif
 }
 
-#ifndef LISP_FEATURE_SB_SAFEPOINT
+#ifdef LISP_FEATURE_GC_STW_SIGNAL
 void
 check_gc_signals_unblocked_or_lose(sigset_t *sigset)
 {
@@ -614,7 +617,7 @@ unblock_deferrable_signals(sigset_t *where)
 {
     if (interrupt_handler_pending_p())
         lose("unblock_deferrable_signals: losing proposition");
-#ifndef LISP_FEATURE_SB_SAFEPOINT
+#ifdef LISP_FEATURE_GC_STW_SIGNAL
     // If 'where' is null, check_gc_signals_unblocked_or_lose() will
     // fetch the current signal mask (from the OS) and check that.
     check_gc_signals_unblocked_or_lose(where);
@@ -636,7 +639,7 @@ unblock_deferrable_signals(sigset_t *where)
         thread_sigmask(SIG_UNBLOCK, sigset, 0);
 }
 
-#ifndef LISP_FEATURE_SB_SAFEPOINT
+#ifdef LISP_FEATURE_GC_STW_SIGNAL
 // This function previously had an #ifdef guard precluding doing anything for
 // win32, which was redundant because SB_SAFEPOINT is always defined for win32.
 void unblock_gc_stop_signal(void) {
@@ -648,7 +651,7 @@ void
 unblock_signals_in_context_and_maybe_warn(os_context_t *context)
 {
     sigset_t *sigset = os_context_sigmask_addr(context);
-#ifndef LISP_FEATURE_SB_SAFEPOINT
+#ifdef LISP_FEATURE_GC_STW_SIGNAL
     if (sigismember(sigset, SIG_STOP_FOR_GC)) {
         corruption_warning_and_maybe_lose(
 "Enabling blocked gc signals to allow returning to Lisp without risking\n\
@@ -672,7 +675,7 @@ they are not safe to interrupt at all, this is a pretty severe occurrence.\n");
  * The purpose is to avoid losing the pending gc signal if a
  * deferrable interrupt async unwinds between clearing the pseudo
  * atomic and trapping to GC.*/
-#ifndef LISP_FEATURE_SB_SAFEPOINT
+#ifdef LISP_FEATURE_GC_STW_SIGNAL
 void maybe_save_gc_mask_and_block_deferrables(os_context_t *context)
 {
     struct thread *thread = get_sb_vm_thread();
@@ -718,6 +721,7 @@ void maybe_save_gc_mask_and_block_deferrables(os_context_t *context)
 /* Are we leaving WITH-GCING and already running with interrupts
  * enabled, without the protection of *GC-INHIBIT* T and there is gc
  * (or stop for gc) pending, but we haven't trapped yet? */
+#ifndef LISP_FEATURE_YIELDPOINTS
 int
 in_leaving_without_gcing_race_p(struct thread __attribute__((unused)) *thread)
 {
@@ -749,7 +753,7 @@ check_interrupt_context_or_lose(os_context_t *context)
     int pseudo_atomic_interrupted = get_pseudo_atomic_interrupted(thread);
     int in_race_p = in_leaving_without_gcing_race_p(thread);
     int safepoint_active = 0;
-#if defined(LISP_FEATURE_SB_SAFEPOINT)
+#ifdef LISP_FEATURE_SB_SAFEPOINT
     /* Don't try to take the gc state lock if there's a chance that
      * we're already holding it (thread_register_gc_trigger() is
      * called from PA, gc_stop_the_world() and gc_start_the_world()
@@ -800,13 +804,14 @@ check_interrupt_context_or_lose(os_context_t *context)
         check_deferrables_blocked_or_lose(sigset);
     else {
         check_deferrables_unblocked_or_lose(sigset);
-#ifndef LISP_FEATURE_SB_SAFEPOINT
+#ifdef LISP_FEATURE_GC_STW_SIGNAL
         /* If deferrables are unblocked then we are open to signals
          * that run lisp code. */
         check_gc_signals_unblocked_or_lose(sigset);
 #endif
     }
 }
+#endif
 
 /*
  * utility routines used by various signal handlers
@@ -1056,7 +1061,7 @@ interrupt_handle_pending(os_context_t *context)
     }
 
     assert_blockables_blocked();
-#ifndef LISP_FEATURE_SB_SAFEPOINT
+#ifdef LISP_FEATURE_GC_STW_SIGNAL
     /*
      * (On safepoint builds, there is no gc_blocked_deferrables nor
      * SIG_STOP_FOR_GC.)
@@ -1097,7 +1102,7 @@ interrupt_handle_pending(os_context_t *context)
             thread_in_lisp_raised(context);
             undo_fake_foreign_function_call(context);
         }
-#elif defined(LISP_FEATURE_SB_THREAD)
+#elif defined THREADS_USING_GCSIGNAL
         if (read_TLS(STOP_FOR_GC_PENDING,thread) != NIL) {
             /* STOP_FOR_GC_PENDING and GC_PENDING are cleared by
              * the signal handler if it actually stops us. */
@@ -1234,7 +1239,7 @@ interrupt_handle_now(int signal, siginfo_t *info, os_context_t *context)
          * be available; should we copy it or was nobody using it anyway?)
          * then we should convert this to return-elsewhere */
 
-#if !defined(LISP_FEATURE_SB_SAFEPOINT) && defined(LISP_FEATURE_C_STACK_IS_CONTROL_STACK)
+#if defined LISP_FEATURE_GC_STW_SIGNAL && defined LISP_FEATURE_C_STACK_IS_CONTROL_STACK
         /* Leave deferrable signals blocked, the handler itself will
          * allow signals again when it sees fit. */
         /* handler.lisp will hide from the GC, will be enabled in the handler itself.
@@ -1278,8 +1283,8 @@ run_deferred_handler(struct interrupt_data *data, os_context_t *context)
     (*pending_handler)(data->pending_signal,&(data->pending_info), context);
 }
 
-#ifndef LISP_FEATURE_WIN32
+#ifdef LISP_FEATURE_UNIX
-static void
+void
 store_signal_data_for_later (struct interrupt_data *data, void *handler,
                              int signal,
                              siginfo_t *info, os_context_t *context)
@@ -1301,6 +1306,9 @@ store_signal_data_for_later (struct interrupt_data *data, void *handler,
     sigcopyset(&data->pending_mask, os_context_sigmask_addr(context));
     sigaddset_deferrable(os_context_sigmask_addr(context));
 }
+#endif
+
+#if !defined LISP_FEATURE_WIN32 && !defined LISP_FEATURE_YIELDPOINTS
 
 /* What's going on ?
  *
@@ -1528,7 +1536,7 @@ arrange_return_to_c_function(os_context_t *context,
                              call_into_lisp_lookalike funptr,
                              lispobj function)
 {
-#ifndef LISP_FEATURE_SB_SAFEPOINT
+#ifdef LISP_FEATURE_GC_STOP_SIGNAL
     check_gc_signals_unblocked_or_lose(os_context_sigmask_addr(context));
 #endif
 #if !(defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64))
@@ -1968,6 +1976,7 @@ ll_install_handler (int signal, interrupt_handler_t handler)
 }
 #endif
 
+#ifndef LISP_FEATURE_YIELDPOINTS
 extern void sigprof_handler(int, siginfo_t*, void*);
 
 /* This is called from Lisp. */
@@ -2018,6 +2027,7 @@ void install_handler(int signal, lispobj handler)
     }
 #endif
 }
+#endif
 
 /* This must not go through lisp as it's allowed anytime, even when on
  * the altstack. */

src/runtime/interrupt.h

@@ -76,11 +76,13 @@ struct interrupt_data {
     int pending_signal;
     siginfo_t pending_info;
     sigset_t pending_mask;
+#ifndef LISP_FEATURE_YIELDPOINTS
     /* Was pending mask saved for gc request? True if GC_PENDING or
      * SIG_STOP_FOR_GC happened in a pseudo atomic with GC_INHIBIT NIL
      * and with no pending handler. Both deferrable interrupt handlers
      * and gc are careful not to clobber each other's pending_mask. */
     bool gc_blocked_deferrables;
+#endif
 #if defined LISP_FEATURE_MIPS || defined LISP_FEATURE_PPC \
   || defined LISP_FEATURE_PPC64 || defined LISP_FEATURE_SPARC
 #define HAVE_ALLOCATION_TRAP_CONTEXT 1

src/runtime/linux-os.c

@@ -380,7 +380,7 @@ sigsegv_handler(int signal, siginfo_t *info, os_context_t *context)
 {
     os_vm_address_t addr = arch_get_bad_addr(signal, info, context);
 
-#ifdef LISP_FEATURE_SB_SAFEPOINT
+#if defined LISP_FEATURE_YIELDPOINTS || LISP_FEATURE_SB_SAFEPOINT
     if (handle_safepoint_violation(context, addr)) return;
 #endif
 
@@ -398,7 +398,7 @@ sigsegv_handler(int signal, siginfo_t *info, os_context_t *context)
 void
 os_install_interrupt_handlers(void)
 {
-    if (INSTALL_SIG_MEMORY_FAULT_HANDLER) {
+  if (1) { // INSTALL_SIG_MEMORY_FAULT_HANDLER) {
     ll_install_handler(SIG_MEMORY_FAULT, sigsegv_handler);
     }
 }

src/runtime/monitor.c

@@ -1081,6 +1081,25 @@ ldb_monitor(void)
 #ifdef STANDALONE_LDB
 void gc_stop_the_world() { } // do nothing
 void gc_start_the_world() { } // do nothing
+void defer_until_yieldpoint() { }
+void sigtrap_handler() { }
+void set_gc_pending() { }
+void safepoint_init() { }
+void request_garbage_collection(int) { }
+void cooperate_with_gc(struct thread* th) { lose("cooperate_with_gc %p ?", th); }
+int handle_safepoint_violation(__attribute__((unused)) os_context_t *context,
+                               __attribute__((unused)) os_vm_address_t addr) { return 0; }
+struct alloc_region alloc_cooperate_before(__attribute__((unused)) struct alloc_region*,
+                                           __attribute__((unused)) struct thread*) {
+  struct alloc_region r;
+  memset(&r, 0, sizeof r);
+  return r;
+}
+void alloc_cooperate_after(__attribute__((unused)) struct alloc_region*dst,
+                           __attribute__((unused)) struct alloc_region*src,
+                           __attribute__((unused)) struct thread* th) { }
+void maybe_suspend_for_gc(__attribute__((unused)) struct thread* th) { }
+
 #include <errno.h>
 #include <setjmp.h>
 #include "core.h"

src/runtime/runtime.c

@@ -795,7 +795,7 @@ initialize_lisp(int argc, char *argv[], char *envp[])
     os_install_interrupt_handlers();
 # ifdef LISP_FEATURE_SB_SAFEPOINT
     ll_install_handler(SIGURG, thruption_handler);
-# elif defined LISP_FEATURE_SB_THREAD
+# elif defined THREADS_USING_GCSIGNAL
     ll_install_handler(SIG_STOP_FOR_GC, sig_stop_for_gc_handler);
 # endif
 #else

src/runtime/thread.c

@@ -74,8 +74,18 @@ pthread_key_t current_thread = 0;
 CRITICAL_SECTION all_threads_lock;
 static CRITICAL_SECTION recyclebin_lock;
 static CRITICAL_SECTION in_gc_lock;
+#else
+#ifdef LISP_FEATURE_YIELDPOINTS
+pthread_rwlock_t all_threads_lock = PTHREAD_RWLOCK_INITIALIZER;
+// the functions return 0 on success, but we want boolean true
+#define GRAB_ALL_THREADS_LOCK() !pthread_rwlock_wrlock(&all_threads_lock)
+#define RELEASE_ALL_THREADS_LOCK() !pthread_rwlock_unlock(&all_threads_lock)
+
 #else
 pthread_mutex_t all_threads_lock = PTHREAD_MUTEX_INITIALIZER;
+#define GRAB_ALL_THREADS_LOCK() mutex_acquire(&all_threads_lock)
+#define RELEASE_ALL_THREADS_LOCK() mutex_release(&all_threads_lock)
+#endif
 static pthread_mutex_t recyclebin_lock = PTHREAD_MUTEX_INITIALIZER;
 static pthread_mutex_t in_gc_lock = PTHREAD_MUTEX_INITIALIZER;
 #endif
@@ -121,7 +131,7 @@ char* vm_thread_name(struct thread* th)
 #define get_thread_state(thread) \
  (int)__sync_val_compare_and_swap(&thread->state_word.state, -1, -1)
 
-#ifndef LISP_FEATURE_SB_SAFEPOINT
+#ifdef LISP_FEATURE_GC_STW_SIGNAL
 
 void
 set_thread_state(struct thread *thread,
@@ -445,10 +455,10 @@ init_new_thread(struct thread *th,
 #ifdef LISP_FEATURE_SB_SAFEPOINT
     csp_around_foreign_call(th) = (lispobj)scribble;
 #endif
-    __attribute__((unused)) int lock_ret = mutex_acquire(&all_threads_lock);
+    __attribute__((unused)) int lock_ret = GRAB_ALL_THREADS_LOCK();
     gc_assert(lock_ret);
     link_thread(th);
-    ignore_value(mutex_release(&all_threads_lock));
+    ignore_value(RELEASE_ALL_THREADS_LOCK());
 
     /* Kludge: Changed the order of some steps between the safepoint/
      * non-safepoint versions of this code.  Can we unify this more?
@@ -469,7 +479,8 @@ unregister_thread(struct thread *th,
     gc_close_thread_regions(th, LOCK_PAGE_TABLE|CONSUME_REMAINDER);
 #ifdef LISP_FEATURE_SB_SAFEPOINT
     pop_gcing_safety(&scribble->safety);
-#else
+#endif
+#ifdef LISP_FEATURE_GC_STW_SIGNAL
     /* This state change serves to "acknowledge" any stop-the-world
      * signal received while the STOP_FOR_GC signal is blocked */
     set_thread_state(th, STATE_DEAD, 1);
@@ -478,10 +489,10 @@ unregister_thread(struct thread *th,
      * thread, but since we are either exiting lisp code as a lisp
      * thread that is dying, or exiting lisp code to return to
      * former status as a C thread, it won't wait long. */
-    __attribute__((unused)) int lock_ret = mutex_acquire(&all_threads_lock);
+    __attribute__((unused)) int lock_ret = GRAB_ALL_THREADS_LOCK();
     gc_assert(lock_ret);
     unlink_thread(th);
-    lock_ret = mutex_release(&all_threads_lock);
+    lock_ret = RELEASE_ALL_THREADS_LOCK();
     gc_assert(lock_ret);
 
     arch_os_thread_cleanup(th);
@@ -490,7 +501,7 @@ unregister_thread(struct thread *th,
 #ifdef LISP_FEATURE_UNIX
     os_sem_destroy(&semaphores->sprof_sem);
 #endif
-#ifndef LISP_FEATURE_SB_SAFEPOINT
+#ifdef LISP_FEATURE_GC_STW_SIGNAL
     os_sem_destroy(&semaphores->state_sem);
     os_sem_destroy(&semaphores->state_not_running_sem);
     os_sem_destroy(&semaphores->state_not_stopped_sem);
@@ -577,7 +588,7 @@ void* new_thread_trampoline(void* arg)
     // strictly below the computed th->control_stack_end. So make sure the value we pick
     // is strictly above any value of SP that the interrupt context could have.
 #if defined LISP_FEATURE_C_STACK_IS_CONTROL_STACK && !defined ADDRESS_SANITIZER \
-    && !defined LISP_FEATURE_SB_SAFEPOINT
+    && defined LISP_FEATURE_UNIX
     th->control_stack_end = (lispobj*)&arg + 1;
 #endif
     th->os_kernel_tid = get_nonzero_tid();
@@ -681,7 +692,7 @@ static void attach_os_thread(init_thread_data *scribble)
     void* recycled_memory = get_recyclebin_item();
     struct thread *th = alloc_thread_struct(recycled_memory);
 
-#ifndef LISP_FEATURE_SB_SAFEPOINT
+#ifdef LISP_FEATURE_GC_STW_SIGNAL
     /* new-lisp-thread-trampoline doesn't like when the GC signal is blocked */
     /* FIXME: could be done using a single call to pthread_sigmask
        together with blocking the deferrable signals above. */
@@ -764,7 +775,7 @@ static void detach_os_thread(init_thread_data *scribble)
      *  - but STOP_FOR_GC is pending because it was in the blocked set.
      * Bad things happen unless we clear the pending GC signal.
      */
-#if !defined LISP_FEATURE_SB_SAFEPOINT
+#ifdef LISP_FEATURE_GC_STW_SIGNAL
     sigset_t pending;
     sigpending(&pending);
     if (sigismember(&pending, SIG_STOP_FOR_GC)) {
@@ -863,8 +874,8 @@ callback_wrapper_trampoline(
  *     /   ___ aligned_spaces
  *    /   /
  *  (0) (1)       (2)       (3)       (4)    (5)          (6)
- *   |   | CONTROL | BINDING |  ALIEN  |  CSP | thread     |          |
+ *   |   | CONTROL | BINDING |  ALIEN  | Trap | thread     |          |
- *   |   |  STACK  |  STACK  |  STACK  | PAGE | structure  | altstack |
+ *   |   |  STACK  |  STACK  |  STACK  | page | structure  | altstack |
  *   |...|------------------------------------------------------------|
  *          2MiB       1MiB     1MiB               (*)         (**)
  *
@@ -917,17 +928,17 @@ alloc_thread_struct(void* spaces) {
     /* Aligning up is safe as THREAD_STRUCT_SIZE has
      * THREAD_ALIGNMENT_BYTES padding. */
     char *aligned_spaces = PTR_ALIGN_UP(spaces, THREAD_ALIGNMENT_BYTES);
-    char* csp_page = aligned_spaces + thread_control_stack_size +
+    char* yieldpoint_page = aligned_spaces + thread_control_stack_size +
-                     BINDING_STACK_SIZE + ALIEN_STACK_SIZE;
+                            BINDING_STACK_SIZE + ALIEN_STACK_SIZE;
 
     // Refer to the ASCII art in the block comment above
-    struct thread *th = (void*)(csp_page + THREAD_CSP_PAGE_SIZE
+    struct thread *th = (void*)(yieldpoint_page + THREAD_YIELDPOINT_PAGE_SIZE
                                 + THREAD_HEADER_SLOTS*N_WORD_BYTES);
 
-#ifdef LISP_FEATURE_SB_SAFEPOINT
+#if defined LISP_FEATURE_SB_SAFEPOINT || defined LISP_FEATURE_YIELDPOINTS
     // Out of caution I'm supposing that the last thread to use this memory
     // might have left this page as read-only. Could it? I have no idea.
-    os_protect(csp_page, THREAD_CSP_PAGE_SIZE, OS_VM_PROT_READ|OS_VM_PROT_WRITE);
+    os_protect(yieldpoint_page, THREAD_YIELDPOINT_PAGE_SIZE, OS_VM_PROT_READ|OS_VM_PROT_WRITE);
 #endif
 
 #ifdef LISP_FEATURE_SB_THREAD
@@ -1071,11 +1082,7 @@ alloc_thread_struct(void* spaces) {
     access_control_frame_pointer(th)=0;
 #endif
 
-    thread_interrupt_data(th).pending_handler = 0;
+    memset(&thread_interrupt_data(th), 0, sizeof (struct interrupt_data));
-    thread_interrupt_data(th).gc_blocked_deferrables = 0;
-#if HAVE_ALLOCATION_TRAP_CONTEXT
-    thread_interrupt_data(th).allocation_trap_context = 0;
-#endif
 #if defined LISP_FEATURE_PPC64
     /* Storing a 0 into code coverage mark bytes or GC card mark bytes
      * can be done from the low byte of the thread base register.
@@ -1103,7 +1110,7 @@ alloc_thread_struct(void* spaces) {
         thread_private_events(th,i) = CreateEvent(NULL,FALSE,FALSE,NULL);
     thread_extra_data(th)->synchronous_io_handle_and_flag = 0;
 #endif
-    th->stepping = 0;
+    memset(&th->stepping, 0, N_WORD_BYTES);
     th->card_table = (lispobj)gc_card_mark;
     return th;
 }
@@ -1161,7 +1168,7 @@ void thread_accrue_stw_time(struct thread* th, struct timespec* begin)
 /*
  * (With SB-SAFEPOINT, see the definitions in safepoint.c instead.)
  */
-#if !defined LISP_FEATURE_SB_SAFEPOINT && !defined STANDALONE_LDB
+#if defined LISP_FEATURE_GC_STW_SIGNAL && !defined STANDALONE_LDB
 
 /* To avoid deadlocks when gc stops the world all clients of each
  * mutex must enable or disable SIG_STOP_FOR_GC for the duration of

src/runtime/thread.h

@@ -24,12 +24,14 @@ void set_thread_state(struct thread *thread, char state, bool);
 int thread_wait_until_not(int state, struct thread *thread);
 #endif
 
+#if defined LISP_FEATURE_YIELDPOINTS || defined LISP_FEATURE_SB_SAFEPOINT
+int handle_safepoint_violation(os_context_t *context, os_vm_address_t addr);
+#endif
 #if defined(LISP_FEATURE_SB_SAFEPOINT)
 struct gcing_safety {
     lispobj csp_around_foreign_call;
 };
 
-int handle_safepoint_violation(os_context_t *context, os_vm_address_t addr);
 void* os_get_csp(struct thread* th);
 void assert_on_stack(struct thread *th, void *esp);
 #endif /* defined(LISP_FEATURE_SB_SAFEPOINT) */
@@ -154,10 +156,10 @@ extern pthread_key_t current_thread;
 #endif
 #endif
 
-#ifndef LISP_FEATURE_SB_SAFEPOINT
+#if defined LISP_FEATURE_SB_SAFEPOINT || defined LISP_FEATURE_YIELDPOINTS
-# define THREAD_CSP_PAGE_SIZE 0
+# define THREAD_YIELDPOINT_PAGE_SIZE os_reported_page_size
 #else
-# define THREAD_CSP_PAGE_SIZE os_reported_page_size
+# define THREAD_YIELDPOINT_PAGE_SIZE 0
 #endif
 
 #ifdef LISP_FEATURE_WIN32
@@ -171,7 +173,7 @@ extern pthread_key_t current_thread;
 #define THREAD_STRUCT_SIZE \
   (THREAD_ALIGNMENT_BYTES + \
    thread_control_stack_size + BINDING_STACK_SIZE + ALIEN_STACK_SIZE + \
-   THREAD_CSP_PAGE_SIZE + \
+   THREAD_YIELDPOINT_PAGE_SIZE + \
    (THREAD_HEADER_SLOTS*N_WORD_BYTES) + dynamic_values_bytes + \
    sizeof (struct extra_thread_data) + ALT_STACK_SIZE)
 
@@ -330,7 +332,11 @@ extern void create_main_lisp_thread(lispobj);
 #ifdef LISP_FEATURE_WIN32
 extern CRITICAL_SECTION all_threads_lock;
 #elif defined LISP_FEATURE_SB_THREAD
+# ifdef LISP_FEATURE_YIELDPOINTS
+extern pthread_rwlock_t all_threads_lock;
+# else
 extern pthread_mutex_t all_threads_lock;
+# endif
 #endif
 
 #ifndef LISP_FEATURE_SB_THREAD

src/runtime/tiny-lock.h

@@ -17,7 +17,7 @@ static void release_lock(lock_t *l) { gc_assert(!pthread_mutex_unlock(l)); }
 struct lock { _Atomic(int) grabbed; };
 typedef struct lock lock_t;
 
-static void acquire_lock(lock_t *l) {
+static void __attribute__((unused)) acquire_lock(lock_t *l) {
   int expected = 0, cycles = 0;
   /* atomic_compare_exchange_strong kindly clobbers expected for us,
    * when CAS fails. */
@@ -26,7 +26,11 @@ static void acquire_lock(lock_t *l) {
     if (cycles++ > 1000) sched_yield();
   }
 }
-static void release_lock(lock_t *l) {
+static int __attribute__((unused)) try_acquire_lock(lock_t *l) {
+  int expected = 0;
+  return atomic_compare_exchange_strong(&l->grabbed, &expected, 1);
+}
+static void __attribute__((unused)) release_lock(lock_t *l) {
   atomic_store(&l->grabbed, 0);
 }
 #define LOCK_INITIALIZER { 0 }

src/runtime/x86-64-arch.c

@@ -14,6 +14,7 @@
 #include <stdio.h>
 
 #include "genesis/sbcl.h"
+#include "genesis/hash-table.h"
 #include "runtime.h"
 #include "globals.h"
 #include "validate.h"
@@ -364,7 +365,7 @@ restore_breakpoint_from_single_step(os_context_t * context)
     return;
 }
 
-void
+static void
 sigtrap_handler(int __attribute__((unused)) signal,
                 siginfo_t __attribute__((unused)) *info,
                 os_context_t *context)
@@ -501,6 +502,7 @@ arch_install_interrupt_handlers()
      * CL way, I hope there will at least be a comment to explain
      * why.. -- WHN 2001-06-07 */
 #ifndef LISP_FEATURE_WIN32
+    extern void sigtrap_handler();
     ll_install_handler(SIGILL , sigill_handler);
     ll_install_handler(SIGTRAP, sigtrap_handler);
 #endif
@@ -787,3 +789,36 @@ lispobj call_into_lisp_first_time(lispobj fun, lispobj *args, int nargs) {
 }
 
 #include "x86-arch-shared.inc"
+
+void yieldpoint_patch_asm_routines(int flag)
+{
+    struct code* code = (struct code*)asm_routines_start;
+#ifdef LISP_FEATURE_DARWIN_JIT
+    lispobj ht = CONS(code->debug_info)->car;
+#else
+    lispobj ht = code->debug_info;
+#endif
+    struct vector* table =
+        VECTOR(((struct hash_table*)native_pointer(ht))->pairs);
+    int i;
+    uint32_t nop = 0x00401F0F; // really [0F 1F 40 00]
+    uint32_t yp  = 0x806D8545; // really [45 85 6D 80]
+    uint32_t old = nop;
+    uint32_t new = yp;
+    if (!flag) { // deinstall them
+      old = yp;
+      new = nop;
+    }
+    for (i=2 ; i < vector_len(table) ; i += 2) {
+        lispobj value = table->data[i+1];
+        if (listp(value)) {
+            // value = (start-address . (end-address . index))
+            char* entrypoint
+                = code_text_start(code) + fixnum_value(CONS(value)->car);
+            uint32_t* pdword = (uint32_t*)entrypoint;
+            if (*pdword == old)
+                __sync_bool_compare_and_swap(pdword, old, new);
+        }
+    }
+}
+

src/runtime/x86-64-assem.S

@@ -460,3 +460,12 @@ ascs_check_loop:
 ascs_finished:
 	ret
 	SIZE(GNAME(arch_scrub_control_stack))
+
+        .global GNAME(foo)
+GNAME(foo):    .byte 0x66, 0x45, 0x0f, 0x38, 0x2a, 0x7d, 0x80
+        .byte 0x45, 0x0f, 0x38, 0x2a, 0x7d, 0x80
+
+        .globl GNAME(bar)
+GNAME(bar):
+        vmovntdqa -128(%r13), %xmm15
+        vmovntdqa -128(%r13), %ymm15

src/runtime/yieldpoints.c

@@ -0,0 +1,760 @@
+#define _GNU_SOURCE // for pthread_setname_np
+#include <pthread.h>
+#include <signal.h>
+#include <stdio.h>
+#include <limits.h> // INT_MAX
+#include <errno.h>
+#include "thread.h"
+#include "interr.h"
+#include "gc-assert.h"
+#include "core.h"
+#include "atomiclog.inc"
+
+typedef enum { SUSPEND=1, ASYNC_SIGNAL=2 } yield_reason;
+
+static int debug = 0;
+
+typedef enum { UNKNOWN, IN_LISP, LISP_TO_C, C_TO_LISP } yieldpoint_kind;
+int yp_kind_hit[4];
+
+static __thread char threadname[20];
+char *pthreadname(struct thread* th) {
+    pthread_getname_np(th->os_thread, threadname, 20);
+    //sprintf(threadname, "%p", th);
+    return threadname;
+}
+
+char *thread_yieldpoint_trap_page_base(struct thread*th ) {
+    return (char*)th - THREAD_HEADER_SLOTS*N_WORD_BYTES - THREAD_YIELDPOINT_PAGE_SIZE;
+}
+typedef enum { READ_WRITE, READ_ONLY, NO_ACCESS } yieldpoint_page_acc;
+void yieldpoint_trap_toggle(struct thread* th,
+                            yieldpoint_page_acc access)
+{
+    int prot_mode[3] = { OS_VM_PROT_ALL, PROT_READ, PROT_NONE };
+    char* page_base = thread_yieldpoint_trap_page_base(th);
+    // fprintf(stderr, "YP page protect: %d @ %p\n", THREAD_YIELDPOINT_PAGE_SIZE, page_base);
+    mprotect(page_base, THREAD_YIELDPOINT_PAGE_SIZE, prot_mode[access]);
+    th->yieldpoint_page_access = access;
+}
+
+#define INITIATE_GC 0x100
+#define GC_CONTROLLER_QUIT 0x200
+
+extern pthread_rwlock_t all_threads_lock;
+pthread_mutex_t gc_condition_lock = PTHREAD_MUTEX_INITIALIZER;
+pthread_cond_t gc_controller_cond = PTHREAD_COND_INITIALIZER;
+pthread_cond_t gc_completion_cond = PTHREAD_COND_INITIALIZER;
+pthread_t gc_controller;
+pthread_t rdb_thread;
+int gc_notification_reason;
+os_sem_t gc_sync_sem;
+long gc_cycle_count;
+
+static lispobj* yieldpoint_trap_addr(struct thread* th) {
+    return (lispobj*)((char*)th - 128);
+}
+static lispobj get_stackptr_at_foreign_call(struct thread* th) {
+    return *yieldpoint_trap_addr(th);
+}
+static void clear_stackptr_at_foreign_call(struct thread* th) {
+    *yieldpoint_trap_addr(th) = 0;
+}
+void gc_inhibitor_control(int flag) {
+    if (flag)
+      pthread_rwlock_rdlock(&all_threads_lock);
+    else
+      pthread_rwlock_unlock(&all_threads_lock);
+}
+
+extern int futex_wait(int*, int, long, unsigned long);
+extern int futex_wake(int*, int);
+// FIXME: uint32_t as per https://man7.org/linux/man-pages/man2/futex.2.html
+// but our os.c files all use 'int'
+static int32_t world_is_stopped;
+
+static void force_tlab_slowpath(struct alloc_region* r, lispobj* spill)
+{
+    void* real_end = __sync_fetch_and_or(&r->end_addr, 0);
+    /* By stuffing in 0 for 'end' the thread's allocator will fail its next comparison
+     * against the TLAB limit, reverting to the slow path allocator, at which point it
+     * observes the stop request.  The only synchronization needed with the mutator
+     * is to ensure we've got an up-to-date copy of the actual end before clobbering it */
+    while (1) {
+        *spill = (lispobj)real_end;
+        if (real_end == REGION_END_EMPTY_VALUE) break;
+        void* oldval = __sync_val_compare_and_swap(&r->end_addr, real_end, 0);
+        if (oldval == real_end) break;
+        real_end = oldval;
+    }
+}
+static void restore_tlab(struct alloc_region* r, lispobj* spill)
+{
+    if (r->end_addr == 0) {
+        lispobj actual_end = *spill;
+        gc_assert(actual_end != 0);
+        r->end_addr = (void*)actual_end;
+    }
+    *spill = 0;
+}
+
+#define TELNET_SERVER 1
+#if TELNET_SERVER
+#define MAXTHREADS 50
+static struct {
+    struct thread* th;
+    char in_foreign_code;
+    char gc_waiting_on_spinlock;
+    //char did_sem_post;
+}  known_threads[MAXTHREADS];
+static int n_known_threads;
+static int sem_waits;
+static int get_n_currently_waiting_on() { return sem_waits; }
+#endif
+
+// Acquire the locks in this order:
+//   condition_lock, mutators lock, per-thread spinlock (one at a time)
+void gc_stop_the_world() {
+  event0("begin stw");
+    struct thread* me = get_sb_vm_thread();
+    struct thread* th;
+    /* The global "stopped" flag is set *before* doing anything else
+     * because as we're arming the trap for each thread in turn, any thread
+     * that hits a C-to-Lisp yieldpoint should block at the futex_wait call
+     * as though the world is already stopped */
+    world_is_stopped = 1;
+    sem_waits = 0;
+    //    int sem_waits = 0;
+    // TODO: for all threads _except_ the finalizer, stop them; then ask the finalizer
+    // thread to run the pre-GC actions (clobber the hash-caches, etc) and stop itself.
+    for_each_thread(th) {
+#if TELNET_SERVER
+        int ti = n_known_threads++;
+        if (ti > MAXTHREADS) lose("Too many cooks");
+        known_threads[ti].th = th;
+#endif
+        // Thread can't change its state to DEAD without acquiring the rwlock for reading
+        // Therefore if non-dead, it will participate in stop-for-gc by waiting for a
+        // stop-the-world trap, and it will respond with sem_post.
+        if (th == me) continue;
+        //
+        known_threads[ti].gc_waiting_on_spinlock = 1;
+        acquire_lock(&th->yieldpoint_spinlock);
+        if (th->state_word.state == STATE_DEAD) {
+            known_threads[ti].gc_waiting_on_spinlock = 0;
+            release_lock(&th->yieldpoint_spinlock);
+            continue;
+        }
+        // th->stepping.suspend = -1;
+        if (debug) fprintf(stderr, "GC: will stop thread %p (%s)\n", th, pthreadname(th));
+        __sync_fetch_and_or(&th->interrupt_reason, SUSPEND);
+        force_tlab_slowpath(&th->cons_tlab, &th->spill_cons_tlab_end);
+        force_tlab_slowpath(&th->sys_cons_tlab, &th->spill_sys_cons_tlab_end);
+        force_tlab_slowpath(&th->mixed_tlab, &th->spill_mixed_tlab_end);
+        force_tlab_slowpath(&th->sys_mixed_tlab, &th->spill_sys_mixed_tlab_end);
+        yieldpoint_trap_toggle(th, READ_ONLY);
+        lispobj stackptr = get_stackptr_at_foreign_call(th);
+        yieldpoint_trap_toggle(th, NO_ACCESS);
+        release_lock(&th->yieldpoint_spinlock);
+        known_threads[ti].gc_waiting_on_spinlock = 0;
+        event2("stopping %p, sp=%lx", th, stackptr);
+        if (stackptr) {
+            known_threads[ti].in_foreign_code = 1;
+            /* Assume that the next instruction after a Lisp-to-C yieldpoint
+             * is a call into C which pushes the return address on the stack.
+             * This gets us the return PC "for free" relative to the #+sb-safepoint
+             * technique which uses LEA [RIP+n] to compute and store the PC. */
+            if ((lispobj*)stackptr - 1 >= th->control_stack_start)
+                stackptr -= N_WORD_BYTES;
+            gc_assert(stackptr >= (lispobj)th->control_stack_start &&
+                      stackptr < (lispobj)th->control_stack_end);
+            th->control_stack_pointer = (lispobj*)stackptr;
+            if (debug)
+              fprintf(stderr, "thread %p stackptr = %p = end-%dw\n",
+                      th, th->control_stack_pointer,
+                      (int)(th->control_stack_end - th->control_stack_pointer));
+        }
+        if (stackptr == 0) ++sem_waits; // the thread is in Lisp
+    }
+    if (debug) fprintf(stderr, "GC: sem_wait for %d\n", sem_waits);
+    event1("waiting on %d threads", sem_waits);
+    // Wait for all threads executing Lisp (i.e. not foreign code) to stop
+    while (sem_waits--) sem_wait(&gc_sync_sem);
+    // Assert that every threads' stack pointer is known
+    for_each_thread(th) {
+        if (th->control_stack_pointer != 0 ||
+            read_TLS(FREE_INTERRUPT_CONTEXT_INDEX, th)) {
+        } else {
+            lose("Thread %p context is unknown", th);
+        }
+        restore_tlab(&th->cons_tlab, &th->spill_cons_tlab_end);
+        restore_tlab(&th->sys_cons_tlab, &th->spill_sys_cons_tlab_end);
+        restore_tlab(&th->mixed_tlab, &th->spill_mixed_tlab_end);
+        restore_tlab(&th->sys_mixed_tlab, &th->spill_sys_mixed_tlab_end);
+    }
+    n_known_threads = 0;
+    memset(known_threads, 0, sizeof known_threads);
+}
+
+void gc_start_the_world() {
+    struct thread* th;
+    for_each_thread(th) {
+        th->control_stack_pointer = 0;
+        __sync_fetch_and_and(&th->interrupt_reason, ~SUSPEND);
+        //th->stepping.suspend = 0;
+    }
+    world_is_stopped = 0;
+    futex_wake(&world_is_stopped, INT_MAX);
+    if (debug) fprintf(stderr, "GC: world restarted\n");
+}
+
+void show_yp_kind_hit() {
+  fprintf(stderr, "YP hit: %d %d %d %d\n", yp_kind_hit[0], yp_kind_hit[1], yp_kind_hit[2], yp_kind_hit[3]);
+}
+
+/*
+Finalizer thread should wake on any of the following events:
+- finalizer item queued
+- interrupt-thread action
+- other deferred async signal
+- post-gc hooks
+The first 3 are working, the last is not. I need a way to tell
+it to run the hooks */
+
+extern int finalizer_thread_runflag;
+void finalizer_thread_wait () {
+    /* pthread_cond_wait can never return EINTR which is what made
+     * SB-THREAD:INTERRUPT-THREAD unreliable on the finalizer.
+     * Direct use of a futex gives nicer behavior */
+    int c = finalizer_thread_runflag;
+    if (c) futex_wait(&finalizer_thread_runflag, c, -1, 0);
+
+}
+void finalizer_thread_wake () {
+    futex_wake(&finalizer_thread_runflag, 1);
+}
+void finalizer_thread_stop () {
+    finalizer_thread_runflag = 0;
+    futex_wake(&finalizer_thread_runflag, 1);
+}
+
+extern void yieldpoint_patch_asm_routines(int);
+void* collector_main(__attribute__((unused)) void* dummy)
+{
+#ifdef LISP_FEATURE_LINUX
+    pthread_setname_np(pthread_self(), "collectorMain");
+#endif
+    pthread_mutex_lock(&gc_condition_lock);
+    for (;;) {
+        pthread_cond_wait(&gc_controller_cond, &gc_condition_lock);
+        int reason = gc_notification_reason;
+        if (reason & GC_CONTROLLER_QUIT) break;
+        if (!(gc_notification_reason & INITIATE_GC)) continue; // sleep some more
+        if (debug) fprintf(stderr, "GC main wants to run\n");
+        /* One or more threads that we need to try to suspend might each be
+         * trying to acquire the lock to signal a GC request, so never hold
+         * the condition lock while trying to initiat a collection */
+        pthread_mutex_unlock(&gc_condition_lock);
+        /* No thread can die nor be created; and no thread can inhibit GC. */
+        pthread_rwlock_wrlock(&all_threads_lock);
+        // Patching is needed in order for threads to reach a yieldpoint quicker,
+        // since asm routines have NOPs where yieldpoints should be.
+        //yieldpoint_patch_asm_routines(1);
+        gc_stop_the_world();
+        int generation = gc_notification_reason & 7;
+        extern void collect_garbage(generation_index_t);
+        //show_yp_kind_hit();
+        collect_garbage(generation);
+        gc_notification_reason = 0;
+        ++gc_cycle_count;
+        // TODO: enqueue a finalizer thread action to run post-GC hooks
+        gc_start_the_world();
+        pthread_rwlock_unlock(&all_threads_lock);
+        finalizer_thread_wake();
+        pthread_mutex_lock(&gc_condition_lock);
+        // Manually requested GC should wait on this condition
+        pthread_cond_broadcast(&gc_completion_cond);
+        extern void empty_thread_recyclebin();
+        empty_thread_recyclebin();
+        // can be un-patched at any time
+        //yieldpoint_patch_asm_routines(0);
+    }
+    pthread_mutex_unlock(&gc_condition_lock);
+    return 0;
+}
+
+#if TELNET_SERVER
+#include <sys/socket.h>
+#include <netinet/in.h>
+int listener;
+void* debugging_service_main(__attribute__((unused)) void* dummy)
+{
+#if 0
+  {sigset_t mask;
+    pthread_sigmask(SIG_SETMASK, 0, &mask);
+     char buf[100]; sigset_tostring(&mask, buf, sizeof buf);
+      printf("service thread has mask %s\n", buf);
+      sigset_tostring(&deferrable_sigset, buf, sizeof buf);
+      printf("deferrable is %s\n", buf);
+      sigset_tostring(&blockable_sigset, buf, sizeof buf);
+      printf("blockable  is %s\n", buf);}
+#endif
+    struct sockaddr_in sin;
+    memset(&sin, 0, sizeof sin);
+    sin.sin_addr.s_addr = INADDR_ANY;
+    sin.sin_port = 0;
+    listener = socket(AF_INET, SOCK_STREAM, 0);
+    if (bind(listener, &sin, sizeof sin)) {perror("bind");exit(1);}
+    if (listen(listener, 5)) {perror("listen");exit(1);}
+    socklen_t addrlen = sizeof sin;
+    if (getsockname(listener, &sin, &addrlen)) {perror("getsockname");exit(1);}
+    char buf[64];
+    int n = snprintf(buf, sizeof buf, "Pid %d listening on port %d\n", getpid(), ntohs(sin.sin_port));
+    write(2, buf, n);
+    int peer;
+    FILE* stream = 0;
+    while (1) {
+      peer = accept(listener, &sin, &addrlen);
+      if (peer < 0) lose("wtf?");
+      stream = fdopen(peer, "w");
+      setlinebuf(stream);
+      fprintf(stream, "nthreads=%d waiting_on=%d\n", n_known_threads, get_n_currently_waiting_on());
+      fprintf(stream, " pthread vm_thread tid State Lip/C spinlock_wait\n");
+      {int i;for (i=0;i<n_known_threads;++i) {
+          struct thread* th  = known_threads[i].th;
+          if (!th) {
+            fprintf(stream, "%d: bad\n", i);
+          } else {
+            int sw = th->state_word.state;
+            lispobj mutex = read_TLS(CURRENT_MUTEX, th);
+            fprintf(stream, "%d: %lx %p %lx %s %s %d ",
+                    i, th->os_thread, th, th->os_kernel_tid,
+                    (sw==STATE_DEAD?"DEAD":sw==STATE_RUNNING?"RUN ":sw==STATE_STOPPED?"STOP":"????"),
+                    known_threads[i].in_foreign_code?"C   ":"Lisp",
+                    known_threads[i].gc_waiting_on_spinlock);
+            if (mutex != 0) {
+              struct lispmutex* m = (void*)native_pointer(mutex);
+              lispobj name = m->name;
+              fprintf(stderr, "mutex=%lx (state=%lx owner=%lx name=%s)",
+                      mutex, m->uw_state, m->_owner,
+                      (other_pointer_p(name) && simple_base_string_p(name)) ? (char*)(name+1) : "?");
+            }
+            putc('\n', stderr);
+          }
+        }
+      }
+      while (1) {
+        char line[80];
+        write(peer, "> ", 2);
+        int n = read(peer, line, sizeof line);
+        if (n<=0){ fclose(stream); break; }
+        printf("got n=%d command [%s]\n", n, line);
+        char cmd = line[0];
+        if (cmd == 'q') break;
+        write(peer, "m'kay\n",6);
+      }
+      printf("remote debug service connected\n");
+      close(peer);
+    }
+}
+#endif
+
+void safepoint_init() { // backward-compatible function name
+    os_sem_init(&gc_sync_sem, 0);
+    sigset_t oldmask;
+    // Don't want SIGCHLD, SIGARLM, etc
+    pthread_sigmask(SIG_BLOCK, &blockable_sigset, &oldmask);
+    pthread_create(&gc_controller, NULL, collector_main, 0);
+    if (debug) fprintf(stderr, "GC controller thread is %p\n", (void*)gc_controller);
+#ifdef TELNET_SERVER
+    pthread_create(&rdb_thread, NULL, debugging_service_main, 0);
+    pthread_setname_np(rdb_thread, "debug");
+#endif
+    pthread_sigmask(SIG_SETMASK, &oldmask, 0);
+}
+
+void request_garbage_collection(int generation)
+{
+    if (generation == -1) { // auto-triggered request
+        // a read barrier is not important here
+        if (gc_notification_reason) return; // request already pending
+        pthread_mutex_lock(&gc_condition_lock);
+        gc_notification_reason |= INITIATE_GC;
+        pthread_cond_broadcast(&gc_controller_cond);
+        pthread_mutex_unlock(&gc_condition_lock);
+    } else {
+        pthread_mutex_lock(&gc_condition_lock);
+        /* Take the higher of competing args to SB-EXT:GC if two user threads
+         * nearly simultaneously invoke it */
+        int pending = gc_notification_reason & 7;
+        if (pending > generation) generation = pending;
+        gc_notification_reason = INITIATE_GC | generation;
+        long starting_count = gc_cycle_count;
+        /* The Lisp side will deal with the case of explicitly requesting a collection
+         * while inside without-gcing. That's kinda stupid and it's unclear why we would
+         * want to support that, other than regression tests assert that it works */
+        pthread_cond_broadcast(&gc_controller_cond);
+        while (gc_cycle_count == starting_count)
+            pthread_cond_wait(&gc_completion_cond, &gc_condition_lock);
+        pthread_mutex_unlock(&gc_condition_lock);
+    }
+}
+
+extern void
+store_signal_data_for_later (struct interrupt_data *data, void *handler,
+                             int signal,
+                             siginfo_t *info, os_context_t *context);
+
+/* Unlike maybe_now_maybe_later, this handler never handles a signal right away
+ * but instead always defers it to a yieldpoint.
+ * It would be neat if we could figure out which Lisp thread is in the foreground
+ * so SIGINT could be directed correctly the first time instead of having to
+ * potentially re-signal it in Lisp */
+void defer_to_yieldpoint(int sig, siginfo_t* info, void* context)
+{
+    int _saved_errno = errno;
+    struct thread* th = get_sb_vm_thread();
+    store_signal_data_for_later(&thread_interrupt_data(th), (void*)1,
+                                sig, info, context);
+    lispobj enabled = read_TLS(INTERRUPTS_ENABLED, th);
+#if 1
+    {
+    char b[100];
+    int n = snprintf(b, sizeof b, "%s: Deferring: %s (pc=%lx) %s\n",
+                     pthreadname(th), strsignal(sig),
+                     os_context_pc(context),
+                     enabled==NIL?"DISABLED":enabled==LISP_T?"ENABLED":"?");
+
+      write(2,b,n);
+      //libunwind_backtrace(th, context);
+    }
+#endif
+    if (enabled == NIL) {
+        write_TLS(INTERRUPTS_ENABLED, 0, th); // 0 = "signal deferred"
+        /* WITHOUT-INTERRUPTS will check whether a signal got deferred,
+         * and will explicitly handle it without a yieldpoint trap */
+    } else if (enabled == LISP_T) {
+        /* If the lock is already taken, then either the GC controller is frobbing it,
+         * or this thread itself is in alloc_cooperate. In either case we don't need
+         * to arm the trap. The worst that happens is a deferred interrupt
+         * gets handled a little later */
+        __sync_fetch_and_or(&th->interrupt_reason, ASYNC_SIGNAL);
+        if (try_acquire_lock(&th->yieldpoint_spinlock)) {
+            yieldpoint_trap_toggle(th, NO_ACCESS);
+            release_lock(&th->yieldpoint_spinlock);
+        }
+    } else {
+        lose("Received async interrupt with enable neither T nor NIL");
+    }
+    errno = _saved_errno;
+}
+
+static void publish_context(struct thread* thread, os_context_t* context)
+{
+    /* Do dynamic binding of the active interrupt context index
+     * and save the context in the context array. */
+    int context_index =
+        fixnum_value(read_TLS(FREE_INTERRUPT_CONTEXT_INDEX, thread));
+    if (context_index >= MAX_INTERRUPTS)
+        lose("maximum interrupt nesting depth (%d) exceeded", MAX_INTERRUPTS);
+
+    bind_variable(FREE_INTERRUPT_CONTEXT_INDEX, make_fixnum(context_index + 1), thread);
+    nth_interrupt_context(context_index, thread) = context;
+}
+
+static void unpublish_context(struct thread* thread)
+{
+    // Never leave stale pointers in the signal context array
+    int ici = fixnum_value(read_TLS(FREE_INTERRUPT_CONTEXT_INDEX,thread));
+    nth_interrupt_context(ici - 1, thread) = NULL;
+    /* Undo dynamic binding of FREE_INTERRUPT_CONTEXT_INDEX */
+    unbind(thread);
+}
+
+#if 0
+void sigtrap_handler(int __attribute__((unused)) signal,
+                     siginfo_t __attribute__((unused)) *info,
+                     os_context_t *context)
+{
+    struct thread*th = get_sb_vm_thread();
+    if (!th->stepping.suspend) lose("Why are you closed?");
+    publish_context(th, context);
+    sem_post(&gc_sync_sem);
+    if (debug) {
+      char buf[100];
+      int n = snprintf(buf, sizeof buf, "%s: posted\n", pthreadname(th));
+      write(2, buf, n);
+    }
+    do { futex_wait(&world_is_stopped, 1, -1, 0); } while (world_is_stopped);
+    if (debug) fprintf(stderr, "%s: back from futex_wait\n", pthreadname(th));
+    unpublish_context(th);
+}
+#endif
+
+static void suspend_for_gc(struct thread* th)
+{
+    if (debug)fprintf(stderr, "%s: need to suspend in allocator\n", pthreadname(th));
+    __sync_fetch_and_add(&yp_kind_hit[0], 1);
+    ucontext_t context; // don't really need this whole context, but that's fine
+    getcontext(&context);
+    publish_context(th, &context);
+    th->state_word.state = STATE_STOPPED;
+    sem_post(&gc_sync_sem);
+    do { futex_wait(&world_is_stopped, 1, -1, 0); } while (world_is_stopped);
+    th->state_word.state = STATE_RUNNING;
+    if (debug) fprintf(stderr, "%s: back from futex_wait in allocator\n", pthreadname(th));
+    unpublish_context(th);
+}
+
+void maybe_suspend_for_gc(struct thread* th)
+{
+    if (th->interrupt_reason & SUSPEND) suspend_for_gc(th);
+}
+
+/* Return a copy of the thread's region. We operate on the copy so that it is not
+ * succeptible to having the 'end' slot clobbered while in the call sequence of lisp_alloc. */
+struct alloc_region alloc_cooperate_before(struct alloc_region* r, struct thread* th)
+{
+    struct alloc_region result;
+    while (1) {
+        // acquire_lock(&th->yieldpoint_spinlock);
+        result = *r;
+        // release_lock(&th->yieldpoint_spinlock);
+        if (result.end_addr) return result;
+        gc_assert(th->interrupt_reason & SUSPEND);
+        suspend_for_gc(th);
+    }
+}
+
+static lispobj* region_end_spill_slot(struct thread* th, struct alloc_region* r)
+{
+    if (r == &th->cons_tlab) return &th->spill_cons_tlab_end;
+    if (r == &th->sys_cons_tlab) return &th->spill_sys_cons_tlab_end;
+    if (r == &th->mixed_tlab) return &th->spill_mixed_tlab_end;
+    if (r == &th->sys_mixed_tlab) return &th->spill_sys_mixed_tlab_end;
+    lose("Unknown TLAB %p for thread %p", r, th);
+}
+
+/* Restore the thread's TLAB from the shadow copy. If GC already forced the region
+ * into a slow path fallback, we have replicate that effect. It won't work to yield
+ * now because we'll lose the object whose space was just allocated but whose bits
+ * were not written */
+void alloc_cooperate_after(struct alloc_region* dst, struct alloc_region* src,
+                           struct thread* th)
+{
+    acquire_lock(&th->yieldpoint_spinlock);
+    bool yield = !dst->end_addr;
+    *dst = *src;
+    lispobj* spill_slot = region_end_spill_slot(th, dst);
+    if (yield)
+       force_tlab_slowpath(dst, spill_slot);
+    else
+       gc_assert(*spill_slot == 0);
+    release_lock(&th->yieldpoint_spinlock);
+#if 0
+    if (yield) //start_addr != src->start_addr || dst->end_addr != src->end_addr)
+      fprintf(stderr, "cooperate_after detected detected change of region: TLAB=%p:%p (free=%p) shadow=%p:%p (free=%p) yield=%d\n",
+              dst->start_addr, dst->end_addr, dst->free_pointer,
+              src->start_addr, src->end_addr, src->free_pointer, yield);
+#endif
+}
+
+#ifdef LISP_FEATURE_X86_64
+static yieldpoint_kind infer_kind(unsigned char* pc) {
+    if (pc[0] == 0x45 && pc[1] == 0x84) return IN_LISP;   // TEST BYTE
+    if (pc[0] == 0x45 && pc[1] == 0x85) return IN_LISP;   // TEST DWORD
+    if (pc[0] == 0x66 && pc[1] == 0x45) return IN_LISP;   // MOVNTDQA
+    if (pc[0] == 0xC4 && pc[1] == 0x42) return IN_LISP;   // VMOVNTDQA
+    if (pc[0] == 0x49 && pc[1] == 0x89) return LISP_TO_C; // MOV mem, RSP
+    if (pc[0] == 0x49 && pc[1] == 0x31) return C_TO_LISP; // XOR mem, RSP
+    return UNKNOWN;
+}
+#endif
+
+static void yieldpoint_trap(struct thread* th, os_context_t *context)
+{
+    unsigned char* pc = (void*)os_context_pc(context);
+    yieldpoint_kind kind = infer_kind(pc);
+    if (debug) {
+        char buf[100];
+        int n = snprintf(buf, sizeof buf, "%s: YP trap %d %d pc=%p\n",
+                         pthreadname(th), (int)th->interrupt_reason, kind, pc);
+        write(2, buf, n);
+        sb_dump_mcontext("foo", context);
+    }
+    event3("YP trap %x %d %p", th->interrupt_reason, kind, pc);
+    if (kind == UNKNOWN) lose("unrecognized yieldpoint @ %p", pc);
+    __sync_fetch_and_add(&yp_kind_hit[kind], 1);
+    while (1) {
+        int reason = th->interrupt_reason;
+        if (!reason) {
+            /* Disarm the trap but only if a double-check of the trap reason
+             * confirms that it need not be armed. A yieldpoint trap can't happen
+             * in alloc_cooperate, so this can't deadlock with itself */
+            acquire_lock(&th->yieldpoint_spinlock);
+            // FIXME: atomic load probably needed here? especially for non-x86
+            reason = th->interrupt_reason;
+            if (!reason) yieldpoint_trap_toggle(th, READ_WRITE);
+            release_lock(&th->yieldpoint_spinlock);
+            if (!reason) return;
+        }
+        /* Always cooperate with GC before doing anything else. */
+        if (reason & SUSPEND) {
+            int context_published = 0;
+            th->state_word.state = STATE_STOPPED;
+            if (kind == C_TO_LISP) {
+                /* Trapped trying to get back to Lisp from a C call. Do not sem_post,
+                 * just wait until world isn't stopped. */
+            } else {
+                publish_context(th, context);
+                context_published = 1;
+                sem_post(&gc_sync_sem);
+                if (debug) {
+                  char buf[100];
+                  int n = snprintf(buf, sizeof buf, "%s: posted\n", pthreadname(th));
+                  write(2, buf, n);
+                }
+            }
+            do { futex_wait(&world_is_stopped, 1, -1, 0); } while (world_is_stopped);
+            th->state_word.state = STATE_RUNNING;
+            if (debug) fprintf(stderr, "%s: back from futex_wait\n", pthreadname(th));
+            if (context_published) unpublish_context(th);
+            reason &= ~SUSPEND;
+        }
+        if (!reason) continue; // try to return now
+        gc_assert(reason & ASYNC_SIGNAL);
+        // Make the yieldpoint instruction act like it was a CALL to a Lisp asm routine
+        static char* asm_trampoline;
+        if (!asm_trampoline) { // Lookup and/or memoize the routine to call
+            asm_trampoline = get_asm_routine_by_name("HANDLE-DEFERRED-SIGNAL", 0);
+            gc_assert(asm_trampoline);
+            if (debug) fprintf(stderr, "YP asm tramp is %p\n", asm_trampoline);
+        }
+        /* Disarm the trap, ensuring that we're "in Lisp" regardless of the kind of yieldpoint,
+         * because we don't want to handle async signals from C. (The Lisp signal handler
+         * is ordinary Lisp code that can cons, triggering a garbage collection)
+         * But also consider the following theoretically possible sequence:
+         * GC is initiated, arms this thread's trap, completes, is immediately re-initiated
+         * and arms this thread's trap. If we unilaterally disarm it, then we will miss the
+         * second stop request that arrived in rapid-fire succession */
+        acquire_lock(&th->yieldpoint_spinlock);
+        if (th->interrupt_reason & SUSPEND) { // dang, not again?
+            release_lock(&th->yieldpoint_spinlock);
+            continue;
+        }
+        yieldpoint_trap_toggle(th, READ_WRITE);
+        clear_stackptr_at_foreign_call(th);
+        release_lock(&th->yieldpoint_spinlock);
+        os_context_register_t return_to = (os_context_register_t)pc;
+        /* If returning from foreign code (at a C-to-Lisp yieldpoint), step beyond the
+         * yieldpoint. Having cleared the stack-pointer slot in the thread structure,
+         * the collector understands that this thread is effectively in Lisp
+         * regardless of the kind of yieldpoint trap */
+        if (kind == C_TO_LISP) return_to += 4; // size of the XOR instruction
+        /* Simulate a CALL that returns to the yieldpoint (or one instruction after).
+         * God forbid this store hits the stack guard page.
+         * Maybe just don't handle the async signal in that case? */
+        lispobj* sp = (lispobj*)*os_context_sp_addr(context);
+        --sp;
+        fprintf(stderr, "YP trap: delivering signal to thread %p, pushing old PC %lx\n", th, return_to);
+        *sp = return_to;
+        *os_context_sp_addr(context) = (os_context_register_t)sp;
+        /* If yet another GC stop request arrives, the next yieldpoint will be in the
+         * prologue of the Lisp function that handles the deferred signal */
+        OS_CONTEXT_PC(context) = (os_context_register_t)asm_trampoline;
+        return;
+    }
+}
+
+int handle_safepoint_violation(os_context_t *context, os_vm_address_t fault_address) {
+    struct thread*th = get_sb_vm_thread();
+    if (th && yieldpoint_trap_addr(th) == (lispobj*)fault_address) {
+        yieldpoint_trap(th, context);
+        return 1;
+    }
+    return 0;
+}
+int show_interrupt_data() {
+    struct thread*th = get_sb_vm_thread();
+    struct interrupt_data *data = &thread_interrupt_data(th);
+    siginfo_t *inf = &data->pending_info;
+    char string1[100], string2[100];
+    sigset_t oldmask;
+    int result = data->pending_signal;
+    pthread_sigmask(SIG_SETMASK, 0, &oldmask);
+    sigset_tostring(&oldmask, string1, 100);
+    sigset_tostring(&data->pending_mask, string2, 100);
+    printf("sig=%d no=%d errno=%d code=%d pid=%d uid=%d st=%d cur_mask=%s pend_mask=%s\n",
+           data->pending_signal, inf->si_signo, inf->si_errno, inf->si_code, inf->si_pid, inf->si_uid,
+           inf->si_status, string1, string2);
+    return result;
+}
+int get_pending_signal_number() {
+    struct thread*th = get_sb_vm_thread();
+    return thread_interrupt_data(th).pending_signal;
+}
+void flush_pending_signal_and_restore() {
+    struct thread*th = get_sb_vm_thread();
+    struct interrupt_data *data = &thread_interrupt_data(th);
+    //siginfo_t *inf = &data->pending_info;
+    data->pending_handler = 0;
+    data->pending_signal = 0;
+    __sync_fetch_and_and(&th->interrupt_reason, ~ASYNC_SIGNAL);
+    pthread_sigmask(SIG_SETMASK, &data->pending_mask, 0);
+}
+
+extern void interrupt_handle_now_handler(int, siginfo_t*, void*);
+extern void sigprof_handler(int, siginfo_t*, void*);
+extern void (*interrupt_low_level_handlers[NSIG]) (int, siginfo_t*, os_context_t*);
+
+ /* This is called from Lisp. */
+void install_handler(int signal, lispobj handler)
+{
+    struct sigaction sa;
+    memset(&sa, 0, sizeof sa);
+
+    printf("HL handler %d (%s)\n", signal, strsignal(signal));
+    if (interrupt_low_level_handlers[signal]) {
+        // When there's a low-level handler, we must leave it alone.
+        // Give it the lisp function to call if it decides to forward a signal.
+        // SIG_IGN and SIG_DFL don't always do what you think in such case.
+        lisp_sig_handlers[signal] = functionp(handler) ? handler : 0;
+    } else if (signal == SIGPROF) {
+        if (handler) sa.sa_sigaction = sigprof_handler;
+        else         sa.sa_handler   = SIG_DFL;
+        // The handler is signal-safe, but because it uses component_ptr_from_pc(),
+        // it must block GC, lest crashes occur from dereferencing wild pointers.
+        // FIXME: skip collect a profiling sample if GC is in progress which can happen
+        // if we transited through a lisp-to-c yieldpoint
+        sa.sa_mask = blockable_sigset;
+        sa.sa_flags = SA_SIGINFO | SA_RESTART;
+        sigaction(signal, &sa, NULL);
+        return;
+    } else {
+        // Our "abstract" values for SIG_DFL and SIG_IGN are 0 and 1
+        // respectively which are probably the real values from signal.h
+        // but this way way don't need to put them in grovel-headers.c
+        if (handler==0 || handler==1) {
+            sa.sa_handler = handler ? SIG_IGN : SIG_DFL;
+            // assign the OS level action before clearing the lisp function.
+            // (If a signal were to be delivered to the C trampoline when the lisp
+            // function is NIL, we'd get the effect of :IGNORE regardless
+            // of what the default action should be)
+            sigaction(signal, &sa, NULL);
+            lisp_sig_handlers[signal] = 0;
+            return;
+        }
+        sa.sa_flags = SA_SIGINFO;
+        if (signal != SIGURG) sa.sa_flags |= SA_RESTART;
+        if (sigismember(&deferrable_sigset, signal)) {
+            sa.sa_sigaction = defer_to_yieldpoint;
+        } else {
+            sa.sa_sigaction = interrupt_handle_now_handler;
+            sa.sa_flags |= SA_NODEFER;
+        }
+        sa.sa_mask = blockable_sigset;
+        // ensure the C handler sees a lisp function before doing sigaction()
+        lisp_sig_handlers[signal] = handler;
+        sigaction(signal, &sa, NULL);
+    }
+}

tests/run-tests.lisp

@@ -224,6 +224,9 @@
       sb-c::*compile-file-elapsed-time*
       sb-c::*phash-lambda-cache*
       ,(maybe "SB-IMPL" "*RUN-GC-HOOKS*")
+      sb-x86-64-asm::*total-n-yieldpoints-deleted*
+      sb-x86-64-asm::*original-total-n-yieldpoints*
+      sb-thread::*anon-thread-name-generator*
       sb-impl::**finalizer-store**
       sb-impl::*finalizer-rehashlist*
       sb-impl::*finalizers-triggered*

tools-for-build/grovel-headers.c

@@ -55,6 +55,9 @@
 #include <signal.h>
 #include <errno.h>
 #include <time.h>
+#ifdef LISP_FEATURE_YIELDPOINTS
+#include <ucontext.h> // probably already included via signal.h
+#endif
 
 #ifdef LISP_FEATURE_BSD
   #include <sys/param.h>
@@ -280,6 +283,9 @@ main(int argc, char __attribute__((unused)) *argv[])
 
     printf(";;; signals\n");
     defconstant("sizeof-sigset_t", sizeof (sigset_t));
+#ifdef LISP_FEATURE_YIELDPOINTS
+    defconstant("sizeof-ucontext_t", sizeof (ucontext_t));
+#endif
     defconstant("sig_block", SIG_BLOCK);
     defconstant("sig_unblock", SIG_UNBLOCK);
     defconstant("sig_setmask", SIG_SETMASK);