0.9.16.40:

[sbcl.git] / src / code / target-thread.lisp

diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp
index c77d056..302a9fa 100644 (file)
--- a/src/code/target-thread.lisp
+++ b/src/code/target-thread.lisp
@@ -156,13 +156,18 @@ in future versions."
         int (word unsigned-long) (n unsigned-long))))
 
 ;;; used by debug-int.lisp to access interrupt contexts
-#!-(and sb-fluid sb-thread) (declaim (inline sb!vm::current-thread-offset-sap))
+#!-(or sb-fluid sb-thread) (declaim (inline sb!vm::current-thread-offset-sap))
 #!-sb-thread
 (defun sb!vm::current-thread-offset-sap (n)
   (declare (type (unsigned-byte 27) n))
   (sap-ref-sap (alien-sap (extern-alien "all_threads" (* t)))
                (* n sb!vm:n-word-bytes)))
 
+#!+sb-thread
+(defun sb!vm::current-thread-offset-sap (n)
+  (declare (type (unsigned-byte 27) n))
+  (sb!vm::current-thread-offset-sap n))
+
 ;;;; spinlocks
 
 (declaim (inline get-spinlock release-spinlock))
@@ -591,12 +596,29 @@ returns the thread exits."
          (real-function (coerce function 'function))
          (initial-function
           (lambda ()
-            ;; in time we'll move some of the binding presently done in C
-            ;; here too
+            ;; In time we'll move some of the binding presently done in C
+            ;; here too.
+            ;;
+            ;; KLUDGE: Here we have a magic list of variables that are
+            ;; not thread-safe for one reason or another.  As people
+            ;; report problems with the thread safety of certain
+            ;; variables, (e.g. "*print-case* in multiple threads
+            ;; broken", sbcl-devel 2006-07-14), we add a few more
+            ;; bindings here.  The Right Thing is probably some variant
+            ;; of Allegro's *cl-default-special-bindings*, as that is at
+            ;; least accessible to users to secure their own libraries.
+            ;;   --njf, 2006-07-15
             (let ((*current-thread* thread)
                   (sb!kernel::*restart-clusters* nil)
                   (sb!kernel::*handler-clusters* nil)
                   (sb!kernel::*condition-restarts* nil)
+                  (sb!impl::*step-out* nil)
+                  ;; internal printer variables
+                  (sb!impl::*previous-case* nil)
+                  (sb!impl::*previous-readtable-case* nil)
+                  (sb!impl::*merge-sort-temp-vector* (vector)) ; keep these small!
+                  (sb!impl::*zap-array-data-temp* (vector))    ;
+                  (sb!impl::*internal-symbol-output-fun* nil)
                   (sb!impl::*descriptor-handlers* nil)) ; serve-event
               (setf (thread-os-thread thread) (current-thread-sap-id))
               (with-mutex (*all-threads-lock*)
@@ -738,3 +760,18 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated"
     (if (eql tl-val sb!vm::no-tls-value-marker-widetag)
         (sb!vm::symbol-global-value symbol)
         (sb!kernel:make-lisp-obj tl-val))))
+
+(defun sb!vm::locked-symbol-global-value-add (symbol-name delta)
+  (sb!vm::locked-symbol-global-value-add symbol-name delta))
+
+;;; Stepping
+
+(defun thread-stepping ()
+  (sb!kernel:make-lisp-obj
+   (sap-ref-word (current-thread-sap)
+                 (* sb!vm::thread-stepping-slot sb!vm:n-word-bytes))))
+
+(defun (setf thread-stepping) (value)
+  (setf (sap-ref-word (current-thread-sap)
+                      (* sb!vm::thread-stepping-slot sb!vm:n-word-bytes))
+        (sb!kernel:get-lisp-obj-address value)))