From a1fcc8b1291150eed98107f6f593c4a7737acbcb Mon Sep 17 00:00:00 2001 From: Douglas Katzman Date: Fri, 26 Apr 2024 20:52:02 -0400 Subject: [PATCH] New yieldpoints for SBCL25 dev meeting Add "--with-yieldpoints --with-ultrafutex" to test-drive this patch. --- src/assembly/x86-64/alloc.lisp | 2 +- src/assembly/x86-64/arith.lisp | 2 +- src/assembly/x86-64/assem-rtns.lisp | 3 + src/assembly/x86-64/tramps.lisp | 43 +- src/code/final.lisp | 15 +- src/code/gc.lisp | 29 + src/code/sysmacs.lisp | 10 +- src/code/target-signal.lisp | 33 +- src/code/target-thread.lisp | 78 +-- src/code/thread-structs.lisp | 2 +- src/code/thread.lisp | 14 +- src/cold/compile-cold-sbcl.lisp | 3 + src/cold/exports.lisp | 2 +- src/cold/shared.lisp | 3 + src/cold/warm.lisp | 1 + src/compiler/assem.lisp | 37 +- src/compiler/codegen.lisp | 3 +- src/compiler/fndb.lisp | 2 +- src/compiler/generic/genesis.lisp | 5 + src/compiler/generic/objdef.lisp | 12 +- src/compiler/generic/parms.lisp | 13 +- src/compiler/generic/utils.lisp | 2 +- src/compiler/generic/vm-fndb.lisp | 1 + src/compiler/ir2opt.lisp | 2 +- src/compiler/ir2tran.lisp | 4 +- src/compiler/policies.lisp | 1 - src/compiler/pseudo-vops.lisp | 2 +- src/compiler/x86-64/alloc.lisp | 48 +- src/compiler/x86-64/array.lisp | 2 +- src/compiler/x86-64/c-call.lisp | 29 +- src/compiler/x86-64/call.lisp | 7 +- src/compiler/x86-64/cell.lisp | 29 +- src/compiler/x86-64/insts.lisp | 170 +++++- src/compiler/x86-64/macros.lisp | 73 ++- src/compiler/x86-64/parms.lisp | 7 +- src/compiler/x86-64/system.lisp | 21 +- src/compiler/x86-64/target-insts.lisp | 5 + src/compiler/x86-64/vm.lisp | 2 +- src/runtime/GNUmakefile | 4 +- src/runtime/alloc.c | 44 +- src/runtime/breakpoint.c | 4 +- src/runtime/gc-common.c | 6 +- src/runtime/gc.h | 4 - src/runtime/gencgc-alloc-region.h | 3 +- src/runtime/gencgc.c | 60 +- src/runtime/immobile-space.c | 1 + src/runtime/interrupt.c | 40 +- src/runtime/interrupt.h | 2 + src/runtime/linux-os.c | 4 +- src/runtime/monitor.c | 19 + src/runtime/runtime.c | 2 +- src/runtime/thread.c | 55 +- src/runtime/thread.h | 16 +- src/runtime/tiny-lock.h | 8 +- src/runtime/x86-64-arch.c | 37 +- src/runtime/x86-64-assem.S | 9 + src/runtime/yieldpoints.c | 760 ++++++++++++++++++++++++++ tests/run-tests.lisp | 3 + tools-for-build/grovel-headers.c | 6 + 59 files changed, 1553 insertions(+), 251 deletions(-) create mode 100644 src/runtime/yieldpoints.c diff --git a/src/assembly/x86-64/alloc.lisp b/src/assembly/x86-64/alloc.lisp index 5fee79e1b..9dbc814a8 100644 --- a/src/assembly/x86-64/alloc.lisp +++ b/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) diff --git a/src/assembly/x86-64/arith.lisp b/src/assembly/x86-64/arith.lisp index b422a704c..1bc095d64 100644 --- a/src/assembly/x86-64/arith.lisp +++ b/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) diff --git a/src/assembly/x86-64/assem-rtns.lisp b/src/assembly/x86-64/assem-rtns.lisp index 2d983c5c3..4e48dc256 100644 --- a/src/assembly/x86-64/assem-rtns.lisp +++ b/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) diff --git a/src/assembly/x86-64/tramps.lisp b/src/assembly/x86-64/tramps.lisp index 212634416..fc884aee0 100644 --- a/src/assembly/x86-64/tramps.lisp +++ b/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)) diff --git a/src/code/final.lisp b/src/code/final.lisp index fbe2a7596..88def2a2f 100644 --- a/src/code/final.lisp +++ b/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))) diff --git a/src/code/gc.lisp b/src/code/gc.lisp index 7efd4156a..8ff21fe48 100644 --- a/src/code/gc.lisp +++ b/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) diff --git a/src/code/sysmacs.lisp b/src/code/sysmacs.lisp index 55e578336..346b00e1b 100644 --- a/src/code/sysmacs.lisp +++ b/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))) diff --git a/src/code/target-signal.lisp b/src/code/target-signal.lisp index f718155a5..7992deb72 100644 --- a/src/code/target-signal.lisp +++ b/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)))))) diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 646b1de26..2474d8b9b 100644 --- a/src/code/target-thread.lisp +++ b/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) - :extern "futex_wait")) + (with-alien ((%wait (function int unsigned (unsigned 32) long unsigned-long) + :extern "futex_wait")) + (defun fast-futex-wait (word-addr oldval to-sec to-usec) + (alien-funcall %wait word-addr oldval to-sec to-usec)) + (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 (ignore queue n)) - #-sb-thread - (error "Not supported in unithread builds.") - #+sb-thread - (cond - #+sb-futex - (t + (declare (ignorable queue n)) + #-sb-thread (error "Not supported in unithread builds.") + #+sb-futex ; implies sb-thread per feature-compatibility-tests + (progn ;; 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 - (t - (with-cas-lock ((waitqueue-%owner queue)) - (%waitqueue-wakeup queue n))))) + #+(and sb-thread (not sb-futex)) + (with-cas-lock ((waitqueue-%owner queue)) + (%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 () - (sap-ref-lispobj (current-thread-sap) - (* sb-vm::thread-stepping-slot sb-vm:n-word-bytes))) - -(defun (setf thread-stepping) (value) - (setf (sap-ref-lispobj (current-thread-sap) - (* sb-vm::thread-stepping-slot sb-vm:n-word-bytes)) - value)) +#+sb-thread +(macrolet ((access-it () + `(sap-ref-8 (current-thread-sap) + (* sb-vm::thread-stepping-slot sb-vm:n-word-bytes)))) + (defun thread-stepping () (access-it)) + (defun (setf thread-stepping) (value) (setf (access-it) value))) ;;;; Diagnostic tool diff --git a/src/code/thread-structs.lisp b/src/code/thread-structs.lisp index 98b0f465a..784e90809 100644 --- a/src/code/thread-structs.lisp +++ b/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)) diff --git a/src/code/thread.lisp b/src/code/thread.lisp index 4f571eed6..e19b51085 100644 --- a/src/code/thread.lisp +++ b/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 (dynamic-extent function)) + (declare (function function) (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) diff --git a/src/cold/compile-cold-sbcl.lisp b/src/cold/compile-cold-sbcl.lisp index fd4487a64..2a0bbd8d3 100644 --- a/src/cold/compile-cold-sbcl.lisp +++ b/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." diff --git a/src/cold/exports.lisp b/src/cold/exports.lisp index c8e1307a9..4e80cb998 100644 --- a/src/cold/exports.lisp +++ b/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" diff --git a/src/cold/shared.lisp b/src/cold/shared.lisp index 773d36115..1c67580be 100644 --- a/src/cold/shared.lisp +++ b/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 diff --git a/src/cold/warm.lisp b/src/cold/warm.lisp index 446d19472..2e6d0379d 100644 --- a/src/cold/warm.lisp +++ b/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) diff --git a/src/compiler/assem.lisp b/src/compiler/assem.lisp index a8edddd96..480ec509b 100644 --- a/src/compiler/assem.lisp +++ b/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) - (princ it stream) - (write-char #\space stream)) - (princ (stmt-mnemonic stmt) stream))) + (format t stream "~@[~A ~]~A ~:S" + (stmt-labels stmt) + (stmt-mnemonic stmt) + (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))) - (do ((stmt (section-start section) (stmt-next stmt))) - ((null stmt)) - (dolist (label (ensure-list (stmt-labels stmt))) - (aver (not (gethash label label->stmt))) - (setf (gethash label label->stmt) stmt))) - (perform-jump-to-jump-elimination (section-start section) label->stmt))) + (let ((label->stmt (make-hash-table)) + (elsewhere-labels (alloc-xset))) + (dolist (section `((nil . ,code-section) + (t . ,elsewhere-section))) + (do ((stmt (section-start (cdr section)) (stmt-next stmt))) + ((null 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) diff --git a/src/compiler/codegen.lisp b/src/compiler/codegen.lisp index dfbdd94c3..58459a5da 100644 --- a/src/compiler/codegen.lisp +++ b/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)) diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index c45305236..d89d82b0c 100644 --- a/src/compiler/fndb.lisp +++ b/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 diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index d836d8607..2b40688a6 100644 --- a/src/compiler/generic/genesis.lisp +++ b/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 ~%") (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 () diff --git a/src/compiler/generic/objdef.lisp b/src/compiler/generic/objdef.lisp index 3e794bd6b..c1189096f 100644 --- a/src/compiler/generic/objdef.lisp +++ b/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) diff --git a/src/compiler/generic/parms.lisp b/src/compiler/generic/parms.lisp index 032551d30..9ae8ccf51 100644 --- a/src/compiler/generic/parms.lisp +++ b/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 - #+(and x86-64 (not sb-safepoint)) 16 - #+(and (not x86-64) immobile-space) 14 ; the safepoint trap page is at word index -15 - #+(and (not x86-64) (not immobile-space)) 0) + #+x86-64 (or #+(or sb-safepoint yieldpoints) 14 ; the safepoint trap page is at word index -15 + 16) + #-x86-64 (or #+immobile-space 14 ; the safepoint trap page is at word index -15 + 0)) (progn (defconstant +highest-normal-generation+ 5) diff --git a/src/compiler/generic/utils.lisp b/src/compiler/generic/utils.lisp index b2b79e3fc..53b74431d 100644 --- a/src/compiler/generic/utils.lisp +++ b/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 diff --git a/src/compiler/generic/vm-fndb.lisp b/src/compiler/generic/vm-fndb.lisp index 3cad0b0e2..02e5f506a 100644 --- a/src/compiler/generic/vm-fndb.lisp +++ b/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 () diff --git a/src/compiler/ir2opt.lisp b/src/compiler/ir2opt.lisp index 8f4c1b4ac..ed898f445 100644 --- a/src/compiler/ir2opt.lisp +++ b/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)) diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 49db2d69e..afa529a65 100644 --- a/src/compiler/ir2tran.lisp +++ b/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 diff --git a/src/compiler/policies.lisp b/src/compiler/policies.lisp index 1068f464f..f51b30bf6 100644 --- a/src/compiler/policies.lisp +++ b/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") diff --git a/src/compiler/pseudo-vops.lisp b/src/compiler/pseudo-vops.lisp index 0dba9cfec..cd3645400 100644 --- a/src/compiler/pseudo-vops.lisp +++ b/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) diff --git a/src/compiler/x86-64/alloc.lisp b/src/compiler/x86-64/alloc.lisp index 04e8b0460..0df017a08 100644 --- a/src/compiler/x86-64/alloc.lisp +++ b/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) - (:generator 1 (emit-end-pseudo-atomic))) +(define-vop (sb-c::end-allocation) + (: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) - :elide-if stack-allocate-p :thread-tn thread-tn) + (with-allocator (:default-exit (not remain-pseudo-atomic) + :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) - :elide-if stack-allocate-p :thread-tn thread-tn) + (with-allocator (:default-exit (not remain-pseudo-atomic) + :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) - :thread-tn thread-tn) + (with-allocator (:default-exit (not remain-pseudo-atomic) + :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 diff --git a/src/compiler/x86-64/array.lisp b/src/compiler/x86-64/array.lisp index 0ec0be70e..18b9a6af1 100644 --- a/src/compiler/x86-64/array.lisp +++ b/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)))) diff --git a/src/compiler/x86-64/c-call.lisp b/src/compiler/x86-64/c-call.lisp index dca6e23f4..6308ec91d 100644 --- a/src/compiler/x86-64/c-call.lisp +++ b/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))) - (inst call (if (tn-p fun) + (let ((operand + (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 diff --git a/src/compiler/x86-64/call.lisp b/src/compiler/x86-64/call.lisp index 77e10cda1..27d34fa42 100644 --- a/src/compiler/x86-64/call.lisp +++ b/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) diff --git a/src/compiler/x86-64/cell.lisp b/src/compiler/x86-64/cell.lisp index 09807e6cb..07841191d 100644 --- a/src/compiler/x86-64/cell.lisp +++ b/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))) - (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))) + (invoke-asm-routine 'call 'mutex-unlock-if-held vop)) (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) - instance-pointer-lowtag) instance) + (inst xchg operand-size + (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 diff --git a/src/compiler/x86-64/insts.lisp b/src/compiler/x86-64/insts.lisp index 05f45e466..1b556e4bc 100644 --- a/src/compiler/x86-64/insts.lisp +++ b/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 -;;; 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) +(defun sb-assem::perform-jump-to-jump-elimination (starting-stmt label->stmt-map elsewhere-labels) (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)) diff --git a/src/compiler/x86-64/macros.lisp b/src/compiler/x86-64/macros.lisp index 19be921dc..dcbf57e8e 100644 --- a/src/compiler/x86-64/macros.lisp +++ b/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. - ;; Also, it would be good to emit only the last of consecutive safepoints in - ;; 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))) + #+yieldpoints (inst yieldpoint :lisp) + #+sb-safepoint (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)) diff --git a/src/compiler/x86-64/parms.lisp b/src/compiler/x86-64/parms.lisp index c429f56c5..95ee1c44e 100644 --- a/src/compiler/x86-64/parms.lisp +++ b/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))) diff --git a/src/compiler/x86-64/system.lisp b/src/compiler/x86-64/system.lisp index a80bd57b2..4d9da454a 100644 --- a/src/compiler/x86-64/system.lisp +++ b/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) + ))) diff --git a/src/compiler/x86-64/target-insts.lisp b/src/compiler/x86-64/target-insts.lisp index 6648f2406..d8c6e08f9 100644 --- a/src/compiler/x86-64/target-insts.lisp +++ b/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)) diff --git a/src/compiler/x86-64/vm.lisp b/src/compiler/x86-64/vm.lisp index 70f070c2c..a39f11799 100644 --- a/src/compiler/x86-64/vm.lisp +++ b/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 ;; diff --git a/src/runtime/GNUmakefile b/src/runtime/GNUmakefile index 15e12a995..589c7f777 100644 --- a/src/runtime/GNUmakefile +++ b/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 diff --git a/src/runtime/alloc.c b/src/runtime/alloc.c index 4f98c4d36..93d42a8e1 100644 --- a/src/runtime/alloc.c +++ b/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() -// each receive the size an a single-bit flag affecting locality of the result. +/* 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. + * 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, \ - sys ? &self->sys_##TLAB##_tlab : THREAD_ALLOC_REGION(self,TLAB), \ - nbytes, page_type, self); } + struct alloc_region* tlab \ + = sys ? &self->sys_##TLAB##_tlab : THREAD_ALLOC_REGION(self,TLAB); \ + struct alloc_region region = alloc_cooperate_before(tlab, self); \ + lispobj* res = lisp_alloc(largep | sys, ®ion, nbytes, page_type, self); \ + alloc_cooperate_after(tlab, ®ion, 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, ®ion, 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, ®ion, 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, ®ion, 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, ®ion, self); return result; } #else diff --git a/src/runtime/breakpoint.c b/src/runtime/breakpoint.c index d1df31943..b40adf506 100644 --- a/src/runtime/breakpoint.c +++ b/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 diff --git a/src/runtime/gc-common.c b/src/runtime/gc-common.c index 532a61a02..9bc43769c 100644 --- a/src/runtime/gc-common.c +++ b/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 diff --git a/src/runtime/gc.h b/src/runtime/gc.h index 5fdc215c2..86c9187b9 100644 --- a/src/runtime/gc.h +++ b/src/runtime/gc.h @@ -23,10 +23,6 @@ #include #include -#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 diff --git a/src/runtime/gencgc-alloc-region.h b/src/runtime/gencgc-alloc-region.h index b2e94ae08..6ec6c7871 100644 --- a/src/runtime/gencgc-alloc-region.h +++ b/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; } diff --git a/src/runtime/gencgc.c b/src/runtime/gencgc.c index 1637d94e4..e31027c4b 100644 --- a/src/runtime/gencgc.c +++ b/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; - switch (page_type) { - case PAGE_TYPE_MIXED: - if ((hint = thread_extra_data(th)->mixed_page_hint) > 0 && hint <= global_start) { - thread_extra_data(th)->mixed_page_hint = - 1; - return hint; + struct thread* th = get_sb_vm_thread(); + if (th) { + page_index_t hint; + switch (page_type) { + case PAGE_TYPE_MIXED: + 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)", - th, fixnum_value(read_TLS(FREE_INTERRUPT_CONTEXT_INDEX,th)), + if (th->control_stack_pointer != 0) esp = th->control_stack_pointer; + /* 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 - gc_assert(page_table[pg].type != PAGE_TYPE_CONS); + if (state->object_header) { // is not a 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])) diff --git a/src/runtime/immobile-space.c b/src/runtime/immobile-space.c index 95d6acee7..b4bb3f74e 100644 --- a/src/runtime/immobile-space.c +++ b/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"); } } diff --git a/src/runtime/interrupt.c b/src/runtime/interrupt.c index 856c20e6d..9c6476ede 100644 --- a/src/runtime/interrupt.c +++ b/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 -static void +#ifdef LISP_FEATURE_UNIX +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. */ diff --git a/src/runtime/interrupt.h b/src/runtime/interrupt.h index f25ef9d75..b3d4bb3c8 100644 --- a/src/runtime/interrupt.h +++ b/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 diff --git a/src/runtime/linux-os.c b/src/runtime/linux-os.c index eef476bf0..f7ee7afbb 100644 --- a/src/runtime/linux-os.c +++ b/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); } } diff --git a/src/runtime/monitor.c b/src/runtime/monitor.c index ff2d84a87..88c069942 100644 --- a/src/runtime/monitor.c +++ b/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 #include #include "core.h" diff --git a/src/runtime/runtime.c b/src/runtime/runtime.c index 274687c8f..02f720d66 100644 --- a/src/runtime/runtime.c +++ b/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 diff --git a/src/runtime/thread.c b/src/runtime/thread.c index 10b39a8de..6350c3e73 100644 --- a/src/runtime/thread.c +++ b/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 | | - * | | STACK | STACK | STACK | PAGE | structure | altstack | + * | | CONTROL | BINDING | ALIEN | Trap | thread | | + * | | 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 + - BINDING_STACK_SIZE + ALIEN_STACK_SIZE; + char* yieldpoint_page = aligned_spaces + thread_control_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; - thread_interrupt_data(th).gc_blocked_deferrables = 0; -#if HAVE_ALLOCATION_TRAP_CONTEXT - thread_interrupt_data(th).allocation_trap_context = 0; -#endif + memset(&thread_interrupt_data(th), 0, sizeof (struct interrupt_data)); #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 diff --git a/src/runtime/thread.h b/src/runtime/thread.h index 003860dda..1c1569944 100644 --- a/src/runtime/thread.h +++ b/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 -# define THREAD_CSP_PAGE_SIZE 0 +#if defined LISP_FEATURE_SB_SAFEPOINT || defined LISP_FEATURE_YIELDPOINTS +# 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 diff --git a/src/runtime/tiny-lock.h b/src/runtime/tiny-lock.h index 5fa152ed7..b215b3799 100644 --- a/src/runtime/tiny-lock.h +++ b/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 } diff --git a/src/runtime/x86-64-arch.c b/src/runtime/x86-64-arch.c index a8008fd62..ca00230b0 100644 --- a/src/runtime/x86-64-arch.c +++ b/src/runtime/x86-64-arch.c @@ -14,6 +14,7 @@ #include #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); + } + } +} + diff --git a/src/runtime/x86-64-assem.S b/src/runtime/x86-64-assem.S index 097a86cb2..f65302441 100644 --- a/src/runtime/x86-64-assem.S +++ b/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 diff --git a/src/runtime/yieldpoints.c b/src/runtime/yieldpoints.c new file mode 100644 index 000000000..d758bb351 --- /dev/null +++ b/src/runtime/yieldpoints.c @@ -0,0 +1,760 @@ +#define _GNU_SOURCE // for pthread_setname_np +#include +#include +#include +#include // INT_MAX +#include +#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 +#include +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;istate_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); + } +} diff --git a/tests/run-tests.lisp b/tests/run-tests.lisp index 29fba5266..cda9b5763 100644 --- a/tests/run-tests.lisp +++ b/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* diff --git a/tools-for-build/grovel-headers.c b/tools-for-build/grovel-headers.c index 9c0c555d0..2fde9a65a 100644 --- a/tools-for-build/grovel-headers.c +++ b/tools-for-build/grovel-headers.c @@ -55,6 +55,9 @@ #include #include #include +#ifdef LISP_FEATURE_YIELDPOINTS +#include // probably already included via signal.h +#endif #ifdef LISP_FEATURE_BSD #include @@ -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);