Email Archive: sbcl-commits (read-only)
|
[Sbcl-commits] master: Add safepoint mechanism
From: David Lichteblau <lichteblau@us...> - 2012-08-10 18:55
|
The branch "master" has been updated in SBCL:
via e6f4c7523aa628ece995ee01879d3fb90eed6d9f (commit)
from 4bc19d9ce2f31330e3d2a8639c078451d1adc79d (commit)
- Log -----------------------------------------------------------------
commit e6f4c7523aa628ece995ee01879d3fb90eed6d9f
Author: David Lichteblau <david@...>
Date: Thu Apr 28 13:51:35 2011 +0200
Add safepoint mechanism
* Stop threads for GC at safepoints only.
* Replaces use of SIG_STOP_FOR_GC.
* Currently not used by default. Users need to set feature
SB-SAFEPOINT to enable this code. SB-SAFEPOINT should only be set
when SB-THREAD is also enabled.
* ISA support: Each architecture needs VOP support, and changes to
foreign call-out assembly; only x86 and x86-64 implemented at this
point.
* OS support: Minor changes to signal handling required, currently
implemented for Linux and Solaris.
* Performance note: Does not currently replace pseudo-atomic entirely,
except on Windows. Only once further work has been done to reduce
use of signals will pseudo-atomic become truly redundant. Therefore
use of safepoints on POSIX currently still implies the combined
performance overhead of both mechanisms.
* Design alternatives exist for some choices made here. In particular,
this commit places the safepoint trap page into the SBCL binary for
simplicity. It is likely that future changes to allow slam-free
runtime changes will have to go back to a hand-crafted address
parameter.
* This feature has been extracted from work related to Windows
support and backported to POSIX.
Credits: Uses the CSP-based stop-the-world protocol by Anton Kovalenko,
based on the safepoint and threading work by Dmitry Kalyanov. Use of
safepoints for SBCL originally researched by Paul Khuong.
---
package-data-list.lisp-expr | 3 +
src/code/early-impl.lisp | 2 +
src/code/gc.lisp | 2 +
src/code/target-signal.lisp | 4 +-
src/code/target-thread.lisp | 17 +-
src/compiler/fndb.lisp | 6 +
src/compiler/generic/objdef.lisp | 4 +
src/compiler/generic/parms.lisp | 2 +
src/compiler/ir2tran.lisp | 21 +-
src/compiler/policies.lisp | 13 +
src/compiler/x86-64/backend-parms.lisp | 4 +
src/compiler/x86-64/c-call.lisp | 117 ++++--
src/compiler/x86-64/macros.lisp | 13 +-
src/compiler/x86-64/parms.lisp | 4 +-
src/compiler/x86-64/system.lisp | 7 +
src/compiler/x86/c-call.lisp | 41 ++-
src/compiler/x86/macros.lisp | 13 +-
src/compiler/x86/parms.lisp | 5 +-
src/compiler/x86/system.lisp | 7 +
src/runtime/GNUmakefile | 4 +-
src/runtime/alloc.c | 2 +
src/runtime/breakpoint.c | 4 +
src/runtime/bsd-os.c | 2 +-
src/runtime/cpputil.h | 19 +
src/runtime/dynbind.c | 22 +
src/runtime/dynbind.h | 1 +
src/runtime/funcall.c | 2 +
src/runtime/gc-common.c | 4 +-
src/runtime/gencgc.c | 48 ++-
src/runtime/globals.h | 5 +
src/runtime/interrupt.c | 85 +++-
src/runtime/interrupt.h | 10 +
src/runtime/linux-os.c | 6 +
src/runtime/runtime.h | 10 +
src/runtime/safepoint.c | 775 ++++++++++++++++++++++++++++++++
src/runtime/sunos-os.c | 7 +
src/runtime/thread.c | 107 ++++-
src/runtime/thread.h | 180 ++++++++
src/runtime/x86-64-arch.c | 4 +
src/runtime/x86-64-assem.S | 8 +
src/runtime/x86-arch.c | 4 +
src/runtime/x86-assem.S | 173 +++++++-
src/runtime/x86-linux-os.c | 13 +
src/runtime/x86-sunos-os.c | 4 +
44 files changed, 1685 insertions(+), 99 deletions(-)
diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 770f381..aee1301 100644
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -288,6 +288,7 @@ of SBCL which maintained the CMU-CL-style split into two packages.)"
"HALT"
"IF-EQ"
"IMMEDIATE-TN-P"
+ "INHIBIT-SAFEPOINTS"
"INLINE-SYNTACTIC-CLOSURE-LAMBDA"
"INSERT-STEP-CONDITIONS"
"IR2-COMPONENT-CONSTANTS" "IR2-CONVERT"
@@ -2629,6 +2630,7 @@ structure representations"
"CONTEXT-FLOATING-POINT-MODES" "CONTEXT-FLOAT-REGISTER"
"CONTEXT-PC" "CONTEXT-REGISTER"
"CONTROL-STACK-SC-NUMBER" "COUNT-NO-OPS"
+ #!+sb-safepoint "CSP-SAFEPOINT-TRAP"
"*CURRENT-CATCH-BLOCK*"
"CURRENT-FLOAT-TRAP" "DEFINE-FOR-EACH-PRIMITIVE-OBJECT"
"DESCRIPTOR-REG-SC-NUMBER" "DESCRIPTOR-VS-NON-DESCRIPTOR-STORAGE"
@@ -2674,6 +2676,7 @@ structure representations"
"GENCGC-RELEASE-GRANULARITY"
#!+ppc "PSEUDO-ATOMIC-INTERRUPTED-FLAG"
#!+ppc "PSEUDO-ATOMIC-FLAG"
+ #!+sb-safepoint "GLOBAL-SAFEPOINT-TRAP"
"GENESIS" "HALT-TRAP" "IGNORE-ME-SC-NUMBER"
"IMMEDIATE-CHARACTER-SC-NUMBER" "IMMEDIATE-SAP-SC-NUMBER"
"IMMEDIATE-SC-NUMBER"
diff --git a/src/code/early-impl.lisp b/src/code/early-impl.lisp
index c5319a0..7f0ff41 100644
--- a/src/code/early-impl.lisp
+++ b/src/code/early-impl.lisp
@@ -42,6 +42,8 @@
sb!unix::*unblock-deferrables-on-enabling-interrupts-p*
*interrupts-enabled*
*interrupt-pending*
+ #!+sb-safepoint *gc-safe*
+ #!+sb-safepoint *in-safepoint*
*free-interrupt-context-index*
sb!kernel::*gc-epoch*
sb!vm::*unwind-to-frame-function*
diff --git a/src/code/gc.lisp b/src/code/gc.lisp
index a9893b0..b9d9151 100644
--- a/src/code/gc.lisp
+++ b/src/code/gc.lisp
@@ -254,6 +254,8 @@ statistics are appended to it."
;; turn is a type-error.
(when (plusp run-time)
(incf *gc-run-time* run-time))))
+ #!+sb-safepoint
+ (setf *stop-for-gc-pending* nil)
(setf *gc-pending* nil
new-usage (dynamic-usage))
#!+sb-thread
diff --git a/src/code/target-signal.lisp b/src/code/target-signal.lisp
index 7394695..4343fb6 100644
--- a/src/code/target-signal.lisp
+++ b/src/code/target-signal.lisp
@@ -99,6 +99,7 @@
sb!alien:void
(where sb!alien:unsigned-long)
(old sb!alien:unsigned-long))
+#!-sb-safepoint
(sb!alien:define-alien-routine ("unblock_gc_signals" %unblock-gc-signals)
sb!alien:void
(where sb!alien:unsigned-long)
@@ -107,6 +108,7 @@
(defun unblock-deferrable-signals ()
(%unblock-deferrable-signals 0 0))
+#!-sb-safepoint
(defun unblock-gc-signals ()
(%unblock-gc-signals 0 0))
@@ -228,7 +230,7 @@
(enable-interrupt sigpipe #'sigpipe-handler)
(enable-interrupt sigchld #'sigchld-handler)
#!+hpux (ignore-interrupt sigxcpu)
- (unblock-gc-signals)
+ #!-sb-safepoint (unblock-gc-signals)
(unblock-deferrable-signals)
(values))
diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp
index 82ce827..3b00593 100644
--- a/src/code/target-thread.lisp
+++ b/src/code/target-thread.lisp
@@ -1418,13 +1418,16 @@ See also: RETURN-FROM-THREAD, ABORT-THREAD."
(with-local-interrupts
(sb!unix::unblock-deferrable-signals)
(setf (thread-result thread)
- (cons t
- (multiple-value-list
- (unwind-protect
- (catch '%return-from-thread
- (apply real-function arguments))
- (when *exit-in-process*
- (sb!impl::call-exit-hooks)))))))
+ (prog1
+ (cons t
+ (multiple-value-list
+ (unwind-protect
+ (catch '%return-from-thread
+ (apply real-function arguments))
+ (when *exit-in-process*
+ (sb!impl::call-exit-hooks)))))
+ #!+sb-safepoint
+ (sb!kernel::gc-safepoint))))
;; We're going down, can't handle interrupts
;; sanely anymore. GC remains enabled.
(block-deferrable-signals)
diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp
index ac471cf..f289015 100644
--- a/src/compiler/fndb.lisp
+++ b/src/compiler/fndb.lisp
@@ -1605,6 +1605,12 @@
(defknown sb!vm:%write-barrier () (values) ())
(defknown sb!vm:%data-dependency-barrier () (values) ())
+#!+sb-safepoint
+;;; 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
+;;; use of the VOP in the function prologue anyway.
+(defknown sb!kernel::gc-safepoint () (values) ())
;;;; atomic ops
(defknown %compare-and-swap-svref (simple-vector index t t) t
diff --git a/src/compiler/generic/objdef.lisp b/src/compiler/generic/objdef.lisp
index 938990c..bfc0281 100644
--- a/src/compiler/generic/objdef.lisp
+++ b/src/compiler/generic/objdef.lisp
@@ -423,6 +423,10 @@
(control-stack-pointer :c-type "lispobj *")
#!+mach-exception-handler
(mach-port-name :c-type "mach_port_name_t")
+ (nonpointer-data :c-type "struct nonpointer_thread_data *" :length #!+alpha 2 #!-alpha 1)
+ #!+(and sb-safepoint x86) (selfptr :c-type "struct thread *")
+ #!+sb-safepoint (csp-around-foreign-call :c-type "lispobj *")
+ #!+sb-safepoint (pc-around-foreign-call :c-type "lispobj *")
;; KLUDGE: On alpha, until STEPPING we have been lucky and the 32
;; bit slots came in pairs. However the C compiler will align
;; interrupt_contexts on a double word boundary. This logic should
diff --git a/src/compiler/generic/parms.lisp b/src/compiler/generic/parms.lisp
index 4d793be..f720872 100644
--- a/src/compiler/generic/parms.lisp
+++ b/src/compiler/generic/parms.lisp
@@ -85,6 +85,8 @@
*gc-pending*
#!-sb-thread
*stepping*
+ #!+sb-safepoint sb!impl::*gc-safe*
+ #!+sb-safepoint sb!impl::*in-safepoint*
;; threading support
#!+sb-thread *stop-for-gc-pending*
diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp
index 0ae854b..af5c7e4 100644
--- a/src/compiler/ir2tran.lisp
+++ b/src/compiler/ir2tran.lisp
@@ -1272,7 +1272,10 @@
(let ((lab (gen-label)))
(setf (ir2-physenv-environment-start env) lab)
- (vop note-environment-start node block lab)))
+ (vop note-environment-start node block lab)
+ #!+sb-safepoint
+ (unless (policy fun (>= inhibit-safepoints 2))
+ (vop sb!vm::insert-safepoint node block))))
(values))
@@ -1805,6 +1808,22 @@
2block
#!+sb-dyncount *dynamic-counts-tn* #!-sb-dyncount nil
num))))
+ #!+sb-safepoint
+ (let ((first-node (block-start-node block)))
+ (unless (or (and (bind-p first-node)
+ (xep-p (bind-lambda first-node)))
+ (and (valued-node-p first-node)
+ (node-lvar first-node)
+ (eq (lvar-fun-name
+ (node-lvar first-node))
+ '%nlx-entry)))
+ (when (and (rest (block-pred block))
+ (block-loop block)
+ (member (loop-kind (block-loop block))
+ '(:natural :strange))
+ (eq block (loop-head (block-loop block)))
+ (policy first-node (< inhibit-safepoints 2)))
+ (vop sb!vm::insert-safepoint first-node 2block))))
(ir2-convert-block block)
(incf num))))))
(values))
diff --git a/src/compiler/policies.lisp b/src/compiler/policies.lisp
index 3717744..043e375 100644
--- a/src/compiler/policies.lisp
+++ b/src/compiler/policies.lisp
@@ -135,3 +135,16 @@ debugger.")
(define-optimization-quality store-coverage-data
0
("no" "no" "yes" "yes"))
+
+#!+sb-safepoint
+(define-optimization-quality inhibit-safepoints
+ 0
+ ("no" "no" "yes" "yes")
+ "When disabled, the compiler will insert safepoints at strategic
+points (loop edges, function prologues) to ensure that potentially
+long-running code can be interrupted.
+
+When enabled, no safepoints will be inserted explicitly. Note that
+this declaration does not prevent out-of-line function calls, which
+will encounter safepoints unless the target function has also been
+compiled with this declaration in effect.")
diff --git a/src/compiler/x86-64/backend-parms.lisp b/src/compiler/x86-64/backend-parms.lisp
index 33ffb6e..93f2e01 100644
--- a/src/compiler/x86-64/backend-parms.lisp
+++ b/src/compiler/x86-64/backend-parms.lisp
@@ -47,3 +47,7 @@
;;; The minimum size at which we release address ranges to the OS.
;;; This must be a multiple of the OS page size.
(def!constant gencgc-release-granularity *backend-page-bytes*)
+
+#!+sb-safepoint
+(def!constant thread-saved-csp-offset
+ (- (/ *backend-page-bytes* n-word-bytes)))
diff --git a/src/compiler/x86-64/c-call.lisp b/src/compiler/x86-64/c-call.lisp
index d90427f..65ad782 100644
--- a/src/compiler/x86-64/c-call.lisp
+++ b/src/compiler/x86-64/c-call.lisp
@@ -257,12 +257,37 @@
(args :more t))
(:results (results :more t))
(:temporary (:sc unsigned-reg :offset rax-offset :to :result) rax)
- (:ignore results)
+ ;; For safepoint builds: Force values of non-volatiles to the stack.
+ ;; These are the callee-saved registers in the native ABI, but
+ ;; safepoint-based GC needs to see all Lisp values on the stack. Note
+ ;; that R12-R15 are non-volatile registers, but there is no need to
+ ;; spill R12 because it is our thread-base-tn. RDI and RSI are
+ ;; non-volatile on Windows, but argument passing registers on other
+ ;; platforms.
+ #!+sb-safepoint (:temporary (:sc unsigned-reg :offset r13-offset) r13)
+ #!+sb-safepoint (:temporary (:sc unsigned-reg :offset r14-offset) r14)
+ #!+sb-safepoint (:temporary (:sc unsigned-reg :offset r15-offset) r15)
+ #!+(and sb-safepoint win32) (:temporary
+ (:sc unsigned-reg :offset rdi-offset) rdi)
+ #!+(and sb-safepoint win32) (:temporary
+ (:sc unsigned-reg :offset rsi-offset) rsi)
+ (:ignore results
+ #!+(and sb-safepoint win32) rdi
+ #!+(and sb-safepoint win32) rsi
+ #!+sb-safepoint r15
+ #!+sb-safepoint r13)
(:vop-var vop)
(:save-p t)
(:generator 0
;; ABI: Direction flag must be clear on function entry. -- JES, 2006-01-20
(inst cld)
+ #!+sb-safepoint
+ (progn
+ ;; Current PC - don't rely on function to keep it in a form that
+ ;; GC understands
+ (let ((label (gen-label)))
+ (inst lea r14 (make-fixup nil :code-object label))
+ (emit-label label)))
;; ABI: AL contains amount of arguments passed in XMM registers
;; for vararg calls.
(move-immediate rax
@@ -270,7 +295,19 @@
while tn-ref
count (eq (sb-name (sc-sb (tn-sc (tn-ref-tn tn-ref))))
'float-registers)))
+ #!+sb-safepoint
+ (progn ;Store SP and PC in thread struct
+ (storew rsp-tn thread-base-tn thread-saved-csp-offset)
+ (storew r14 thread-base-tn thread-pc-around-foreign-call-slot))
(inst call function)
+ #!+sb-safepoint
+ (progn
+ ;; Zeroing out
+ (inst xor r14 r14)
+ ;; Zero PC storage place. NB. CSP-then-PC: same sequence on
+ ;; entry/exit, is actually corrent.
+ (storew r14 thread-base-tn thread-saved-csp-offset)
+ (storew r14 thread-base-tn thread-pc-around-foreign-call-slot))
;; To give the debugger a clue. XX not really internal-error?
(note-this-location vop :internal-error)))
@@ -380,7 +417,7 @@
(error "Too many arguments in callback")))
(let* ((segment (make-segment))
(rax rax-tn)
- (rcx rcx-tn)
+ #!+(not sb-safepoint) (rcx rcx-tn)
(rdi rdi-tn)
(rsi rsi-tn)
(rdx rdx-tn)
@@ -444,36 +481,58 @@
(t
(bug "Unknown alien floating point type: ~S" type)))))
- ;; arg0 to FUNCALL3 (function)
- ;;
- ;; Indirect the access to ENTER-ALIEN-CALLBACK through
- ;; the symbol-value slot of SB-ALIEN::*ENTER-ALIEN-CALLBACK*
- ;; to ensure it'll work even if the GC moves ENTER-ALIEN-CALLBACK.
- ;; Skip any SB-THREAD TLS magic, since we don't expect anyone
- ;; to rebind the variable. -- JES, 2006-01-01
- (inst mov rdi (+ nil-value (static-symbol-offset
- 'sb!alien::*enter-alien-callback*)))
- (loadw rdi rdi symbol-value-slot other-pointer-lowtag)
- ;; arg0 to ENTER-ALIEN-CALLBACK (trampoline index)
- (inst mov rsi (fixnumize index))
- ;; arg1 to ENTER-ALIEN-CALLBACK (pointer to argument vector)
- (inst mov rdx rsp)
- ;; add room on stack for return value
- (inst sub rsp 8)
- ;; arg2 to ENTER-ALIEN-CALLBACK (pointer to return value)
- (inst mov rcx rsp)
+ #!-sb-safepoint
+ (progn
+ ;; arg0 to FUNCALL3 (function)
+ ;;
+ ;; Indirect the access to ENTER-ALIEN-CALLBACK through
+ ;; the symbol-value slot of SB-ALIEN::*ENTER-ALIEN-CALLBACK*
+ ;; to ensure it'll work even if the GC moves ENTER-ALIEN-CALLBACK.
+ ;; Skip any SB-THREAD TLS magic, since we don't expect anyone
+ ;; to rebind the variable. -- JES, 2006-01-01
+ (inst mov rdi (+ nil-value (static-symbol-offset
+ 'sb!alien::*enter-alien-callback*)))
+ (loadw rdi rdi symbol-value-slot other-pointer-lowtag)
+ ;; arg0 to ENTER-ALIEN-CALLBACK (trampoline index)
+ (inst mov rsi (fixnumize index))
+ ;; arg1 to ENTER-ALIEN-CALLBACK (pointer to argument vector)
+ (inst mov rdx rsp)
+ ;; add room on stack for return value
+ (inst sub rsp 8)
+ ;; arg2 to ENTER-ALIEN-CALLBACK (pointer to return value)
+ (inst mov rcx rsp)
- ;; Make new frame
- (inst push rbp)
- (inst mov rbp rsp)
+ ;; Make new frame
+ (inst push rbp)
+ (inst mov rbp rsp)
- ;; Call
- (inst mov rax (foreign-symbol-address "funcall3"))
- (inst call rax)
+ ;; Call
+ (inst mov rax (foreign-symbol-address "funcall3"))
+ (inst call rax)
- ;; Back! Restore frame
- (inst mov rsp rbp)
- (inst pop rbp)
+ ;; Back! Restore frame
+ (inst mov rsp rbp)
+ (inst pop rbp))
+
+ #!+sb-safepoint
+ (progn
+ ;; arg0 to ENTER-ALIEN-CALLBACK (trampoline index)
+ (inst mov rdi (fixnumize index))
+ ;; arg1 to ENTER-ALIEN-CALLBACK (pointer to argument vector)
+ (inst mov rsi rsp)
+ ;; add room on stack for return value
+ (inst sub rsp 8)
+ ;; arg2 to ENTER-ALIEN-CALLBACK (pointer to return value)
+ (inst mov rdx rsp)
+ ;; Make new frame
+ (inst push rbp)
+ (inst mov rbp rsp)
+ ;; Call
+ (inst mov rax (foreign-symbol-address "callback_wrapper_trampoline"))
+ (inst call rax)
+ ;; Back! Restore frame
+ (inst mov rsp rbp)
+ (inst pop rbp))
;; Result now on top of stack, put it in the right register
(cond
diff --git a/src/compiler/x86-64/macros.lisp b/src/compiler/x86-64/macros.lisp
index 13deab4..0df9cf4 100644
--- a/src/compiler/x86-64/macros.lisp
+++ b/src/compiler/x86-64/macros.lisp
@@ -297,6 +297,11 @@
:disp (* n-word-bytes thread-pseudo-atomic-bits-slot))
0))
+#!+sb-safepoint
+(defun emit-safepoint ()
+ (inst test al-tn (make-ea :byte
+ :disp (make-fixup "gc_safepoint_page" :foreign))))
+
#!+sb-thread
(defmacro pseudo-atomic (&rest forms)
(with-unique-names (label)
@@ -314,7 +319,13 @@
;; if PAI was set, interrupts were disabled at the same time
;; using the process signal mask.
(inst break pending-interrupt-trap)
- (emit-label ,label))))
+ (emit-label ,label)
+ #!+sb-safepoint
+ ;; In this case, when allocation thinks a GC should be done, it
+ ;; does not mark PA as interrupted, but schedules a safepoint
+ ;; trap instead. Let's take the opportunity to trigger that
+ ;; safepoint right now.
+ (emit-safepoint))))
#!-sb-thread
diff --git a/src/compiler/x86-64/parms.lisp b/src/compiler/x86-64/parms.lisp
index 1dbc383..d294c4f 100644
--- a/src/compiler/x86-64/parms.lisp
+++ b/src/compiler/x86-64/parms.lisp
@@ -138,7 +138,9 @@
(defenum (:start 24)
object-not-list-trap
- object-not-instance-trap)
+ object-not-instance-trap
+ #!+sb-safepoint global-safepoint-trap
+ #!+sb-safepoint csp-safepoint-trap)
;;;; static symbols
diff --git a/src/compiler/x86-64/system.lisp b/src/compiler/x86-64/system.lisp
index ae57c4c..9d7973c 100644
--- a/src/compiler/x86-64/system.lisp
+++ b/src/compiler/x86-64/system.lisp
@@ -259,6 +259,13 @@
(:generator 1
(inst break pending-interrupt-trap)))
+#!+sb-safepoint
+(define-vop (insert-safepoint)
+ (:policy :fast-safe)
+ (:translate sb!kernel::gc-safepoint)
+ (:generator 0
+ (emit-safepoint)))
+
#!+sb-thread
(defknown current-thread-offset-sap ((unsigned-byte 64))
system-area-pointer (flushable))
diff --git a/src/compiler/x86/c-call.lisp b/src/compiler/x86/c-call.lisp
old mode 100644
new mode 100755
index 7eec472..01cf930
--- a/src/compiler/x86/c-call.lisp
+++ b/src/compiler/x86/c-call.lisp
@@ -262,15 +262,24 @@
:from :eval :to :result) ecx)
(:temporary (:sc unsigned-reg :offset edx-offset
:from :eval :to :result) edx)
- (:node-var node)
+ #!+sb-safepoint (:temporary (:sc unsigned-reg :offset esi-offset) esi)
+ #!+sb-safepoint (:temporary (:sc unsigned-reg :offset edi-offset) edi)
+ #!-sb-safepoint (:node-var node)
(:vop-var vop)
(:save-p t)
- (:ignore args ecx edx)
+ (:ignore args ecx edx
+ #!+sb-safepoint esi
+ #!+sb-safepoint edi)
(:generator 0
;; FIXME & OAOOM: This is brittle and error-prone to maintain two
;; instances of the same logic, on in arch-assem.S, and one in
;; c-call.lisp. If you modify this, modify that one too...
- (cond ((policy node (> space speed))
+ (cond ((and
+ ;; On safepoints builds, we currently use the out-of-line
+ ;; calling routine irrespectively of SPACE and SPEED policy.
+ ;; An inline version of said changes is left to the
+ ;; sufficiently motivated maintainer.
+ #!-sb-safepoint (policy node (> space speed)))
(move eax function)
(inst call (make-fixup "call_into_c" :foreign)))
(t
@@ -413,15 +422,23 @@ pointer to the arguments."
(inst push eax) ; arg1
(inst push (ash index 2)) ; arg0
- ;; Indirect the access to ENTER-ALIEN-CALLBACK through
- ;; the symbol-value slot of SB-ALIEN::*ENTER-ALIEN-CALLBACK*
- ;; to ensure it'll work even if the GC moves ENTER-ALIEN-CALLBACK.
- ;; Skip any SB-THREAD TLS magic, since we don't expecte anyone
- ;; to rebind the variable. -- JES, 2006-01-01
- (load-symbol-value eax sb!alien::*enter-alien-callback*)
- (inst push eax) ; function
- (inst mov eax (foreign-symbol-address "funcall3"))
- (inst call eax)
+ #!+sb-safepoint
+ (progn
+ (inst mov eax (foreign-symbol-address "callback_wrapper_trampoline"))
+ (inst call eax))
+
+ #!-sb-safepoint
+ (progn
+ ;; Indirect the access to ENTER-ALIEN-CALLBACK through
+ ;; the symbol-value slot of SB-ALIEN::*ENTER-ALIEN-CALLBACK*
+ ;; to ensure it'll work even if the GC moves ENTER-ALIEN-CALLBACK.
+ ;; Skip any SB-THREAD TLS magic, since we don't expecte anyone
+ ;; to rebind the variable. -- JES, 2006-01-01
+ (load-symbol-value eax sb!alien::*enter-alien-callback*)
+ (inst push eax) ; function
+ (inst mov eax (foreign-symbol-address "funcall3"))
+ (inst call eax))
+
;; now put the result into the right register
(cond
((and (alien-integer-type-p return-type)
diff --git a/src/compiler/x86/macros.lisp b/src/compiler/x86/macros.lisp
index 7386f77..344b72d 100644
--- a/src/compiler/x86/macros.lisp
+++ b/src/compiler/x86/macros.lisp
@@ -356,6 +356,11 @@
(defmacro %clear-pseudo-atomic ()
'(inst mov (make-ea :dword :disp (* 4 thread-pseudo-atomic-bits-slot)) 0 :fs))
+#!+sb-safepoint
+(defun emit-safepoint ()
+ (inst test al-tn (make-ea :byte
+ :disp (make-fixup "gc_safepoint_page" :foreign))))
+
#!+sb-thread
(defmacro pseudo-atomic (&rest forms)
(with-unique-names (label)
@@ -369,7 +374,13 @@
;; if PAI was set, interrupts were disabled at the same time
;; using the process signal mask.
(inst break pending-interrupt-trap)
- (emit-label ,label))))
+ (emit-label ,label)
+ #!+sb-safepoint
+ ;; In this case, when allocation thinks a GC should be done, it
+ ;; does not mark PA as interrupted, but schedules a safepoint
+ ;; trap instead. Let's take the opportunity to trigger that
+ ;; safepoint right now.
+ (emit-safepoint))))
#!-sb-thread
(defmacro pseudo-atomic (&rest forms)
diff --git a/src/compiler/x86/parms.lisp b/src/compiler/x86/parms.lisp
index 89e56d6..fc51de6 100644
--- a/src/compiler/x86/parms.lisp
+++ b/src/compiler/x86/parms.lisp
@@ -186,7 +186,6 @@
#!+win32
(progn
-
(def!constant read-only-space-start #x22000000)
(def!constant read-only-space-end #x220ff000)
@@ -306,7 +305,9 @@
(defenum (:start 24)
object-not-list-trap
- object-not-instance-trap)
+ object-not-instance-trap
+ #!+sb-safepoint global-safepoint-trap
+ #!+sb-safepoint csp-safepoint-trap)
;;;; static symbols
diff --git a/src/compiler/x86/system.lisp b/src/compiler/x86/system.lisp
index 2128d2b..0cd90a3 100644
--- a/src/compiler/x86/system.lisp
+++ b/src/compiler/x86/system.lisp
@@ -254,6 +254,13 @@
(:generator 1
(inst break pending-interrupt-trap)))
+#!+sb-safepoint
+(define-vop (insert-safepoint)
+ (:policy :fast-safe)
+ (:translate sb!kernel::gc-safepoint)
+ (:generator 0
+ (emit-safepoint)))
+
#!+sb-thread
(defknown current-thread-offset-sap ((unsigned-byte 32))
system-area-pointer (flushable))
diff --git a/src/runtime/GNUmakefile b/src/runtime/GNUmakefile
index ccb3bb4..3d75800 100644
--- a/src/runtime/GNUmakefile
+++ b/src/runtime/GNUmakefile
@@ -44,8 +44,8 @@ COMMON_SRC = alloc.c backtrace.c breakpoint.c coreparse.c \
dynbind.c funcall.c gc-common.c globals.c interr.c interrupt.c \
largefile.c monitor.c os-common.c parse.c print.c purify.c \
pthread-futex.c \
- regnames.c run-program.c runtime.c save.c search.c \
- thread.c time.c util.c validate.c vars.c wrap.c
+ regnames.c run-program.c runtime.c safepoint.c save.c search.c \
+ thread.c time.c util.c validate.c vars.c wrap.c
C_SRC = $(COMMON_SRC) ${ARCH_SRC} ${OS_SRC} ${GC_SRC}
diff --git a/src/runtime/alloc.c b/src/runtime/alloc.c
index f67ccd0..9e97887 100644
--- a/src/runtime/alloc.c
+++ b/src/runtime/alloc.c
@@ -40,10 +40,12 @@ pa_alloc(int bytes, int page_type_flag)
lispobj *result;
struct thread *th = arch_os_get_current_thread();
+#ifndef LISP_FEATURE_SB_SAFEPOINT
/* SIG_STOP_FOR_GC must be unblocked: else two threads racing here
* may deadlock: one will wait on the GC lock, and the other
* cannot stop the first one... */
check_gc_signals_unblocked_or_lose(0);
+#endif
/* FIXME: OOAO violation: see arch_pseudo_* */
set_pseudo_atomic_atomic(th);
diff --git a/src/runtime/breakpoint.c b/src/runtime/breakpoint.c
index 5cada3e..638b2e8 100644
--- a/src/runtime/breakpoint.c
+++ b/src/runtime/breakpoint.c
@@ -130,7 +130,9 @@ void handle_breakpoint(os_context_t *context)
fake_foreign_function_call(context);
+#ifndef LISP_FEATURE_SB_SAFEPOINT
unblock_gc_signals(0, 0);
+#endif
context_sap = alloc_sap(context);
code = find_code(context);
@@ -155,7 +157,9 @@ void *handle_fun_end_breakpoint(os_context_t *context)
fake_foreign_function_call(context);
+#ifndef LISP_FEATURE_SB_SAFEPOINT
unblock_gc_signals(0, 0);
+#endif
context_sap = alloc_sap(context);
code = find_code(context);
codeptr = (struct code *)native_pointer(code);
diff --git a/src/runtime/bsd-os.c b/src/runtime/bsd-os.c
index 5e6eb52..eeaf755 100644
--- a/src/runtime/bsd-os.c
+++ b/src/runtime/bsd-os.c
@@ -241,7 +241,7 @@ os_install_interrupt_handlers(void)
memory_fault_handler);
#endif
-#ifdef LISP_FEATURE_SB_THREAD
+#ifdef THREADS_USING_GCSIGNAL
undoably_install_low_level_interrupt_handler(SIG_STOP_FOR_GC,
sig_stop_for_gc_handler);
#endif
diff --git a/src/runtime/cpputil.h b/src/runtime/cpputil.h
new file mode 100644
index 0000000..fbf1114
--- /dev/null
+++ b/src/runtime/cpputil.h
@@ -0,0 +1,19 @@
+#ifndef SBCL_INCLUDED_CPPUTIL_H
+#define SBCL_INCLUDED_CPPUTIL_H
+
+#include <stdint.h>
+
+#define ALIGN_UP(value,granularity) (((value)+(granularity-1))&(~(granularity-1)))
+#define ALIGN_DOWN(value,granularity) (((value))&(~(granularity-1)))
+#define IS_ALIGNED(value,granularity) (0==(((value))&(granularity-1)))
+
+#define PTR_ALIGN_UP(pointer,granularity) \
+ (typeof(pointer))ALIGN_UP((uintptr_t)pointer,granularity)
+
+#define PTR_ALIGN_DOWN(pointer,granularity) \
+ (typeof(pointer))ALIGN_DOWN((uintptr_t)pointer,granularity)
+
+#define PTR_IS_ALIGNED(pointer,granularity) \
+ IS_ALIGNED((uintptr_t)pointer,granularity)
+
+#endif /* SBCL_INCLUDED_CPPUTIL_H */
diff --git a/src/runtime/dynbind.c b/src/runtime/dynbind.c
index 32f79f0..9e928a3 100644
--- a/src/runtime/dynbind.c
+++ b/src/runtime/dynbind.c
@@ -81,6 +81,28 @@ unbind(void *th)
}
void
+unbind_variable(lispobj name, void *th)
+{
+ struct thread *thread=(struct thread *)th;
+ struct binding *binding;
+ lispobj symbol;
+
+ binding = ((struct binding *)get_binding_stack_pointer(thread)) - 1;
+
+ symbol = binding->symbol;
+
+ if (symbol != name)
+ lose("unbind_variable, 0x%p != 0x%p", symbol, name);
+
+ SetTlSymbolValue(symbol, binding->value,thread);
+
+ binding->symbol = 0;
+ binding->value = 0;
+
+ set_binding_stack_pointer(thread,binding);
+}
+
+void
unbind_to_here(lispobj *bsp,void *th)
{
struct thread *thread=(struct thread *)th;
diff --git a/src/runtime/dynbind.h b/src/runtime/dynbind.h
index 41aa9eb..526b02d 100644
--- a/src/runtime/dynbind.h
+++ b/src/runtime/dynbind.h
@@ -14,6 +14,7 @@
extern void bind_variable(lispobj symbol, lispobj value,void *thread);
extern void unbind(void *thread);
+extern void unbind_variable(lispobj name, void *thread);
extern void unbind_to_here(lispobj *bsp,void *thread);
#endif
diff --git a/src/runtime/funcall.c b/src/runtime/funcall.c
index c3724eb..9236a48 100644
--- a/src/runtime/funcall.c
+++ b/src/runtime/funcall.c
@@ -27,11 +27,13 @@ extern lispobj call_into_lisp(lispobj fun, lispobj *args, int nargs);
static inline lispobj
safe_call_into_lisp(lispobj fun, lispobj *args, int nargs)
{
+#ifndef LISP_FEATURE_SB_SAFEPOINT
/* SIG_STOP_FOR_GC needs to be enabled before we can call lisp:
* otherwise two threads racing here may deadlock: the other will
* wait on the GC lock, and the other cannot stop the first
* one... */
check_gc_signals_unblocked_or_lose(0);
+#endif
return call_into_lisp(fun, args, nargs);
}
diff --git a/src/runtime/gc-common.c b/src/runtime/gc-common.c
old mode 100644
new mode 100755
index 6816760..96ac8df
--- a/src/runtime/gc-common.c
+++ b/src/runtime/gc-common.c
@@ -2643,7 +2643,7 @@ maybe_gc(os_context_t *context)
* A kludgy alternative is to propagate the sigmask change to the
* outer context.
*/
-#ifndef LISP_FEATURE_WIN32
+#if !(defined(LISP_FEATURE_WIN32) || defined(LISP_FEATURE_SB_SAFEPOINT))
check_gc_signals_unblocked_or_lose(os_context_sigmask_addr(context));
unblock_gc_signals(0, 0);
#endif
@@ -2668,8 +2668,10 @@ maybe_gc(os_context_t *context)
sigset_t *context_sigmask = os_context_sigmask_addr(context);
if (!deferrables_blocked_p(context_sigmask)) {
thread_sigmask(SIG_SETMASK, context_sigmask, 0);
+#ifndef LISP_FEATURE_SB_SAFEPOINT
check_gc_signals_unblocked_or_lose(0);
#endif
+#endif
FSHOW((stderr, "/maybe_gc: calling POST_GC\n"));
funcall0(StaticSymbolFunction(POST_GC));
#ifndef LISP_FEATURE_WIN32
diff --git a/src/runtime/gencgc.c b/src/runtime/gencgc.c
old mode 100644
new mode 100755
index a73bdca..175be61
--- a/src/runtime/gencgc.c
+++ b/src/runtime/gencgc.c
@@ -3423,7 +3423,41 @@ garbage_collect_generation(generation_index_t generation, int raise)
for_each_thread(th) {
void **ptr;
void **esp=(void **)-1;
-#ifdef LISP_FEATURE_SB_THREAD
+ if (th->state == STATE_DEAD)
+ continue;
+# if defined(LISP_FEATURE_SB_SAFEPOINT)
+ /* Conservative collect_garbage is always invoked with a
+ * foreign C call or an interrupt handler on top of every
+ * existing thread, so the stored SP in each thread
+ * structure is valid, no matter which thread we are looking
+ * at. For threads that were running Lisp code, the pitstop
+ * and edge functions maintain this value within the
+ * interrupt or exception handler. */
+ esp = os_get_csp(th);
+ assert_on_stack(th, esp);
+
+ /* In addition to pointers on the stack, also preserve the
+ * return PC, the only value from the context that we need
+ * in addition to the SP. The return PC gets saved by the
+ * foreign call wrapper, and removed from the control stack
+ * into a register. */
+ preserve_pointer(th->pc_around_foreign_call);
+
+ /* And on platforms with interrupts: scavenge ctx registers. */
+
+ /* Disabled on Windows, because it does not have an explicit
+ * stack of `interrupt_contexts'. The reported CSP has been
+ * chosen so that the current context on the stack is
+ * covered by the stack scan. See also set_csp_from_context(). */
+# ifndef LISP_FEATURE_WIN32
+ if (th != arch_os_get_current_thread()) {
+ long k = fixnum_value(
+ SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX,th));
+ while (k > 0)
+ preserve_context_registers(th->interrupt_contexts[--k]);
+ }
+# endif
+# elif defined(LISP_FEATURE_SB_THREAD)
long i,free;
if(th==arch_os_get_current_thread()) {
/* Somebody is going to burn in hell for this, but casting
@@ -3442,9 +3476,12 @@ garbage_collect_generation(generation_index_t generation, int raise)
}
}
}
-#else
+# else
esp = (void **)((void *)&raise);
-#endif
+# endif
+ if (!esp || esp == (void*) -1)
+ lose("garbage_collect: no SP known for thread %x (OS %x)",
+ th, th->os_thread);
for (ptr = ((void **)th->control_stack_end)-1; ptr >= esp; ptr--) {
preserve_pointer(*ptr);
}
@@ -4170,6 +4207,9 @@ general_alloc_internal(long nbytes, int page_type_flag, struct alloc_region *reg
* section */
SetSymbolValue(GC_PENDING,T,thread);
if (SymbolValue(GC_INHIBIT,thread) == NIL) {
+#ifdef LISP_FEATURE_SB_SAFEPOINT
+ thread_register_gc_trigger();
+#else
set_pseudo_atomic_interrupted(thread);
#ifdef LISP_FEATURE_PPC
/* PPC calls alloc() from a trap or from pa_alloc(),
@@ -4183,12 +4223,14 @@ general_alloc_internal(long nbytes, int page_type_flag, struct alloc_region *reg
#else
maybe_save_gc_mask_and_block_deferrables(NULL);
#endif
+#endif
}
}
}
new_obj = gc_alloc_with_region(nbytes, page_type_flag, region, 0);
#ifndef LISP_FEATURE_WIN32
+ /* for sb-prof, and not supported on Windows yet */
alloc_signal = SymbolValue(ALLOC_SIGNAL,thread);
if ((alloc_signal & FIXNUM_TAG_MASK) == 0) {
if ((signed long) alloc_signal <= 0) {
diff --git a/src/runtime/globals.h b/src/runtime/globals.h
index b0e812b..fc8ad96 100644
--- a/src/runtime/globals.h
+++ b/src/runtime/globals.h
@@ -77,6 +77,11 @@ extern lispobj *current_dynamic_space;
extern void globals_init(void);
+#ifdef LISP_FEATURE_SB_SAFEPOINT
+# define GC_SAFEPOINT_PAGE_ADDR ((lispobj) gc_safepoint_page)
+extern char gc_safepoint_page[];
+#endif
+
#else /* LANGUAGE_ASSEMBLY */
# ifdef LISP_FEATURE_MIPS
diff --git a/src/runtime/interrupt.c b/src/runtime/interrupt.c
index 6eccb2d..2a82a2e 100644
--- a/src/runtime/interrupt.c
+++ b/src/runtime/interrupt.c
@@ -302,7 +302,7 @@ sigaddset_blockable(sigset_t *sigset)
void
sigaddset_gc(sigset_t *sigset)
{
-#ifdef LISP_FEATURE_SB_THREAD
+#ifdef THREADS_USING_GCSIGNAL
sigaddset(sigset,SIG_STOP_FOR_GC);
#endif
}
@@ -366,6 +366,7 @@ check_blockables_blocked_or_lose(sigset_t *sigset)
#endif
}
+#ifndef LISP_FEATURE_SB_SAFEPOINT
#if !defined(LISP_FEATURE_WIN32)
boolean
gc_signals_blocked_p(sigset_t *sigset)
@@ -391,6 +392,7 @@ check_gc_signals_blocked_or_lose(sigset_t *sigset)
lose("gc signals unblocked\n");
#endif
}
+#endif
void
block_deferrable_signals(sigset_t *where, sigset_t *old)
@@ -408,6 +410,7 @@ block_blockable_signals(sigset_t *where, sigset_t *old)
#endif
}
+#ifndef LISP_FEATURE_SB_SAFEPOINT
void
block_gc_signals(sigset_t *where, sigset_t *old)
{
@@ -415,6 +418,7 @@ block_gc_signals(sigset_t *where, sigset_t *old)
block_signals(&gc_sigset, where, old);
#endif
}
+#endif
void
unblock_deferrable_signals(sigset_t *where, sigset_t *old)
@@ -422,7 +426,9 @@ unblock_deferrable_signals(sigset_t *where, sigset_t *old)
#ifndef LISP_FEATURE_WIN32
if (interrupt_handler_pending_p())
lose("unblock_deferrable_signals: losing proposition\n");
+#ifndef LISP_FEATURE_SB_SAFEPOINT
check_gc_signals_unblocked_or_lose(where);
+#endif
unblock_signals(&deferrable_sigset, where, old);
#endif
}
@@ -435,6 +441,7 @@ unblock_blockable_signals(sigset_t *where, sigset_t *old)
#endif
}
+#ifndef LISP_FEATURE_SB_SAFEPOINT
void
unblock_gc_signals(sigset_t *where, sigset_t *old)
{
@@ -442,12 +449,14 @@ unblock_gc_signals(sigset_t *where, sigset_t *old)
unblock_signals(&gc_sigset, where, old);
#endif
}
+#endif
void
unblock_signals_in_context_and_maybe_warn(os_context_t *context)
{
#ifndef LISP_FEATURE_WIN32
sigset_t *sigset = os_context_sigmask_addr(context);
+#ifndef LISP_FEATURE_SB_SAFEPOINT
if (all_signals_blocked_p(sigset, &gc_sigset, "gc")) {
corruption_warning_and_maybe_lose(
"Enabling blocked gc signals to allow returning to Lisp without risking\n\
@@ -455,6 +464,7 @@ gc deadlocks. Since GC signals are only blocked in signal handlers when \n\
they are not safe to interrupt at all, this is a pretty severe occurrence.\n");
unblock_gc_signals(sigset, 0);
}
+#endif
if (!interrupt_handler_pending_p()) {
unblock_deferrable_signals(sigset, 0);
}
@@ -477,6 +487,7 @@ check_interrupts_enabled_or_lose(os_context_t *context)
* 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
void
maybe_save_gc_mask_and_block_deferrables(sigset_t *sigset)
{
@@ -515,6 +526,7 @@ maybe_save_gc_mask_and_block_deferrables(sigset_t *sigset)
thread_sigmask(SIG_SETMASK,&oldset,0);
#endif
}
+#endif
/* Are we leaving WITH-GCING and already running with interrupts
* enabled, without the protection of *GC-INHIBIT* T and there is gc
@@ -589,9 +601,11 @@ 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
/* If deferrables are unblocked then we are open to signals
* that run lisp code. */
check_gc_signals_unblocked_or_lose(sigset);
+#endif
}
#endif
}
@@ -774,7 +788,9 @@ interrupt_internal_error(os_context_t *context, boolean continuable)
/* Allocate the SAP object while the interrupts are still
* disabled. */
+#ifndef LISP_FEATURE_SB_SAFEPOINT
unblock_gc_signals(0, 0);
+#endif
context_sap = alloc_sap(context);
#ifndef LISP_FEATURE_WIN32
@@ -840,7 +856,11 @@ interrupt_handle_pending(os_context_t *context)
FSHOW_SIGNAL((stderr, "/entering interrupt_handle_pending\n"));
check_blockables_blocked_or_lose(0);
-
+#ifndef LISP_FEATURE_SB_SAFEPOINT
+ /*
+ * (On safepoint builds, there is no gc_blocked_deferrables nor
+ * SIG_STOP_FOR_GC.)
+ */
/* If GC/SIG_STOP_FOR_GC struck during PA and there was no pending
* handler, then the pending mask was saved and
* gc_blocked_deferrables set. Hence, there can be no pending
@@ -864,11 +884,15 @@ interrupt_handle_pending(os_context_t *context)
#endif
data->gc_blocked_deferrables = 0;
}
+#endif
if (SymbolValue(GC_INHIBIT,thread)==NIL) {
void *original_pending_handler = data->pending_handler;
-#ifdef LISP_FEATURE_SB_THREAD
+#ifdef LISP_FEATURE_SB_SAFEPOINT
+ /* handles the STOP_FOR_GC_PENDING case */
+ thread_pitstop(context);
+#elif defined(LISP_FEATURE_SB_THREAD)
if (SymbolValue(STOP_FOR_GC_PENDING,thread) != NIL) {
/* STOP_FOR_GC_PENDING and GC_PENDING are cleared by
* the signal handler if it actually stops us. */
@@ -925,7 +949,7 @@ interrupt_handle_pending(os_context_t *context)
* that should be handled on the spot. */
if (SymbolValue(GC_PENDING,thread) != NIL)
lose("GC_PENDING after doing gc.");
-#ifdef LISP_FEATURE_SB_THREAD
+#ifdef THREADS_USING_GCSIGNAL
if (SymbolValue(STOP_FOR_GC_PENDING,thread) != NIL)
lose("STOP_FOR_GC_PENDING after doing gc.");
#endif
@@ -1021,12 +1045,17 @@ interrupt_handle_now(int signal, siginfo_t *info, os_context_t *context)
lispobj info_sap, context_sap;
/* Leave deferrable signals blocked, the handler itself will
* allow signals again when it sees fit. */
+#ifndef LISP_FEATURE_SB_SAFEPOINT
unblock_gc_signals(0, 0);
+#endif
context_sap = alloc_sap(context);
info_sap = alloc_sap(info);
FSHOW_SIGNAL((stderr,"/calling Lisp-level handler\n"));
+#ifdef LISP_FEATURE_SB_SAFEPOINT
+ WITH_GC_AT_SAFEPOINTS_ONLY()
+#endif
funcall3(handler.lisp,
make_fixnum(signal),
info_sap,
@@ -1192,7 +1221,7 @@ low_level_maybe_now_maybe_later(int signal, siginfo_t *info, void *void_context)
}
#endif
-#ifdef LISP_FEATURE_SB_THREAD
+#ifdef THREADS_USING_GCSIGNAL
/* This function must not cons, because that may trigger a GC. */
void
@@ -1305,10 +1334,13 @@ extern int *context_eflags_addr(os_context_t *context);
extern lispobj call_into_lisp(lispobj fun, lispobj *args, int nargs);
extern void post_signal_tramp(void);
extern void call_into_lisp_tramp(void);
+
void
-arrange_return_to_lisp_function(os_context_t *context, lispobj function)
+arrange_return_to_c_function(os_context_t *context,
+ call_into_lisp_lookalike funptr,
+ lispobj function)
{
-#ifndef LISP_FEATURE_WIN32
+#if !(defined(LISP_FEATURE_WIN32) || defined(LISP_FEATURE_SB_SAFEPOINT))
check_gc_signals_unblocked_or_lose
(os_context_sigmask_addr(context));
#endif
@@ -1386,7 +1418,7 @@ arrange_return_to_lisp_function(os_context_t *context, lispobj function)
*(register_save_area + 8) = *context_eflags_addr(context);
*os_context_pc_addr(context) =
- (os_context_register_t) call_into_lisp_tramp;
+ (os_context_register_t) funptr;
*os_context_register_addr(context,reg_ECX) =
(os_context_register_t) register_save_area;
#else
@@ -1451,7 +1483,7 @@ arrange_return_to_lisp_function(os_context_t *context, lispobj function)
#ifdef LISP_FEATURE_X86
#if !defined(LISP_FEATURE_DARWIN)
- *os_context_pc_addr(context) = (os_context_register_t)call_into_lisp;
+ *os_context_pc_addr(context) = (os_context_register_t)funptr;
*os_context_register_addr(context,reg_ECX) = 0;
*os_context_register_addr(context,reg_EBP) = (os_context_register_t)(sp-2);
#ifdef __NetBSD__
@@ -1463,7 +1495,7 @@ arrange_return_to_lisp_function(os_context_t *context, lispobj function)
#endif /* LISP_FEATURE_DARWIN */
#elif defined(LISP_FEATURE_X86_64)
- *os_context_pc_addr(context) = (os_context_register_t)call_into_lisp;
+ *os_context_pc_addr(context) = (os_context_register_t)funptr;
*os_context_register_addr(context,reg_RCX) = 0;
*os_context_register_addr(context,reg_RBP) = (os_context_register_t)(sp-2);
*os_context_register_addr(context,reg_RSP) = (os_context_register_t)(sp-18);
@@ -1489,6 +1521,16 @@ arrange_return_to_lisp_function(os_context_t *context, lispobj function)
(long)function));
}
+void
+arrange_return_to_lisp_function(os_context_t *context, lispobj function)
+{
+#if defined(LISP_FEATURE_DARWIN)
+ arrange_return_to_c_function(context, call_into_lisp_tramp, function);
+#else
+ arrange_return_to_c_function(context, call_into_lisp, function);
+#endif
+}
+
/* KLUDGE: Theoretically the approach we use for undefined alien
* variables should work for functions as well, but on PPC/Darwin
* we get bus error at bogus addresses instead, hence this workaround,
@@ -1754,8 +1796,13 @@ undoably_install_low_level_interrupt_handler (int signal,
sa.sa_flags = SA_SIGINFO | SA_RESTART
| (sigaction_nodefer_works ? SA_NODEFER : 0);
#ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
- if(signal==SIG_MEMORY_FAULT)
+ if(signal==SIG_MEMORY_FAULT) {
sa.sa_flags |= SA_ONSTACK;
+# ifdef LISP_FEATURE_SB_SAFEPOINT
+ sigaddset(&sa.sa_mask, SIGRTMIN);
+ sigaddset(&sa.sa_mask, SIGRTMIN+1);
+# endif
+ }
#endif
sigaction(signal, &sa, NULL);
@@ -1890,7 +1937,9 @@ unhandled_trap_error(os_context_t *context)
{
lispobj context_sap;
fake_foreign_function_call(context);
+#ifndef LISP_FEATURE_SB_SAFEPOINT
unblock_gc_signals(0, 0);
+#endif
context_sap = alloc_sap(context);
#ifndef LISP_FEATURE_WIN32
thread_sigmask(SIG_SETMASK, os_context_sigmask_addr(context), 0);
@@ -1933,6 +1982,20 @@ handle_trap(os_context_t *context, int trap)
arch_handle_single_step_trap(context, trap);
break;
#endif
+#ifdef LISP_FEATURE_SB_SAFEPOINT
+ case trap_GlobalSafepoint:
+ fake_foreign_function_call(context);
+ thread_in_lisp_raised(context);
+ undo_fake_foreign_function_call(context);
+ arch_skip_instruction(context);
+ break;
+ case trap_CspSafepoint:
+ fake_foreign_function_call(context);
+ thread_in_safety_transition(context);
+ undo_fake_foreign_function_call(context);
+ arch_skip_instruction(context);
+ break;
+#endif
case trap_Halt:
fake_foreign_function_call(context);
lose("%%PRIMITIVE HALT called; the party is over.\n");
diff --git a/src/runtime/interrupt.h b/src/runtime/interrupt.h
index 05c6638..a148236 100644
--- a/src/runtime/interrupt.h
+++ b/src/runtime/interrupt.h
@@ -123,10 +123,15 @@ struct interrupt_data {
#endif
};
+typedef lispobj (*call_into_lisp_lookalike)(
+ lispobj fun, lispobj *args, int nargs);
+
extern boolean interrupt_handler_pending_p(void);
extern void interrupt_init(void);
extern void fake_foreign_function_call(os_context_t* context);
extern void undo_fake_foreign_function_call(os_context_t* context);
+extern void arrange_return_to_c_function(
+ os_context_t *, call_into_lisp_lookalike, lispobj);
extern void arrange_return_to_lisp_function(os_context_t *, lispobj);
extern void interrupt_handle_now(int, siginfo_t*, os_context_t*);
extern void interrupt_handle_pending(os_context_t*);
@@ -171,4 +176,9 @@ extern void lisp_memory_fault_error(os_context_t *context,
extern void lower_thread_control_stack_guard_page(struct thread *th);
extern void reset_thread_control_stack_guard_page(struct thread *th);
+#if defined(LISP_FEATURE_SB_SAFEPOINT) && !defined(LISP_FEATURE_WIN32)
+void rtmin0_handler(int signal, siginfo_t *info, os_context_t *context);
+void rtmin1_handler(int signal, siginfo_t *info, os_context_t *context);
+#endif
+
#endif
diff --git a/src/runtime/linux-os.c b/src/runtime/linux-os.c
index 151aea0..43cd19f 100644
--- a/src/runtime/linux-os.c
+++ b/src/runtime/linux-os.c
@@ -435,6 +435,10 @@ sigsegv_handler(int signal, siginfo_t *info, os_context_t *context)
}
#endif
+#ifdef LISP_FEATURE_SB_SAFEPOINT
+ if (!handle_safepoint_violation(context, addr))
+#endif
+
#ifdef LISP_FEATURE_GENCGC
if (!gencgc_handle_wp_violation(addr))
#else
@@ -450,8 +454,10 @@ os_install_interrupt_handlers(void)
undoably_install_low_level_interrupt_handler(SIG_MEMORY_FAULT,
sigsegv_handler);
#ifdef LISP_FEATURE_SB_THREAD
+# ifndef LISP_FEATURE_SB_SAFEPOINT
undoably_install_low_level_interrupt_handler(SIG_STOP_FOR_GC,
sig_stop_for_gc_handler);
+# endif
#endif
}
diff --git a/src/runtime/runtime.h b/src/runtime/runtime.h
index 3c29b27..e99d86b 100644
--- a/src/runtime/runtime.h
+++ b/src/runtime/runtime.h
@@ -29,6 +29,12 @@
#define thread_mutex_unlock(l) 0
#endif
+#if defined(LISP_FEATURE_SB_SAFEPOINT)
+void map_gc_page();
+void unmap_gc_page();
+int check_pending_interrupts();
+#endif
+
/* Block blockable interrupts for each SHOW, if not 0. */
#define QSHOW_SIGNAL_SAFE 1
/* Enable extra-verbose low-level debugging output for signals? (You
@@ -259,4 +265,8 @@ other_immediate_lowtag_p(lispobj header)
extern void *successful_malloc (size_t size);
extern char *copied_string (char *string);
+#if defined(LISP_FEATURE_SB_THREAD) && !defined(LISP_FEATURE_SB_SAFEPOINT)
+# define THREADS_USING_GCSIGNAL 1
+#endif
+
#endif /* _SBCL_RUNTIME_H_ */
diff --git a/src/runtime/safepoint.c b/src/runtime/safepoint.c
new file mode 100644
index 0000000..953b8e9
--- /dev/null
+++ b/src/runtime/safepoint.c
@@ -0,0 +1,775 @@
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+#include "sbcl.h"
+
+#ifdef LISP_FEATURE_SB_SAFEPOINT /* entire file */
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#ifndef LISP_FEATURE_WIN32
+#include <sched.h>
+#endif
+#include <signal.h>
+#include <stddef.h>
+#include <errno.h>
+#include <sys/types.h>
+#ifndef LISP_FEATURE_WIN32
+#include <sys/wait.h>
+#endif
+#ifdef LISP_FEATURE_MACH_EXCEPTION_HANDLER
+#include <mach/mach.h>
+#include <mach/mach_error.h>
+#include <mach/mach_types.h>
+#endif
+#include "runtime.h"
+#include "validate.h"
+#include "thread.h"
+#include "arch.h"
+#include "target-arch-os.h"
+#include "os.h"
+#include "globals.h"
+#include "dynbind.h"
+#include "genesis/cons.h"
+#include "genesis/fdefn.h"
+#include "interr.h"
+#include "alloc.h"
+#include "gc-internal.h"
+#include "pseudo-atomic.h"
+#include "interrupt.h"
+#include "lispregs.h"
+
+/* Temporarily, this macro is a wrapper for FSHOW_SIGNAL. Ultimately,
+ * it will be restored to its full win32 branch functionality, where it
+ * provides a very useful tracing mechanism that is configurable at
+ * runtime. */
+#define odxprint_show(what, fmt, args...) \
+ do { \
+ struct thread *__self = arch_os_get_current_thread(); \
+ FSHOW_SIGNAL((stderr, "[%p/%p:%s] " fmt "\n", \
+ __self, \
+ __self->os_thread, \
+ #what, \
+ ##args)); \
+ } while (0)
+
+#if QSHOW_SIGNALS
+# define odxprint odxprint_show
+#else
+# define odxprint(what, fmt, args...) do {} while (0)
+#endif
+
+#if !defined(LISP_FEATURE_WIN32)
+/* win32-os.c covers these, but there is no unixlike-os.c, so the normal
+ * definition goes here. Fixme: (Why) don't these work for Windows?
+ */
+void
+map_gc_page()
+{
+ odxprint(misc, "map_gc_page");
+ os_protect((void *) GC_SAFEPOINT_PAGE_ADDR,
+ 4,
+ OS_VM_PROT_READ | OS_VM_PROT_WRITE);
+}
+
+void
+unmap_gc_page()
+{
+ odxprint(misc, "unmap_gc_page");
+ os_protect((void *) GC_SAFEPOINT_PAGE_ADDR, 4, OS_VM_PROT_NONE);
+}
+#endif /* !LISP_FEATURE_WIN32 */
+
+static inline int
+thread_may_gc()
+{
+ /* Thread may gc if all of these are true:
+ * 1) GC_INHIBIT == NIL (outside of protected part of without-gcing)
+ * 2) GC_PENDING != :in-progress (outside of recursion protection)
+ * Note that we are in a safepoint here, which is always outside of PA. */
+
+ struct thread *self = arch_os_get_current_thread();
+ return (SymbolValue(GC_INHIBIT, self) == NIL
+ && (SymbolTlValue(GC_PENDING, self) == T ||
+ SymbolTlValue(GC_PENDING, self) == NIL));
+}
+
+int
+on_stack_p(struct thread *th, void *esp)
+{
+ return (void *)th->control_stack_start
+ <= esp && esp
+ < (void *)th->control_stack_end;
+}
+
+#ifndef LISP_FEATURE_WIN32
+/* (Technically, we still allocate an altstack even on Windows. Since
+ * Windows has a contiguous stack with an automatic guard page of
+ * user-configurable size instead of an alternative stack though, the
+ * SBCL-allocated altstack doesn't actually apply and won't be used.) */
+int
+on_altstack_p(struct thread *th, void *esp)
+{
+ void *start = (void *)th+dynamic_values_bytes;
+ void *end = (char *)start + 32*SIGSTKSZ;
+ return start <= esp && esp < end;
+}
+#endif
+
+void
+assert_on_stack(struct thread *th, void *esp)
+{
+ if (on_stack_p(th, esp))
+ return;
+#ifndef LISP_FEATURE_WIN32
+ if (on_altstack_p(th, esp))
+ lose("thread %p: esp on altstack: %p", th, esp);
+#endif
+ lose("thread %p: bogus esp: %p", th, esp);
+}
+
+// returns 0 if skipped, 1 otherwise
+int
+check_pending_gc(os_context_t *ctx)
+{
+ odxprint(misc, "check_pending_gc");
+ struct thread * self = arch_os_get_current_thread();
+ int done = 0;
+ sigset_t sigset;
+
+ if ((SymbolValue(IN_SAFEPOINT,self) == T) &&
+ ((SymbolValue(GC_INHIBIT,self) == NIL) &&
+ (SymbolValue(GC_PENDING,self) == NIL))) {
+ SetSymbolValue(IN_SAFEPOINT,NIL,self);
+ }
+ if (thread_may_gc() && (SymbolValue(IN_SAFEPOINT, self) == NIL)) {
+ if ((SymbolTlValue(GC_PENDING, self) == T)) {
+ lispobj gc_happened = NIL;
+
+ bind_variable(IN_SAFEPOINT,T,self);
+ block_deferrable_signals(NULL,&sigset);
+ if(SymbolTlValue(GC_PENDING,self)==T)
+ gc_happened = funcall0(StaticSymbolFunction(SUB_GC));
+ unbind_variable(IN_SAFEPOINT,self);
+ thread_sigmask(SIG_SETMASK,&sigset,NULL);
+ if (gc_happened == T) {
+ /* POST_GC wants to enable interrupts */
+ if (SymbolValue(INTERRUPTS_ENABLED,self) == T ||
+ SymbolValue(ALLOW_WITH_INTERRUPTS,self) == T) {
+ odxprint(misc, "going to call POST_GC");
+ funcall0(StaticSymbolFunction(POST_GC));
+ }
+ done = 1;
+ }
+ }
+ }
+ return done;
+}
+
+/* Several ideas on interthread signalling should be
+ tried. Implementation below was chosen for its moderate size and
+ relative simplicity.
+
+ Mutex is the only (conventional) system synchronization primitive
+ used by it. Some of the code below looks weird with this
+ limitation; rwlocks, Windows Event Objects, or perhaps pthread
+ barriers could be used to improve clarity.
+
+ No condvars here: our pthreads_win32 is great, but it doesn't
+ provide wait morphing optimization; let's avoid extra context
+ switches and extra contention. */
+
+struct gc_dispatcher {
+
+ /* Held by the first thread that decides to signal all others, for
+ the entire period while common GC safepoint page is
+ unmapped. This thread is called `STW (stop-the-world)
+ initiator' below. */
+ pthread_mutex_t mx_gpunmapped;
+
+ /* Held by STW initiator while it updates th_stw_initiator and
+ takes other locks in this structure */
+ pthread_mutex_t mx_gptransition;
+
+ /* Held by STW initiator until the world should be started (GC
+ complete, thruptions delivered). */
+ pthread_mutex_t mx_gcing;
+
+ /* Held by a SUB-GC's gc_stop_the_world() when thread in SUB-GC
+ holds the GC Lisp-level mutex, but _couldn't_ become STW
+ initiator (i.e. another thread is already stopping the
+ world). */
+ pthread_mutex_t mx_subgc;
+
+ /* First thread (at this round) that decided to stop the world */
+ struct thread *th_stw_initiator;
+
+ /* Thread running SUB-GC under the `supervision' of STW
+ initiator */
+ struct thread *th_subgc;
+
+ /* Stop counter. Nested gc-stop-the-world and gc-start-the-world
+ work without thundering herd. */
+ int stopped;
+
+} gc_dispatcher = {
+ /* mutexes lazy initialized, other data initially zeroed */
+ .mx_gpunmapped = PTHREAD_MUTEX_INITIALIZER,
+ .mx_gptransition = PTHREAD_MUTEX_INITIALIZER,
+ .mx_gcing = PTHREAD_MUTEX_INITIALIZER,
+ .mx_subgc = PTHREAD_MUTEX_INITIALIZER,
+};
+
+
+/* set_thread_csp_access -- alter page permissions for not-in-Lisp
+ flag (Lisp Stack Top) of the thread `p'. The flag may be modified
+ if `writable' is true.
+
+ Return true if there is a non-null value in the flag.
+
+ When a thread enters C code or leaves it, a per-thread location is
+ modified. That machine word serves as a not-in-Lisp flag; for
+ convenience, when in C, it's filled with a topmost stack location
+ that may contain Lisp data. When thread is in Lisp, the word
+ contains NULL.
+
+ GENCGC uses each thread's flag value for conservative garbage collection.
+
+ There is a full VM page reserved for this word; page permissions
+ are switched to read-only for race-free examine + wait + use
+ scenarios. */
+static inline boolean
+set_thread_csp_access(struct thread* p, boolean writable)
+{
+ os_protect((os_vm_address_t) p->csp_around_foreign_call,
+ THREAD_CSP_PAGE_SIZE,
+ writable? (OS_VM_PROT_READ|OS_VM_PROT_WRITE)
+ : (OS_VM_PROT_READ));
+ return !!*p->csp_around_foreign_call;
+}
+
+
+/* maybe_become_stw_initiator -- if there is no stop-the-world action
+ in progress, begin it by unmapping GC page, and record current
+ thread as STW initiator.
+
+ Return true if current thread becomes a GC initiator, or already
+ _is_ a STW initiator.
+
+ Unlike gc_stop_the_world and gc_start_the_world (that should be
+ used in matching pairs), maybe_become_stw_initiator is idempotent
+ within a stop-restart cycle. With this call, a thread may `reserve
+ the right' to stop the world as early as it wants. */
+
+static inline boolean
+maybe_become_stw_initiator()
+{
+ struct thread* self = arch_os_get_current_thread();
+
+ /* Double-checked locking. Possible word tearing on some
+ architectures, FIXME FIXME, but let's think of it when GENCGC
+ and threaded SBCL is ported to them. */
+ if (!gc_dispatcher.th_stw_initiator) {
+ odxprint(misc,"NULL STW BEFORE GPTRANSITION");
+ pthread_mutex_lock(&gc_dispatcher.mx_gptransition);
+ /* We hold mx_gptransition. Is there no STW initiator yet? */
+ if (!gc_dispatcher.th_stw_initiator) {
+ odxprint(misc,"NULL STW IN GPTRANSITION, REPLACING");
+ /* Then we are... */
+ gc_dispatcher.th_stw_initiator = self;
+
+ /* hold mx_gcing until we restart the world */
+ pthread_mutex_lock(&gc_dispatcher.mx_gcing);
+
+ /* and mx_gpunmapped until we remap common GC page */
+ pthread_mutex_lock(&gc_dispatcher.mx_gpunmapped);
+
+ /* we unmap it; other threads running Lisp code will now
+ trap. */
+ unmap_gc_page();
+
+ /* stop counter; the world is not stopped yet. */
+ gc_dispatcher.stopped = 0;
+ }
+ pthread_mutex_unlock(&gc_dispatcher.mx_gptransition);
+ }
+ return gc_dispatcher.th_stw_initiator == self;
+}
+
+
+/* maybe_let_the_world_go -- if current thread is a STW initiator,
+ unlock internal GC structures, and return true. */
+static inline boolean
+maybe_let_the_world_go()
+{
+ struct thread* self = arch_os_get_current_thread();
+ if (gc_dispatcher.th_stw_initiator == self) {
+ pthread_mutex_lock(&gc_dispatcher.mx_gptransition);
+ if (gc_dispatcher.th_stw_initiator == self) {
+ gc_dispatcher.th_stw_initiator = NULL;
+ }
+ pthread_mutex_unlock(&gc_dispatcher.mx_gcing);
+ pthread_mutex_unlock(&gc_dispatcher.mx_gptransition);
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+
+/* gc_stop_the_world -- become STW initiator (waiting for other GCs to
+ complete if necessary), and make sure all other threads are either
+ stopped or gc-safe (i.e. running foreign calls).
+
+ If GC initiator already exists, gc_stop_the_world() either waits
+ for its completion, or cooperates with it: e.g. concurrent pending
+ thruption handler allows (SUB-GC) to complete under its
+ `supervision'.
+
+ Code sections bounded by gc_stop_the_world and gc_start_the_world
+ may be nested; inner calls don't stop or start threads,
+ decrementing or incrementing the stop counter instead. */
+void
+gc_stop_the_world()
+{
+ struct thread* self = arch_os_get_current_thread(), *p;
+ if (SymbolTlValue(GC_INHIBIT,self)!=T) {
+ /* If GC is enabled, this thread may wait for current STW
+ initiator without causing deadlock. */
+ if (!maybe_become_stw_initiator()) {
+ pthread_mutex_lock(&gc_dispatcher.mx_gcing);
+ maybe_become_stw_initiator();
+ pthread_mutex_unlock(&gc_dispatcher.mx_gcing);
+ }
+ /* Now _this thread_ should be STW initiator */
+ gc_assert(self == gc_dispatcher.th_stw_initiator);
+ } else {
+ /* GC inhibited; e.g. we are inside SUB-GC */
+ if (!maybe_become_stw_initiator()) {
+ /* Some trouble. Inside SUB-GC, holding the Lisp-side
+ mutex, but some other thread is stopping the world. */
+ {
+ /* In SUB-GC, holding mutex; other thread wants to
+ GC. */
+ if (gc_dispatcher.th_subgc == self) {
+ /* There is an outer gc_stop_the_world() by _this_
+ thread, running subordinately to initiator.
+ Just increase stop counter. */
+ ++gc_dispatcher.stopped;
+ return;
+ }
+ /* Register as subordinate collector thread: take
+ mx_subgc */
+ pthread_mutex_lock(&gc_dispatcher.mx_subgc);
+ ++gc_dispatcher.stopped;
+
+ /* Unlocking thread's own thread_qrl() designates
+ `time to examine me' to other threads. */
+ pthread_mutex_unlock(thread_qrl(self));
+
+ /* STW (GC) initiator thread will see our thread needs
+ to finish GC. It will stop the world and itself,
+ and unlock its qrl. */
+ pthread_mutex_lock(thread_qrl(gc_dispatcher.th_stw_initiator));
+ return;
+ }
+ }
+ }
+ if (!gc_dispatcher.stopped++) {
+ /* Outermost stop: signal other threads */
+ pthread_mutex_lock(&all_threads_lock);
+ /* Phase 1: ensure all threads are aware of the need to stop,
+ or locked in the foreign code. */
+ for_each_thread(p) {
+ pthread_mutex_t *p_qrl = thread_qrl(p);
+ if (p==self)
+ continue;
+
+ /* Read-protect p's flag */
+ if (!set_thread_csp_access(p,0)) {
+ odxprint(safepoints,"taking qrl %p of %p", p_qrl, p);
+ /* Thread is in Lisp, so it should trap (either in
+ Lisp or in Lisp->FFI transition). Trap handler
+ unlocks thread_qrl(p); when it happens, we're safe
+ to examine that thread. */
+ pthread_mutex_lock(p_qrl);
+ odxprint(safepoints,"taken qrl %p of %p", p_qrl, p);
+ /* Mark thread for the future: should we collect, or
+ wait for its final permission? */
+ if (SymbolTlValue(GC_INHIBIT,p)!=T) {
+ SetTlSymbolValue(GC_SAFE,T,p);
+ } else {
+ SetTlSymbolValue(GC_SAFE,NIL,p);
+ }
+ pthread_mutex_unlock(p_qrl);
+ } else {
+ /* In C; we just disabled writing. */
+ {
+ if (SymbolTlValue(GC_INHIBIT,p)==T) {
+ /* GC inhibited there */
+ SetTlSymbolValue(STOP_FOR_GC_PENDING,T,p);
+ /* Enable writing. Such threads trap by
+ pending thruption when WITHOUT-GCING
+ section ends */
+ set_thread_csp_access(p,1);
+ SetTlSymbolValue(GC_SAFE,NIL,p);
+ } else {
+ /* Thread allows concurrent GC. It runs in C
+ (not a mutator), its in-Lisp flag is
+ read-only (so it traps on return). */
+ SetTlSymbolValue(GC_SAFE,T,p);
+ }
+ }
+ }
+ }
+ /* All threads are ready (GC_SAFE == T) or notified (GC_SAFE == NIL). */
+ map_gc_page();
+ pthread_mutex_unlock(&gc_dispatcher.mx_gpunmapped);
+ /* Threads with GC inhibited -- continued */
+ odxprint(safepoints,"after remapping GC page %p",self);
+
+ SetTlSymbolValue(STOP_FOR_GC_PENDING,NIL,self);
+ {
+ struct thread* priority_gc = NULL;
+ for_each_thread(p) {
+ if (p==self)
+ continue;
+ if (SymbolTlValue(GC_SAFE,p)!=T) {
+ /* Wait for thread to `park'. NB it _always_ does
+ it with a pending interrupt trap, so CSP locking is
+ not needed */
+ odxprint(safepoints,"waiting final parking %p (qrl %p)",p, thread_qrl(p));
+ WITH_STATE_SEM(p) {
+ pthread_mutex_lock(thread_qrl(p));
+ if (SymbolTlValue(GC_INHIBIT,p)==T) {
+ /* Concurrent GC invoked manually */
+ gc_assert(!priority_gc); /* Should be at most one at a time */
+ priority_gc = p;
+ }
+ pthread_mutex_unlock(thread_qrl(p));
+ }
+ }
+ if (!os_get_csp(p))
+ lose("gc_stop_the_world: no SP in parked thread: %p", p);
+ }
+ if (priority_gc) {
+ /* This thread is managing the entire process, so it
+ has to allow manually-invoked GC to complete */
+ if (!set_thread_csp_access(self,1)) {
+ /* Create T.O.S. */
+ *self->csp_around_foreign_call = (lispobj)__builtin_frame_address(0);
+ /* Unlock myself */
+ pthread_mutex_unlock(thread_qrl(self));
+ /* Priority GC should take over, holding
+ mx_subgc until it's done. */
+ pthread_mutex_lock(&gc_dispatcher.mx_subgc);
+ /* Lock myself */
+ pthread_mutex_lock(thread_qrl(self));
+ *self->csp_around_foreign_call = 0;
+ SetTlSymbolValue(GC_PENDING,NIL,self);
+ pthread_mutex_unlock(&gc_dispatcher.mx_subgc);
+ } else {
+ /* Unlock myself */
+ pthread_mutex_unlock(thread_qrl(self));
+ /* Priority GC should take over, holding
+ mx_subgc until it's done. */
+ pthread_mutex_lock(&gc_dispatcher.mx_subgc);
+ /* Lock myself */
+ pthread_mutex_lock(thread_qrl(self));
+ /* Unlock sub-gc */
+ pthread_mutex_unlock(&gc_dispatcher.mx_subgc);
+ }
+ }
+ }
+ }
+}
+
+
+/* gc_start_the_world() -- restart all other threads if the call
+ matches the _outermost_ gc_stop_the_world(), or decrement the stop
+ counter. */
+void
+gc_start_the_world()
+{
+ struct thread* self = arch_os_get_current_thread(), *p;
+ if (gc_dispatcher.th_stw_initiator != self) {
+ odxprint(misc,"Unmapper %p self %p",gc_dispatcher.th_stw_initiator,self);
+ gc_assert (gc_dispatcher.th_subgc == self);
+ if (--gc_dispatcher.stopped == 1) {
+ gc_dispatcher.th_subgc = NULL;
+ pthread_mutex_unlock(&gc_dispatcher.mx_subgc);
+ /* GC initiator may continue now */
+ pthread_mutex_unlock(thread_qrl(gc_dispatcher.th_stw_initiator));
+ }
+ return;
+ }
+
+ gc_assert(gc_dispatcher.th_stw_initiator == self);
+
+ if (!--gc_dispatcher.stopped) {
+ for_each_thread(p) {
+ {
+ SetTlSymbolValue(STOP_FOR_GC_PENDING,NIL,p);
+ SetTlSymbolValue(GC_PENDING,NIL,p);
+ }
+ set_thread_csp_access(p,1);
+ }
+ pthread_mutex_unlock(&all_threads_lock);
+ /* Release everyone */
+ maybe_let_the_world_go();
+ }
+}
+
+
+/* in_race_p() -- return TRUE if no other thread is inside SUB-GC with
+ GC-PENDING :IN-PROGRESS. Used to prevent deadlock between manual
+ SUB-GC, auto-gc and thruption. */
+static inline boolean
+in_race_p()
+{
+ struct thread* self = arch_os_get_current_thread(), *p;
+ boolean result = 0;
+ pthread_mutex_lock(&all_threads_lock);
+ for_each_thread(p) {
+ if (p!=self &&
+ SymbolTlValue(GC_PENDING,p)!=T &&
+ SymbolTlValue(GC_PENDING,p)!=NIL) {
+ result = 1;
+ break;
+ }
+ }
+ pthread_mutex_unlock(&all_threads_lock);
+ if (result) {
+ map_gc_page();
+ pthread_mutex_unlock(&gc_dispatcher.mx_gpunmapped);
+ maybe_let_the_world_go();
+ }
+ return result;
+}
+
+static void
+set_csp_from_context(struct thread *self, os_context_t *ctx)
+{
+ void **sp = (void **) *os_context_register_addr(ctx, reg_SP);
+ gc_assert((void **)self->control_stack_start
+ <= sp && sp
+ < (void **)self->control_stack_end);
+ *self->csp_around_foreign_call = (lispobj) sp;
+}
+
+void
+thread_pitstop(os_context_t *ctxptr)
+{
+ struct thread* self = arch_os_get_current_thread();
+ boolean inhibitor = (SymbolTlValue(GC_INHIBIT,self)==T);
+
+ odxprint(safepoints,"pitstop [%p]", ctxptr);
+ if (inhibitor) {
+ SetTlSymbolValue(STOP_FOR_GC_PENDING,T,self);
+ /* Free qrl to let know we're ready... */
+ WITH_STATE_SEM(self) {
+ pthread_mutex_unlock(thread_qrl(self));
+ pthread_mutex_lock(&gc_dispatcher.mx_gpunmapped);
+ pthread_mutex_lock(thread_qrl(self));
+ pthread_mutex_unlock(&gc_dispatcher.mx_gpunmapped);
+ }
+ /* Enable FF-CSP recording (not hurt: will gc at pit-stop, and
+ pit-stop always waits for GC end) */
+ set_thread_csp_access(self,1);
+ } else {
+ if (self == gc_dispatcher.th_stw_initiator && gc_dispatcher.stopped) {
+ set_thread_csp_access(self,1);
+ check_pending_gc(ctxptr);
+ return;
+ }
+ if ((SymbolTlValue(GC_PENDING,self)!=NIL) &&
+ maybe_become_stw_initiator() && !in_race_p()) {
+ gc_stop_the_world();
+ set_thread_csp_access(self,1);
+ check_pending_gc(ctxptr);
+ gc_start_the_world();
+ } else {
+ /* An innocent thread which is not an initiator _and_ is
+ not objecting. */
+ odxprint(safepoints,"pitstop yielding [%p]", ctxptr);
+ if (!set_thread_csp_access(self,1)) {
+ if (os_get_csp(self))
+ lose("thread_pitstop: would lose csp");
+ set_csp_from_context(self, ctxptr);
+ pthread_mutex_unlock(thread_qrl(self));
+ pthread_mutex_lock(&gc_dispatcher.mx_gcing);
+ *self->csp_around_foreign_call = 0;
+ pthread_mutex_lock(thread_qrl(self));
+ pthread_mutex_unlock(&gc_dispatcher.mx_gcing);
+ } else {
+ pthread_mutex_lock(&gc_dispatcher.mx_gcing);
+ set_thread_csp_access(self,1);
+ WITH_GC_AT_SAFEPOINTS_ONLY() {
+ pthread_mutex_unlock(&gc_dispatcher.mx_gcing);
+ }
+ return;
+ }
+ }
+ }
+}
+
+static inline void
+thread_edge(os_context_t *ctxptr)
+{
+ struct thread *self = arch_os_get_current_thread();
+ set_thread_csp_access(self,1);
+ if (os_get_csp(self)) {
+ if (!self->pc_around_foreign_call)
+ return; /* trivialize */
+ odxprint(safepoints,"edge leaving [%p]", ctxptr);
+ if (SymbolTlValue(GC_INHIBIT,self)!=T) {
+ {
+ pthread_mutex_lock(&gc_dispatcher.mx_gcing);
+ odxprint(safepoints,"edge leaving [%p] took gcing", ctxptr);
+ pthread_mutex_unlock(&gc_dispatcher.mx_gcing);
+ odxprint(safepoints,"edge leaving [%p] released gcing", ctxptr);
+ }
+ }
+ } else {
+ /* Entering. */
+ odxprint(safepoints,"edge entering [%p]", ctxptr);
+ if (os_get_csp(self))
+ lose("thread_edge: would lose csp");
+ set_csp_from_context(self, ctxptr);
+ if (SymbolTlValue(GC_INHIBIT,self)!=T) {
+ pthread_mutex_unlock(thread_qrl(self));
+ pthread_mutex_lock(&gc_dispatcher.mx_gcing);
+ *self->csp_around_foreign_call = 0;
+ pthread_mutex_lock(thread_qrl(self));
+ pthread_mutex_unlock(&gc_dispatcher.mx_gcing);
+ } else {
+ SetTlSymbolValue(STOP_FOR_GC_PENDING,T,self);
+ pthread_mutex_unlock(thread_qrl(self));
+
|
Thread View
| Thread | Author | Date |
|---|---|---|
| [Sbcl-commits] master: Add safepoint mechanism | David Lichteblau <lichteblau@us...> |