X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-package.lisp;h=87f1da1c6db1de8454c6a849d709a986bf5a1601;hb=b56c1a4dc22aa0ac827343667584aa6090b15f02;hp=ff0bd1467a7c0c6ea83e56f2ec0d902777a8463a;hpb=3b0286241ce0ef2eec2e66c01f7a49c7c9f3a461;p=sbcl.git diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp index ff0bd14..87f1da1 100644 --- a/src/code/target-package.lisp +++ b/src/code/target-package.lisp @@ -28,6 +28,53 @@ (!cold-init-forms (/show0 "entering !PACKAGE-COLD-INIT")) +;;;; 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. + (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-system-table (,names) + ,@body))) + ;;;; PACKAGE-HASHTABLE stuff (def!method print-object ((table package-hashtable) stream) @@ -46,23 +93,6 @@ ;;; 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 @@ -329,13 +359,6 @@ error if any of PACKAGES is not a valid package designator." ;;; 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 @@ -359,31 +382,30 @@ error if any of PACKAGES is not a valid package designator." (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. @@ -535,11 +557,13 @@ error if any of PACKAGES is not a valid package designator." (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 @@ -565,36 +589,41 @@ list. :INTERNAL-SYMBOLS and :EXTERNAL-SYMBOLS are estimates for the number of 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 "Leave existing package alone." - "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-package-graph () + ;; 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. @@ -605,106 +634,115 @@ implementation it is ~S." *default-package-use-list*) ;;; 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 ~ + (let ((package nil)) + (tagbody :restart + (setq package (find-undeleted-package-or-lose package-designator)) + (let* ((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 - "~@" - :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 + "~@" + :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)) (defun intern (name &optional (package (sane-package))) @@ -748,7 +786,7 @@ implementation it is ~S." *default-package-use-list*) ;; 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) @@ -759,8 +797,8 @@ implementation it is ~S." *default-package-use-list*) (%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)))))))))) @@ -902,7 +940,7 @@ implementation it is ~S." *default-package-use-list*) "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))) @@ -926,8 +964,8 @@ uninterned." (remove symbol shadowing-symbols))) (multiple-value-bind (s w) (find-symbol name package) - (declare (ignore s)) - (cond ((or (eq w :internal) (eq w :external)) + (cond ((not (eq symbol s)) nil) + ((or (eq w :internal) (eq w :external)) (nuke-symbol (if (eq w :internal) (package-internal-symbols package) (package-external-symbols package)) @@ -973,11 +1011,12 @@ uninterned." (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)) @@ -1033,10 +1072,11 @@ uninterned." (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 @@ -1062,7 +1102,7 @@ uninterned." "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)) @@ -1074,6 +1114,7 @@ the importation, then a correctable error is signalled." (let ((found (member sym syms :test #'string=))) (if found (when (not (eq (car found) sym)) + (setf syms (remove (car found) syms)) (name-conflict package 'import sym sym (car found))) (push sym syms)))) ((not (eq s sym)) @@ -1098,7 +1139,7 @@ the importation, then a correctable error is signalled." #!+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)) @@ -1128,7 +1169,7 @@ the importation, then a correctable error is signalled." 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)) @@ -1157,7 +1198,7 @@ it is not already present." "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))) @@ -1216,7 +1257,7 @@ 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 () @@ -1238,12 +1279,12 @@ PACKAGE." "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)) ;;;; APROPOS and APROPOS-LIST