X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-package.lisp;h=4569a11a41757114128fad39d382990ea3a6fcd2;hb=71bc8b09fc75083ea4bb2aee954abca1f1e1f214;hp=d8355459751e9076044a25405d2eac44c818c996;hpb=93c8158fd4996e2a7184eb0f8d63812a7bc2562c;p=sbcl.git diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp index d835545..4569a11 100644 --- a/src/code/target-package.lisp +++ b/src/code/target-package.lisp @@ -28,35 +28,92 @@ (!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. + ;; + ;; 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-system-table (,names) + ,@body))) + ;;;; PACKAGE-HASHTABLE stuff (def!method print-object ((table package-hashtable) stream) (declare (type stream stream)) (print-unreadable-object (table stream :type t) (format stream - ":SIZE ~S :FREE ~S :DELETED ~S" - (package-hashtable-size table) - (package-hashtable-free table) - (package-hashtable-deleted table)))) + ":SIZE ~S :FREE ~S :DELETED ~S" + (package-hashtable-size table) + (package-hashtable-free table) + (package-hashtable-deleted table)))) + +;;; the maximum load factor we allow in a package hashtable +(defconstant +package-rehash-threshold+ 0.75) -;;; the maximum density we allow in a package hashtable -(defconstant package-rehash-threshold 0.75) +;;; the load factor desired for a package hashtable when writing a +;;; core image +(defconstant +package-hashtable-image-load-factor+ 0.5) ;;; Make a package hashtable having a prime number of entries at least -;;; as great as (/ SIZE PACKAGE-REHASH-THRESHOLD). If RES is supplied, +;;; as great as (/ SIZE +PACKAGE-REHASH-THRESHOLD+). If RES is supplied, ;;; then it is destructively modified to produce the result. This is ;;; useful when changing the size, since there are many pointers to ;;; the hashtable. +;;; Actually, the smallest table built here has three entries. This +;;; is necessary because the double hashing step size is calculated +;;; using a division by the table size minus two. (defun make-or-remake-package-hashtable (size - &optional + &optional res) (flet ((actual-package-hashtable-size (size) (loop for n of-type fixnum - from (logior (truncate size package-rehash-threshold) 1) + from (logior (ceiling size +package-rehash-threshold+) 1) by 2 when (positive-primep n) return n))) (let* ((n (actual-package-hashtable-size size)) - (size (truncate (* n package-rehash-threshold))) + (size (truncate (* n +package-rehash-threshold+))) (table (make-array n)) (hash (make-array n :element-type '(unsigned-byte 8) @@ -69,38 +126,49 @@ (package-hashtable-deleted res) 0) (setf res (%make-package-hashtable table hash size))) res))) + +;;; Destructively resize TABLE to have room for at least SIZE entries +;;; and rehash its existing entries. +(defun resize-package-hashtable (table size) + (let* ((vec (package-hashtable-table table)) + (hash (package-hashtable-hash table)) + (len (length vec))) + (make-or-remake-package-hashtable size table) + (dotimes (i len) + (when (> (aref hash i) 1) + (add-symbol table (svref vec i)))))) ;;;; package locking operations, built conditionally on :sb-package-locks #!+sb-package-locks (progn -(defun package-locked-p (package) - #!+sb-doc +(defun package-locked-p (package) + #!+sb-doc "Returns T when PACKAGE is locked, NIL otherwise. Signals an error if PACKAGE doesn't designate a valid package." (package-lock (find-undeleted-package-or-lose package))) (defun lock-package (package) - #!+sb-doc + #!+sb-doc "Locks PACKAGE and returns T. Has no effect if PACKAGE was already locked. Signals an error if PACKAGE is not a valid package designator" (setf (package-lock (find-undeleted-package-or-lose package)) t)) (defun unlock-package (package) - #!+sb-doc + #!+sb-doc "Unlocks PACKAGE and returns T. Has no effect if PACKAGE was already unlocked. Signals an error if PACKAGE is not a valid package designator." (setf (package-lock (find-undeleted-package-or-lose package)) nil) t) (defun package-implemented-by-list (package) - #!+sb-doc + #!+sb-doc "Returns a list containing the implementation packages of PACKAGE. Signals an error if PACKAGE is not a valid package designator." (package-%implementation-packages (find-undeleted-package-or-lose package))) -(defun package-implements-list (package) - #!+sb-doc +(defun package-implements-list (package) + #!+sb-doc "Returns the packages that PACKAGE is an implementation package of. Signals an error if PACKAGE is not a valid package designator." (let ((package (find-undeleted-package-or-lose package))) @@ -108,28 +176,28 @@ of. Signals an error if PACKAGE is not a valid package designator." when (member package (package-%implementation-packages x)) collect x))) -(defun add-implementation-package (packages-to-add - &optional (package *package*)) - #!+sb-doc +(defun add-implementation-package (packages-to-add + &optional (package *package*)) + #!+sb-doc "Adds PACKAGES-TO-ADD as implementation packages of PACKAGE. Signals an error if PACKAGE or any of the PACKAGES-TO-ADD is not a valid package designator." (let ((package (find-undeleted-package-or-lose package)) - (packages-to-add (package-listify packages-to-add))) + (packages-to-add (package-listify packages-to-add))) (setf (package-%implementation-packages package) (union (package-%implementation-packages package) (mapcar #'find-undeleted-package-or-lose packages-to-add))))) -(defun remove-implementation-package (packages-to-remove - &optional (package *package*)) - #!+sb-doc +(defun remove-implementation-package (packages-to-remove + &optional (package *package*)) + #!+sb-doc "Removes PACKAGES-TO-REMOVE from the implementation packages of PACKAGE. Signals an error if PACKAGE or any of the PACKAGES-TO-REMOVE is not a valid package designator." (let ((package (find-undeleted-package-or-lose package)) - (packages-to-remove (package-listify packages-to-remove))) + (packages-to-remove (package-listify packages-to-remove))) (setf (package-%implementation-packages package) - (nset-difference + (nset-difference (package-%implementation-packages package) (mapcar #'find-undeleted-package-or-lose packages-to-remove))))) @@ -140,15 +208,15 @@ error if any of PACKAGES is not a valid package designator." (with-unique-names (unlocked-packages) `(let (,unlocked-packages) (unwind-protect - (progn + (progn (dolist (p ',packages) (when (package-locked-p p) (push p ,unlocked-packages) (unlock-package p))) ,@forms) (dolist (p ,unlocked-packages) - (when (find-package p) - (lock-package p))))))) + (when (find-package p) + (lock-package p))))))) (defun package-lock-violation (package &key (symbol nil symbol-p) format-control format-arguments) @@ -187,7 +255,7 @@ error if any of PACKAGES is not a valid package designator." ;; comparison to *package*, since during cold init this gets ;; called before *package* is bound -- but no package should ;; be locked at that point. - (and package + (and package (package-lock package) ;; In package or implementation package (not (or (eq package *package*) @@ -214,15 +282,15 @@ error if any of PACKAGES is not a valid package designator." ;;; ;;; Must be used inside the dynamic contour established by ;;; WITH-SINGLE-PACKAGE-LOCKED-ERROR -(defun assert-package-unlocked (package &optional format-control - &rest format-arguments) - #!-sb-package-locks +(defun assert-package-unlocked (package &optional format-control + &rest format-arguments) + #!-sb-package-locks (declare (ignore format-control format-arguments)) #!+sb-package-locks (when (package-lock-violation-p package) - (package-lock-violation package - :format-control format-control - :format-arguments format-arguments)) + (package-lock-violation package + :format-control format-control + :format-arguments format-arguments)) package) ;;; Must be used inside the dynamic contour established by @@ -236,21 +304,23 @@ error if any of PACKAGES is not a valid package designator." (declare (ignore format)) #!+sb-package-locks (let* ((symbol (etypecase name - (symbol name) - (list (if (eq 'setf (first name)) - (second name) - ;; Skip (class-predicate foo), etc. - ;; FIXME: MOP and package-lock - ;; interaction needs to be thought about. - (return-from - assert-symbol-home-package-unlocked - name))))) - (package (symbol-package symbol))) + (symbol name) + (list (if (and (consp (cdr name)) + (eq 'setf (first name))) + (second name) + ;; Skip lists of length 1, single conses and + ;; (class-predicate foo), etc. + ;; FIXME: MOP and package-lock + ;; interaction needs to be thought about. + (return-from + assert-symbol-home-package-unlocked + name))))) + (package (symbol-package symbol))) (when (package-lock-violation-p package symbol) - (package-lock-violation package - :symbol symbol - :format-control format - :format-arguments (list name)))) + (package-lock-violation package + :symbol symbol + :format-control format + :format-arguments (list name)))) name) @@ -259,16 +329,16 @@ error if any of PACKAGES is not a valid package designator." (def!method print-object ((package package) stream) (let ((name (package-%name package))) (if name - (print-unreadable-object (package stream :type t) - (prin1 name stream)) - (print-unreadable-object (package stream :type t :identity t) - (write-string "(deleted)" stream))))) + (print-unreadable-object (package stream :type t) + (prin1 name stream)) + (print-unreadable-object (package stream :type t :identity t) + (write-string "(deleted)" stream))))) ;;; ANSI says (in the definition of DELETE-PACKAGE) that these, and ;;; most other operations, are unspecified for deleted packages. We ;;; just do the easy thing and signal errors in that case. (macrolet ((def (ext real) - `(defun ,ext (x) (,real (find-undeleted-package-or-lose x))))) + `(defun ,ext (x) (,real (find-undeleted-package-or-lose x))))) (def package-nicknames package-%nicknames) (def package-use-list package-%use-list) (def package-used-by-list package-%used-by-list) @@ -276,8 +346,8 @@ error if any of PACKAGES is not a valid package designator." (defun %package-hashtable-symbol-count (table) (let ((size (the fixnum - (- (package-hashtable-size table) - (package-hashtable-deleted table))))) + (- (package-hashtable-size table) + (package-hashtable-deleted table))))) (the fixnum (- size (package-hashtable-free table))))) @@ -287,17 +357,11 @@ error if any of PACKAGES is not a valid package designator." (defun package-external-symbol-count (package) (%package-hashtable-symbol-count (package-external-symbols package))) -(defvar *package* (error "*PACKAGE* should be initialized in cold load!") +(defvar *package* (error "*PACKAGE* should be initialized in cold load!") #!+sb-doc "the current package") ;;; 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 - (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 @@ -317,34 +381,34 @@ error if any of PACKAGES is not a valid package designator." (define-condition bootstrap-package-not-found (condition) ((name :initarg :name :reader bootstrap-package-name))) (defun debootstrap-package (&optional condition) - (invoke-restart + (invoke-restart (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))) + (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)))))) + :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. @@ -355,7 +419,7 @@ error if any of PACKAGES is not a valid package designator." ;;; Make a package name into a simple-string. (defun package-namify (n) - (stringify-name n "package")) + (stringify-package-designator n)) ;;; ANSI specifies (in the definition of DELETE-PACKAGE) that PACKAGE-NAME ;;; returns NIL (not an error) for a deleted package, so this is a special @@ -370,167 +434,199 @@ error if any of PACKAGES is not a valid package designator." ;;; must be between 2 and 255. (defmacro entry-hash (length sxhash) `(the fixnum - (+ (the fixnum - (rem (the fixnum - (logxor ,length - ,sxhash - (the fixnum (ash ,sxhash -8)) - (the fixnum (ash ,sxhash -16)) - (the fixnum (ash ,sxhash -19)))) - 254)) - 2))) + (+ (the fixnum + (rem (the fixnum + (logxor ,length + ,sxhash + (the fixnum (ash ,sxhash -8)) + (the fixnum (ash ,sxhash -16)) + (the fixnum (ash ,sxhash -19)))) + 254)) + 2))) ;;; FIXME: should be wrapped in EVAL-WHEN (COMPILE EXECUTE) ;;; Add a symbol to a package hashtable. The symbol is assumed ;;; not to be present. (defun add-symbol (table symbol) + (when (zerop (package-hashtable-free table)) + ;; The hashtable is full. Resize it to be able to hold twice the + ;; amount of symbols than it currently contains. The actual new size + ;; can be smaller than twice the current size if the table contained + ;; deleted entries. + (resize-package-hashtable table + (* (- (package-hashtable-size table) + (package-hashtable-deleted table)) + 2))) (let* ((vec (package-hashtable-table table)) - (hash (package-hashtable-hash table)) - (len (length vec)) - (sxhash (%sxhash-simple-string (symbol-name symbol))) - (h2 (the fixnum (1+ (the fixnum (rem sxhash - (the fixnum (- len 2)))))))) - (declare (fixnum len sxhash h2)) - (cond ((zerop (the fixnum (package-hashtable-free table))) - (make-or-remake-package-hashtable (* (package-hashtable-size table) - 2) - table) - (add-symbol table symbol) - (dotimes (i len) - (declare (fixnum i)) - (when (> (the fixnum (aref hash i)) 1) - (add-symbol table (svref vec i))))) - (t - (do ((i (rem sxhash len) (rem (+ i h2) len))) - ((< (the fixnum (aref hash i)) 2) - (if (zerop (the fixnum (aref hash i))) - (decf (package-hashtable-free table)) - (decf (package-hashtable-deleted table))) - (setf (svref vec i) symbol) - (setf (aref hash i) - (entry-hash (length (symbol-name symbol)) - sxhash))) - (declare (fixnum i))))))) + (hash (package-hashtable-hash table)) + (len (length vec)) + (sxhash (%sxhash-simple-string (symbol-name symbol))) + (h2 (1+ (rem sxhash (- len 2))))) + (declare (fixnum sxhash h2)) + (do ((i (rem sxhash len) (rem (+ i h2) len))) + ((< (the fixnum (aref hash i)) 2) + (if (zerop (the fixnum (aref hash i))) + (decf (package-hashtable-free table)) + (decf (package-hashtable-deleted table))) + (setf (svref vec i) symbol) + (setf (aref hash i) + (entry-hash (length (symbol-name symbol)) + sxhash))) + (declare (fixnum i))))) + +;;; Resize the package hashtables of all packages so that their load +;;; factor is +PACKAGE-HASHTABLE-IMAGE-LOAD-FACTOR+. Called from +;;; SAVE-LISP-AND-DIE to optimize space usage in the image. +(defun tune-hashtable-sizes-of-all-packages () + (flet ((tune-table-size (table) + (resize-package-hashtable + table + (round (* (/ +package-rehash-threshold+ + +package-hashtable-image-load-factor+) + (- (package-hashtable-size table) + (package-hashtable-free table) + (package-hashtable-deleted table))))))) + (dolist (package (list-all-packages)) + (tune-table-size (package-internal-symbols package)) + (tune-table-size (package-external-symbols package))))) ;;; Find where the symbol named STRING is stored in TABLE. INDEX-VAR ;;; is bound to the index, or NIL if it is not present. SYMBOL-VAR ;;; is bound to the symbol. LENGTH and HASH are the length and sxhash ;;; of STRING. ENTRY-HASH is the entry-hash of the string and length. (defmacro with-symbol ((index-var symbol-var table string length sxhash - entry-hash) - &body forms) + entry-hash) + &body forms) (let ((vec (gensym)) (hash (gensym)) (len (gensym)) (h2 (gensym)) - (name (gensym)) (name-len (gensym)) (ehash (gensym))) + (name (gensym)) (name-len (gensym)) (ehash (gensym))) `(let* ((,vec (package-hashtable-table ,table)) - (,hash (package-hashtable-hash ,table)) - (,len (length ,vec)) - (,h2 (1+ (the index (rem (the index ,sxhash) - (the index (- ,len 2))))))) + (,hash (package-hashtable-hash ,table)) + (,len (length ,vec)) + (,h2 (1+ (the index (rem (the hash ,sxhash) + (the index (- ,len 2))))))) (declare (type index ,len ,h2)) - (prog ((,index-var (rem (the index ,sxhash) ,len)) - ,symbol-var ,ehash) - (declare (type (or index null) ,index-var)) - LOOP - (setq ,ehash (aref ,hash ,index-var)) - (cond ((eql ,ehash ,entry-hash) - (setq ,symbol-var (svref ,vec ,index-var)) - (let* ((,name (symbol-name ,symbol-var)) - (,name-len (length ,name))) - (declare (type index ,name-len)) - (when (and (= ,name-len ,length) - (string= ,string ,name - :end1 ,length - :end2 ,name-len)) - (go DOIT)))) - ((zerop ,ehash) - (setq ,index-var nil) - (go DOIT))) - (setq ,index-var (+ ,index-var ,h2)) - (when (>= ,index-var ,len) - (setq ,index-var (- ,index-var ,len))) - (go LOOP) - DOIT - (return (progn ,@forms)))))) + (prog ((,index-var (rem (the hash ,sxhash) ,len)) + ,symbol-var ,ehash) + (declare (type (or index null) ,index-var)) + LOOP + (setq ,ehash (aref ,hash ,index-var)) + (cond ((eql ,ehash ,entry-hash) + (setq ,symbol-var (svref ,vec ,index-var)) + (let* ((,name (symbol-name ,symbol-var)) + (,name-len (length ,name))) + (declare (type index ,name-len)) + (when (and (= ,name-len ,length) + (string= ,string ,name + :end1 ,length + :end2 ,name-len)) + (go DOIT)))) + ((zerop ,ehash) + (setq ,index-var nil) + (go DOIT))) + (setq ,index-var (+ ,index-var ,h2)) + (when (>= ,index-var ,len) + (setq ,index-var (- ,index-var ,len))) + (go LOOP) + DOIT + (return (progn ,@forms)))))) ;;; Delete the entry for STRING in TABLE. The entry must exist. (defun nuke-symbol (table string) (declare (simple-string string)) (let* ((length (length string)) - (hash (%sxhash-simple-string string)) - (ehash (entry-hash length hash))) - (declare (type index length hash)) + (hash (%sxhash-simple-string string)) + (ehash (entry-hash length hash))) + (declare (type index length) + (type hash hash)) (with-symbol (index symbol table string length hash ehash) (setf (aref (package-hashtable-hash table) index) 1) (setf (aref (package-hashtable-table table) index) nil) - (incf (package-hashtable-deleted table))))) + (incf (package-hashtable-deleted table)))) + ;; If the table is less than one quarter full, halve its size and + ;; rehash the entries. + (let* ((size (package-hashtable-size table)) + (deleted (package-hashtable-deleted table)) + (used (- size + (package-hashtable-free table) + deleted))) + (declare (type fixnum size deleted used)) + (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)) - (found (gethash n *package-names*))) - (cond ((not found) - (setf (gethash n *package-names*) package) - (push n (package-%nicknames package))) - ((eq found package)) - ((string= (the string (package-%name found)) n) - (error 'simple-package-error - :package package - :format-control "~S is a package name, so it cannot be a nickname for ~S." - :format-arguments (list n (package-%name package)))) - (t - (error 'simple-package-error - :package package - :format-control "~S is already a nickname for ~S." - :format-arguments (list n (package-%name found)))))))) + (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 + :package package + :format-control "~S is a package name, so it cannot be a nickname for ~S." + :format-arguments (list n (package-%name package)))) + (t + (cerror "Leave this nickname alone." + 'simple-package-error + :package package + :format-control "~S is already a nickname for ~S." + :format-arguments (list n (package-%name found)))))))) (defun make-package (name &key - (use '#.*default-package-use-list*) - nicknames - (internal-symbols 10) - (external-symbols 10)) + (use '#.*default-package-use-list*) + nicknames + (internal-symbols 10) + (external-symbols 10)) #!+sb-doc #.(format nil - "Make a new package having the specified NAME, NICKNAMES, and - USE 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*) - - ;; 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))) + "Make a new package having the specified NAME, NICKNAMES, and USE +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*) + (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. @@ -541,103 +637,115 @@ error if any of PACKAGES is not a valid package designator." ;;; 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." - (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 ~ - ~{~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)) + (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)) + (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." - (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 ())) - (maphash (lambda (k v) - (declare (ignore k)) - (pushnew v res)) - *package-names*) + (with-package-names (names) + (maphash (lambda (k v) + (declare (ignore k)) + (pushnew v res)) + names)) res)) (defun intern (name &optional (package (sane-package))) @@ -647,13 +755,13 @@ error if any of PACKAGES is not a valid package designator." ;; We just simple-stringify the name and call INTERN*, where the real ;; logic is. (let ((name (if (simple-string-p name) - name - (coerce name 'simple-string))) - (package (find-undeleted-package-or-lose package))) + name + (coerce name 'simple-string))) + (package (find-undeleted-package-or-lose package))) (declare (simple-string name)) (intern* name - (length name) - package))) + (length name) + package))) (defun find-symbol (name &optional (package (sane-package))) #!+sb-doc @@ -666,8 +774,8 @@ error if any of PACKAGES is not a valid package designator." (let ((name (if (simple-string-p name) name (coerce name 'simple-string)))) (declare (simple-string name)) (find-symbol* name - (length name) - (find-undeleted-package-or-lose package)))) + (length name) + (find-undeleted-package-or-lose package)))) ;;; If the symbol named by the first LENGTH characters of NAME doesn't exist, ;;; then create it, special-casing the keyword package. @@ -675,46 +783,66 @@ error if any of PACKAGES is not a valid package designator." (declare (simple-string name)) (multiple-value-bind (symbol where) (find-symbol* name length package) (cond (where - (values symbol where)) - (t - (let ((symbol-name (subseq name 0 length))) - (with-single-package-locked-error - (:package package "interning ~A" symbol-name) - (let ((symbol (make-symbol symbol-name))) - (%set-symbol-package symbol package) - (cond ((eq package *keyword-package*) - (add-symbol (package-external-symbols package) symbol) - (%set-symbol-value symbol symbol)) - (t - (add-symbol (package-internal-symbols package) symbol))) - (values symbol nil)))))))) + (values symbol where)) + (t + ;; Let's try again with a lock: the common case has the + ;; 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-package-graph () + (setf (values symbol where) (find-symbol* name length package)) + (if where + (values symbol where) + (let ((symbol-name (subseq name 0 length))) + (with-single-package-locked-error + (:package package "interning ~A" symbol-name) + (let ((symbol (make-symbol symbol-name))) + (%set-symbol-package symbol package) + (cond + ((eq package *keyword-package*) + (%set-symbol-value symbol symbol) + (add-symbol (package-external-symbols package) symbol)) + (t + (add-symbol (package-internal-symbols package) symbol))) + (values symbol nil)))))))))) ;;; Check internal and external symbols, then scan down the list -;;; of hashtables for inherited symbols. When an inherited symbol -;;; is found pull that table to the beginning of the list. +;;; of hashtables for inherited symbols. (defun find-symbol* (string length package) (declare (simple-string string) - (type index length)) + (type index length)) (let* ((hash (%sxhash-simple-substring string length)) - (ehash (entry-hash length hash))) - (declare (type index hash ehash)) + (ehash (entry-hash length hash))) + (declare (type hash hash ehash)) (with-symbol (found symbol (package-internal-symbols package) - string length hash ehash) + string length hash ehash) (when found - (return-from find-symbol* (values symbol :internal)))) + (return-from find-symbol* (values symbol :internal)))) (with-symbol (found symbol (package-external-symbols package) - string length hash ehash) + string length hash ehash) (when found - (return-from find-symbol* (values symbol :external)))) + (return-from find-symbol* (values symbol :external)))) (let ((head (package-tables package))) (do ((prev head table) - (table (cdr head) (cdr table))) - ((null table) (values nil nil)) - (with-symbol (found symbol (car table) string length hash ehash) - (when found - (unless (eq prev head) - (shiftf (cdr prev) (cdr table) (cdr head) table)) - (return-from find-symbol* (values symbol :inherited)))))))) + (table (cdr head) (cdr table))) + ((null table) (values nil nil)) + (with-symbol (found symbol (car table) string length hash ehash) + (when found + ;; At this point we used to move the table to the + ;; beginning of the list, probably on the theory that we'd + ;; soon be looking up further items there. Unfortunately + ;; that was very much non-thread safe. Since the failure + ;; mode was nasty (corruption of the package in a way + ;; which would make symbol lookups loop infinitely) and it + ;; would be triggered just by doing reads to a resource + ;; that users can't do their own locking on, that code has + ;; been removed. If we ever add locking to packages, + ;; resurrecting that code might make sense, even though it + ;; didn't seem to have much of an performance effect in + ;; normal use. + ;; + ;; -- JES, 2006-09-13 + (return-from find-symbol* (values symbol :inherited)))))))) ;;; Similar to FIND-SYMBOL, but only looks for an external symbol. ;;; This is used for fast name-conflict checking in this file and symbol @@ -722,13 +850,25 @@ error if any of PACKAGES is not a valid package designator." (defun find-external-symbol (string package) (declare (simple-string string)) (let* ((length (length string)) - (hash (%sxhash-simple-string string)) - (ehash (entry-hash length hash))) - (declare (type index length hash)) + (hash (%sxhash-simple-string string)) + (ehash (entry-hash length hash))) + (declare (type index length) + (type hash hash)) (with-symbol (found symbol (package-external-symbols package) - string length hash ehash) + string length hash ehash) (values symbol found)))) +(defun print-symbol-with-prefix (stream symbol colon at) + #!+sb-doc + "For use with ~/: Write SYMBOL to STREAM as if it is not accessible from + the current package." + (declare (ignore colon at)) + ;; Only keywords should be accessible from the keyword package, and + ;; keywords are always printed with colons, so this guarantees that the + ;; symbol will not be printed without a prefix. + (let ((*package* *keyword-package*)) + (write symbol :stream stream :escape t))) + (define-condition name-conflict (reference-condition package-error) ((function :initarg :function :reader name-conflict-function) (datum :initarg :datum :reader name-conflict-datum) @@ -737,7 +877,8 @@ error if any of PACKAGES is not a valid package designator." (:report (lambda (c s) (format s "~@<~S ~S causes name-conflicts in ~S between the ~ - following symbols:~2I~@:_~{~S~^, ~}~:@>" + following symbols:~2I~@:_~ + ~{~/sb-impl::print-symbol-with-prefix/~^, ~}~:@>" (name-conflict-function c) (name-conflict-datum c) (package-error-package c) @@ -747,14 +888,17 @@ error if any of PACKAGES is not a valid package designator." (restart-case (error 'name-conflict :package package :symbols symbols :function function :datum datum) - (resolve-conflict (s) + (resolve-conflict (chosen-symbol) :report "Resolve conflict." :interactive (lambda () (let* ((len (length symbols)) - (nlen (length (write-to-string len :base 10)))) + (nlen (length (write-to-string len :base 10))) + (*print-pretty* t)) (format *query-io* "~&~@