From 26bbfd93d01cefc0bbf97727379bdbdace8bf609 Mon Sep 17 00:00:00 2001 From: Gabor Melis Date: Fri, 6 Oct 2006 11:44:20 +0000 Subject: [PATCH] 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 --- NEWS | 2 ++ doc/internals/specials.texinfo | 11 ++++++++++- src/compiler/alpha/cell.lisp | 4 ++-- src/compiler/hppa/cell.lisp | 4 ++-- src/compiler/mips/cell.lisp | 4 ++-- src/compiler/ppc/cell.lisp | 4 ++-- src/compiler/sparc/cell.lisp | 4 ++-- src/compiler/x86-64/cell.lisp | 6 +++--- src/compiler/x86/cell.lisp | 6 +++--- tests/signals.impure.lisp | 37 +++++++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 11 files changed, 66 insertions(+), 18 deletions(-) create mode 100644 tests/signals.impure.lisp diff --git a/NEWS b/NEWS index 4d647ab..a30ad70 100644 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 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 --- 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" -- 1.7.10.4