From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Wed, 14 Nov 2007 18:30:14 +0000 (+0000)
Subject: 1.0.11.24: internal hash-table usage thread-safety, part 2
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=81880593109f9f359cd06dc5c4323750ccc2bf21;p=sbcl.git

1.0.11.24: internal hash-table usage thread-safety, part 2

* Logical hosts.

* TRACE.

* Instrumenting profiler.

* Mapping over *PACKAGE-NAMES*.
---

diff --git a/src/code/ntrace.lisp b/src/code/ntrace.lisp
index 4404d66..c9cca4d 100644
--- a/src/code/ntrace.lisp
+++ b/src/code/ntrace.lisp
@@ -37,7 +37,7 @@
 
 ;;; a hash table that maps each traced function to the TRACE-INFO. The
 ;;; entry for a closure is the shared function entry object.
-(defvar *traced-funs* (make-hash-table :test 'eq))
+(defvar *traced-funs* (make-hash-table :test 'eq :synchronized t))
 
 ;;; A TRACE-INFO object represents all the information we need to
 ;;; trace a given function.
diff --git a/src/code/profile.lisp b/src/code/profile.lisp
index 754fcb0..15b8c74 100644
--- a/src/code/profile.lisp
+++ b/src/code/profile.lisp
@@ -46,7 +46,8 @@
   (make-hash-table
    ;; EQL testing isn't good enough for generalized function names
    ;; like (SETF FOO).
-   :test 'equal))
+   :test 'equal
+   :synchronized t))
 (defstruct (profile-info (:copier nil))
   (name              (missing-arg) :read-only t)
   (encapsulated-fun  (missing-arg) :type function :read-only t)
diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp
index 2e5bef5..d4876ef 100644
--- a/src/code/target-package.lisp
+++ b/src/code/target-package.lisp
@@ -46,7 +46,8 @@
 ;;; core image
 (defconstant +package-hashtable-image-load-factor+ 0.5)
 
-;;; All destructive package modifications are serialized on this lock.
+;;; All destructive package modifications are serialized on this lock,
+;;; plus iterations on *PACKAGE-NAMES*.
 (defvar *package-lock*)
 
 (!cold-init-forms
@@ -690,10 +691,11 @@ implementation it is ~S." *default-package-use-list*)
   #!+sb-doc
   "Return a list of all existing packages."
   (let ((res ()))
-    (maphash (lambda (k v)
-               (declare (ignore k))
-               (pushnew v res))
-             *package-names*)
+    (with-packages ()
+      (maphash (lambda (k v)
+                 (declare (ignore k))
+                 (pushnew v res))
+               *package-names*))
     res))
 
 (defun intern (name &optional (package (sane-package)))
@@ -1300,11 +1302,12 @@ PACKAGE."
   "Return a list of all symbols in the system having the specified name."
   (let ((string (string string-or-symbol))
         (res ()))
-    (maphash (lambda (k v)
-               (declare (ignore k))
-               (multiple-value-bind (s w) (find-symbol string v)
-                 (when w (pushnew s res))))
-             *package-names*)
+    (with-packages ()
+      (maphash (lambda (k v)
+                 (declare (ignore k))
+                 (multiple-value-bind (s w) (find-symbol string v)
+                   (when w (pushnew s res))))
+               *package-names*))
     res))
 
 ;;;; APROPOS and APROPOS-LIST
diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp
index 6f8f1a0..f32e656 100644
--- a/src/code/target-pathname.lisp
+++ b/src/code/target-pathname.lisp
@@ -111,7 +111,7 @@
 
 ;;; Hash table searching maps a logical pathname's host to its
 ;;; physical pathname translation.
-(defvar *logical-hosts* (make-hash-table :test 'equal))
+(defvar *logical-hosts* (make-hash-table :test 'equal :synchronized t))
 
 ;;;; patterns
 
@@ -1338,11 +1338,12 @@ PARSE-NAMESTRING."
 ;;; a new one if necessary.
 (defun intern-logical-host (thing)
   (declare (values logical-host))
-  (or (find-logical-host thing nil)
-      (let* ((name (logical-word-or-lose thing))
-             (new (make-logical-host :name name)))
-        (setf (gethash name *logical-hosts*) new)
-        new)))
+  (with-locked-hash-table (*logical-hosts*)
+    (or (find-logical-host thing nil)
+        (let* ((name (logical-word-or-lose thing))
+               (new (make-logical-host :name name)))
+          (setf (gethash name *logical-hosts*) new)
+          new))))
 
 ;;;; logical pathname parsing
 
diff --git a/version.lisp-expr b/version.lisp-expr
index d1d72c4..98d52c7 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.11.23"
+"1.0.11.24"