Add safepoint mechanism
authorDavid Lichteblau <david@lichteblau.com>
Thu, 28 Apr 2011 11:51:35 +0000 (13:51 +0200)
committerDavid Lichteblau <david@lichteblau.com>
Fri, 10 Aug 2012 12:51:45 +0000 (14:51 +0200)
  * 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.

45 files changed:
package-data-list.lisp-expr
src/code/early-impl.lisp
src/code/gc.lisp
src/code/target-signal.lisp
src/code/target-thread.lisp
src/compiler/fndb.lisp
src/compiler/generic/objdef.lisp
src/compiler/generic/parms.lisp
src/compiler/ir2tran.lisp
src/compiler/policies.lisp
src/compiler/x86-64/backend-parms.lisp
src/compiler/x86-64/c-call.lisp
src/compiler/x86-64/macros.lisp
src/compiler/x86-64/parms.lisp
src/compiler/x86-64/system.lisp
src/compiler/x86/c-call.lisp [changed mode: 0644->0755]
src/compiler/x86/macros.lisp
src/compiler/x86/parms.lisp
src/compiler/x86/system.lisp
src/runtime/GNUmakefile
src/runtime/alloc.c
src/runtime/breakpoint.c
src/runtime/bsd-os.c
src/runtime/cpputil.h [new file with mode: 0644]
src/runtime/dynbind.c
src/runtime/dynbind.h
src/runtime/funcall.c
src/runtime/gc-common.c [changed mode: 0644->0755]
src/runtime/gencgc.c [changed mode: 0644->0755]
src/runtime/globals.h
src/runtime/interrupt.c
src/runtime/interrupt.h
src/runtime/linux-os.c
src/runtime/runtime.h
src/runtime/safepoint.c [new file with mode: 0644]
src/runtime/sunos-os.c
src/runtime/thread.c
src/runtime/thread.h
src/runtime/win32-os.c [changed mode: 0644->0755]
src/runtime/x86-64-arch.c
src/runtime/x86-64-assem.S
src/runtime/x86-arch.c
src/runtime/x86-assem.S
src/runtime/x86-linux-os.c
src/runtime/x86-sunos-os.c

index 770f381..aee1301 100644 (file)
@@ -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"
index c5319a0..7f0ff41 100644 (file)
@@ -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*
index a9893b0..b9d9151 100644 (file)
@@ -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
index 7394695..4343fb6 100644 (file)
@@ -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)
 (defun unblock-deferrable-signals ()
   (%unblock-deferrable-signals 0 0))
 
+#!-sb-safepoint
 (defun unblock-gc-signals ()
   (%unblock-gc-signals 0 0))
 
   (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))
 \f
index 82ce827..3b00593 100644 (file)
@@ -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)
index ac471cf..f289015 100644 (file)
 (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
index 938990c..bfc0281 100644 (file)
   (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
index 4d793be..f720872 100644 (file)
@@ -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*
index 0ae854b..af5c7e4 100644 (file)
 
     (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))
 \f
                        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))
index 3717744..043e375 100644 (file)
@@ -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.")
index 33ffb6e..93f2e01 100644 (file)
@@ -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)))
index d90427f..65ad782 100644 (file)
          (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
                        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)))
 
              (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)
                   (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)
-
-        ;; Make new frame
-        (inst push rbp)
-        (inst mov  rbp rsp)
-
-        ;; Call
-        (inst mov  rax (foreign-symbol-address "funcall3"))
-        (inst call rax)
-
-        ;; Back! Restore frame
-        (inst mov rsp rbp)
-        (inst pop rbp)
+        #!-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)
+
+          ;; Call
+          (inst mov  rax (foreign-symbol-address "funcall3"))
+          (inst call rax)
+
+          ;; 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
index 13deab4..0df9cf4 100644 (file)
               :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)
        ;; 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
index 1dbc383..d294c4f 100644 (file)
 
 (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)
 \f
 ;;;; static symbols
 
index ae57c4c..9d7973c 100644 (file)
   (: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))
old mode 100644 (file)
new mode 100755 (executable)
index 7eec472..01cf930
                    :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)
index 7386f77..344b72d 100644 (file)
 (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)
        ;; 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)
index 89e56d6..fc51de6 100644 (file)
 
 #!+win32
 (progn
-
   (def!constant read-only-space-start #x22000000)
   (def!constant read-only-space-end   #x220ff000)
 
 
 (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)
 \f
 ;;;; static symbols
 
index 2128d2b..0cd90a3 100644 (file)
   (: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))
index ccb3bb4..3d75800 100644 (file)
@@ -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}
 
index f67ccd0..9e97887 100644 (file)
@@ -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);
index 5cada3e..638b2e8 100644 (file)
@@ -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);
index 5e6eb52..eeaf755 100644 (file)
@@ -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 (file)
index 0000000..fbf1114
--- /dev/null
@@ -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 */
index 32f79f0..9e928a3 100644 (file)
@@ -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;
index 41aa9eb..526b02d 100644 (file)
@@ -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
index c3724eb..9236a48 100644 (file)
@@ -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);
 }
 
old mode 100644 (file)
new mode 100755 (executable)
index 6816760..96ac8df
@@ -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
old mode 100644 (file)
new mode 100755 (executable)
index a73bdca..175be61
@@ -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) {
index b0e812b..fc8ad96 100644 (file)
@@ -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
index 6eccb2d..2a82a2e 100644 (file)
@@ -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");
index 05c6638..a148236 100644 (file)
@@ -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
index 151aea0..43cd19f 100644 (file)
@@ -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
 }
 
index 3c29b27..e99d86b 100644 (file)
 #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 (file)
index 0000000..953b8e9
--- /dev/null
@@ -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,
+};
+
+\f
+/* 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;
+}
+
+\f
+/* 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;
+}
+
+\f
+/* 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;
+    }
+}
+
+\f
+/* 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);
+                }
+            }
+        }
+    }
+}
+
+\f
+/* 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();
+    }
+}
+
+\f
+/* 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;
+}
+\f
+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));
+            pthread_mutex_lock(&gc_dispatcher.mx_gpunmapped);
+            *self->csp_around_foreign_call = 0;
+            pthread_mutex_lock(thread_qrl(self));
+            pthread_mutex_unlock(&gc_dispatcher.mx_gpunmapped);
+        }
+    }
+}
+
+\f
+/* thread_register_gc_trigger --
+
+   Called by GENCGC in each thread where GC_PENDING becomes T because
+   allocated memory size has crossed the threshold in
+   auto_gc_trigger. For the new collective GC sequence, its first call
+   marks a process-wide beginning of GC.
+*/
+void
+thread_register_gc_trigger()
+{
+    odxprint(misc, "/thread_register_gc_trigger");
+    struct thread* self = arch_os_get_current_thread();
+    /* This function should be called instead of former
+       set_pseudo_atomic_interrupted(), e.g. never with true
+       GC_INHIBIT */
+    gc_assert(SymbolTlValue(GC_INHIBIT,self)!=T);
+
+    /* unmap GC page, signal other threads... */
+    maybe_become_stw_initiator();
+}
+
+
+\f
+void
+thread_in_safety_transition(os_context_t *ctx)
+{
+    FSHOW_SIGNAL((stderr, "thread_in_safety_transition\n"));
+    thread_edge(ctx);
+}
+
+void
+thread_in_lisp_raised(os_context_t *ctx)
+{
+    FSHOW_SIGNAL((stderr, "thread_in_lisp_raised\n"));
+    thread_pitstop(ctx);
+}
+
+void**
+os_get_csp(struct thread* th)
+{
+    FSHOW_SIGNAL((stderr, "Thread %p has CSP *(%p) == %p, stack [%p,%p]\n",
+                  th,
+                  th->csp_around_foreign_call,
+                  *(void***)th->csp_around_foreign_call,
+                  th->control_stack_start,
+                  th->control_stack_end));
+    return *(void***)th->csp_around_foreign_call;
+}
+
+
+#ifndef LISP_FEATURE_WIN32
+
+/* Designed to be of the same type as call_into_lisp.  Ignores its
+ * arguments. */
+lispobj
+handle_global_safepoint_violation(lispobj fun, lispobj *args, int nargs)
+{
+#if trap_GlobalSafepoint != 0x1a
+# error trap_GlobalSafepoint mismatch
+#endif
+    asm("int3; .byte 0x1a;");
+    return 0;
+}
+
+lispobj
+handle_csp_safepoint_violation(lispobj fun, lispobj *args, int nargs)
+{
+#if trap_CspSafepoint != 0x1b
+# error trap_CspSafepoint mismatch
+#endif
+    asm("int3; .byte 0x1b;");
+    return 0;
+}
+
+int
+handle_safepoint_violation(os_context_t *ctx, os_vm_address_t fault_address)
+{
+    FSHOW_SIGNAL((stderr, "fault_address = %p, sp = %p, &csp = %p\n",
+                  fault_address,
+                  GC_SAFEPOINT_PAGE_ADDR,
+                  arch_os_get_current_thread()->csp_around_foreign_call));
+
+    struct thread *self = arch_os_get_current_thread();
+
+    if (fault_address == (os_vm_address_t) GC_SAFEPOINT_PAGE_ADDR) {
+        /* We're on the altstack and don't want to run Lisp code. */
+        arrange_return_to_c_function(ctx, handle_global_safepoint_violation, 0);
+        return 1;
+    }
+
+    if (fault_address == (os_vm_address_t) self->csp_around_foreign_call) {
+        arrange_return_to_c_function(ctx, handle_csp_safepoint_violation, 0);
+        return 1;
+    }
+
+    /* not a safepoint */
+    return 0;
+}
+#endif /* LISP_FEATURE_WIN32 */
+
+void
+callback_wrapper_trampoline(lispobj arg0, lispobj arg1, lispobj arg2)
+{
+    struct thread* th = arch_os_get_current_thread();
+    if (!th)
+        lose("callback invoked in non-lisp thread.  Sorry, that is not supported yet.");
+
+    WITH_GC_AT_SAFEPOINTS_ONLY()
+        funcall3(SymbolValue(ENTER_ALIEN_CALLBACK, 0), arg0, arg1, arg2);
+}
+
+#endif /* LISP_FEATURE_SB_SAFEPOINT -- entire file */
index 4389564..769d0a4 100644 (file)
@@ -138,6 +138,11 @@ sigsegv_handler(int signal, siginfo_t *info, os_context_t *context)
 {
     void* fault_addr = (void*)info->si_addr;
 
+#ifdef LISP_FEATURE_SB_SAFEPOINT
+    if (handle_safepoint_violation(context, fault_addr))
+            return;
+#endif
+
     if (!gencgc_handle_wp_violation(fault_addr))
         if(!handle_guard_page_triggered(context, fault_addr))
             lisp_memory_fault_error(context, fault_addr);
@@ -165,8 +170,10 @@ os_install_interrupt_handlers()
                                                  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
 }
 
index 4b42d1d..db24c6e 100644 (file)
 #include "interr.h"             /* for lose() */
 #include "alloc.h"
 #include "gc-internal.h"
+#include "cpputil.h"
+#include "pseudo-atomic.h"
+#include "interrupt.h"
+#include "lispregs.h"
 
 #ifdef LISP_FEATURE_WIN32
 /*
@@ -205,13 +209,16 @@ initial_thread_trampoline(struct thread *th)
 #ifdef LISP_FEATURE_SB_THREAD
     pthread_setspecific(lisp_thread, (void *)1);
 #endif
-#if defined(LISP_FEATURE_SB_THREAD) && defined(LISP_FEATURE_PPC)
+#if defined(THREADS_USING_GCSIGNAL) && defined(LISP_FEATURE_PPC)
     /* SIG_STOP_FOR_GC defaults to blocked on PPC? */
     unblock_gc_signals(0,0);
 #endif
     function = th->no_tls_value_marker;
     th->no_tls_value_marker = NO_TLS_VALUE_MARKER_WIDETAG;
     if(arch_os_thread_init(th)==0) return 1;
+#ifdef LISP_FEATURE_SB_SAFEPOINT
+    pthread_mutex_lock(thread_qrl(th));
+#endif
     link_thread(th);
     th->os_thread=thread_self();
 #ifndef LISP_FEATURE_WIN32
@@ -231,20 +238,6 @@ initial_thread_trampoline(struct thread *th)
 }
 
 #ifdef LISP_FEATURE_SB_THREAD
-#define THREAD_STATE_LOCK_SIZE \
-    ((sizeof(os_sem_t))+(sizeof(os_sem_t))+(sizeof(os_sem_t)))
-#else
-#define THREAD_STATE_LOCK_SIZE 0
-#endif
-
-#define THREAD_STRUCT_SIZE (thread_control_stack_size + BINDING_STACK_SIZE + \
-                            ALIEN_STACK_SIZE +                               \
-                            THREAD_STATE_LOCK_SIZE +                         \
-                            dynamic_values_bytes +                           \
-                            32 * SIGSTKSZ +                                  \
-                            THREAD_ALIGNMENT_BYTES)
-
-#ifdef LISP_FEATURE_SB_THREAD
 /* THREAD POST MORTEM CLEANUP
  *
  * Memory allocated for the thread stacks cannot be reclaimed while
@@ -344,7 +337,9 @@ new_thread_trampoline(struct thread *th)
 
     FSHOW((stderr,"/creating thread %lu\n", thread_self()));
     check_deferrables_blocked_or_lose(0);
+#ifndef LISP_FEATURE_SB_SAFEPOINT
     check_gc_signals_unblocked_or_lose(0);
+#endif
     pthread_setspecific(lisp_thread, (void *)1);
     function = th->no_tls_value_marker;
     th->no_tls_value_marker = NO_TLS_VALUE_MARKER_WIDETAG;
@@ -361,12 +356,33 @@ new_thread_trampoline(struct thread *th)
      * list and we're just adding this thread to it, there is no
      * danger of deadlocking even with SIG_STOP_FOR_GC blocked (which
      * it is not). */
+#ifdef LISP_FEATURE_SB_SAFEPOINT
+    *th->csp_around_foreign_call = (lispobj)&function;
+    pthread_mutex_lock(thread_qrl(th));
+#endif
     lock_ret = pthread_mutex_lock(&all_threads_lock);
     gc_assert(lock_ret == 0);
     link_thread(th);
     lock_ret = pthread_mutex_unlock(&all_threads_lock);
     gc_assert(lock_ret == 0);
 
+    /* Kludge: Changed the order of some steps between the safepoint/
+     * non-safepoint versions of this code.  Can we unify this more?
+     */
+#ifdef LISP_FEATURE_SB_SAFEPOINT
+    WITH_GC_AT_SAFEPOINTS_ONLY() {
+        result = funcall0(function);
+        block_blockable_signals(0, 0);
+        gc_alloc_update_page_tables(BOXED_PAGE_FLAG, &th->alloc_region);
+    }
+    lock_ret = pthread_mutex_lock(&all_threads_lock);
+    gc_assert(lock_ret == 0);
+    unlink_thread(th);
+    lock_ret = pthread_mutex_unlock(&all_threads_lock);
+    gc_assert(lock_ret == 0);
+    pthread_mutex_unlock(thread_qrl(th));
+    set_thread_state(th,STATE_DEAD);
+#else
     result = funcall0(function);
 
     /* Block GC */
@@ -382,6 +398,7 @@ new_thread_trampoline(struct thread *th)
     unlink_thread(th);
     pthread_mutex_unlock(&all_threads_lock);
     gc_assert(lock_ret == 0);
+#endif
 
     if(th->tls_cookie>=0) arch_os_thread_cleanup(th);
     os_sem_destroy(th->state_sem);
@@ -449,12 +466,15 @@ create_thread_struct(lispobj initial_function) {
     aligned_spaces = (void *)((((unsigned long)(char *)spaces)
                                + THREAD_ALIGNMENT_BYTES-1)
                               &~(unsigned long)(THREAD_ALIGNMENT_BYTES-1));
-    per_thread=(union per_thread_data *)
+    void* csp_page=
         (aligned_spaces+
          thread_control_stack_size+
          BINDING_STACK_SIZE+
-         ALIEN_STACK_SIZE +
-         THREAD_STATE_LOCK_SIZE);
+         ALIEN_STACK_SIZE);
+    per_thread=(union per_thread_data *)
+        (csp_page + THREAD_CSP_PAGE_SIZE);
+    struct nonpointer_thread_data *nonpointer_data
+        = (void *) &per_thread->dynamic_values[TLS_SIZE];
 
 #ifdef LISP_FEATURE_SB_THREAD
     for(i = 0; i < (dynamic_values_bytes / sizeof(lispobj)); i++)
@@ -496,18 +516,30 @@ create_thread_struct(lispobj initial_function) {
     set_binding_stack_pointer(th,th->binding_stack_start);
     th->this=th;
     th->os_thread=0;
+
+#ifdef LISP_FEATURE_SB_SAFEPOINT
+    th->pc_around_foreign_call = 0;
+    th->csp_around_foreign_call = csp_page;
+#endif
+
 #ifdef LISP_FEATURE_SB_THREAD
+    /* Contrary to the "allocate all the spaces at once" comment above,
+     * the os_attr is allocated separately.  We cannot put it into the
+     * nonpointer data, because it's used for post_mortem and freed
+     * separately */
     th->os_attr=malloc(sizeof(pthread_attr_t));
-    th->state_sem=(os_sem_t *)((void *)th->alien_stack_start + ALIEN_STACK_SIZE);
-    th->state_not_running_sem=(os_sem_t *)
-        ((void *)th->state_sem + (sizeof(os_sem_t)));
-    th->state_not_stopped_sem=(os_sem_t *)
-        ((void *)th->state_not_running_sem + (sizeof(os_sem_t)));
+    th->nonpointer_data = nonpointer_data;
+    th->state_sem=&nonpointer_data->state_sem;
+    th->state_not_running_sem=&nonpointer_data->state_not_running_sem;
+    th->state_not_stopped_sem=&nonpointer_data->state_not_stopped_sem;
     th->state_not_running_waitcount = 0;
     th->state_not_stopped_waitcount = 0;
     os_sem_init(th->state_sem, 1);
     os_sem_init(th->state_not_running_sem, 0);
     os_sem_init(th->state_not_stopped_sem, 0);
+# ifdef LISP_FEATURE_SB_SAFEPOINT
+    pthread_mutex_init(thread_qrl(th), NULL);
+# endif
 #endif
     th->state=STATE_RUNNING;
 #ifdef LISP_FEATURE_STACK_GROWS_DOWNWARD_NOT_UPWARD
@@ -562,6 +594,10 @@ create_thread_struct(lispobj initial_function) {
 #ifdef LISP_FEATURE_SB_THREAD
     bind_variable(STOP_FOR_GC_PENDING,NIL,th);
 #endif
+#if defined(LISP_FEATURE_SB_SAFEPOINT)
+    bind_variable(GC_SAFE,NIL,th);
+    bind_variable(IN_SAFEPOINT,NIL,th);
+#endif
 #ifndef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
     access_control_stack_pointer(th)=th->control_stack_start;
 #endif
@@ -671,6 +707,10 @@ os_thread_t create_thread(lispobj initial_function) {
  * the usual pseudo-atomic checks (we don't want to stop a thread while
  * it's in the middle of allocation) then waits for another SIG_STOP_FOR_GC.
  */
+/*
+ * (With SB-SAFEPOINT, see the definitions in safepoint.c instead.)
+ */
+#ifndef LISP_FEATURE_SB_SAFEPOINT
 
 /* 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
@@ -762,7 +802,9 @@ void gc_start_the_world()
 
     FSHOW_SIGNAL((stderr,"/gc_start_the_world:end\n"));
 }
-#endif
+
+#endif /* !LISP_FEATURE_SB_SAFEPOINT */
+#endif /* !LISP_FEATURE_SB_THREAD */
 
 int
 thread_yield()
@@ -798,6 +840,23 @@ kill_safely(os_thread_t os_thread, int signal)
 #ifdef LISP_FEATURE_SB_THREAD
         sigset_t oldset;
         struct thread *thread;
+        /* Frequent special case: resignalling to self.  The idea is
+         * that leave_region safepoint will acknowledge the signal, so
+         * there is no need to take locks, roll thread to safepoint
+         * etc. */
+        /* Kludge (on safepoint builds): At the moment, this isn't just
+         * an optimization; rather it masks the fact that
+         * gc_stop_the_world() grabs the all_threads mutex without
+         * releasing it, and since we're not using recursive pthread
+         * mutexes, the pthread_mutex_lock() around the all_threads loop
+         * would go wrong.  Why are we running interruptions while
+         * stopping the world though?  Test case is (:ASYNC-UNWIND
+         * :SPECIALS), especially with s/10/100/ in both loops. */
+        if (os_thread == pthread_self()) {
+            pthread_kill(os_thread, signal);
+            return 0;
+        }
+
         /* pthread_kill is not async signal safe and we don't want to be
          * interrupted while holding the lock. */
         block_deferrable_signals(0, &oldset);
index 76ec1a6..c8c15e5 100644 (file)
 #include "genesis/thread.h"
 #include "genesis/fdefn.h"
 #include "interrupt.h"
+#include "validate.h"           /* for BINDING_STACK_SIZE etc */
 
 #define STATE_RUNNING MAKE_FIXNUM(1)
 #define STATE_STOPPED MAKE_FIXNUM(2)
 #define STATE_DEAD MAKE_FIXNUM(3)
+#if defined(LISP_FEATURE_SB_SAFEPOINT)
+# define STATE_SUSPENDED_BRIEFLY MAKE_FIXNUM(4)
+# define STATE_GC_BLOCKER MAKE_FIXNUM(5)
+# define STATE_PHASE1_BLOCKER MAKE_FIXNUM(5)
+# define STATE_PHASE2_BLOCKER MAKE_FIXNUM(6)
+# define STATE_INTERRUPT_BLOCKER MAKE_FIXNUM(7)
+#endif
 
 #ifdef LISP_FEATURE_SB_THREAD
 lispobj thread_state(struct thread *thread);
 void set_thread_state(struct thread *thread, lispobj state);
 void wait_for_thread_state_change(struct thread *thread, lispobj state);
+
+#if defined(LISP_FEATURE_SB_SAFEPOINT)
+enum threads_suspend_reason {
+    SUSPEND_REASON_NONE,
+    SUSPEND_REASON_GC,
+    SUSPEND_REASON_INTERRUPT,
+    SUSPEND_REASON_GCING
+};
+
+struct threads_suspend_info {
+    int suspend;
+    pthread_mutex_t world_lock;
+    pthread_mutex_t lock;
+    enum threads_suspend_reason reason;
+    int phase;
+    struct thread * gc_thread;
+    struct thread * interrupted_thread;
+    int blockers;
+    int used_gc_page;
+};
+
+struct suspend_phase {
+    int suspend;
+    enum threads_suspend_reason reason;
+    int phase;
+    struct suspend_phase *next;
+};
+
+extern struct threads_suspend_info suspend_info;
+
+struct gcing_safety {
+    lispobj csp_around_foreign_call;
+    lispobj* pc_around_foreign_call;
+};
+
+int handle_safepoint_violation(os_context_t *context, os_vm_address_t addr);
+void** os_get_csp(struct thread* th);
+void alloc_gc_page();
+void assert_on_stack(struct thread *th, void *esp);
+#endif /* defined(LISP_FEATURE_SB_SAFEPOINT) */
+
 extern pthread_key_t lisp_thread;
 #endif
 
@@ -39,6 +88,57 @@ union per_thread_data {
     lispobj dynamic_values[1];  /* actually more like 4000 or so */
 };
 
+/* A helper structure for data local to a thread, which is not pointer-sized.
+ *
+ * Originally, all layouting of these fields was done manually in C code
+ * with pointer arithmetic.  We let the C compiler figure it out now.
+ *
+ * (Why is this not part of `struct thread'?  Because that structure is
+ * declared using genesis, and we would run into issues with fields that
+ * are of unknown length.)
+ */
+struct nonpointer_thread_data
+{
+#ifdef LISP_FEATURE_SB_THREAD
+    os_sem_t state_sem;
+    os_sem_t state_not_running_sem;
+    os_sem_t state_not_stopped_sem;
+# ifdef LISP_FEATURE_SB_SAFEPOINT
+   /* For safepoint-based builds, together with thread's
+    * csp_around_foreign_call pointer target, thread_qrl(thread) makes
+    * `quickly revokable lock'. Unlike most mutexes, this one is
+    * normally locked; by convention, other thread may read and use the
+    * thread's FFI-CSP location _either_ when the former holds the
+    * lock(mutex) _or_ when page permissions for FFI-CSP location were
+    * set to read-only.
+    *
+    * Combined semantic of QRL is not the same as the semantic of mutex
+    * returned by this function; rather, the mutex, when released by the
+    * owning thread, provides an edge-triggered notification of QRL
+    * release, which is represented by writing non-null
+    * csp_around_foreign_call.
+    *
+    * When owner thread is `in Lisp' (i.e. a heap mutator), its FFI-CSP
+    * contains null, otherwise it points to the top of C stack that
+    * should be preserved by GENCGC. If another thread needs to wait for
+    * mutator state change with `in Lisp => in C' direction, it disables
+    * FFI-CSP overwrite using page protection, and takes the mutex
+    * returned by thread_qrl(). Page fault handler normally ends up in a
+    * routine releasing this mutex and waiting for some appropriate
+    * event to take it back.
+    *
+    * This way, each thread may modify its own FFI-CSP content freely
+    * without memory barriers (paying with exception handling overhead
+    * whenever a contention happens). */
+    pthread_mutex_t qrl_lock;
+# endif
+#else
+    /* An unused field follows, to ensure that the struct in non-empty
+     * for non-GCC compilers. */
+    int unused;
+#endif
+};
+
 extern struct thread *all_threads;
 extern int dynamic_values_bytes;
 
@@ -177,6 +277,20 @@ StaticSymbolFunction(lispobj sym)
 extern __thread struct thread *current_thread;
 #endif
 
+#ifdef LISP_FEATURE_SB_SAFEPOINT
+# define THREAD_CSP_PAGE_SIZE BACKEND_PAGE_BYTES
+#else
+# define THREAD_CSP_PAGE_SIZE 0
+#endif
+
+#define THREAD_STRUCT_SIZE (thread_control_stack_size + BINDING_STACK_SIZE + \
+                            ALIEN_STACK_SIZE +                          \
+                            sizeof(struct nonpointer_thread_data) +     \
+                            dynamic_values_bytes +                      \
+                            32 * SIGSTKSZ +                             \
+                            THREAD_ALIGNMENT_BYTES +                    \
+                            THREAD_CSP_PAGE_SIZE)
+
 /* This is clearly per-arch and possibly even per-OS code, but we can't
  * put it somewhere sensible like x86-linux-os.c because it needs too
  * much stuff like struct thread and all_threads to be defined, which
@@ -233,6 +347,72 @@ extern kern_return_t mach_lisp_thread_init(struct thread *thread);
 extern kern_return_t mach_lisp_thread_destroy(struct thread *thread);
 #endif
 
+#ifdef LISP_FEATURE_SB_SAFEPOINT
+void thread_in_safety_transition(os_context_t *ctx);
+void thread_in_lisp_raised(os_context_t *ctx);
+void thread_pitstop(os_context_t *ctxptr);
+extern void thread_register_gc_trigger();
+
+#define thread_qrl(th) (&(th)->nonpointer_data->qrl_lock)
+
+static inline
+void push_gcing_safety(struct gcing_safety *into)
+{
+    struct thread* th = arch_os_get_current_thread();
+    asm volatile ("");
+    if ((into->csp_around_foreign_call =
+         *th->csp_around_foreign_call)) {
+        *th->csp_around_foreign_call = 0;
+        asm volatile ("");
+        into->pc_around_foreign_call = th->pc_around_foreign_call;
+        th->pc_around_foreign_call = 0;
+        asm volatile ("");
+    } else {
+        into->pc_around_foreign_call = 0;
+    }
+}
+
+static inline
+void pop_gcing_safety(struct gcing_safety *from)
+{
+    struct thread* th = arch_os_get_current_thread();
+    if (from->csp_around_foreign_call) {
+        asm volatile ("");
+        *th->csp_around_foreign_call = from->csp_around_foreign_call;
+        asm volatile ("");
+        th->pc_around_foreign_call = from->pc_around_foreign_call;
+        asm volatile ("");
+    }
+}
+
+/* Even with just -O1, gcc optimizes the jumps in this "loop" away
+ * entirely, giving the ability to define WITH-FOO-style macros. */
+#define RUN_BODY_ONCE(prefix, finally_do)               \
+    int prefix##done = 0;                               \
+    for (; !prefix##done; finally_do, prefix##done = 1)
+
+#define WITH_GC_AT_SAFEPOINTS_ONLY_hygenic(var)        \
+    struct gcing_safety var;                    \
+    push_gcing_safety(&var);                    \
+    RUN_BODY_ONCE(var, pop_gcing_safety(&var))
+
+#define WITH_GC_AT_SAFEPOINTS_ONLY()                           \
+    WITH_GC_AT_SAFEPOINTS_ONLY_hygenic(sbcl__gc_safety)
+
+#define WITH_STATE_SEM_hygenic(var, thread)                             \
+    os_sem_wait((thread)->state_sem, "thread_state");                   \
+    RUN_BODY_ONCE(var, os_sem_post((thread)->state_sem, "thread_state"))
+
+#define WITH_STATE_SEM(thread)                                     \
+    WITH_STATE_SEM_hygenic(sbcl__state_sem, thread)
+
+#endif
+
+extern boolean is_some_thread_local_addr(os_vm_address_t addr);
 extern void create_initial_thread(lispobj);
 
+#ifdef LISP_FEATURE_SB_THREAD
+extern pthread_mutex_t all_threads_lock;
+#endif
+
 #endif /* _INCLUDE_THREAD_H_ */
old mode 100644 (file)
new mode 100755 (executable)
index bc25a9e..62333e2 100644 (file)
@@ -110,6 +110,10 @@ void arch_skip_instruction(os_context_t *context)
         case trap_FunEndBreakpoint: /* not tested */
             break;
 
+#ifdef LISP_FEATURE_SB_SAFEPOINT
+        case trap_GlobalSafepoint:
+        case trap_CspSafepoint:
+#endif
         case trap_PendingInterrupt:
         case trap_Halt:
         case trap_SingleStepAround:
index 34b9df5..bc41986 100644 (file)
 #define align_8byte    8
 #define align_16byte   16
 #define align_32byte   32
+#define align_page     32768
 #else
 #define        align_4byte     2
 #define        align_8byte     3
 #define        align_16byte    4       
+#define        align_page      15
 #endif                 
 
 /*
@@ -535,4 +537,10 @@ ascs_finished:
        ret
        SIZE(GNAME(arch_scrub_control_stack))
 \f
+       .globl GNAME(gc_safepoint_page)
+       .data
+        .align  align_page
+GNAME(gc_safepoint_page):
+        .fill 32768
+\f
         END()
index cbb6fb4..f85ed07 100644 (file)
@@ -113,6 +113,10 @@ void arch_skip_instruction(os_context_t *context)
         case trap_FunEndBreakpoint: /* not tested */
             break;
 
+#ifdef LISP_FEATURE_SB_SAFEPOINT
+        case trap_GlobalSafepoint:
+        case trap_CspSafepoint:
+#endif
         case trap_PendingInterrupt:
         case trap_Halt:
         case trap_SingleStepAround:
index d04e194..22f38f1 100644 (file)
 #define align_4byte    4
 #define align_8byte    8
 #define align_16byte   16
+#define align_page     4096
 #else
 #define        align_4byte     2
 #define        align_8byte     3
 #define        align_16byte    4       
+#define align_page     12
 #endif                 
 
 /*
 #define SIZE(name)
 #endif
 
+/* Helper macros for access to thread-locals slots for both OS types:
+ * ------------------------------------------------------------------------
+ *
+ *                          Windows TEB block
+ * ==================        __________
+ * | Win32 %FS base | ---->  |        | 0
+ * ==================        |        | 1
+ *                           z        z
+ *     TLS slots start here> |XXXXXXXX| e10 = TEB_STATIC_TLS_SLOTS_OFFSET
+ *                           |XXXXXXXX| e11
+ *                           z   ...  z
+ *                           |XXXXXXXX| e4e
+ *     TLS ends here>     ,- |XXXXXXXX| e4f = TEB_STATIC_TLS_SLOTS_OFFSET+63
+ *                       /   z        z
+ *                       |   ----------
+ *                       |
+ *                       |   big blob of SBCL-specific thread-local data
+ *                       |     |----------------------------------------|
+ *                       |     |   CONTROL, BINDING, ALIEN STACK        |
+ *                       |     z                                        z
+ * ==================    |     |----------------------------------------|
+ * | Linux %FS base | -->|     |   FFI stack pointer                    |
+ * ==================    |     |    (extra page for mprotect)           |
+ *                        \    |----------------------------------------|
+ *   (union p_t_d) ----->  \-> | struct thread {   | dynamic_values[0]  |
+ *   .                         |   ...             |               [1]  |
+ *   .                         z   ...             z               ...  z
+ *   [tls data begins]         | }                 |               ...  | <-
+ *   [declared end of p_t_d]   |----------------------------------------| . |
+ *   .                         |                                   ...  | . |
+ *   .                         |                           [TLS_SIZE-1] | <-|
+ *   [tls data actually ends]  |----------------------------------------|   |
+ *   .                         | ALTSTACK                               |   |
+ *   .                         |----------------------------------------|   |
+ *   .                         | struct nonpointer_thread_data { }      |   |
+ *   .                         ------------------------------------------   |
+ *   [blob actually ends]                                                   |
+ *                                                                         /
+ *                                                                        /
+ *                                                                       /
+ *          ______________________                                      /
+ *          | struct symbol {    |                                     /
+ *          z   ...              z                                    /
+ *          |   fixnum tls_index;  // fixnum value relative to union /
+ *          | }                  |           (< TLS_SIZE = 4096)
+ *          ---------------------|
+ */
+#ifdef LISP_FEATURE_WIN32
+# define TEB_STATIC_TLS_SLOTS_OFFSET 0xE10
+# define TEB_SBCL_THREAD_BASE_OFFSET (TEB_STATIC_TLS_SLOTS_OFFSET+(63*4))
+# define SBCL_THREAD_BASE_EA %fs:TEB_SBCL_THREAD_BASE_OFFSET
+# define MAYBE_FS(addr) addr
+# define LoadTlSymbolValueAddress(symbol,reg) ;         \
+       movl    SBCL_THREAD_BASE_EA, reg ;              \
+       addl    (symbol+SYMBOL_TLS_INDEX_OFFSET), reg ;
+# define LoadCurrentThreadSlot(offset,reg);     \
+       movl    SBCL_THREAD_BASE_EA, reg ;      \
+       movl    offset(reg), reg ;
+#elif defined(LISP_FEATURE_LINUX) || defined(LISP_FEATURE_SUNOS)
+  /* see comment in arch_os_thread_init */
+# define SBCL_THREAD_BASE_EA %fs:THREAD_SELFPTR_OFFSET
+# define MAYBE_FS(addr) addr
+#else
+  /* perhaps there's an OS out there that actually supports %fs without
+   * jumping through hoops, so just in case, here a default definition: */
+# define SBCL_THREAD_BASE_EA $0
+# define MAYBE_FS(addr) %fs:addr
+#endif
+
+/* gas can't parse 4096LU; redefine */
+#if BACKEND_PAGE_BYTES == 4096
+# undef BACKEND_PAGE_BYTES
+# define BACKEND_PAGE_BYTES 4096
+#elif BACKEND_PAGE_BYTES == 32768
+# undef BACKEND_PAGE_BYTES
+# define BACKEND_PAGE_BYTES 32768
+#else
+# error BACKEND_PAGE_BYTES mismatch
+#endif
+
+/* OAOOM because we don't have the C headers here */
+#define THREAD_CSP_PAGE_SIZE BACKEND_PAGE_BYTES
+
+/* the CSP page sits right before the thread */
+#define THREAD_SAVED_CSP_OFFSET (-THREAD_CSP_PAGE_SIZE)
+
 /*
  * x86/darwin (as of MacOS X 10.4.5) doesn't reliably file signal
  * handlers (SIGTRAP or Mach exception handlers) for 0xCC, wo we have
  * FIXME & OAOOM: This duplicates call-out in src/compiler/x86/c-call.lisp,
  * so if you tweak this, change that too!
  */
+/*
+ * Note on sections specific to LISP_FEATURE_SB_SAFEPOINT:
+ *
+ * The code below is essential to safepoint-based garbage collection,
+ * and several details need to be considered for correct implementation.
+ *
+ * The stack spilling approach:
+ *   On SB-SAFEPOINT platforms, the CALL-OUT vop is defined to spill all
+ *   live Lisp TNs to the stack to provide information for conservative
+ *   GC cooperatively (avoiding the need to retrieve register values
+ *   from POSIX signal contexts or Windows GetThreadContext()).
+ *
+ * Finding the SP at all:
+ *   The main remaining value needed by GC is the stack pointer (SP) at
+ *   the moment of entering the foreign function.  For this purpose, a
+ *   thread-local field for the SP is used.  Two stores to that field
+ *   are done for each C call, one to save the SP before calling out and
+ *   and one to undo that store afterwards.
+ *
+ * Stores as synchronization points:
+ *   These two stores delimit the C call: While the SP is set, our
+ *   thread is known not to run Lisp code: During GC, memory protection
+ *   ensures that no thread proceeds across stores.
+ *
+ * The return PC issue:
+ *   (Note that CALL-OUT has, in principle, two versions: Inline
+ *   assembly in the VOP -or- alternatively the out-of-line version you
+ *   are currently reading.  In reality, safepoint builds currently
+ *   lack the inline code entirely.)
+ *
+ *   Both versions need to take special care with the return PC:
+ *   - In the inline version of the code (if it existed), the two stores
+ *     would be done directly in the CALL-OUT vop.  In that theoretical
+ *     implementation, there is a time interval between return of the
+ *     actual C call and a second SP store during which the return
+ *     address might not be on the stack anymore.
+ *   - In this out-of-line version, the stores are done during
+ *     call_into_c's frame, but an equivalent problem arises: In order
+ *     to present the stack of arguments as our foreign function expects
+ *     them, call_into_c has to pop the Lisp return address into a
+ *     register first; this register has to be preserved by GENCGC
+ *     separately: our return address is not in the stack anymore.
+ *   In both case, stack scanning alone is not sufficient to pin
+ *   the return address, and we communicate it to GC explicitly
+ *   in addition to the SP.
+ *
+ * Note on look-alike accessor macros with vastly different behaviour:
+ *   THREAD_PC_AROUND_FOREIGN_CALL_OFFSET is an "ordinary" field of the
+ *   struct thread, whereas THREAD_SAVED_CSP_OFFSET is a synchronization
+ *   point on a potentially write-protected page.
+*/
+
        .text
        .align  align_16byte,0x90
        .globl GNAME(call_into_c)
@@ -113,6 +253,11 @@ GNAME(call_into_c):
        popl    %ebx
 
 /* Setup the NPX for C */
+        /* The VOP says regarding CLD: "Clear out DF: Darwin, Windows,
+         * and Solaris at least require this, and it should not hurt
+         * others either." call_into_c didn't have it, but better safe than
+         * sorry. */
+        cld
        fstp    %st(0)
        fstp    %st(0)
        fstp    %st(0)
@@ -122,8 +267,25 @@ GNAME(call_into_c):
        fstp    %st(0)
        fstp    %st(0)
 
+#ifdef LISP_FEATURE_SB_SAFEPOINT
+        /* enter safe region: store SP and return PC */
+       movl    SBCL_THREAD_BASE_EA,%edi
+       movl    %esp,MAYBE_FS(THREAD_SAVED_CSP_OFFSET(%edi))
+       movl    %ebx,MAYBE_FS(THREAD_PC_AROUND_FOREIGN_CALL_OFFSET(%edi))
+#endif
+
+       /* foreign call, preserving ESI, EDI, and EBX */
        call    *%eax             # normal callout using Lisp stack
-       movl    %eax,%ecx         # remember integer return value
+        /* return values now in eax/edx OR st(0) */
+
+#ifdef LISP_FEATURE_SB_SAFEPOINT
+        /* leave region: clear the SP!  (Also unpin the return PC.) */
+       xorl    %ecx,%ecx
+       movl    %ecx,MAYBE_FS(THREAD_SAVED_CSP_OFFSET(%edi))
+       movl    %ecx,MAYBE_FS(THREAD_PC_AROUND_FOREIGN_CALL_OFFSET(%edi))
+#endif
+
+        movl   %eax,%ecx         # remember integer return value
 
 /* Check for a return FP value. */
        fxam
@@ -163,7 +325,7 @@ Lfp_rtn_value:
 
 /* We don't need to restore eax, because the result is in st(0). */
 
-/* Return. FIXME: It would be nice to restructure this to use RET. */  
+/* Return. FIXME: It would be nice to restructure this to use RET. */
        jmp     *%ebx
 
        SIZE(GNAME(call_into_c))
@@ -202,6 +364,7 @@ GNAME(call_into_lisp_first_time):
 GNAME(call_into_lisp):
        pushl   %ebp            # Save old frame pointer.
        movl    %esp,%ebp       # Establish new frame.
+
 Lstack:
 /* Save the NPX state */
        fwait                   # Catch any pending NPX exceptions.
@@ -763,6 +926,12 @@ GNAME(fast_bzero_pointer):
          * to fast_bzero_detect if OS supports SSE.  */
         .long GNAME(fast_bzero_base)
 \f
+       .globl GNAME(gc_safepoint_page)
+       .data
+        .align  align_page
+GNAME(gc_safepoint_page):
+        .fill BACKEND_PAGE_BYTES
+\f
        .text
        .align  align_16byte,0x90
        .globl GNAME(fast_bzero)
index ddbe154..373ffc5 100644 (file)
@@ -106,6 +106,19 @@ int arch_os_thread_init(struct thread *thread) {
     thread->tls_cookie=n;
     pthread_mutex_unlock(&modify_ldt_lock);
 
+    /* now %fs:0 refers to the current thread.  Useful!  Less usefully,
+     * Linux/x86 isn't capable of reporting a faulting si_addr on a
+     * segment as defined above (whereas faults on the segment that %gs
+     * usually points are reported just fine...).  As a special
+     * workaround, we store each thread structure's absolute address as
+     * as slot in itself, so that within the thread,
+     *   movl %fs:SELFPTR_OFFSET,x
+     * stores the absolute address of %fs:0 into x.
+     */
+#ifdef LISP_FEATURE_SB_SAFEPOINT
+    thread->selfptr = thread;
+#endif
+
     if(n<0) return 0;
 #ifdef LISP_FEATURE_GCC_TLS
     current_thread = thread;
index 46ae087..0edd0b1 100644 (file)
@@ -102,6 +102,10 @@ int arch_os_thread_init(struct thread *thread) {
 
   thread->tls_cookie = sel;
   pthread_setspecific(specials,thread);
+
+# ifdef LISP_FEATURE_SB_SAFEPOINT
+    thread->selfptr = thread;
+# endif
 #endif
 
 #ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK