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
;;; 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*)
(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"
;;; 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)
;;; 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
;;;; 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.
;;; 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*)
;;; [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
(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."
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))
(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)
(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)
(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)
;;; 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))))
;;; 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))))
;;; 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."
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))
root)))
nil))
\f
-;;; 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)
(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)
;;; 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"
projects / sbcl.git / commitdiff