From: Nikodemus Siivola Date: Thu, 17 Dec 2009 11:42:22 +0000 (+0000) Subject: 1.0.33.11: thread-safe FIND-PACKAGE & DEFPACKAGE X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=3b0286241ce0ef2eec2e66c01f7a49c7c9f3a461;p=sbcl.git 1.0.33.11: thread-safe FIND-PACKAGE & DEFPACKAGE * Must use WITH-PACKAGES around the GETHASH *PACKAGE-NAMES*. --- diff --git a/NEWS b/NEWS index 0b40d46..e73d12b 100644 --- a/NEWS +++ b/NEWS @@ -15,6 +15,8 @@ changes relative to sbcl-1.0.33: from CMUCL (reported by xme@gmx.net; launchpad bug lp#491104) * bug fix: PRINT-OBJECT for clos instances respects the right margin when pretty printing + * bug fix: FIND-PACKAGE & DEFPACKAGE were not thread safe. (reported by + Attila Lendvai) changes in sbcl-1.0.33 relative to sbcl-1.0.32: * new port: support added for x86-64 NetBSD. (thanks to Aymeric Vincent) diff --git a/src/code/defpackage.lisp b/src/code/defpackage.lisp index ff3037c..5df0f16 100644 --- a/src/code/defpackage.lisp +++ b/src/code/defpackage.lisp @@ -212,7 +212,7 @@ implement lock doc-string) (declare #!-sb-package-locks (ignore implement lock)) - (enter-new-nicknames package nicknames) + (%enter-new-nicknames package nicknames) ;; 1. :shadow and :shadowing-import-from ;; ;; shadows is a list of strings, shadowing-imports is a list of symbols. @@ -299,25 +299,26 @@ (type (or simple-string null) doc-string) #!-sb-package-locks (ignore implement lock)) - (let* ((existing-package (find-package name)) - (use (use-list-packages existing-package use)) - (shadowing-imports (import-list-symbols shadowing-imports)) - (imports (import-list-symbols imports))) - (if existing-package - (update-package-with-variance existing-package name - nicknames source-location - shadows shadowing-imports - use imports interns exports - implement lock doc-string) - (let ((package (make-package name - :use nil - :internal-symbols (or size 10) - :external-symbols (length exports)))) - (update-package package - nicknames source-location - shadows shadowing-imports - use imports interns exports - implement lock doc-string))))) + (with-packages () + (let* ((existing-package (find-package name)) + (use (use-list-packages existing-package use)) + (shadowing-imports (import-list-symbols shadowing-imports)) + (imports (import-list-symbols imports))) + (if existing-package + (update-package-with-variance existing-package name + nicknames source-location + shadows shadowing-imports + use imports interns exports + implement lock doc-string) + (let ((package (make-package name + :use nil + :internal-symbols (or size 10) + :external-symbols (length exports)))) + (update-package package + nicknames source-location + shadows shadowing-imports + use imports interns exports + implement lock doc-string)))))) (defun find-or-make-symbol (name package) (multiple-value-bind (symbol how) (find-symbol name package) diff --git a/src/code/package.lisp b/src/code/package.lisp index dd9ca3e..4a9f7ad 100644 --- a/src/code/package.lisp +++ b/src/code/package.lisp @@ -369,3 +369,8 @@ of :INHERITED :EXTERNAL :INTERNAL." (t (,',init-macro :inherited) (setf ,',counter nil))))))))))))) ,@body)))))))) + +(defmacro-mundanely with-packages ((&key) &body forms) + `(flet ((thunk () ,@forms)) + (declare (dynamic-extent #'thunk)) + (call-with-packages #'thunk))) diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp index 01ed836..ff0bd14 100644 --- a/src/code/target-package.lisp +++ b/src/code/target-package.lisp @@ -53,14 +53,15 @@ (!cold-init-forms (setf *package-lock* (sb!thread:make-mutex :name "Package Lock"))) -(defmacro with-packages ((&key) &body forms) +(defun call-with-packages (function) + (declare (function function)) ;; FIXME: Since name conflicts can be signalled while holding the ;; mutex, user code can be run leading to lock ordering problems. ;; ;; This used to be a spinlock, but there it can be held for a long ;; time while the debugger waits for user input. - `(sb!thread:with-recursive-lock (*package-lock*) - ,@forms)) + (sb!thread:with-recursive-lock (*package-lock*) + (funcall function))) ;;; Make a package hashtable having a prime number of entries at least ;;; as great as (/ SIZE +PACKAGE-REHASH-THRESHOLD+). If RES is supplied, @@ -332,7 +333,8 @@ error if any of PACKAGES is not a valid package designator." (defvar *package-names*) (declaim (type hash-table *package-names*)) (!cold-init-forms - (setf *package-names* (make-hash-table :test 'equal))) + ;; No lock, accesses are synchonized on WITH-PACKAGES. + (setf *package-names* (make-hash-table :test 'equal))) ;;; This magical variable is T during initialization so that ;;; USE-PACKAGE's of packages that don't yet exist quietly win. Such @@ -357,30 +359,31 @@ error if any of PACKAGES is not a valid package designator." (find-restart-or-control-error 'debootstrap-package condition))) (defun find-package (package-designator) - (flet ((find-package-from-string (string) - (declare (type string string)) - (let ((packageoid (gethash string *package-names*))) - (when (and (null packageoid) - (not *in-package-init*) ; KLUDGE - (let ((mismatch (mismatch "SB!" string))) - (and mismatch (= mismatch 3)))) - (restart-case - (signal 'bootstrap-package-not-found :name string) - (debootstrap-package () - (return-from find-package - (if (string= string "SB!XC") - (find-package "COMMON-LISP") - (find-package - (substitute #\- #\! string :count 1))))))) - packageoid))) - (typecase package-designator - (package package-designator) - (symbol (find-package-from-string (symbol-name package-designator))) - (string (find-package-from-string package-designator)) - (character (find-package-from-string (string package-designator))) - (t (error 'type-error - :datum package-designator - :expected-type '(or character package string symbol)))))) + (with-packages () + (flet ((find-package-from-string (string) + (declare (type string string)) + (let ((packageoid (gethash string *package-names*))) + (when (and (null packageoid) + (not *in-package-init*) ; KLUDGE + (let ((mismatch (mismatch "SB!" string))) + (and mismatch (= mismatch 3)))) + (restart-case + (signal 'bootstrap-package-not-found :name string) + (debootstrap-package () + (return-from find-package + (if (string= string "SB!XC") + (find-package "COMMON-LISP") + (find-package + (substitute #\- #\! string :count 1))))))) + packageoid))) + (typecase package-designator + (package package-designator) + (symbol (find-package-from-string (symbol-name package-designator))) + (string (find-package-from-string package-designator)) + (character (find-package-from-string (string package-designator))) + (t (error 'type-error + :datum package-designator + :expected-type '(or character package string symbol))))))) ;;; Return a list of packages given a package designator or list of ;;; package designators, or die trying. @@ -525,10 +528,10 @@ error if any of PACKAGES is not a valid package designator." (when (< used (truncate size 4)) (resize-package-hashtable table (* used 2))))) -;;; Enter any new NICKNAMES for PACKAGE into *PACKAGE-NAMES*. -;;; If there is a conflict then give the user a chance to do -;;; something about it. -(defun enter-new-nicknames (package nicknames) +;;; Enter any new NICKNAMES for PACKAGE into *PACKAGE-NAMES*. If there is a +;;; conflict then give the user a chance to do something about it. Caller is +;;; responsible for having acquired the mutex via WITH-PACKAGES. +(defun %enter-new-nicknames (package nicknames) (declare (type list nicknames)) (dolist (n nicknames) (let* ((n (package-namify n)) @@ -590,7 +593,7 @@ implementation it is ~S." *default-package-use-list*) ;; Perhaps this can be solved by just moving ENTER-NEW-NICKNAMES before ;; USE-PACKAGE, but I need to check what kinds of errors can be caused by ;; USE-PACKAGE, too. - (enter-new-nicknames package nicknames) + (%enter-new-nicknames package nicknames) (setf (gethash name *package-names*) package)))) ;;; Change the name if we can, blast any old nicknames and then @@ -629,7 +632,7 @@ implementation it is ~S." *default-package-use-list*) (setf (package-%name package) name (gethash name *package-names*) package (package-%nicknames package) ()) - (enter-new-nicknames package nicknames)) + (%enter-new-nicknames package nicknames)) package))) (defun delete-package (package-designator) diff --git a/version.lisp-expr b/version.lisp-expr index 1939214..8fb7f06 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.16" +"1.0.33.17"