(!cold-init-forms
(/show0 "entering !PACKAGE-COLD-INIT"))
\f
+;;;; Thread safety
+;;;;
+;;;; ...this could still use work, but the basic idea is:
+;;;;
+;;;; *PACKAGE-GRAPH-LOCK* is held via WITH-PACKAGE-GRAPH while working on
+;;;; package graph, including package -> package links, and interning and
+;;;; uninterning symbols.
+;;;;
+;;;; Hash-table lock on *PACKAGE-NAMES* is held via WITH-PACKAGE-NAMES while
+;;;; frobbing name -> package associations.
+;;;;
+;;;; There should be no deadlocks due to ordering issues between these two, as
+;;;; the latter is only held over operations guaranteed to terminate in finite
+;;;; time.
+;;;;
+;;;; Errors may be signalled while holding on to the *PACKAGE-GRAPH-LOCK*,
+;;;; which can still lead to pretty damned inconvenient situations -- but
+;;;; since FIND-PACKAGE, FIND-SYMBOL from other threads isn't blocked by this,
+;;;; the situation isn't *quite* hopeless.
+;;;;
+;;;; A better long-term solution seems to be in splitting the granularity of
+;;;; the *PACKAGE-GRAPH-LOCK* down: for interning a per-package lock should be
+;;;; sufficient, though interaction between parallel intern and use-package
+;;;; needs to be considered with some care.
+
+(defvar *package-graph-lock*)
+(!cold-init-forms
+ (setf *package-graph-lock* (sb!thread:make-mutex :name "Package Graph Lock")))
+
+(defun call-with-package-graph (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-graph-lock*)
+ (funcall function)))
+
+;;; a map from package names to packages
+(defvar *package-names*)
+(declaim (type hash-table *package-names*))
+(!cold-init-forms
+ (setf *package-names* (make-hash-table :test 'equal :synchronized t)))
+
+(defmacro with-package-names ((names &key) &body body)
+ `(let ((,names *package-names*))
+ (with-locked-hash-table (,names)
+ ,@body)))
+\f
;;;; PACKAGE-HASHTABLE stuff
(def!method print-object ((table package-hashtable) stream)
;;; core image
(defconstant +package-hashtable-image-load-factor+ 0.5)
-;;; All destructive package modifications are serialized on this lock,
-;;; plus iterations on *PACKAGE-NAMES*.
-(defvar *package-lock*)
-
-(!cold-init-forms
- (setf *package-lock* (sb!thread:make-mutex :name "Package Lock")))
-
-(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*)
- (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,
;;; then it is destructively modified to produce the result. This is
;;; FIXME: should be declared of type PACKAGE, with no NIL init form,
;;; after I get around to cleaning up DOCUMENTATION
-;;; a map from package names to packages
-(defvar *package-names*)
-(declaim (type hash-table *package-names*))
-(!cold-init-forms
- ;; 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
;;; packages are thrown onto the list *DEFERRED-USE-PACKAGES* so that
(find-restart-or-control-error 'debootstrap-package condition)))
(defun find-package (package-designator)
- (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)))))))
+ (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.
(declare (type list nicknames))
(dolist (n nicknames)
(let* ((n (package-namify n))
- (found (gethash n *package-names*)))
- (cond ((not found)
- (setf (gethash n *package-names*) package)
- (push n (package-%nicknames package)))
- ((eq found package))
+ (found (with-package-names (names)
+ (or (gethash n names)
+ (progn
+ (setf (gethash n names) package)
+ (push n (package-%nicknames package))
+ package)))))
+ (cond ((eq found package))
((string= (the string (package-%name found)) n)
(cerror "Ignore this nickname."
'simple-package-error
internal and external symbols which will ultimately be present in the package.
The default value of USE is implementation-dependent, and in this
implementation it is ~S." *default-package-use-list*)
- (with-packages ()
- ;; Check for package name conflicts in name and nicknames, then
- ;; make the package.
- (when (find-package name)
- ;; ANSI specifies that this error is correctable.
- (cerror "Clobber existing package."
- "A package named ~S already exists" name))
- (let* ((name (package-namify name))
- (package (internal-make-package
- :%name name
- :internal-symbols (make-or-remake-package-hashtable
- internal-symbols)
- :external-symbols (make-or-remake-package-hashtable
- external-symbols))))
-
- ;; Do a USE-PACKAGE for each thing in the USE list so that checking for
- ;; conflicting exports among used packages is done.
- (if *in-package-init*
- (push (list use package) *!deferred-use-packages*)
- (use-package use package))
-
- ;; FIXME: ENTER-NEW-NICKNAMES can fail (ERROR) if nicknames are illegal,
- ;; which would leave us with possibly-bad side effects from the earlier
- ;; USE-PACKAGE (e.g. this package on the used-by lists of other packages,
- ;; but not in *PACKAGE-NAMES*, and possibly import side effects too?).
- ;; 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)
- (setf (gethash name *package-names*) package))))
+ (prog (clobber)
+ :restart
+ (when (find-package name)
+ ;; ANSI specifies that this error is correctable.
+ (cerror "Clobber existing package."
+ "A package named ~S already exists" name)
+ (setf clobber t))
+ (with-packages ()
+ ;; Check for race, signal the error outside the lock.
+ (when (and (not clobber) (find-package name))
+ (go :restart))
+ (let* ((name (package-namify name))
+ (package (internal-make-package
+ :%name name
+ :internal-symbols (make-or-remake-package-hashtable
+ internal-symbols)
+ :external-symbols (make-or-remake-package-hashtable
+ external-symbols))))
+
+ ;; Do a USE-PACKAGE for each thing in the USE list so that checking for
+ ;; conflicting exports among used packages is done.
+ (if *in-package-init*
+ (push (list use package) *!deferred-use-packages*)
+ (use-package use package))
+
+ ;; FIXME: ENTER-NEW-NICKNAMES can fail (ERROR) if nicknames are illegal,
+ ;; which would leave us with possibly-bad side effects from the earlier
+ ;; USE-PACKAGE (e.g. this package on the used-by lists of other packages,
+ ;; but not in *PACKAGE-NAMES*, and possibly import side effects too?).
+ ;; 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)
+ (return (setf (gethash name *package-names*) package))))
+ (bug "never")))
;;; Change the name if we can, blast any old nicknames and then
;;; add in any new ones.
;;; the package name if NAME is the same package that's referred to by PACKAGE.
;;; If it's a *different* package, we should probably signal an error.
;;; (perhaps (ERROR 'ANSI-WEIRDNESS ..):-)
-(defun rename-package (package name &optional (nicknames ()))
+(defun rename-package (package-designator name &optional (nicknames ()))
#!+sb-doc
"Changes the name and nicknames for a package."
- (with-packages ()
- (let* ((package (find-undeleted-package-or-lose package))
- (name (package-namify name))
- (found (find-package name))
- (nicks (mapcar #'string nicknames)))
- (unless (or (not found) (eq found package))
- (error 'simple-package-error
- :package name
- :format-control "A package named ~S already exists."
- :format-arguments (list name)))
- (with-single-package-locked-error ()
- (unless (and (string= name (package-name package))
- (null (set-difference nicks (package-nicknames package)
- :test #'string=)))
- (assert-package-unlocked package "rename as ~A~@[ with nickname~P ~
+ (tagbody :restart
+ (let* ((package (find-undeleted-package-or-lose package-designator))
+ (name (package-namify name))
+ (found (find-package name))
+ (nicks (mapcar #'string nicknames)))
+ (unless (or (not found) (eq found package))
+ (error 'simple-package-error
+ :package name
+ :format-control "A package named ~S already exists."
+ :format-arguments (list name)))
+ (with-single-package-locked-error ()
+ (unless (and (string= name (package-name package))
+ (null (set-difference nicks (package-nicknames package)
+ :test #'string=)))
+ (assert-package-unlocked package "rename as ~A~@[ with nickname~P ~
~{~A~^, ~}~]"
- name (length nicks) nicks))
- ;; do the renaming
- (remhash (package-%name package) *package-names*)
- (dolist (n (package-%nicknames package))
- (remhash n *package-names*))
- (setf (package-%name package) name
- (gethash name *package-names*) package
- (package-%nicknames package) ())
- (%enter-new-nicknames package nicknames))
- package)))
+ name (length nicks) nicks))
+ (with-package-names (names)
+ ;; Check for race conditions now that we have the lock.
+ (unless (eq package (find-package package-designator))
+ (go :restart))
+ ;; Do the renaming.
+ (remhash (package-%name package) names)
+ (dolist (n (package-%nicknames package))
+ (remhash n names))
+ (setf (package-%name package) name
+ (gethash name names) package
+ (package-%nicknames package) ()))
+ (%enter-new-nicknames package nicknames))
+ package)))
(defun delete-package (package-designator)
#!+sb-doc
"Delete the package designated by PACKAGE-DESIGNATOR from the package
system data structures."
- (with-packages ()
- (let ((package (if (packagep package-designator)
- package-designator
- (find-package package-designator))))
- (cond ((not package)
- ;; This continuable error is required by ANSI.
- (cerror
- "Return ~S."
- (make-condition
- 'simple-package-error
- :package package-designator
- :format-control "There is no package named ~S."
- :format-arguments (list package-designator))
- nil))
- ((not (package-name package)) ; already deleted
- nil)
- (t
- (with-single-package-locked-error
- (:package package "deleting package ~A" package)
- (let ((use-list (package-used-by-list package)))
- (when use-list
- ;; This continuable error is specified by ANSI.
- (cerror
- "Remove dependency in other packages."
- (make-condition
- 'simple-package-error
- :package package
- :format-control
- "~@<Package ~S is used by package~P:~2I~_~S~@:>"
- :format-arguments (list (package-name package)
- (length use-list)
- (mapcar #'package-name use-list))))
- (dolist (p use-list)
- (unuse-package package p))))
- (dolist (used (package-use-list package))
- (unuse-package used package))
- (do-symbols (sym package)
- (unintern sym package))
- (remhash (package-name package) *package-names*)
- (dolist (nick (package-nicknames package))
- (remhash nick *package-names*))
- (setf (package-%name package) nil
- ;; Setting PACKAGE-%NAME to NIL is required in order to
- ;; make PACKAGE-NAME return NIL for a deleted package as
- ;; ANSI requires. Setting the other slots to NIL
- ;; and blowing away the PACKAGE-HASHTABLES is just done
- ;; for tidiness and to help the GC.
- (package-%nicknames package) nil
- (package-%use-list package) nil
- (package-tables package) nil
- (package-%shadowing-symbols package) nil
- (package-internal-symbols package)
- (make-or-remake-package-hashtable 0)
- (package-external-symbols package)
- (make-or-remake-package-hashtable 0))
- t))))))
+ (tagbody :restart
+ (let ((package (find-package package-designator)))
+ (cond ((not package)
+ ;; This continuable error is required by ANSI.
+ (cerror
+ "Return ~S."
+ (make-condition
+ 'simple-package-error
+ :package package-designator
+ :format-control "There is no package named ~S."
+ :format-arguments (list package-designator))
+ (return-from delete-package nil)))
+ ((not (package-name package)) ; already deleted
+ (return-from delete-package nil))
+ (t
+ (with-single-package-locked-error
+ (:package package "deleting package ~A" package)
+ (let ((use-list (package-used-by-list package)))
+ (when use-list
+ ;; This continuable error is specified by ANSI.
+ (cerror
+ "Remove dependency in other packages."
+ (make-condition
+ 'simple-package-error
+ :package package
+ :format-control
+ "~@<Package ~S is used by package~P:~2I~_~S~@:>"
+ :format-arguments (list (package-name package)
+ (length use-list)
+ (mapcar #'package-name use-list))))
+ (dolist (p use-list)
+ (unuse-package package p))))
+ (with-package-graph ()
+ ;; Check for races, restart if necessary.
+ (let ((package2 (find-package package-designator)))
+ (when (or (neq package package2) (package-used-by-list package2))
+ (go :restart)))
+ (dolist (used (package-use-list package))
+ (unuse-package used package))
+ (do-symbols (sym package)
+ (unintern sym package))
+ (with-package-names (names)
+ (remhash (package-name package) names)
+ (dolist (nick (package-nicknames package))
+ (remhash nick names))
+ (setf (package-%name package) nil
+ ;; Setting PACKAGE-%NAME to NIL is required in order to
+ ;; make PACKAGE-NAME return NIL for a deleted package as
+ ;; ANSI requires. Setting the other slots to NIL
+ ;; and blowing away the PACKAGE-HASHTABLES is just done
+ ;; for tidiness and to help the GC.
+ (package-%nicknames package) nil))
+ (setf (package-%use-list package) nil
+ (package-tables package) nil
+ (package-%shadowing-symbols package) nil
+ (package-internal-symbols package)
+ (make-or-remake-package-hashtable 0)
+ (package-external-symbols package)
+ (make-or-remake-package-hashtable 0)))
+ (return-from delete-package t)))))))
(defun list-all-packages ()
#!+sb-doc
"Return a list of all existing packages."
(let ((res ()))
- (with-packages ()
+ (with-package-names (names)
(maphash (lambda (k v)
(declare (ignore k))
(pushnew v res))
- *package-names*))
+ names))
res))
\f
(defun intern (name &optional (package (sane-package)))
;; symbol already interned, handled by the first leg of the
;; COND, but in case another thread is interning in
;; parallel we need to check after grabbing the lock.
- (with-packages ()
+ (with-package-graph ()
(setf (values symbol where) (find-symbol* name length package))
(if where
(values symbol where)
(%set-symbol-package symbol package)
(cond
((eq package *keyword-package*)
- (add-symbol (package-external-symbols package) symbol)
- (%set-symbol-value symbol symbol))
+ (%set-symbol-value symbol symbol)
+ (add-symbol (package-external-symbols package) symbol))
(t
(add-symbol (package-internal-symbols package) symbol)))
(values symbol nil))))))))))
"Makes SYMBOL no longer present in PACKAGE. If SYMBOL was present then T is
returned, otherwise NIL. If PACKAGE is SYMBOL's home package, then it is made
uninterned."
- (with-packages ()
+ (with-package-graph ()
(let* ((package (find-undeleted-package-or-lose package))
(name (symbol-name symbol))
(shadowing-symbols (package-%shadowing-symbols package)))
(defun export (symbols &optional (package (sane-package)))
#!+sb-doc
"Exports SYMBOLS from PACKAGE, checking that no name conflicts result."
- (with-packages ()
+ (with-package-graph ()
(let ((package (find-undeleted-package-or-lose package))
+ (symbols (symbol-listify symbols))
(syms ()))
;; Punt any symbols that are already external.
- (dolist (sym (symbol-listify symbols))
+ (dolist (sym symbols)
(multiple-value-bind (s w)
(find-external-symbol (symbol-name sym) package)
(declare (ignore s))
(defun unexport (symbols &optional (package (sane-package)))
#!+sb-doc
"Makes SYMBOLS no longer exported from PACKAGE."
- (with-packages ()
+ (with-package-graph ()
(let ((package (find-undeleted-package-or-lose package))
+ (symbols (symbol-listify symbols))
(syms ()))
- (dolist (sym (symbol-listify symbols))
+ (dolist (sym symbols)
(multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
(cond ((or (not w) (not (eq s sym)))
(error 'simple-package-error
"Make SYMBOLS accessible as internal symbols in PACKAGE. If a symbol is
already accessible then it has no effect. If a name conflict would result from
the importation, then a correctable error is signalled."
- (with-packages ()
+ (with-package-graph ()
(let* ((package (find-undeleted-package-or-lose package))
(symbols (symbol-listify symbols))
(homeless (remove-if #'symbol-package symbols))
#!+sb-doc
"Import SYMBOLS into package, disregarding any name conflict. If
a symbol of the same name is present, then it is uninterned."
- (with-packages ()
+ (with-package-graph ()
(let* ((package (find-undeleted-package-or-lose package))
(internal (package-internal-symbols package))
(symbols (symbol-listify symbols))
specified SYMBOLS. If a symbol with the given name is already present in
PACKAGE, then the existing symbol is placed in the shadowing symbols list if
it is not already present."
- (with-packages ()
+ (with-package-graph ()
(let* ((package (find-undeleted-package-or-lose package))
(internal (package-internal-symbols package))
(symbols (string-listify symbols))
"Add all the PACKAGES-TO-USE to the use list for PACKAGE so that the
external symbols of the used packages are accessible as internal symbols in
PACKAGE."
- (with-packages ()
+ (with-package-graph ()
(let ((packages (package-listify packages-to-use))
(package (find-undeleted-package-or-lose package)))
(defun unuse-package (packages-to-unuse &optional (package (sane-package)))
#!+sb-doc
"Remove PACKAGES-TO-UNUSE from the USE list for PACKAGE."
- (with-packages ()
+ (with-package-graph ()
(let ((package (find-undeleted-package-or-lose package))
(packages (package-listify packages-to-unuse)))
(with-single-package-locked-error ()
"Return a list of all symbols in the system having the specified name."
(let ((string (string string-or-symbol))
(res ()))
- (with-packages ()
+ (with-package-names (names)
(maphash (lambda (k v)
(declare (ignore k))
(multiple-value-bind (s w) (find-symbol string v)
(when w (pushnew s res))))
- *package-names*))
+ names))
res))
\f
;;;; APROPOS and APROPOS-LIST
projects / sbcl.git / commitdiff