From 6147892310586401bae00de7e65a386c72531136 Mon Sep 17 00:00:00 2001
From: Gabor Melis <mega@hotpop.com>
Date: Tue, 15 Dec 2009 15:22:22 +0000
Subject: [PATCH] 1.0.33.11: fix detection of tls exhaustion

... that was added in 1.0.16.21 and whose ways were shown to be wrong
by the additional pseudo atomic asserts added later.

With this fix the user gets to see the tls exhausted message instead
of a random complaint about pa.
---
 src/assembly/x86-64/alloc.lisp  |   11 ++++++++---
 src/assembly/x86/alloc.lisp     |   11 ++++++++---
 src/compiler/x86-64/macros.lisp |    8 ++++++++
 src/compiler/x86/macros.lisp    |    6 ++++++
 version.lisp-expr               |    2 +-
 5 files changed, 31 insertions(+), 7 deletions(-)

diff --git a/src/assembly/x86-64/alloc.lisp b/src/assembly/x86-64/alloc.lisp
index 2c113b0..80d5406 100644
--- a/src/assembly/x86-64/alloc.lisp
+++ b/src/assembly/x86-64/alloc.lisp
@@ -94,7 +94,8 @@
                (emit-label get-tls-index-lock)
                (inst mov target 1)
                (zeroize rax-tn)
-               (inst cmpxchg (make-ea-for-symbol-value *tls-index-lock*) target :lock)
+               (inst cmpxchg (make-ea-for-symbol-value *tls-index-lock*)
+                     target :lock)
                (inst jmp :ne get-tls-index-lock)
                ;; The symbol is now in OTHER.
                (inst pop other)
@@ -105,9 +106,13 @@
                (inst jmp :ne release-tls-index-lock)
                ;; Allocate a new tls-index.
                (load-symbol-value target *free-tls-index*)
-               (let ((error (generate-error-code nil 'tls-exhausted-error)))
+               (let ((not-error (gen-label))
+                     (error (generate-error-code nil 'tls-exhausted-error)))
                  (inst cmp target (fixnumize tls-size))
-                 (inst jmp :ge error))
+                 (inst jmp :l not-error)
+                 (%clear-pseudo-atomic)
+                 (inst jmp error)
+                 (emit-label not-error))
                (inst add (make-ea-for-symbol-value *free-tls-index*)
                      (fixnumize 1))
                (storew target other symbol-tls-index-slot other-pointer-lowtag)
diff --git a/src/assembly/x86/alloc.lisp b/src/assembly/x86/alloc.lisp
index 65cfdb0..897855b 100644
--- a/src/assembly/x86/alloc.lisp
+++ b/src/assembly/x86/alloc.lisp
@@ -102,7 +102,8 @@
                (emit-label get-tls-index-lock)
                (inst mov target 1)
                (inst xor eax-tn eax-tn)
-               (inst cmpxchg (make-ea-for-symbol-value *tls-index-lock*) target :lock)
+               (inst cmpxchg (make-ea-for-symbol-value *tls-index-lock*)
+                     target :lock)
                (inst jmp :ne get-tls-index-lock)
                ;; The symbol is now in OTHER.
                (inst pop other)
@@ -113,9 +114,13 @@
                (inst jmp :ne release-tls-index-lock)
                ;; Allocate a new tls-index.
                (load-symbol-value target *free-tls-index*)
-               (let ((error (generate-error-code nil 'tls-exhausted-error)))
+               (let ((not-error (gen-label))
+                     (error (generate-error-code nil 'tls-exhausted-error)))
                  (inst cmp target (fixnumize tls-size))
-                 (inst jmp :ge error))
+                 (inst jmp :l not-error)
+                 (%clear-pseudo-atomic)
+                 (inst jmp error)
+                 (emit-label not-error))
                (inst add (make-ea-for-symbol-value *free-tls-index*)
                      (fixnumize 1))
                (storew target other symbol-tls-index-slot other-pointer-lowtag)
diff --git a/src/compiler/x86-64/macros.lisp b/src/compiler/x86-64/macros.lisp
index 018b43c..e591b24 100644
--- a/src/compiler/x86-64/macros.lisp
+++ b/src/compiler/x86-64/macros.lisp
@@ -292,6 +292,14 @@
        (progn ,@body)
        (pseudo-atomic ,@body)))
 
+;;; Unsafely clear pa flags so that the image can properly lose in a
+;;; pa section.
+#!+sb-thread
+(defmacro %clear-pseudo-atomic ()
+  '(inst mov (make-ea :qword :base thread-base-tn
+              :disp (* 8 thread-pseudo-atomic-bits-slot))
+    0))
+
 #!+sb-thread
 (defmacro pseudo-atomic (&rest forms)
   (with-unique-names (label)
diff --git a/src/compiler/x86/macros.lisp b/src/compiler/x86/macros.lisp
index 29d3009..af6f52d 100644
--- a/src/compiler/x86/macros.lisp
+++ b/src/compiler/x86/macros.lisp
@@ -350,6 +350,12 @@
        (progn ,@forms)
        (pseudo-atomic ,@forms)))
 
+;;; Unsafely clear pa flags so that the image can properly lose in a
+;;; pa section.
+#!+sb-thread
+(defmacro %clear-pseudo-atomic ()
+  '(inst mov (make-ea :dword :disp (* 4 thread-pseudo-atomic-bits-slot)) 0 :fs))
+
 #!+sb-thread
 (defmacro pseudo-atomic (&rest forms)
   (with-unique-names (label)
diff --git a/version.lisp-expr b/version.lisp-expr
index 18f2b3f..766a544 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".)
-"1.0.33.10"
+"1.0.33.11"
-- 
1.7.10.4