From: Nikodemus Siivola Date: Wed, 14 Nov 2007 15:57:27 +0000 (+0000) Subject: 1.0.11.23: internal hash-table usage thread-safety, part 1 X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=32eb2c37fb2d9b12c5b5f674fe33b77f611120cb;p=sbcl.git 1.0.11.23: internal hash-table usage thread-safety, part 1 * Use :SYNCHRONIZED hash-tables for the most part, and a light dash of WITH-LOCKED-HASH-TABLE as approriapte: *FORWARD-REFERENCED-LAYOUTS*, CLASSOID-SUBCLASSES, *COMPILED-DEBUG-FUNS*, *FUN-END-COOKIES*, *COMPONENT-BREAKPOINT-OFFSETS*, *EFFECTIVE-METHOD-CACHE*. * Replace *FOREIGN-LOCK* with *SHARED-OBJECT-LOCK* and hash-table based locking for *LINKAGE-INFO* for efficiency. --- diff --git a/NEWS b/NEWS index da64a4f..2d649b1 100644 --- a/NEWS +++ b/NEWS @@ -5,6 +5,8 @@ changes in sbcl-1.0.12 relative to sbcl-1.0.11: concurrent accesses (but not iteration.) See also: SB-EXT:WITH-LOCKED-HASH-TABLE, and SB-EXT:HASH-TABLE-SYNCHRONIZED-P. + * bug fix: number of thread safety issues relating to SBCL's internal + hash-table usage have been fixed. * bug fix: SB-SYS:WITH-PINNED-OBJECTS could cause garbage values to be returned from its body when the values were being returned using unknown-values return convection and the W-P-O was wrapped diff --git a/src/code/class.lisp b/src/code/class.lisp index 79dc7ae..082484c 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -101,7 +101,9 @@ ;;; cold-load time. (defvar *forward-referenced-layouts*) (!cold-init-forms - (setq *forward-referenced-layouts* (make-hash-table :test 'equal)) + (setq *forward-referenced-layouts* (make-hash-table :test 'equal + #-sb-xc-host #-sb-xc-host + :synchronized t)) #-sb-xc-host (progn (/show0 "processing *!INITIAL-LAYOUTS*") (dolist (x *!initial-layouts*) @@ -495,7 +497,9 @@ (let* ((super (layout-classoid super-layout)) (subclasses (or (classoid-subclasses super) (setf (classoid-subclasses super) - (make-hash-table :test 'eq))))) + (make-hash-table :test 'eq + #-sb-xc-host #-sb-xc-host + :synchronized t))))) (when (and (eq (classoid-state super) :sealed) (not (gethash classoid subclasses))) (warn "unsealing sealed class ~S in order to subclass it" diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 11c74df..f8358a4 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -300,15 +300,19 @@ ;;; duplicate COMPILED-DEBUG-FUN structures. (defvar *compiled-debug-funs* (make-hash-table :test 'eq)) -;;; Make a COMPILED-DEBUG-FUN for a SB!C::COMPILER-DEBUG-FUN -;;; and its component. This maps the latter to the former in -;;; *COMPILED-DEBUG-FUNS*. If there already is a -;;; COMPILED-DEBUG-FUN, then this returns it from -;;; *COMPILED-DEBUG-FUNS*. +;;; Make a COMPILED-DEBUG-FUN for a SB!C::COMPILER-DEBUG-FUN and its +;;; component. This maps the latter to the former in +;;; *COMPILED-DEBUG-FUNS*. If there already is a COMPILED-DEBUG-FUN, +;;; then this returns it from *COMPILED-DEBUG-FUNS*. +;;; +;;; FIXME: It seems this table can potentially grow without bounds, +;;; and retains roots to functions that might otherwise be collected. (defun make-compiled-debug-fun (compiler-debug-fun component) - (or (gethash compiler-debug-fun *compiled-debug-funs*) - (setf (gethash compiler-debug-fun *compiled-debug-funs*) - (%make-compiled-debug-fun compiler-debug-fun component)))) + (let ((table *compiled-debug-funs*)) + (with-locked-hash-table (table) + (or (gethash compiler-debug-fun table) + (setf (gethash compiler-debug-fun table) + (%make-compiled-debug-fun compiler-debug-fun component)))))) (defstruct (bogus-debug-fun (:include debug-fun) @@ -2861,7 +2865,7 @@ register." ;;; This maps bogus-lra-components to cookies, so that ;;; HANDLE-FUN-END-BREAKPOINT can find the appropriate cookie for the ;;; breakpoint hook. -(defvar *fun-end-cookies* (make-hash-table :test 'eq)) +(defvar *fun-end-cookies* (make-hash-table :test 'eq :synchronized t)) ;;; This returns a hook function for the start helper breakpoint ;;; associated with a :FUN-END breakpoint. The returned function @@ -3113,7 +3117,7 @@ register." ;;;; breakpoint handlers (layer between C and exported interface) ;;; This maps components to a mapping of offsets to BREAKPOINT-DATAs. -(defvar *component-breakpoint-offsets* (make-hash-table :test 'eq)) +(defvar *component-breakpoint-offsets* (make-hash-table :test 'eq :synchronized t)) ;;; This returns the BREAKPOINT-DATA object associated with component cross ;;; offset. If none exists, this makes one, installs it, and returns it. @@ -3135,6 +3139,8 @@ register." ;;; We use this when there are no longer any active breakpoints ;;; corresponding to DATA. (defun delete-breakpoint-data (data) + ;; Again, this looks brittle. Is there no danger of being interrupted + ;; here? (let* ((component (breakpoint-data-component data)) (offsets (delete (breakpoint-data-offset data) (gethash component *component-breakpoint-offsets*) @@ -3238,6 +3244,8 @@ register." ;;; [old C code] or HANDLE-FUN-END-BREAKPOINT calls this directly ;;; [new C code]. (defun handle-fun-end-breakpoint-aux (breakpoints data signal-context) + ;; FIXME: This looks brittle: what if we are interrupted somewhere + ;; here? ...or do we have interrupts disabled here? (delete-breakpoint-data data) (let* ((scp (locally diff --git a/src/code/foreign-load.lisp b/src/code/foreign-load.lisp index 86016be..2e619ef 100644 --- a/src/code/foreign-load.lisp +++ b/src/code/foreign-load.lisp @@ -11,11 +11,9 @@ (in-package "SB!ALIEN") -;;; Used to serialize modifications to *linkage-info*, -;;; *shared-objects* and the linkage-table proper. Calls thru -;;; linkage-table are unaffected. -(defvar *foreign-lock* - (sb!thread:make-mutex :name "foreign definition lock")) +;;; Used to serialize modifications to *shared-objects*. +(defvar *shared-objects-lock* + (sb!thread:make-mutex :name "shared object list lock")) (define-unsupported-fun load-foreign "Unsupported as of SBCL 0.8.13. See LOAD-SHARED-OBJECT." @@ -90,17 +88,18 @@ expected if user or library-code has called dlopen on FILE. References to foreign symbols in loaded shared objects do not survive intact through SB-EXT:SAVE-LISP-AND-DIE on all platforms. See SB-EXT:SAVE-LISP-AND-DIE for details." - (sb!thread:with-mutex (*foreign-lock*) - (let* ((filename (or (unix-namestring file) file)) - (old (find filename *shared-objects* :key #'shared-object-file :test #'equal)) - (obj (or old (make-shared-object :file filename)))) - (dlopen-or-lose obj) - (setf *shared-objects* (append (remove obj *shared-objects*) - (list obj))) - #!+linkage-table - (when (or old (undefined-foreign-symbols-p)) - (update-linkage-table)) - (pathname filename)))) + (let ((filename (or (unix-namestring file) file)) + (old nil)) + (sb!thread:with-mutex (*shared-objects-lock*) + (setf old (find filename *shared-objects* :key #'shared-object-file :test #'equal)) + (let* ((obj (or old (make-shared-object :file filename)))) + (dlopen-or-lose obj) + (setf *shared-objects* (append (remove obj *shared-objects*) + (list obj))))) + #!+linkage-table + (when (or old (undefined-foreign-symbols-p)) + (update-linkage-table)) + (pathname filename))) (defun try-reopen-shared-object (obj) (declare (type shared-object obj)) diff --git a/src/code/foreign.lisp b/src/code/foreign.lisp index 805c5ab..edc559c 100644 --- a/src/code/foreign.lisp +++ b/src/code/foreign.lisp @@ -129,13 +129,12 @@ if the symbol isn't found." (when (<= sb!vm:linkage-table-space-start addr sb!vm:linkage-table-space-end) - (maphash (lambda (name-and-datap info) - (let ((table-addr (linkage-info-address info))) - (when (<= table-addr - addr - (+ table-addr sb!vm:linkage-table-entry-size)) - (return-from sap-foreign-symbol (car name-and-datap))))) - *linkage-info*)) + (dohash ((name-and-datap info) *linkage-info* :locked t) + (let ((table-addr (linkage-info-address info))) + (when (<= table-addr + addr + (+ table-addr sb!vm:linkage-table-entry-size)) + (return-from sap-foreign-symbol (car name-and-datap)))))) #!+os-provides-dladdr (with-alien ((info (struct dl-info (filename c-string) diff --git a/src/code/linkage-table.lisp b/src/code/linkage-table.lisp index 8380d6d..8d122a9 100644 --- a/src/code/linkage-table.lisp +++ b/src/code/linkage-table.lisp @@ -19,7 +19,7 @@ (in-package "SB!IMPL") -(defvar *foreign-lock*) ; initialized in foreign-load.lisp +(defvar *shared-object-lock*) ; initialized in foreign-load.lisp (define-alien-routine arch-write-linkage-table-jmp void (table-address system-area-pointer) @@ -29,7 +29,7 @@ (table-address system-area-pointer) (real-address system-area-pointer)) -(defvar *linkage-info* (make-hash-table :test 'equal)) +(defvar *linkage-info* (make-hash-table :test 'equal :synchronized t)) (defstruct linkage-info datap address) @@ -62,7 +62,7 @@ ;;; in the linkage table. (defun ensure-foreign-symbol-linkage (name datap) (/show0 "ensure-foreign-symbol-linkage") - (sb!thread:with-mutex (*foreign-lock*) + (with-locked-hash-table (*linkage-info*) (let ((info (or (gethash (cons name datap) *linkage-info*) (link-foreign-symbol name datap)))) (linkage-info-address info)))) @@ -70,16 +70,17 @@ ;;; Update the linkage-table. Called during initialization after all ;;; shared libraries have been reopened, and after a previously loaded ;;; shared object is reloaded. +;;; +;;; FIXME: Should figure out how to write only those entries that need +;;; updating. (defun update-linkage-table () - ;; Doesn't take care of its own locking -- callers are responsible - (maphash (lambda (name-and-datap info) - (let* ((name (car name-and-datap)) - (datap (cdr name-and-datap)) - (table-address (linkage-info-address info)) - (real-address - (ensure-dynamic-foreign-symbol-address name datap))) - (aver (and table-address real-address)) - (write-linkage-table-entry table-address - real-address - datap))) - *linkage-info*)) + (dohash ((name-and-datap info) *linkage-info* :locked t) + (let* ((name (car name-and-datap)) + (datap (cdr name-and-datap)) + (table-address (linkage-info-address info)) + (real-address + (ensure-dynamic-foreign-symbol-address name datap))) + (aver (and table-address real-address)) + (write-linkage-table-entry table-address + real-address + datap)))) diff --git a/src/code/win32-foreign-load.lisp b/src/code/win32-foreign-load.lisp index a0bfe7a..2005525 100644 --- a/src/code/win32-foreign-load.lisp +++ b/src/code/win32-foreign-load.lisp @@ -14,8 +14,8 @@ ;;; Used to serialize modifications to *linkage-info*, ;;; *shared-objects* and the linkage-table proper. Calls thru ;;; linkage-table are unaffected. -(defvar *foreign-lock* - (sb!thread:make-mutex :name "foreign definition lock")) +(defvar *shared-objects-lock* + (sb!thread:make-mutex :name "shared object list lock")) (define-unsupported-fun load-foreign "Unsupported as of SBCL 0.8.13. See LOAD-SHARED-OBJECT." @@ -79,15 +79,17 @@ expected if user or library-code has called dlopen on FILE. References to foreign symbols in loaded shared objects do not survive intact through SB-EXT:SAVE-LISP-AND-DIE on all platforms. See SB-EXT:SAVE-LISP-AND-DIE for details." - (sb!thread:with-mutex (*foreign-lock*) - (let* ((filename (or (unix-namestring file) file)) - (old (find filename *shared-objects* :key #'shared-object-file :test #'equal)) - (obj (or old (make-shared-object :file filename)))) - (unless old - (dlopen-or-lose obj)) - (setf *shared-objects* (append (remove obj *shared-objects*) - (list obj))) - (pathname filename)))) + ;; FIXME: 1. This is copy-paste from foreign-load.lisp. + ;; FIXME: 2. Once windows gets threads, this is going to need a lock. + ;; FIXME: 3. No linkage table on windows? + (let* ((filename (or (unix-namestring file) file)) + (old (find filename *shared-objects* :key #'shared-object-file :test #'equal)) + (obj (or old (make-shared-object :file filename)))) + (unless old + (dlopen-or-lose obj)) + (setf *shared-objects* (append (remove obj *shared-objects*) + (list obj))) + (pathname filename))) (defun try-reopen-shared-object (obj) (declare (type shared-object obj)) diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index 3be7f77..e301b76 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -1643,12 +1643,21 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 root))) nil)) -;;; FIXME: Needs a lock. +;;; Not synchronized, as all the uses we have for it are multiple ones +;;; and need WITH-LOCKED-HASH-TABLE in any case. +;;; +;;; FIXME: Is it really more efficient to store this stuff in a global +;;; table instead of having a slot in each method? +;;; +;;; FIXME: This table also seems to contain early methods, which should +;;; presumably be dropped during the bootstrap. (defvar *effective-method-cache* (make-hash-table :test 'eq)) (defun flush-effective-method-cache (generic-function) - (dolist (method (generic-function-methods generic-function)) - (remhash method *effective-method-cache*))) + (let ((cache *effective-method-cache*)) + (with-locked-hash-table (cache) + (dolist (method (generic-function-methods generic-function)) + (remhash method cache))))) (defun get-secondary-dispatch-function (gf methods types &optional method-alist wrappers) @@ -1675,9 +1684,10 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (lambda (&rest args) (apply #'no-applicable-method gf args)))) (let* ((key (car methods)) - (ht-value (or (gethash key *effective-method-cache*) - (setf (gethash key *effective-method-cache*) - (cons nil nil))))) + (ht *effective-method-cache*) + (ht-value (with-locked-hash-table (ht) + (or (gethash key ht) + (setf (gethash key ht) (cons nil nil)))))) (if (and (null (cdr methods)) all-applicable-p ; the most common case (null method-alist-p) wrappers-p (not function-p)) (or (car ht-value) diff --git a/version.lisp-expr b/version.lisp-expr index d295a3c..d1d72c4 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.22" +"1.0.11.23"