0.9.17.10: async unwind for specials

  * in UNBIND zero the symbol before the value
  * in UNBIND-TO-HERE zero the value even if the symbol is zero

diff --git a/NEWS b/NEWS
index 4d647ab..a30ad70 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -8,6 +8,8 @@ changes in sbcl-0.9.18 (1.0.beta?) relative to sbcl-0.9.16:
   * bug fix: remove a race condition in the setting of
     funcallable-instance functions, this should make threaded CLOS
     code more stable against memory faults.
+  * bug fix: corruption of specials when unbinding is interrupted by an
+    asynchronous unwind (reported by Hannu Koivisto)
   * improvement: the debugger will now also display local variables that
     are only used once, for code compiled with a DEBUG optimization quality
     of 2 or higher.

diff --git a/doc/internals/specials.texinfo b/doc/internals/specials.texinfo
index 036851e..96e9afc 100644 (file)
--- a/doc/internals/specials.texinfo
+++ b/doc/internals/specials.texinfo
@@ -52,4 +52,13 @@ garbage pointer.
 
 Furthermore, @code{BIND} must always write the value to the binding
 stack first and the symbol second because the symbol being non-zero
-means validity to @code{UNBIND-TO-HERE}.
+means validity to @code{UNBIND-TO-HERE}. For similar reasons
+@code{UNBIND} also zeroes the symbol first. But if it is interrupted
+by a signal that does an async unwind then @code{UNBIND-TO-HERE} can
+be triggered when the symbol is zeroed but the value is not. In this
+case @code{UNBIND-TO-HERE} must zero out the value to avoid leaving
+garbage around that may wreck the ship on the next @code{BIND}.
+
+In other words, the invariant is that the binding stack above bsp only
+contains zeros. This makes @code{BIND} safe in face of gc triggered at
+any point during its execution.

diff --git a/src/compiler/alpha/cell.lisp b/src/compiler/alpha/cell.lisp
index c3fadf9..4e80a7b 100644 (file)
--- a/src/compiler/alpha/cell.lisp
+++ b/src/compiler/alpha/cell.lisp
@@ -179,8 +179,8 @@
     (loadw value bsp-tn (- binding-value-slot binding-size))
     (#!+gengc storew-and-remember-slot #!-gengc storew
              value symbol symbol-value-slot other-pointer-lowtag)
-    (storew zero-tn bsp-tn (- binding-value-slot binding-size))
     (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
+    (storew zero-tn bsp-tn (- binding-value-slot binding-size))
     (inst subq bsp-tn (* 2 n-word-bytes) bsp-tn)))
 
 
@@ -203,10 +203,10 @@
       (inst beq symbol skip)
       (#!+gengc storew-and-remember-slot #!-gengc storew
                value symbol symbol-value-slot other-pointer-lowtag)
-      (storew zero-tn bsp-tn (- binding-value-slot binding-size))
       (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
 
       (emit-label skip)
+      (storew zero-tn bsp-tn (- binding-value-slot binding-size))
       (inst subq bsp-tn (* 2 n-word-bytes) bsp-tn)
       (inst cmpeq where bsp-tn temp)
       (inst beq temp loop)

diff --git a/src/compiler/hppa/cell.lisp b/src/compiler/hppa/cell.lisp
index 545051c..42879ad 100644 (file)
--- a/src/compiler/hppa/cell.lisp
+++ b/src/compiler/hppa/cell.lisp
@@ -167,8 +167,8 @@
     (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
     (loadw value bsp-tn (- binding-value-slot binding-size))
     (storew value symbol symbol-value-slot other-pointer-lowtag)
-    (storew zero-tn bsp-tn (- binding-value-slot binding-size))
     (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
+    (storew zero-tn bsp-tn (- binding-value-slot binding-size))
     (inst addi (- (* binding-size n-word-bytes)) bsp-tn bsp-tn)))
 
 (define-vop (unbind-to-here)
@@ -182,10 +182,10 @@
     (inst comb := symbol zero-tn skip)
     (loadw value bsp-tn (- binding-value-slot binding-size))
     (storew value symbol symbol-value-slot other-pointer-lowtag)
-    (storew zero-tn bsp-tn (- binding-value-slot binding-size))
     (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
 
     SKIP
+    (storew zero-tn bsp-tn (- binding-value-slot binding-size))
     (inst addi (* -2 n-word-bytes) bsp-tn bsp-tn)
     (inst comb :<> where bsp-tn loop :nullify t)
     (loadw symbol bsp-tn (- binding-symbol-slot binding-size))

diff --git a/src/compiler/mips/cell.lisp b/src/compiler/mips/cell.lisp
index 40ac92c..ab632fb 100644 (file)
--- a/src/compiler/mips/cell.lisp
+++ b/src/compiler/mips/cell.lisp
@@ -184,8 +184,8 @@
     (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
     (loadw value bsp-tn (- binding-value-slot binding-size))
     (storew value symbol symbol-value-slot other-pointer-lowtag)
-    (storew zero-tn bsp-tn (- binding-value-slot binding-size))
     (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
+    (storew zero-tn bsp-tn (- binding-value-slot binding-size))
     (inst addu bsp-tn bsp-tn (* -2 n-word-bytes))))
 
 
@@ -206,10 +206,10 @@
       (inst beq symbol zero-tn skip)
       (loadw value bsp-tn (- binding-value-slot binding-size))
       (storew value symbol symbol-value-slot other-pointer-lowtag)
-      (storew zero-tn bsp-tn (- binding-value-slot binding-size))
       (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
 
       (emit-label skip)
+      (storew zero-tn bsp-tn (- binding-value-slot binding-size))
       (inst addu bsp-tn bsp-tn (* -2 n-word-bytes))
       (inst bne where bsp-tn loop)
       (inst nop)

diff --git a/src/compiler/ppc/cell.lisp b/src/compiler/ppc/cell.lisp
index 553dfe8..d44dc85 100644 (file)
--- a/src/compiler/ppc/cell.lisp
+++ b/src/compiler/ppc/cell.lisp
@@ -171,8 +171,8 @@
     (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
     (loadw value bsp-tn (- binding-value-slot binding-size))
     (storew value symbol symbol-value-slot other-pointer-lowtag)
-    (storew zero-tn bsp-tn (- binding-value-slot binding-size))
     (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
+    (storew zero-tn bsp-tn (- binding-value-slot binding-size))
     (inst subi bsp-tn bsp-tn (* 2 n-word-bytes))))
 
 
@@ -194,10 +194,10 @@
       (inst beq skip)
       (loadw value bsp-tn (- binding-value-slot binding-size))
       (storew value symbol symbol-value-slot other-pointer-lowtag)
-      (storew zero-tn bsp-tn (- binding-value-slot binding-size))
       (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
 
       (emit-label skip)
+      (storew zero-tn bsp-tn (- binding-value-slot binding-size))
       (inst subi bsp-tn bsp-tn (* 2 n-word-bytes))
       (inst cmpw where bsp-tn)
       (inst bne loop)

diff --git a/src/compiler/sparc/cell.lisp b/src/compiler/sparc/cell.lisp
index 7670c05..8767f02 100644 (file)
--- a/src/compiler/sparc/cell.lisp
+++ b/src/compiler/sparc/cell.lisp
@@ -167,8 +167,8 @@
     (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
     (loadw value bsp-tn (- binding-value-slot binding-size))
     (storew value symbol symbol-value-slot other-pointer-lowtag)
-    (storew zero-tn bsp-tn (- binding-value-slot binding-size))
     (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
+    (storew zero-tn bsp-tn (- binding-value-slot binding-size))
     (inst sub bsp-tn bsp-tn (* 2 n-word-bytes))))
 
 (define-vop (unbind-to-here)
@@ -190,10 +190,10 @@
       (inst b :eq skip)
       (loadw value bsp-tn (- binding-value-slot binding-size))
       (storew value symbol symbol-value-slot other-pointer-lowtag)
-      (storew zero-tn bsp-tn (- binding-value-slot binding-size))
       (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
 
       (emit-label skip)
+      (storew zero-tn bsp-tn (- binding-value-slot binding-size))
       (inst sub bsp-tn bsp-tn (* 2 n-word-bytes))
       (inst cmp where bsp-tn)
       (inst b :ne loop)

diff --git a/src/compiler/x86-64/cell.lisp b/src/compiler/x86-64/cell.lisp
index b9371f2..ed3a1c9 100644 (file)
--- a/src/compiler/x86-64/cell.lisp
+++ b/src/compiler/x86-64/cell.lisp
@@ -353,8 +353,8 @@
     (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls-index)
           value)
 
-    (storew 0 bsp (- binding-value-slot binding-size))
     (storew 0 bsp (- binding-symbol-slot binding-size))
+    (storew 0 bsp (- binding-value-slot binding-size))
     (inst sub bsp (* binding-size n-word-bytes))
     (store-binding-stack-pointer bsp)))
 
@@ -366,8 +366,8 @@
     (loadw symbol bsp (- binding-symbol-slot binding-size))
     (loadw value bsp (- binding-value-slot binding-size))
     (storew value symbol symbol-value-slot other-pointer-lowtag)
-    (storew 0 bsp (- binding-value-slot binding-size))
     (storew 0 bsp (- binding-symbol-slot binding-size))
+    (storew 0 bsp (- binding-value-slot binding-size))
     (inst sub bsp (* binding-size n-word-bytes))
     (store-symbol-value bsp *binding-stack-pointer*)))
 
@@ -392,10 +392,10 @@
     #!+sb-thread
     (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls-index)
           value)
-    (storew 0 bsp (- binding-value-slot binding-size))
     (storew 0 bsp (- binding-symbol-slot binding-size))
 
     SKIP
+    (storew 0 bsp (- binding-value-slot binding-size))
     (inst sub bsp (* binding-size n-word-bytes))
     (inst cmp where bsp)
     (inst jmp :ne LOOP)

diff --git a/src/compiler/x86/cell.lisp b/src/compiler/x86/cell.lisp
index 53cea4a..ca2eca9 100644 (file)
--- a/src/compiler/x86/cell.lisp
+++ b/src/compiler/x86/cell.lisp
@@ -356,8 +356,8 @@
     (inst fs-segment-prefix)
     (inst mov (make-ea :dword :base tls-index) value)
 
-    (storew 0 bsp (- binding-value-slot binding-size))
     (storew 0 bsp (- binding-symbol-slot binding-size))
+    (storew 0 bsp (- binding-value-slot binding-size))
     (inst sub bsp (* binding-size n-word-bytes))
     (store-binding-stack-pointer bsp)))
 
@@ -369,8 +369,8 @@
     (loadw symbol bsp (- binding-symbol-slot binding-size))
     (loadw value bsp (- binding-value-slot binding-size))
     (storew value symbol symbol-value-slot other-pointer-lowtag)
-    (storew 0 bsp (- binding-value-slot binding-size))
     (storew 0 bsp (- binding-symbol-slot binding-size))
+    (storew 0 bsp (- binding-value-slot binding-size))
     (inst sub bsp (* binding-size n-word-bytes))
     (store-symbol-value bsp *binding-stack-pointer*)))
 
@@ -394,10 +394,10 @@
                   tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
     #!+sb-thread (inst fs-segment-prefix)
     #!+sb-thread (inst mov (make-ea :dword :base tls-index) value)
-    (storew 0 bsp (- binding-value-slot binding-size))
     (storew 0 bsp (- binding-symbol-slot binding-size))
 
     SKIP
+    (storew 0 bsp (- binding-value-slot binding-size))
     (inst sub bsp (* binding-size n-word-bytes))
     (inst cmp where bsp)
     (inst jmp :ne loop)

diff --git a/tests/signals.impure.lisp b/tests/signals.impure.lisp
new file mode 100644 (file)
index 0000000..16b9767
--- /dev/null
+++ b/tests/signals.impure.lisp
@@ -0,0 +1,37 @@
+;;;; Tests for async signal safety.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;
+;;;; This software is in the public domain and is provided with
+;;;; absoluely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+(use-package :test-util)
+
+(with-test (:name (:async-unwind :specials))
+  (let ((*x0* nil) (*x1* nil) (*x2* nil) (*x3* nil) (*x4* nil))
+    (declare (special *x0* *x1* *x2* *x3* *x4*))
+    (loop repeat 10 do
+          (loop repeat 10 do
+                (catch 'again
+                  (sb-ext:schedule-timer (sb-ext:make-timer
+                                          (lambda ()
+                                            (throw 'again nil)))
+                                         (random 0.1))
+                  (loop
+                   (let ((*x0* (cons nil nil)) (*x1* (cons nil nil))
+                         (*x2* (cons nil nil)) (*x3* (cons nil nil))
+                         (*x4* (cons nil nil)))
+                     (declare (special *x0* *x1* *x2* *x3* *x4*)))))
+                (when (not (and (null *x0*) (null *x1*) (null *x2*) (null *x3*)
+                                (null *x4*)))
+                  (format t "~S ~S ~S ~S ~S~%" *x0* *x1* *x2* *x3* *x4*)
+                  (assert nil)))
+          (princ '*)
+          (force-output))
+    (terpri)))

diff --git a/version.lisp-expr b/version.lisp-expr
index 258197d..0ceec08 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.9.17.9"
+"0.9.17.10"