mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
New yieldpoints for SBCL25 dev meeting
Add "--with-yieldpoints --with-ultrafutex" to test-drive this patch.
This commit is contained in:
Douglas Katzman
parent
c111da51e1
commit
a1fcc8b129
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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))))))
|
||||
|
|
|
|||
|
|
@ -510,11 +510,11 @@ See also: RETURN-FROM-THREAD and SB-EXT:EXIT."
|
|||
|
||||
(define-alien-routine "futex_wake" int (word-addr unsigned) (n unsigned-long))
|
||||
|
||||
(defun futex-wait (word-addr oldval to-sec to-usec)
|
||||
(with-alien ((%wait (function int unsigned
|
||||
(unsigned 32)
|
||||
long unsigned-long)
|
||||
(with-alien ((%wait (function int unsigned (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
|
||||
#+(and sb-thread (not sb-futex))
|
||||
(with-cas-lock ((waitqueue-%owner queue))
|
||||
(%waitqueue-wakeup queue n)))))
|
||||
(%waitqueue-wakeup queue n)))
|
||||
|
||||
|
||||
(declaim (ftype (sfunction (waitqueue) null) condition-broadcast))
|
||||
|
|
@ -1885,6 +1878,10 @@ session."
|
|||
(prot "protect_alien_stack_guard_page")))
|
||||
(unless (= (sap-int thread-sap) 0) thread-sap))))
|
||||
|
||||
(sb-ext:defglobal *lisp-yps-executed* 0)
|
||||
(sb-ext:defglobal *c-yps-executed* 0)
|
||||
(declaim (fixnum *lisp-yps-executed* *c-yps-executed*))
|
||||
|
||||
;;; Remove thread from its session, if it has one, and from *all-threads*.
|
||||
;;; Also clobber the pointer to the primitive thread
|
||||
;;; which makes THREAD-ALIVE-P return false hereafter.
|
||||
|
|
@ -1925,7 +1922,9 @@ session."
|
|||
(setf (sap-ref-8 (current-thread-sap) ; state_word.sprof_enable
|
||||
(1+ (ash sb-vm:thread-state-word-slot sb-vm:word-shift)))
|
||||
0)
|
||||
;; Take ownership of our statistical profiling data and transfer the results to
|
||||
(sb-ext:atomic-incf *lisp-yps-executed* (sb-sys:sap-int (sb-vm::current-thread-offset-sap sb-vm::thread-lisp-yps-executed-slot)))
|
||||
(sb-ext:atomic-incf *c-yps-executed* (sb-sys:sap-int (sb-vm::current-thread-offset-sap sb-vm::thread-c-yps-executed-slot)))
|
||||
;; take ownership of our statistical profiling data and transfer the results to
|
||||
;; the global pool. This doesn't need to synchronize with the signal handler,
|
||||
;; which is effectively disabled now, but does synchronize via the interruptions
|
||||
;; mutex with any other thread trying to read this thread's data.
|
||||
|
|
@ -2062,6 +2061,7 @@ session."
|
|||
0)
|
||||
) ; end PROGN for #+sb-thread
|
||||
|
||||
(sb-ext:defglobal *anon-thread-name-generator* 0)
|
||||
(defun make-thread (function &key name arguments)
|
||||
"Create a new thread of NAME that runs FUNCTION with the argument
|
||||
list designator provided (defaults to no argument). Thread exits when
|
||||
|
|
@ -2075,7 +2075,10 @@ See also: RETURN-FROM-THREAD, ABORT-THREAD."
|
|||
#-sb-thread (declare (ignore function name arguments))
|
||||
#-sb-thread (error "Not supported in unithread builds.")
|
||||
#+sb-thread
|
||||
(let ((name (when name (possibly-base-stringize name))))
|
||||
(let ((name (if name
|
||||
(possibly-base-stringize name)
|
||||
(with-system-mutex (*make-thread-lock*)
|
||||
(format nil "Thr~D" (incf *anon-thread-name-generator*))))))
|
||||
(assert (or (atom arguments) (null (cdr (last arguments))))
|
||||
(arguments)
|
||||
"Argument passed to ~S, ~S, is an improper list."
|
||||
|
|
@ -2399,6 +2402,11 @@ Short version: be careful out there."
|
|||
;; the behavior is undefined."
|
||||
;; so we use the death lock to keep the thread alive, unless it already isn't.
|
||||
;;
|
||||
(let ((str (let ((*print-pretty* nil))
|
||||
(format nil "~s interrupts ~S with ~s~%"
|
||||
(thread-name *current-thread*) (thread-name thread) function))))
|
||||
(with-pinned-objects (str)
|
||||
(sb-unix:unix-write 2 str 0 (length str))))
|
||||
(when (with-deathlok (thread c-thread)
|
||||
;; Return T if couldn't interrupt.
|
||||
(cond ((eql c-thread 0) t)
|
||||
|
|
@ -2647,14 +2655,12 @@ mechanism for inter-thread communication."
|
|||
|
||||
;;;; Stepping
|
||||
|
||||
(defun thread-stepping ()
|
||||
(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
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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."
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
(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)))
|
||||
(setf (gethash label label->stmt) stmt)))
|
||||
(perform-jump-to-jump-elimination (section-start section) 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)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -3044,6 +3044,9 @@ Legal values for OFFSET are -4, -8, -12, ..."
|
|||
(dolist (target-feature-name (sort (mapcar #'c-symbol-name sb-xc:*features*)
|
||||
#'string<))
|
||||
(format t "#define LISP_FEATURE_~A~%" target-feature-name))
|
||||
;; A random one derived from sb-xc:*features* but not spelled in the usual way,
|
||||
;; and to easy to accidentaly fail to define if used in multiple files.
|
||||
#+(and sb-thread gc-stw-signal) (format t "#define THREADS_USING_GCSIGNAL~%")
|
||||
(terpri)
|
||||
;; and miscellaneous constants
|
||||
(format t "#define SBCL_TARGET_ARCHITECTURE_STRING ~S~%"
|
||||
|
|
@ -3376,6 +3379,7 @@ lispobj symbol_package(struct symbol*);~%" (genesis-header-prefix))
|
|||
;; but it gets cast to HANDLE upon use.
|
||||
#+(and unix sb-thread) (format t "#include <pthread.h>~%")
|
||||
(format t "#include ~S
|
||||
#include ~S
|
||||
|
||||
#define N_HISTOGRAM_BINS_LARGE 32
|
||||
#define N_HISTOGRAM_BINS_SMALL 32
|
||||
|
|
@ -3395,6 +3399,7 @@ struct thread_state_word {
|
|||
;; autogenerated files can use full paths to other inclusions
|
||||
;; (in case your build system disfavors use of -I compiler options)
|
||||
(namestring (merge-pathnames "gencgc-alloc-region.h" (lispobj-dot-h)))
|
||||
(namestring (merge-pathnames "tiny-lock.h" (lispobj-dot-h)))
|
||||
#+64-bit " char padding[4];" #-64-bit ""))
|
||||
|
||||
(defun write-weak-pointer-manipulators ()
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -142,7 +142,6 @@ debugger.")
|
|||
1
|
||||
("no" "no" "yes" "yes"))
|
||||
|
||||
#+sb-safepoint
|
||||
(define-optimization-quality insert-safepoints
|
||||
1
|
||||
("no" "yes" "yes" "yes")
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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,9 +958,10 @@
|
|||
(header (logior (ash (1- words) n-widetag-bits) closure-widetag))
|
||||
(remain-pseudo-atomic
|
||||
(eq (car (last (vop-codegen-info vop))) :pseudo-atomic)))
|
||||
(declare (ignorable remain-pseudo-atomic))
|
||||
(unless stack-allocate-p
|
||||
(instrument-alloc closure-widetag bytes node (list result temp) thread-tn))
|
||||
(pseudo-atomic (:default-exit (not remain-pseudo-atomic)
|
||||
(with-allocator (:default-exit (not remain-pseudo-atomic)
|
||||
:elide-if stack-allocate-p :thread-tn thread-tn)
|
||||
(if stack-allocate-p
|
||||
(stack-allocation bytes fun-pointer-lowtag result stack-allocate-p)
|
||||
|
|
@ -1030,12 +1032,13 @@
|
|||
&aux (bytes (pad-data-block words))
|
||||
(remain-pseudo-atomic
|
||||
(eq (car (last (vop-codegen-info vop))) :pseudo-atomic)))
|
||||
(declare (ignorable remain-pseudo-atomic))
|
||||
#+bignum-assertions
|
||||
(when (eq type bignum-widetag) (setq bytes (* bytes 2))) ; use 2x the space
|
||||
(progn name) ; possibly not used
|
||||
(unless stack-allocate-p
|
||||
(instrument-alloc type bytes node (list result alloc-temp) thread-tn))
|
||||
(pseudo-atomic (:default-exit (not remain-pseudo-atomic)
|
||||
(with-allocator (:default-exit (not remain-pseudo-atomic)
|
||||
:elide-if stack-allocate-p :thread-tn thread-tn)
|
||||
;; If storing a header word, defer ORing in the lowtag until after
|
||||
;; the header is written so that displacement can be 0.
|
||||
|
|
@ -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,7 +1131,7 @@
|
|||
;; because it might be in the same physical reg as BYTES.
|
||||
;; Yup, the lifetime specs in this vop are pretty confusing.
|
||||
(instrument-alloc type bytes node alloc-temp thread-tn)
|
||||
(pseudo-atomic (:default-exit (not remain-pseudo-atomic)
|
||||
(with-allocator (:default-exit (not remain-pseudo-atomic)
|
||||
:thread-tn thread-tn)
|
||||
(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
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
)))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
;;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -23,10 +23,6 @@
|
|||
#include <stdint.h>
|
||||
#include <string.h>
|
||||
|
||||
#if defined LISP_FEATURE_SB_THREAD && !defined LISP_FEATURE_SB_SAFEPOINT
|
||||
# define THREADS_USING_GCSIGNAL 1
|
||||
#endif
|
||||
|
||||
#if defined LISP_FEATURE_GENERATIONAL && !defined LISP_FEATURE_C_STACK_IS_CONTROL_STACK
|
||||
# define GENCGC_IS_PRECISE 1
|
||||
#else
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -324,8 +324,9 @@ 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];
|
||||
struct thread* th = get_sb_vm_thread();
|
||||
if (th) {
|
||||
page_index_t hint;
|
||||
switch (page_type) {
|
||||
case PAGE_TYPE_MIXED:
|
||||
|
|
@ -341,6 +342,7 @@ get_alloc_start_page(unsigned int page_type)
|
|||
}
|
||||
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]))
|
||||
|
|
|
|||
|
|
@ -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");
|
||||
}
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -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. */
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1081,6 +1081,25 @@ ldb_monitor(void)
|
|||
#ifdef STANDALONE_LDB
|
||||
void gc_stop_the_world() { } // do nothing
|
||||
void gc_start_the_world() { } // do nothing
|
||||
void defer_until_yieldpoint() { }
|
||||
void sigtrap_handler() { }
|
||||
void set_gc_pending() { }
|
||||
void safepoint_init() { }
|
||||
void request_garbage_collection(int) { }
|
||||
void cooperate_with_gc(struct thread* th) { lose("cooperate_with_gc %p ?", th); }
|
||||
int handle_safepoint_violation(__attribute__((unused)) os_context_t *context,
|
||||
__attribute__((unused)) os_vm_address_t addr) { return 0; }
|
||||
struct alloc_region alloc_cooperate_before(__attribute__((unused)) struct alloc_region*,
|
||||
__attribute__((unused)) struct thread*) {
|
||||
struct alloc_region r;
|
||||
memset(&r, 0, sizeof r);
|
||||
return r;
|
||||
}
|
||||
void alloc_cooperate_after(__attribute__((unused)) struct alloc_region*dst,
|
||||
__attribute__((unused)) struct alloc_region*src,
|
||||
__attribute__((unused)) struct thread* th) { }
|
||||
void maybe_suspend_for_gc(__attribute__((unused)) struct thread* th) { }
|
||||
|
||||
#include <errno.h>
|
||||
#include <setjmp.h>
|
||||
#include "core.h"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 +
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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,8 +332,12 @@ 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
|
||||
// Put in an empty conversion to avoid warning at the point of use:
|
||||
|
|
|
|||
|
|
@ -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 }
|
||||
|
|
|
|||
|
|
@ -14,6 +14,7 @@
|
|||
#include <stdio.h>
|
||||
|
||||
#include "genesis/sbcl.h"
|
||||
#include "genesis/hash-table.h"
|
||||
#include "runtime.h"
|
||||
#include "globals.h"
|
||||
#include "validate.h"
|
||||
|
|
@ -364,7 +365,7 @@ restore_breakpoint_from_single_step(os_context_t * context)
|
|||
return;
|
||||
}
|
||||
|
||||
void
|
||||
static void
|
||||
sigtrap_handler(int __attribute__((unused)) signal,
|
||||
siginfo_t __attribute__((unused)) *info,
|
||||
os_context_t *context)
|
||||
|
|
@ -501,6 +502,7 @@ arch_install_interrupt_handlers()
|
|||
* CL way, I hope there will at least be a comment to explain
|
||||
* why.. -- WHN 2001-06-07 */
|
||||
#ifndef LISP_FEATURE_WIN32
|
||||
extern void sigtrap_handler();
|
||||
ll_install_handler(SIGILL , sigill_handler);
|
||||
ll_install_handler(SIGTRAP, sigtrap_handler);
|
||||
#endif
|
||||
|
|
@ -787,3 +789,36 @@ lispobj call_into_lisp_first_time(lispobj fun, lispobj *args, int nargs) {
|
|||
}
|
||||
|
||||
#include "x86-arch-shared.inc"
|
||||
|
||||
void yieldpoint_patch_asm_routines(int flag)
|
||||
{
|
||||
struct code* code = (struct code*)asm_routines_start;
|
||||
#ifdef LISP_FEATURE_DARWIN_JIT
|
||||
lispobj ht = CONS(code->debug_info)->car;
|
||||
#else
|
||||
lispobj ht = code->debug_info;
|
||||
#endif
|
||||
struct vector* table =
|
||||
VECTOR(((struct hash_table*)native_pointer(ht))->pairs);
|
||||
int i;
|
||||
uint32_t nop = 0x00401F0F; // really [0F 1F 40 00]
|
||||
uint32_t yp = 0x806D8545; // really [45 85 6D 80]
|
||||
uint32_t old = nop;
|
||||
uint32_t new = yp;
|
||||
if (!flag) { // deinstall them
|
||||
old = yp;
|
||||
new = nop;
|
||||
}
|
||||
for (i=2 ; i < vector_len(table) ; i += 2) {
|
||||
lispobj value = table->data[i+1];
|
||||
if (listp(value)) {
|
||||
// value = (start-address . (end-address . index))
|
||||
char* entrypoint
|
||||
= code_text_start(code) + fixnum_value(CONS(value)->car);
|
||||
uint32_t* pdword = (uint32_t*)entrypoint;
|
||||
if (*pdword == old)
|
||||
__sync_bool_compare_and_swap(pdword, old, new);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
760
src/runtime/yieldpoints.c
Normal file
760
src/runtime/yieldpoints.c
Normal file
|
|
@ -0,0 +1,760 @@
|
|||
#define _GNU_SOURCE // for pthread_setname_np
|
||||
#include <pthread.h>
|
||||
#include <signal.h>
|
||||
#include <stdio.h>
|
||||
#include <limits.h> // INT_MAX
|
||||
#include <errno.h>
|
||||
#include "thread.h"
|
||||
#include "interr.h"
|
||||
#include "gc-assert.h"
|
||||
#include "core.h"
|
||||
#include "atomiclog.inc"
|
||||
|
||||
typedef enum { SUSPEND=1, ASYNC_SIGNAL=2 } yield_reason;
|
||||
|
||||
static int debug = 0;
|
||||
|
||||
typedef enum { UNKNOWN, IN_LISP, LISP_TO_C, C_TO_LISP } yieldpoint_kind;
|
||||
int yp_kind_hit[4];
|
||||
|
||||
static __thread char threadname[20];
|
||||
char *pthreadname(struct thread* th) {
|
||||
pthread_getname_np(th->os_thread, threadname, 20);
|
||||
//sprintf(threadname, "%p", th);
|
||||
return threadname;
|
||||
}
|
||||
|
||||
char *thread_yieldpoint_trap_page_base(struct thread*th ) {
|
||||
return (char*)th - THREAD_HEADER_SLOTS*N_WORD_BYTES - THREAD_YIELDPOINT_PAGE_SIZE;
|
||||
}
|
||||
typedef enum { READ_WRITE, READ_ONLY, NO_ACCESS } yieldpoint_page_acc;
|
||||
void yieldpoint_trap_toggle(struct thread* th,
|
||||
yieldpoint_page_acc access)
|
||||
{
|
||||
int prot_mode[3] = { OS_VM_PROT_ALL, PROT_READ, PROT_NONE };
|
||||
char* page_base = thread_yieldpoint_trap_page_base(th);
|
||||
// fprintf(stderr, "YP page protect: %d @ %p\n", THREAD_YIELDPOINT_PAGE_SIZE, page_base);
|
||||
mprotect(page_base, THREAD_YIELDPOINT_PAGE_SIZE, prot_mode[access]);
|
||||
th->yieldpoint_page_access = access;
|
||||
}
|
||||
|
||||
#define INITIATE_GC 0x100
|
||||
#define GC_CONTROLLER_QUIT 0x200
|
||||
|
||||
extern pthread_rwlock_t all_threads_lock;
|
||||
pthread_mutex_t gc_condition_lock = PTHREAD_MUTEX_INITIALIZER;
|
||||
pthread_cond_t gc_controller_cond = PTHREAD_COND_INITIALIZER;
|
||||
pthread_cond_t gc_completion_cond = PTHREAD_COND_INITIALIZER;
|
||||
pthread_t gc_controller;
|
||||
pthread_t rdb_thread;
|
||||
int gc_notification_reason;
|
||||
os_sem_t gc_sync_sem;
|
||||
long gc_cycle_count;
|
||||
|
||||
static lispobj* yieldpoint_trap_addr(struct thread* th) {
|
||||
return (lispobj*)((char*)th - 128);
|
||||
}
|
||||
static lispobj get_stackptr_at_foreign_call(struct thread* th) {
|
||||
return *yieldpoint_trap_addr(th);
|
||||
}
|
||||
static void clear_stackptr_at_foreign_call(struct thread* th) {
|
||||
*yieldpoint_trap_addr(th) = 0;
|
||||
}
|
||||
void gc_inhibitor_control(int flag) {
|
||||
if (flag)
|
||||
pthread_rwlock_rdlock(&all_threads_lock);
|
||||
else
|
||||
pthread_rwlock_unlock(&all_threads_lock);
|
||||
}
|
||||
|
||||
extern int futex_wait(int*, int, long, unsigned long);
|
||||
extern int futex_wake(int*, int);
|
||||
// FIXME: uint32_t as per https://man7.org/linux/man-pages/man2/futex.2.html
|
||||
// but our os.c files all use 'int'
|
||||
static int32_t world_is_stopped;
|
||||
|
||||
static void force_tlab_slowpath(struct alloc_region* r, lispobj* spill)
|
||||
{
|
||||
void* real_end = __sync_fetch_and_or(&r->end_addr, 0);
|
||||
/* By stuffing in 0 for 'end' the thread's allocator will fail its next comparison
|
||||
* against the TLAB limit, reverting to the slow path allocator, at which point it
|
||||
* observes the stop request. The only synchronization needed with the mutator
|
||||
* is to ensure we've got an up-to-date copy of the actual end before clobbering it */
|
||||
while (1) {
|
||||
*spill = (lispobj)real_end;
|
||||
if (real_end == REGION_END_EMPTY_VALUE) break;
|
||||
void* oldval = __sync_val_compare_and_swap(&r->end_addr, real_end, 0);
|
||||
if (oldval == real_end) break;
|
||||
real_end = oldval;
|
||||
}
|
||||
}
|
||||
static void restore_tlab(struct alloc_region* r, lispobj* spill)
|
||||
{
|
||||
if (r->end_addr == 0) {
|
||||
lispobj actual_end = *spill;
|
||||
gc_assert(actual_end != 0);
|
||||
r->end_addr = (void*)actual_end;
|
||||
}
|
||||
*spill = 0;
|
||||
}
|
||||
|
||||
#define TELNET_SERVER 1
|
||||
#if TELNET_SERVER
|
||||
#define MAXTHREADS 50
|
||||
static struct {
|
||||
struct thread* th;
|
||||
char in_foreign_code;
|
||||
char gc_waiting_on_spinlock;
|
||||
//char did_sem_post;
|
||||
} known_threads[MAXTHREADS];
|
||||
static int n_known_threads;
|
||||
static int sem_waits;
|
||||
static int get_n_currently_waiting_on() { return sem_waits; }
|
||||
#endif
|
||||
|
||||
// Acquire the locks in this order:
|
||||
// condition_lock, mutators lock, per-thread spinlock (one at a time)
|
||||
void gc_stop_the_world() {
|
||||
event0("begin stw");
|
||||
struct thread* me = get_sb_vm_thread();
|
||||
struct thread* th;
|
||||
/* The global "stopped" flag is set *before* doing anything else
|
||||
* because as we're arming the trap for each thread in turn, any thread
|
||||
* that hits a C-to-Lisp yieldpoint should block at the futex_wait call
|
||||
* as though the world is already stopped */
|
||||
world_is_stopped = 1;
|
||||
sem_waits = 0;
|
||||
// int sem_waits = 0;
|
||||
// TODO: for all threads _except_ the finalizer, stop them; then ask the finalizer
|
||||
// thread to run the pre-GC actions (clobber the hash-caches, etc) and stop itself.
|
||||
for_each_thread(th) {
|
||||
#if TELNET_SERVER
|
||||
int ti = n_known_threads++;
|
||||
if (ti > MAXTHREADS) lose("Too many cooks");
|
||||
known_threads[ti].th = th;
|
||||
#endif
|
||||
// Thread can't change its state to DEAD without acquiring the rwlock for reading
|
||||
// Therefore if non-dead, it will participate in stop-for-gc by waiting for a
|
||||
// stop-the-world trap, and it will respond with sem_post.
|
||||
if (th == me) continue;
|
||||
//
|
||||
known_threads[ti].gc_waiting_on_spinlock = 1;
|
||||
acquire_lock(&th->yieldpoint_spinlock);
|
||||
if (th->state_word.state == STATE_DEAD) {
|
||||
known_threads[ti].gc_waiting_on_spinlock = 0;
|
||||
release_lock(&th->yieldpoint_spinlock);
|
||||
continue;
|
||||
}
|
||||
// th->stepping.suspend = -1;
|
||||
if (debug) fprintf(stderr, "GC: will stop thread %p (%s)\n", th, pthreadname(th));
|
||||
__sync_fetch_and_or(&th->interrupt_reason, SUSPEND);
|
||||
force_tlab_slowpath(&th->cons_tlab, &th->spill_cons_tlab_end);
|
||||
force_tlab_slowpath(&th->sys_cons_tlab, &th->spill_sys_cons_tlab_end);
|
||||
force_tlab_slowpath(&th->mixed_tlab, &th->spill_mixed_tlab_end);
|
||||
force_tlab_slowpath(&th->sys_mixed_tlab, &th->spill_sys_mixed_tlab_end);
|
||||
yieldpoint_trap_toggle(th, READ_ONLY);
|
||||
lispobj stackptr = get_stackptr_at_foreign_call(th);
|
||||
yieldpoint_trap_toggle(th, NO_ACCESS);
|
||||
release_lock(&th->yieldpoint_spinlock);
|
||||
known_threads[ti].gc_waiting_on_spinlock = 0;
|
||||
event2("stopping %p, sp=%lx", th, stackptr);
|
||||
if (stackptr) {
|
||||
known_threads[ti].in_foreign_code = 1;
|
||||
/* Assume that the next instruction after a Lisp-to-C yieldpoint
|
||||
* is a call into C which pushes the return address on the stack.
|
||||
* This gets us the return PC "for free" relative to the #+sb-safepoint
|
||||
* technique which uses LEA [RIP+n] to compute and store the PC. */
|
||||
if ((lispobj*)stackptr - 1 >= th->control_stack_start)
|
||||
stackptr -= N_WORD_BYTES;
|
||||
gc_assert(stackptr >= (lispobj)th->control_stack_start &&
|
||||
stackptr < (lispobj)th->control_stack_end);
|
||||
th->control_stack_pointer = (lispobj*)stackptr;
|
||||
if (debug)
|
||||
fprintf(stderr, "thread %p stackptr = %p = end-%dw\n",
|
||||
th, th->control_stack_pointer,
|
||||
(int)(th->control_stack_end - th->control_stack_pointer));
|
||||
}
|
||||
if (stackptr == 0) ++sem_waits; // the thread is in Lisp
|
||||
}
|
||||
if (debug) fprintf(stderr, "GC: sem_wait for %d\n", sem_waits);
|
||||
event1("waiting on %d threads", sem_waits);
|
||||
// Wait for all threads executing Lisp (i.e. not foreign code) to stop
|
||||
while (sem_waits--) sem_wait(&gc_sync_sem);
|
||||
// Assert that every threads' stack pointer is known
|
||||
for_each_thread(th) {
|
||||
if (th->control_stack_pointer != 0 ||
|
||||
read_TLS(FREE_INTERRUPT_CONTEXT_INDEX, th)) {
|
||||
} else {
|
||||
lose("Thread %p context is unknown", th);
|
||||
}
|
||||
restore_tlab(&th->cons_tlab, &th->spill_cons_tlab_end);
|
||||
restore_tlab(&th->sys_cons_tlab, &th->spill_sys_cons_tlab_end);
|
||||
restore_tlab(&th->mixed_tlab, &th->spill_mixed_tlab_end);
|
||||
restore_tlab(&th->sys_mixed_tlab, &th->spill_sys_mixed_tlab_end);
|
||||
}
|
||||
n_known_threads = 0;
|
||||
memset(known_threads, 0, sizeof known_threads);
|
||||
}
|
||||
|
||||
void gc_start_the_world() {
|
||||
struct thread* th;
|
||||
for_each_thread(th) {
|
||||
th->control_stack_pointer = 0;
|
||||
__sync_fetch_and_and(&th->interrupt_reason, ~SUSPEND);
|
||||
//th->stepping.suspend = 0;
|
||||
}
|
||||
world_is_stopped = 0;
|
||||
futex_wake(&world_is_stopped, INT_MAX);
|
||||
if (debug) fprintf(stderr, "GC: world restarted\n");
|
||||
}
|
||||
|
||||
void show_yp_kind_hit() {
|
||||
fprintf(stderr, "YP hit: %d %d %d %d\n", yp_kind_hit[0], yp_kind_hit[1], yp_kind_hit[2], yp_kind_hit[3]);
|
||||
}
|
||||
|
||||
/*
|
||||
Finalizer thread should wake on any of the following events:
|
||||
- finalizer item queued
|
||||
- interrupt-thread action
|
||||
- other deferred async signal
|
||||
- post-gc hooks
|
||||
The first 3 are working, the last is not. I need a way to tell
|
||||
it to run the hooks */
|
||||
|
||||
extern int finalizer_thread_runflag;
|
||||
void finalizer_thread_wait () {
|
||||
/* pthread_cond_wait can never return EINTR which is what made
|
||||
* SB-THREAD:INTERRUPT-THREAD unreliable on the finalizer.
|
||||
* Direct use of a futex gives nicer behavior */
|
||||
int c = finalizer_thread_runflag;
|
||||
if (c) futex_wait(&finalizer_thread_runflag, c, -1, 0);
|
||||
|
||||
}
|
||||
void finalizer_thread_wake () {
|
||||
futex_wake(&finalizer_thread_runflag, 1);
|
||||
}
|
||||
void finalizer_thread_stop () {
|
||||
finalizer_thread_runflag = 0;
|
||||
futex_wake(&finalizer_thread_runflag, 1);
|
||||
}
|
||||
|
||||
extern void yieldpoint_patch_asm_routines(int);
|
||||
void* collector_main(__attribute__((unused)) void* dummy)
|
||||
{
|
||||
#ifdef LISP_FEATURE_LINUX
|
||||
pthread_setname_np(pthread_self(), "collectorMain");
|
||||
#endif
|
||||
pthread_mutex_lock(&gc_condition_lock);
|
||||
for (;;) {
|
||||
pthread_cond_wait(&gc_controller_cond, &gc_condition_lock);
|
||||
int reason = gc_notification_reason;
|
||||
if (reason & GC_CONTROLLER_QUIT) break;
|
||||
if (!(gc_notification_reason & INITIATE_GC)) continue; // sleep some more
|
||||
if (debug) fprintf(stderr, "GC main wants to run\n");
|
||||
/* One or more threads that we need to try to suspend might each be
|
||||
* trying to acquire the lock to signal a GC request, so never hold
|
||||
* the condition lock while trying to initiat a collection */
|
||||
pthread_mutex_unlock(&gc_condition_lock);
|
||||
/* No thread can die nor be created; and no thread can inhibit GC. */
|
||||
pthread_rwlock_wrlock(&all_threads_lock);
|
||||
// Patching is needed in order for threads to reach a yieldpoint quicker,
|
||||
// since asm routines have NOPs where yieldpoints should be.
|
||||
//yieldpoint_patch_asm_routines(1);
|
||||
gc_stop_the_world();
|
||||
int generation = gc_notification_reason & 7;
|
||||
extern void collect_garbage(generation_index_t);
|
||||
//show_yp_kind_hit();
|
||||
collect_garbage(generation);
|
||||
gc_notification_reason = 0;
|
||||
++gc_cycle_count;
|
||||
// TODO: enqueue a finalizer thread action to run post-GC hooks
|
||||
gc_start_the_world();
|
||||
pthread_rwlock_unlock(&all_threads_lock);
|
||||
finalizer_thread_wake();
|
||||
pthread_mutex_lock(&gc_condition_lock);
|
||||
// Manually requested GC should wait on this condition
|
||||
pthread_cond_broadcast(&gc_completion_cond);
|
||||
extern void empty_thread_recyclebin();
|
||||
empty_thread_recyclebin();
|
||||
// can be un-patched at any time
|
||||
//yieldpoint_patch_asm_routines(0);
|
||||
}
|
||||
pthread_mutex_unlock(&gc_condition_lock);
|
||||
return 0;
|
||||
}
|
||||
|
||||
#if TELNET_SERVER
|
||||
#include <sys/socket.h>
|
||||
#include <netinet/in.h>
|
||||
int listener;
|
||||
void* debugging_service_main(__attribute__((unused)) void* dummy)
|
||||
{
|
||||
#if 0
|
||||
{sigset_t mask;
|
||||
pthread_sigmask(SIG_SETMASK, 0, &mask);
|
||||
char buf[100]; sigset_tostring(&mask, buf, sizeof buf);
|
||||
printf("service thread has mask %s\n", buf);
|
||||
sigset_tostring(&deferrable_sigset, buf, sizeof buf);
|
||||
printf("deferrable is %s\n", buf);
|
||||
sigset_tostring(&blockable_sigset, buf, sizeof buf);
|
||||
printf("blockable is %s\n", buf);}
|
||||
#endif
|
||||
struct sockaddr_in sin;
|
||||
memset(&sin, 0, sizeof sin);
|
||||
sin.sin_addr.s_addr = INADDR_ANY;
|
||||
sin.sin_port = 0;
|
||||
listener = socket(AF_INET, SOCK_STREAM, 0);
|
||||
if (bind(listener, &sin, sizeof sin)) {perror("bind");exit(1);}
|
||||
if (listen(listener, 5)) {perror("listen");exit(1);}
|
||||
socklen_t addrlen = sizeof sin;
|
||||
if (getsockname(listener, &sin, &addrlen)) {perror("getsockname");exit(1);}
|
||||
char buf[64];
|
||||
int n = snprintf(buf, sizeof buf, "Pid %d listening on port %d\n", getpid(), ntohs(sin.sin_port));
|
||||
write(2, buf, n);
|
||||
int peer;
|
||||
FILE* stream = 0;
|
||||
while (1) {
|
||||
peer = accept(listener, &sin, &addrlen);
|
||||
if (peer < 0) lose("wtf?");
|
||||
stream = fdopen(peer, "w");
|
||||
setlinebuf(stream);
|
||||
fprintf(stream, "nthreads=%d waiting_on=%d\n", n_known_threads, get_n_currently_waiting_on());
|
||||
fprintf(stream, " pthread vm_thread tid State Lip/C spinlock_wait\n");
|
||||
{int i;for (i=0;i<n_known_threads;++i) {
|
||||
struct thread* th = known_threads[i].th;
|
||||
if (!th) {
|
||||
fprintf(stream, "%d: bad\n", i);
|
||||
} else {
|
||||
int sw = th->state_word.state;
|
||||
lispobj mutex = read_TLS(CURRENT_MUTEX, th);
|
||||
fprintf(stream, "%d: %lx %p %lx %s %s %d ",
|
||||
i, th->os_thread, th, th->os_kernel_tid,
|
||||
(sw==STATE_DEAD?"DEAD":sw==STATE_RUNNING?"RUN ":sw==STATE_STOPPED?"STOP":"????"),
|
||||
known_threads[i].in_foreign_code?"C ":"Lisp",
|
||||
known_threads[i].gc_waiting_on_spinlock);
|
||||
if (mutex != 0) {
|
||||
struct lispmutex* m = (void*)native_pointer(mutex);
|
||||
lispobj name = m->name;
|
||||
fprintf(stderr, "mutex=%lx (state=%lx owner=%lx name=%s)",
|
||||
mutex, m->uw_state, m->_owner,
|
||||
(other_pointer_p(name) && simple_base_string_p(name)) ? (char*)(name+1) : "?");
|
||||
}
|
||||
putc('\n', stderr);
|
||||
}
|
||||
}
|
||||
}
|
||||
while (1) {
|
||||
char line[80];
|
||||
write(peer, "> ", 2);
|
||||
int n = read(peer, line, sizeof line);
|
||||
if (n<=0){ fclose(stream); break; }
|
||||
printf("got n=%d command [%s]\n", n, line);
|
||||
char cmd = line[0];
|
||||
if (cmd == 'q') break;
|
||||
write(peer, "m'kay\n",6);
|
||||
}
|
||||
printf("remote debug service connected\n");
|
||||
close(peer);
|
||||
}
|
||||
}
|
||||
#endif
|
||||
|
||||
void safepoint_init() { // backward-compatible function name
|
||||
os_sem_init(&gc_sync_sem, 0);
|
||||
sigset_t oldmask;
|
||||
// Don't want SIGCHLD, SIGARLM, etc
|
||||
pthread_sigmask(SIG_BLOCK, &blockable_sigset, &oldmask);
|
||||
pthread_create(&gc_controller, NULL, collector_main, 0);
|
||||
if (debug) fprintf(stderr, "GC controller thread is %p\n", (void*)gc_controller);
|
||||
#ifdef TELNET_SERVER
|
||||
pthread_create(&rdb_thread, NULL, debugging_service_main, 0);
|
||||
pthread_setname_np(rdb_thread, "debug");
|
||||
#endif
|
||||
pthread_sigmask(SIG_SETMASK, &oldmask, 0);
|
||||
}
|
||||
|
||||
void request_garbage_collection(int generation)
|
||||
{
|
||||
if (generation == -1) { // auto-triggered request
|
||||
// a read barrier is not important here
|
||||
if (gc_notification_reason) return; // request already pending
|
||||
pthread_mutex_lock(&gc_condition_lock);
|
||||
gc_notification_reason |= INITIATE_GC;
|
||||
pthread_cond_broadcast(&gc_controller_cond);
|
||||
pthread_mutex_unlock(&gc_condition_lock);
|
||||
} else {
|
||||
pthread_mutex_lock(&gc_condition_lock);
|
||||
/* Take the higher of competing args to SB-EXT:GC if two user threads
|
||||
* nearly simultaneously invoke it */
|
||||
int pending = gc_notification_reason & 7;
|
||||
if (pending > generation) generation = pending;
|
||||
gc_notification_reason = INITIATE_GC | generation;
|
||||
long starting_count = gc_cycle_count;
|
||||
/* The Lisp side will deal with the case of explicitly requesting a collection
|
||||
* while inside without-gcing. That's kinda stupid and it's unclear why we would
|
||||
* want to support that, other than regression tests assert that it works */
|
||||
pthread_cond_broadcast(&gc_controller_cond);
|
||||
while (gc_cycle_count == starting_count)
|
||||
pthread_cond_wait(&gc_completion_cond, &gc_condition_lock);
|
||||
pthread_mutex_unlock(&gc_condition_lock);
|
||||
}
|
||||
}
|
||||
|
||||
extern void
|
||||
store_signal_data_for_later (struct interrupt_data *data, void *handler,
|
||||
int signal,
|
||||
siginfo_t *info, os_context_t *context);
|
||||
|
||||
/* Unlike maybe_now_maybe_later, this handler never handles a signal right away
|
||||
* but instead always defers it to a yieldpoint.
|
||||
* It would be neat if we could figure out which Lisp thread is in the foreground
|
||||
* so SIGINT could be directed correctly the first time instead of having to
|
||||
* potentially re-signal it in Lisp */
|
||||
void defer_to_yieldpoint(int sig, siginfo_t* info, void* context)
|
||||
{
|
||||
int _saved_errno = errno;
|
||||
struct thread* th = get_sb_vm_thread();
|
||||
store_signal_data_for_later(&thread_interrupt_data(th), (void*)1,
|
||||
sig, info, context);
|
||||
lispobj enabled = read_TLS(INTERRUPTS_ENABLED, th);
|
||||
#if 1
|
||||
{
|
||||
char b[100];
|
||||
int n = snprintf(b, sizeof b, "%s: Deferring: %s (pc=%lx) %s\n",
|
||||
pthreadname(th), strsignal(sig),
|
||||
os_context_pc(context),
|
||||
enabled==NIL?"DISABLED":enabled==LISP_T?"ENABLED":"?");
|
||||
|
||||
write(2,b,n);
|
||||
//libunwind_backtrace(th, context);
|
||||
}
|
||||
#endif
|
||||
if (enabled == NIL) {
|
||||
write_TLS(INTERRUPTS_ENABLED, 0, th); // 0 = "signal deferred"
|
||||
/* WITHOUT-INTERRUPTS will check whether a signal got deferred,
|
||||
* and will explicitly handle it without a yieldpoint trap */
|
||||
} else if (enabled == LISP_T) {
|
||||
/* If the lock is already taken, then either the GC controller is frobbing it,
|
||||
* or this thread itself is in alloc_cooperate. In either case we don't need
|
||||
* to arm the trap. The worst that happens is a deferred interrupt
|
||||
* gets handled a little later */
|
||||
__sync_fetch_and_or(&th->interrupt_reason, ASYNC_SIGNAL);
|
||||
if (try_acquire_lock(&th->yieldpoint_spinlock)) {
|
||||
yieldpoint_trap_toggle(th, NO_ACCESS);
|
||||
release_lock(&th->yieldpoint_spinlock);
|
||||
}
|
||||
} else {
|
||||
lose("Received async interrupt with enable neither T nor NIL");
|
||||
}
|
||||
errno = _saved_errno;
|
||||
}
|
||||
|
||||
static void publish_context(struct thread* thread, os_context_t* context)
|
||||
{
|
||||
/* Do dynamic binding of the active interrupt context index
|
||||
* and save the context in the context array. */
|
||||
int context_index =
|
||||
fixnum_value(read_TLS(FREE_INTERRUPT_CONTEXT_INDEX, thread));
|
||||
if (context_index >= MAX_INTERRUPTS)
|
||||
lose("maximum interrupt nesting depth (%d) exceeded", MAX_INTERRUPTS);
|
||||
|
||||
bind_variable(FREE_INTERRUPT_CONTEXT_INDEX, make_fixnum(context_index + 1), thread);
|
||||
nth_interrupt_context(context_index, thread) = context;
|
||||
}
|
||||
|
||||
static void unpublish_context(struct thread* thread)
|
||||
{
|
||||
// Never leave stale pointers in the signal context array
|
||||
int ici = fixnum_value(read_TLS(FREE_INTERRUPT_CONTEXT_INDEX,thread));
|
||||
nth_interrupt_context(ici - 1, thread) = NULL;
|
||||
/* Undo dynamic binding of FREE_INTERRUPT_CONTEXT_INDEX */
|
||||
unbind(thread);
|
||||
}
|
||||
|
||||
#if 0
|
||||
void sigtrap_handler(int __attribute__((unused)) signal,
|
||||
siginfo_t __attribute__((unused)) *info,
|
||||
os_context_t *context)
|
||||
{
|
||||
struct thread*th = get_sb_vm_thread();
|
||||
if (!th->stepping.suspend) lose("Why are you closed?");
|
||||
publish_context(th, context);
|
||||
sem_post(&gc_sync_sem);
|
||||
if (debug) {
|
||||
char buf[100];
|
||||
int n = snprintf(buf, sizeof buf, "%s: posted\n", pthreadname(th));
|
||||
write(2, buf, n);
|
||||
}
|
||||
do { futex_wait(&world_is_stopped, 1, -1, 0); } while (world_is_stopped);
|
||||
if (debug) fprintf(stderr, "%s: back from futex_wait\n", pthreadname(th));
|
||||
unpublish_context(th);
|
||||
}
|
||||
#endif
|
||||
|
||||
static void suspend_for_gc(struct thread* th)
|
||||
{
|
||||
if (debug)fprintf(stderr, "%s: need to suspend in allocator\n", pthreadname(th));
|
||||
__sync_fetch_and_add(&yp_kind_hit[0], 1);
|
||||
ucontext_t context; // don't really need this whole context, but that's fine
|
||||
getcontext(&context);
|
||||
publish_context(th, &context);
|
||||
th->state_word.state = STATE_STOPPED;
|
||||
sem_post(&gc_sync_sem);
|
||||
do { futex_wait(&world_is_stopped, 1, -1, 0); } while (world_is_stopped);
|
||||
th->state_word.state = STATE_RUNNING;
|
||||
if (debug) fprintf(stderr, "%s: back from futex_wait in allocator\n", pthreadname(th));
|
||||
unpublish_context(th);
|
||||
}
|
||||
|
||||
void maybe_suspend_for_gc(struct thread* th)
|
||||
{
|
||||
if (th->interrupt_reason & SUSPEND) suspend_for_gc(th);
|
||||
}
|
||||
|
||||
/* Return a copy of the thread's region. We operate on the copy so that it is not
|
||||
* succeptible to having the 'end' slot clobbered while in the call sequence of lisp_alloc. */
|
||||
struct alloc_region alloc_cooperate_before(struct alloc_region* r, struct thread* th)
|
||||
{
|
||||
struct alloc_region result;
|
||||
while (1) {
|
||||
// acquire_lock(&th->yieldpoint_spinlock);
|
||||
result = *r;
|
||||
// release_lock(&th->yieldpoint_spinlock);
|
||||
if (result.end_addr) return result;
|
||||
gc_assert(th->interrupt_reason & SUSPEND);
|
||||
suspend_for_gc(th);
|
||||
}
|
||||
}
|
||||
|
||||
static lispobj* region_end_spill_slot(struct thread* th, struct alloc_region* r)
|
||||
{
|
||||
if (r == &th->cons_tlab) return &th->spill_cons_tlab_end;
|
||||
if (r == &th->sys_cons_tlab) return &th->spill_sys_cons_tlab_end;
|
||||
if (r == &th->mixed_tlab) return &th->spill_mixed_tlab_end;
|
||||
if (r == &th->sys_mixed_tlab) return &th->spill_sys_mixed_tlab_end;
|
||||
lose("Unknown TLAB %p for thread %p", r, th);
|
||||
}
|
||||
|
||||
/* Restore the thread's TLAB from the shadow copy. If GC already forced the region
|
||||
* into a slow path fallback, we have replicate that effect. It won't work to yield
|
||||
* now because we'll lose the object whose space was just allocated but whose bits
|
||||
* were not written */
|
||||
void alloc_cooperate_after(struct alloc_region* dst, struct alloc_region* src,
|
||||
struct thread* th)
|
||||
{
|
||||
acquire_lock(&th->yieldpoint_spinlock);
|
||||
bool yield = !dst->end_addr;
|
||||
*dst = *src;
|
||||
lispobj* spill_slot = region_end_spill_slot(th, dst);
|
||||
if (yield)
|
||||
force_tlab_slowpath(dst, spill_slot);
|
||||
else
|
||||
gc_assert(*spill_slot == 0);
|
||||
release_lock(&th->yieldpoint_spinlock);
|
||||
#if 0
|
||||
if (yield) //start_addr != src->start_addr || dst->end_addr != src->end_addr)
|
||||
fprintf(stderr, "cooperate_after detected detected change of region: TLAB=%p:%p (free=%p) shadow=%p:%p (free=%p) yield=%d\n",
|
||||
dst->start_addr, dst->end_addr, dst->free_pointer,
|
||||
src->start_addr, src->end_addr, src->free_pointer, yield);
|
||||
#endif
|
||||
}
|
||||
|
||||
#ifdef LISP_FEATURE_X86_64
|
||||
static yieldpoint_kind infer_kind(unsigned char* pc) {
|
||||
if (pc[0] == 0x45 && pc[1] == 0x84) return IN_LISP; // TEST BYTE
|
||||
if (pc[0] == 0x45 && pc[1] == 0x85) return IN_LISP; // TEST DWORD
|
||||
if (pc[0] == 0x66 && pc[1] == 0x45) return IN_LISP; // MOVNTDQA
|
||||
if (pc[0] == 0xC4 && pc[1] == 0x42) return IN_LISP; // VMOVNTDQA
|
||||
if (pc[0] == 0x49 && pc[1] == 0x89) return LISP_TO_C; // MOV mem, RSP
|
||||
if (pc[0] == 0x49 && pc[1] == 0x31) return C_TO_LISP; // XOR mem, RSP
|
||||
return UNKNOWN;
|
||||
}
|
||||
#endif
|
||||
|
||||
static void yieldpoint_trap(struct thread* th, os_context_t *context)
|
||||
{
|
||||
unsigned char* pc = (void*)os_context_pc(context);
|
||||
yieldpoint_kind kind = infer_kind(pc);
|
||||
if (debug) {
|
||||
char buf[100];
|
||||
int n = snprintf(buf, sizeof buf, "%s: YP trap %d %d pc=%p\n",
|
||||
pthreadname(th), (int)th->interrupt_reason, kind, pc);
|
||||
write(2, buf, n);
|
||||
sb_dump_mcontext("foo", context);
|
||||
}
|
||||
event3("YP trap %x %d %p", th->interrupt_reason, kind, pc);
|
||||
if (kind == UNKNOWN) lose("unrecognized yieldpoint @ %p", pc);
|
||||
__sync_fetch_and_add(&yp_kind_hit[kind], 1);
|
||||
while (1) {
|
||||
int reason = th->interrupt_reason;
|
||||
if (!reason) {
|
||||
/* Disarm the trap but only if a double-check of the trap reason
|
||||
* confirms that it need not be armed. A yieldpoint trap can't happen
|
||||
* in alloc_cooperate, so this can't deadlock with itself */
|
||||
acquire_lock(&th->yieldpoint_spinlock);
|
||||
// FIXME: atomic load probably needed here? especially for non-x86
|
||||
reason = th->interrupt_reason;
|
||||
if (!reason) yieldpoint_trap_toggle(th, READ_WRITE);
|
||||
release_lock(&th->yieldpoint_spinlock);
|
||||
if (!reason) return;
|
||||
}
|
||||
/* Always cooperate with GC before doing anything else. */
|
||||
if (reason & SUSPEND) {
|
||||
int context_published = 0;
|
||||
th->state_word.state = STATE_STOPPED;
|
||||
if (kind == C_TO_LISP) {
|
||||
/* Trapped trying to get back to Lisp from a C call. Do not sem_post,
|
||||
* just wait until world isn't stopped. */
|
||||
} else {
|
||||
publish_context(th, context);
|
||||
context_published = 1;
|
||||
sem_post(&gc_sync_sem);
|
||||
if (debug) {
|
||||
char buf[100];
|
||||
int n = snprintf(buf, sizeof buf, "%s: posted\n", pthreadname(th));
|
||||
write(2, buf, n);
|
||||
}
|
||||
}
|
||||
do { futex_wait(&world_is_stopped, 1, -1, 0); } while (world_is_stopped);
|
||||
th->state_word.state = STATE_RUNNING;
|
||||
if (debug) fprintf(stderr, "%s: back from futex_wait\n", pthreadname(th));
|
||||
if (context_published) unpublish_context(th);
|
||||
reason &= ~SUSPEND;
|
||||
}
|
||||
if (!reason) continue; // try to return now
|
||||
gc_assert(reason & ASYNC_SIGNAL);
|
||||
// Make the yieldpoint instruction act like it was a CALL to a Lisp asm routine
|
||||
static char* asm_trampoline;
|
||||
if (!asm_trampoline) { // Lookup and/or memoize the routine to call
|
||||
asm_trampoline = get_asm_routine_by_name("HANDLE-DEFERRED-SIGNAL", 0);
|
||||
gc_assert(asm_trampoline);
|
||||
if (debug) fprintf(stderr, "YP asm tramp is %p\n", asm_trampoline);
|
||||
}
|
||||
/* Disarm the trap, ensuring that we're "in Lisp" regardless of the kind of yieldpoint,
|
||||
* because we don't want to handle async signals from C. (The Lisp signal handler
|
||||
* is ordinary Lisp code that can cons, triggering a garbage collection)
|
||||
* But also consider the following theoretically possible sequence:
|
||||
* GC is initiated, arms this thread's trap, completes, is immediately re-initiated
|
||||
* and arms this thread's trap. If we unilaterally disarm it, then we will miss the
|
||||
* second stop request that arrived in rapid-fire succession */
|
||||
acquire_lock(&th->yieldpoint_spinlock);
|
||||
if (th->interrupt_reason & SUSPEND) { // dang, not again?
|
||||
release_lock(&th->yieldpoint_spinlock);
|
||||
continue;
|
||||
}
|
||||
yieldpoint_trap_toggle(th, READ_WRITE);
|
||||
clear_stackptr_at_foreign_call(th);
|
||||
release_lock(&th->yieldpoint_spinlock);
|
||||
os_context_register_t return_to = (os_context_register_t)pc;
|
||||
/* If returning from foreign code (at a C-to-Lisp yieldpoint), step beyond the
|
||||
* yieldpoint. Having cleared the stack-pointer slot in the thread structure,
|
||||
* the collector understands that this thread is effectively in Lisp
|
||||
* regardless of the kind of yieldpoint trap */
|
||||
if (kind == C_TO_LISP) return_to += 4; // size of the XOR instruction
|
||||
/* Simulate a CALL that returns to the yieldpoint (or one instruction after).
|
||||
* God forbid this store hits the stack guard page.
|
||||
* Maybe just don't handle the async signal in that case? */
|
||||
lispobj* sp = (lispobj*)*os_context_sp_addr(context);
|
||||
--sp;
|
||||
fprintf(stderr, "YP trap: delivering signal to thread %p, pushing old PC %lx\n", th, return_to);
|
||||
*sp = return_to;
|
||||
*os_context_sp_addr(context) = (os_context_register_t)sp;
|
||||
/* If yet another GC stop request arrives, the next yieldpoint will be in the
|
||||
* prologue of the Lisp function that handles the deferred signal */
|
||||
OS_CONTEXT_PC(context) = (os_context_register_t)asm_trampoline;
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
int handle_safepoint_violation(os_context_t *context, os_vm_address_t fault_address) {
|
||||
struct thread*th = get_sb_vm_thread();
|
||||
if (th && yieldpoint_trap_addr(th) == (lispobj*)fault_address) {
|
||||
yieldpoint_trap(th, context);
|
||||
return 1;
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
int show_interrupt_data() {
|
||||
struct thread*th = get_sb_vm_thread();
|
||||
struct interrupt_data *data = &thread_interrupt_data(th);
|
||||
siginfo_t *inf = &data->pending_info;
|
||||
char string1[100], string2[100];
|
||||
sigset_t oldmask;
|
||||
int result = data->pending_signal;
|
||||
pthread_sigmask(SIG_SETMASK, 0, &oldmask);
|
||||
sigset_tostring(&oldmask, string1, 100);
|
||||
sigset_tostring(&data->pending_mask, string2, 100);
|
||||
printf("sig=%d no=%d errno=%d code=%d pid=%d uid=%d st=%d cur_mask=%s pend_mask=%s\n",
|
||||
data->pending_signal, inf->si_signo, inf->si_errno, inf->si_code, inf->si_pid, inf->si_uid,
|
||||
inf->si_status, string1, string2);
|
||||
return result;
|
||||
}
|
||||
int get_pending_signal_number() {
|
||||
struct thread*th = get_sb_vm_thread();
|
||||
return thread_interrupt_data(th).pending_signal;
|
||||
}
|
||||
void flush_pending_signal_and_restore() {
|
||||
struct thread*th = get_sb_vm_thread();
|
||||
struct interrupt_data *data = &thread_interrupt_data(th);
|
||||
//siginfo_t *inf = &data->pending_info;
|
||||
data->pending_handler = 0;
|
||||
data->pending_signal = 0;
|
||||
__sync_fetch_and_and(&th->interrupt_reason, ~ASYNC_SIGNAL);
|
||||
pthread_sigmask(SIG_SETMASK, &data->pending_mask, 0);
|
||||
}
|
||||
|
||||
extern void interrupt_handle_now_handler(int, siginfo_t*, void*);
|
||||
extern void sigprof_handler(int, siginfo_t*, void*);
|
||||
extern void (*interrupt_low_level_handlers[NSIG]) (int, siginfo_t*, os_context_t*);
|
||||
|
||||
/* This is called from Lisp. */
|
||||
void install_handler(int signal, lispobj handler)
|
||||
{
|
||||
struct sigaction sa;
|
||||
memset(&sa, 0, sizeof sa);
|
||||
|
||||
printf("HL handler %d (%s)\n", signal, strsignal(signal));
|
||||
if (interrupt_low_level_handlers[signal]) {
|
||||
// When there's a low-level handler, we must leave it alone.
|
||||
// Give it the lisp function to call if it decides to forward a signal.
|
||||
// SIG_IGN and SIG_DFL don't always do what you think in such case.
|
||||
lisp_sig_handlers[signal] = functionp(handler) ? handler : 0;
|
||||
} else if (signal == SIGPROF) {
|
||||
if (handler) sa.sa_sigaction = sigprof_handler;
|
||||
else sa.sa_handler = SIG_DFL;
|
||||
// The handler is signal-safe, but because it uses component_ptr_from_pc(),
|
||||
// it must block GC, lest crashes occur from dereferencing wild pointers.
|
||||
// FIXME: skip collect a profiling sample if GC is in progress which can happen
|
||||
// if we transited through a lisp-to-c yieldpoint
|
||||
sa.sa_mask = blockable_sigset;
|
||||
sa.sa_flags = SA_SIGINFO | SA_RESTART;
|
||||
sigaction(signal, &sa, NULL);
|
||||
return;
|
||||
} else {
|
||||
// Our "abstract" values for SIG_DFL and SIG_IGN are 0 and 1
|
||||
// respectively which are probably the real values from signal.h
|
||||
// but this way way don't need to put them in grovel-headers.c
|
||||
if (handler==0 || handler==1) {
|
||||
sa.sa_handler = handler ? SIG_IGN : SIG_DFL;
|
||||
// assign the OS level action before clearing the lisp function.
|
||||
// (If a signal were to be delivered to the C trampoline when the lisp
|
||||
// function is NIL, we'd get the effect of :IGNORE regardless
|
||||
// of what the default action should be)
|
||||
sigaction(signal, &sa, NULL);
|
||||
lisp_sig_handlers[signal] = 0;
|
||||
return;
|
||||
}
|
||||
sa.sa_flags = SA_SIGINFO;
|
||||
if (signal != SIGURG) sa.sa_flags |= SA_RESTART;
|
||||
if (sigismember(&deferrable_sigset, signal)) {
|
||||
sa.sa_sigaction = defer_to_yieldpoint;
|
||||
} else {
|
||||
sa.sa_sigaction = interrupt_handle_now_handler;
|
||||
sa.sa_flags |= SA_NODEFER;
|
||||
}
|
||||
sa.sa_mask = blockable_sigset;
|
||||
// ensure the C handler sees a lisp function before doing sigaction()
|
||||
lisp_sig_handlers[signal] = handler;
|
||||
sigaction(signal, &sa, NULL);
|
||||
}
|
||||
}
|
||||
|
|
@ -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*
|
||||
|
|
|
|||
|
|
@ -55,6 +55,9 @@
|
|||
#include <signal.h>
|
||||
#include <errno.h>
|
||||
#include <time.h>
|
||||
#ifdef LISP_FEATURE_YIELDPOINTS
|
||||
#include <ucontext.h> // probably already included via signal.h
|
||||
#endif
|
||||
|
||||
#ifdef LISP_FEATURE_BSD
|
||||
#include <sys/param.h>
|
||||
|
|
@ -280,6 +283,9 @@ main(int argc, char __attribute__((unused)) *argv[])
|
|||
|
||||
printf(";;; signals\n");
|
||||
defconstant("sizeof-sigset_t", sizeof (sigset_t));
|
||||
#ifdef LISP_FEATURE_YIELDPOINTS
|
||||
defconstant("sizeof-ucontext_t", sizeof (ucontext_t));
|
||||
#endif
|
||||
defconstant("sig_block", SIG_BLOCK);
|
||||
defconstant("sig_unblock", SIG_UNBLOCK);
|
||||
defconstant("sig_setmask", SIG_SETMASK);
|
||||
|
|
|
|||
Loading…
Reference in a new issue