X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-package.lisp;h=87f1da1c6db1de8454c6a849d709a986bf5a1601;hb=b56c1a4dc22aa0ac827343667584aa6090b15f02;hp=c9ff756b6be27f9a53015e9984a49cb3a4c380c8;hpb=ebbca8290ee358edb1533f30c250f0b25d20f1c4;p=sbcl.git

diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp
index c9ff756..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)
@@ -39,24 +86,31 @@
             (package-hashtable-free table)
             (package-hashtable-deleted table))))
 
-;;; the maximum density we allow in a package hashtable
-(defconstant package-rehash-threshold 0.75)
+;;; the maximum load factor 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
                                          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,6 +123,17 @@
                 (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
 
@@ -294,12 +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
-  (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
@@ -357,7 +416,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
@@ -386,33 +445,47 @@ error if any of PACKAGES is not a valid package designator."
 ;;; 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)))))))
+         (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
@@ -426,10 +499,10 @@ error if any of PACKAGES is not a valid package designator."
     `(let* ((,vec (package-hashtable-table ,table))
             (,hash (package-hashtable-hash ,table))
             (,len (length ,vec))
-            (,h2 (1+ (the index (rem (the index ,sxhash)
+            (,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))
+       (prog ((,index-var (rem (the hash ,sxhash) ,len))
               ,symbol-var ,ehash)
          (declare (type (or index null) ,index-var))
          LOOP
@@ -460,24 +533,37 @@ error if any of PACKAGES is not a valid package designator."
   (let* ((length (length string))
          (hash (%sxhash-simple-string string))
          (ehash (entry-hash length hash)))
-    (declare (type index 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))
+           (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
@@ -498,43 +584,46 @@ error if any of PACKAGES is not a valid package designator."
                           (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.
@@ -545,103 +634,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 ~
+  (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))
+                                    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
-                   "~@<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 ()))
-    (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)))
@@ -681,27 +782,35 @@ error if any of PACKAGES is not a valid package designator."
     (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))))))))
+           ;; 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))
   (let* ((hash (%sxhash-simple-substring string length))
          (ehash (entry-hash length hash)))
-    (declare (type index hash ehash))
+    (declare (type hash hash ehash))
     (with-symbol (found symbol (package-internal-symbols package)
                         string length hash ehash)
       (when found
@@ -716,8 +825,20 @@ error if any of PACKAGES is not a valid package designator."
           ((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))
+            ;; 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.
@@ -728,11 +849,23 @@ error if any of PACKAGES is not a valid package designator."
   (let* ((length (length string))
          (hash (%sxhash-simple-string string))
          (ehash (entry-hash length hash)))
-    (declare (type index length hash))
+    (declare (type index length)
+             (type hash hash))
     (with-symbol (found symbol (package-external-symbols package)
                         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)
@@ -741,7 +874,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)
@@ -751,7 +885,7 @@ 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 ()
@@ -759,7 +893,9 @@ error if any of PACKAGES is not a valid package designator."
                (nlen (length (write-to-string len :base 10)))
                (*print-pretty* t))
           (format *query-io* "~&~@<Select a symbol to be made accessible in ~
-                              package ~A:~2I~@:_~{~{~V,' D. ~S~}~@:_~}~@:>"
+                              package ~A:~2I~@:_~{~{~V,' D. ~
+                              ~/sb-impl::print-symbol-with-prefix/~}~@:_~}~
+                              ~@:>"
                 (package-name package)
                 (loop for s in symbols
                       for i upfrom 1
@@ -770,143 +906,74 @@ error if any of PACKAGES is not a valid package designator."
            (let ((i (parse-integer (read-line *query-io*) :junk-allowed t)))
              (when (and i (<= 1 i len))
                (return (list (nth (1- i) symbols))))))))
-      (multiple-value-bind (symbol status)
-          (find-symbol (symbol-name s) package)
-        (declare (ignore status)) ; FIXME: is that true?
-        (case function
-          ((export)
-           (if (eq symbol s)
-               (shadow symbol package)
-               (unintern symbol package)))
-          ((unintern)
-           (shadowing-import s package))
-          ((import)
-           (if (eq symbol s)
-               nil ; do nothing
-               (shadowing-import s package)))
-          ((use-package)
-           (if (eq symbol s)
-               (shadow s package)
-               (shadowing-import s package))))))))
-
-#+nil ; this solution gives a variable number of restarts instead, but
-      ; no good way of programmatically choosing between them.
-(defun name-conflict (package function datum &rest symbols)
-  (let ((condition (make-condition 'name-conflict
-                                   :package package :symbols symbols
-                                   :function function :datum datum)))
-    ;; this is a gross violation of modularity, but I can't see any
-    ;; other way to have a variable number of restarts.
-    (let ((*restart-clusters*
-           (cons
-            (mapcan
-             (lambda (s)
-               (multiple-value-bind (accessible-symbol status)
-                   (find-symbol (symbol-name s) package)
-                 (cond
-                   ;; difficult case
-                   ((eq s accessible-symbol)
-                    (ecase status
-                      ((:inherited)
-                       (list (make-restart
-                              :name (make-symbol "SHADOWING-IMPORT")
-                              :function (lambda ()
-                                          (shadowing-import s package)
-                                          (return-from name-conflict))
-                              :report-function
-                              (lambda (stream)
-                                (format stream "Shadowing-import ~S into ~A."
-                                        s (package-%name package))))))
-                      ((:internal :external)
-                       (aver (= (length symbols) 2))
-                       ;; ARGH! FIXME: this unintern restart can
-                       ;; _still_ leave the system in an
-                       ;; unsatisfactory state: if the symbol is a
-                       ;; external symbol of a package which is
-                       ;; already used by this package, and has also
-                       ;; been imported, then uninterning it from this
-                       ;; package will still leave it visible!
-                       ;;
-                       ;; (DEFPACKAGE "FOO" (:EXPORT "SYM"))
-                       ;; (DEFPACKAGE "BAR" (:EXPORT "SYM"))
-                       ;; (DEFPACKAGE "BAZ" (:USE "FOO"))
-                       ;; (IMPORT 'FOO:SYM "BAZ")
-                       ;; (USE-PACKAGE "BAR" "BAZ")
-                       ;;
-                       ;; Now (UNINTERN 'FOO:SYM "BAZ") doesn't
-                       ;; resolve the conflict. :-(
-                       ;;
-                       ;; -- CSR, 2004-10-20
-                       (list (make-restart
-                              :name (make-symbol "UNINTERN")
-                              :function (lambda ()
-                                          (unintern s package)
-                                          (import
-                                           (find s symbols :test-not #'eq)
-                                           package)
-                                          (return-from name-conflict))
-                              :report-function
-                              (lambda (stream)
-                                (format stream
-                                        "Unintern ~S from ~A and import ~S."
-                                        s
-                                        (package-%name package)
-                                        (find s symbols :test-not #'eq))))))))
-                   (t (list (make-restart
-                             :name (make-symbol "SHADOWING-IMPORT")
-                             :function (lambda ()
-                                         (shadowing-import s package)
-                                         (return-from name-conflict))
-                             :report-function
-                             (lambda (stream)
-                               (format stream "Shadowing-import ~S into ~A."
-                                       s (package-%name package)))))))))
-             symbols)
-            *restart-clusters*)))
-      (with-condition-restarts condition (car *restart-clusters*)
-        (with-simple-restart (abort "Leave action undone.")
-          (error condition))))))
+      (multiple-value-bind (package-symbol status)
+          (find-symbol (symbol-name chosen-symbol) package)
+        (let* ((accessiblep status)     ; never NIL here
+               (presentp (and accessiblep
+                              (not (eq :inherited status)))))
+          (ecase function
+            ((unintern)
+             (if presentp
+                 (if (eq package-symbol chosen-symbol)
+                     (shadow (list package-symbol) package)
+                     (shadowing-import (list chosen-symbol) package))
+                 (shadowing-import (list chosen-symbol) package)))
+            ((use-package export)
+             (if presentp
+                 (if (eq package-symbol chosen-symbol)
+                     (shadow (list package-symbol) package) ; CLHS 11.1.1.2.5
+                     (if (eq (symbol-package package-symbol) package)
+                         (unintern package-symbol package) ; CLHS 11.1.1.2.5
+                         (shadowing-import (list chosen-symbol) package)))
+                 (shadowing-import (list chosen-symbol) package)))
+            ((import)
+             (if presentp
+                 (if (eq package-symbol chosen-symbol)
+                     nil                ; re-importing the same symbol
+                     (shadowing-import (list chosen-symbol) package))
+                 (shadowing-import (list chosen-symbol) package)))))))))
 
 ;;; If we are uninterning a shadowing symbol, then a name conflict can
 ;;; result, otherwise just nuke the symbol.
 (defun unintern (symbol &optional (package (sane-package)))
   #!+sb-doc
-  "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."
-  (let* ((package (find-undeleted-package-or-lose package))
-         (name (symbol-name symbol))
-         (shadowing-symbols (package-%shadowing-symbols package)))
-    (declare (list shadowing-symbols))
-
-    (with-single-package-locked-error ()
-      (when (find-symbol name package)
-        (assert-package-unlocked package "uninterning ~A" name))
-
-      ;; If a name conflict is revealed, give us a chance to
-      ;; shadowing-import one of the accessible symbols.
-      (when (member symbol shadowing-symbols)
-        (let ((cset ()))
-          (dolist (p (package-%use-list package))
-            (multiple-value-bind (s w) (find-external-symbol name p)
-              (when w (pushnew s cset))))
-          (when (cdr cset)
-            (apply #'name-conflict package 'unintern symbol cset)
-            (return-from unintern t)))
-        (setf (package-%shadowing-symbols package)
-              (remove symbol shadowing-symbols)))
-
-      (multiple-value-bind (s w) (find-symbol name package)
-        (declare (ignore s))
-        (cond ((or (eq w :internal) (eq w :external))
-               (nuke-symbol (if (eq w :internal)
-                                (package-internal-symbols package)
-                                (package-external-symbols package))
-                            name)
-               (if (eq (symbol-package symbol) package)
-                   (%set-symbol-package symbol nil))
-               t)
-              (t 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-package-graph ()
+    (let* ((package (find-undeleted-package-or-lose package))
+           (name (symbol-name symbol))
+           (shadowing-symbols (package-%shadowing-symbols package)))
+      (declare (list shadowing-symbols))
+
+      (with-single-package-locked-error ()
+        (when (find-symbol name package)
+          (assert-package-unlocked package "uninterning ~A" name))
+
+        ;; If a name conflict is revealed, give us a chance to
+        ;; shadowing-import one of the accessible symbols.
+        (when (member symbol shadowing-symbols)
+          (let ((cset ()))
+            (dolist (p (package-%use-list package))
+              (multiple-value-bind (s w) (find-external-symbol name p)
+                (when w (pushnew s cset))))
+            (when (cdr cset)
+              (apply #'name-conflict package 'unintern symbol cset)
+              (return-from unintern t)))
+          (setf (package-%shadowing-symbols package)
+                (remove symbol shadowing-symbols)))
+
+        (multiple-value-bind (s w) (find-symbol name package)
+          (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))
+                              name)
+                 (if (eq (symbol-package symbol) package)
+                     (%set-symbol-package symbol nil))
+                 t)
+                (t nil)))))))
 
 ;;; Take a symbol-or-list-of-symbols and return a list, checking types.
 (defun symbol-listify (thing)
@@ -944,125 +1011,127 @@ error if any of PACKAGES is not a valid package designator."
 (defun export (symbols &optional (package (sane-package)))
   #!+sb-doc
   "Exports SYMBOLS from PACKAGE, checking that no name conflicts result."
-  (let ((package (find-undeleted-package-or-lose package))
-        (syms ()))
-    ;; Punt any symbols that are already external.
-    (dolist (sym (symbol-listify symbols))
-      (multiple-value-bind (s w)
-          (find-external-symbol (symbol-name sym) package)
-        (declare (ignore s))
-        (unless (or w (member sym syms))
-          (push sym syms))))
-    (with-single-package-locked-error ()
-      (when syms
-        (assert-package-unlocked package "exporting symbol~P ~{~A~^, ~}"
-                                 (length syms) syms))
-      ;; Find symbols and packages with conflicts.
-      (let ((used-by (package-%used-by-list package))
-            (cset ()))
-        (dolist (sym syms)
-          (let ((name (symbol-name sym)))
-            (dolist (p used-by)
-              (multiple-value-bind (s w) (find-symbol name p)
-                (when (and w
-                           (not (eq s sym))
-                           (not (member s (package-%shadowing-symbols p))))
-                  ;; Beware: the name conflict is in package P, not in
-                  ;; PACKAGE.
-                  (name-conflict p 'export sym sym s)
-                  (pushnew sym cset))))))
-        (when cset
-          (setq syms (set-difference syms cset))))
-      ;; Check that all symbols are accessible. If not, ask to import them.
-      (let ((missing ())
-            (imports ()))
-        (dolist (sym syms)
-          (multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
-            (cond ((not (and w (eq s sym)))
-                   (push sym missing))
-                  ((eq w :inherited)
-                   (push sym imports)))))
-        (when missing
-          (cerror
-           "~S these symbols into the ~A package."
-           (make-condition
-            'simple-package-error
-            :package package
-            :format-control
-            "~@<These symbols are not accessible in the ~A package:~2I~_~S~@:>"
-            :format-arguments (list (package-%name package) missing))
-           'import (package-%name package))
-          (import missing package))
-        (import imports package))
-
-      ;; And now, three pages later, we export the suckers.
-      (let ((internal (package-internal-symbols package))
-            (external (package-external-symbols package)))
-        (dolist (sym syms)
-          (nuke-symbol internal (symbol-name sym))
-          (add-symbol external sym))))
-      t))
+  (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 symbols)
+        (multiple-value-bind (s w)
+            (find-external-symbol (symbol-name sym) package)
+          (declare (ignore s))
+          (unless (or w (member sym syms))
+            (push sym syms))))
+      (with-single-package-locked-error ()
+        (when syms
+          (assert-package-unlocked package "exporting symbol~P ~{~A~^, ~}"
+                                   (length syms) syms))
+        ;; Find symbols and packages with conflicts.
+        (let ((used-by (package-%used-by-list package)))
+          (dolist (sym syms)
+            (let ((name (symbol-name sym)))
+              (dolist (p used-by)
+                (multiple-value-bind (s w) (find-symbol name p)
+                  (when (and w
+                             (not (eq s sym))
+                             (not (member s (package-%shadowing-symbols p))))
+                    ;; Beware: the name conflict is in package P, not in
+                    ;; PACKAGE.
+                    (name-conflict p 'export sym sym s)))))))
+        ;; Check that all symbols are accessible. If not, ask to import them.
+        (let ((missing ())
+              (imports ()))
+          (dolist (sym syms)
+            (multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
+              (cond ((not (and w (eq s sym)))
+                     (push sym missing))
+                    ((eq w :inherited)
+                     (push sym imports)))))
+          (when missing
+            (cerror
+             "~S these symbols into the ~A package."
+             (make-condition
+              'simple-package-error
+              :package package
+              :format-control
+              "~@<These symbols are not accessible in the ~A package:~2I~_~S~@:>"
+              :format-arguments (list (package-%name package) missing))
+             'import (package-%name package))
+            (import missing package))
+          (import imports package))
+
+        ;; And now, three pages later, we export the suckers.
+        (let ((internal (package-internal-symbols package))
+              (external (package-external-symbols package)))
+          (dolist (sym syms)
+            (nuke-symbol internal (symbol-name sym))
+            (add-symbol external sym))))
+      t)))
 
 ;;; Check that all symbols are accessible, then move from external to internal.
 (defun unexport (symbols &optional (package (sane-package)))
   #!+sb-doc
   "Makes SYMBOLS no longer exported from PACKAGE."
-  (let ((package (find-undeleted-package-or-lose package))
-        (syms ()))
-    (dolist (sym (symbol-listify symbols))
-      (multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
-        (cond ((or (not w) (not (eq s sym)))
-               (error 'simple-package-error
-                      :package package
-                      :format-control "~S is not accessible in the ~A package."
-                      :format-arguments (list sym (package-%name package))))
-              ((eq w :external) (pushnew sym syms)))))
-    (with-single-package-locked-error ()
-      (when syms
-        (assert-package-unlocked package "unexporting symbol~P ~{~A~^, ~}"
-                                 (length syms) syms))
-      (let ((internal (package-internal-symbols package))
-            (external (package-external-symbols package)))
-        (dolist (sym syms)
-          (add-symbol internal sym)
-          (nuke-symbol external (symbol-name sym)))))
-    t))
+  (with-package-graph ()
+    (let ((package (find-undeleted-package-or-lose package))
+          (symbols (symbol-listify symbols))
+          (syms ()))
+      (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
+                        :package package
+                        :format-control "~S is not accessible in the ~A package."
+                        :format-arguments (list sym (package-%name package))))
+                ((eq w :external) (pushnew sym syms)))))
+      (with-single-package-locked-error ()
+        (when syms
+          (assert-package-unlocked package "unexporting symbol~P ~{~A~^, ~}"
+                                   (length syms) syms))
+        (let ((internal (package-internal-symbols package))
+              (external (package-external-symbols package)))
+          (dolist (sym syms)
+            (add-symbol internal sym)
+            (nuke-symbol external (symbol-name sym)))))
+      t)))
 
 ;;; Check for name conflict caused by the import and let the user
 ;;; shadowing-import if there is.
 (defun import (symbols &optional (package (sane-package)))
   #!+sb-doc
-  "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."
-  (let* ((package (find-undeleted-package-or-lose package))
-         (symbols (symbol-listify symbols))
-         (homeless (remove-if #'symbol-package symbols))
-         (syms ()))
-    (with-single-package-locked-error ()
-      (dolist (sym symbols)
-        (multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
-          (cond ((not w)
-                 (let ((found (member sym syms :test #'string=)))
-                   (if found
-                       (when (not (eq (car found) sym))
-                         (name-conflict package 'import sym sym (car found)))
-                       (push sym syms))))
-                ((not (eq s sym))
-                 (name-conflict package 'import sym sym s))
-                ((eq w :inherited) (push sym syms)))))
-      (when (or homeless syms)
-        (let ((union (delete-duplicates (append homeless syms))))
-          (assert-package-unlocked package "importing symbol~P ~{~A~^, ~}"
-                                   (length union) union)))
-      ;; Add the new symbols to the internal hashtable.
-      (let ((internal (package-internal-symbols package)))
-        (dolist (sym syms)
-          (add-symbol internal sym)))
-      ;; If any of the symbols are uninterned, make them be owned by PACKAGE.
-      (dolist (sym homeless)
-        (%set-symbol-package sym package))
-      t)))
+  "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-package-graph ()
+    (let* ((package (find-undeleted-package-or-lose package))
+           (symbols (symbol-listify symbols))
+           (homeless (remove-if #'symbol-package symbols))
+           (syms ()))
+      (with-single-package-locked-error ()
+        (dolist (sym symbols)
+          (multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
+            (cond ((not w)
+                   (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))
+                   (name-conflict package 'import sym sym s))
+                  ((eq w :inherited) (push sym syms)))))
+        (when (or homeless syms)
+          (let ((union (delete-duplicates (append homeless syms))))
+            (assert-package-unlocked package "importing symbol~P ~{~A~^, ~}"
+                                     (length union) union)))
+        ;; Add the new symbols to the internal hashtable.
+        (let ((internal (package-internal-symbols package)))
+          (dolist (sym syms)
+            (add-symbol internal sym)))
+        ;; If any of the symbols are uninterned, make them be owned by PACKAGE.
+        (dolist (sym homeless)
+          (%set-symbol-package sym package))
+        t))))
 
 ;;; If a conflicting symbol is present, unintern it, otherwise just
 ;;; stick the symbol in.
@@ -1070,147 +1139,152 @@ error if any of PACKAGES is not a valid package designator."
   #!+sb-doc
   "Import SYMBOLS into package, disregarding any name conflict. If
   a symbol of the same name is present, then it is uninterned."
-  (let* ((package (find-undeleted-package-or-lose package))
-         (internal (package-internal-symbols package))
-         (symbols (symbol-listify symbols))
-         (lock-asserted-p nil))
-    (with-single-package-locked-error ()
-      (dolist (sym symbols)
-        (multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
-          (unless (or lock-asserted-p
-                      (and (eq s sym)
-                           (member s (package-shadowing-symbols package))))
-            (assert-package-unlocked package "shadowing-importing symbol~P ~
+  (with-package-graph ()
+    (let* ((package (find-undeleted-package-or-lose package))
+           (internal (package-internal-symbols package))
+           (symbols (symbol-listify symbols))
+           (lock-asserted-p nil))
+      (with-single-package-locked-error ()
+        (dolist (sym symbols)
+          (multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
+            (unless (or lock-asserted-p
+                        (and (eq s sym)
+                             (member s (package-shadowing-symbols package))))
+              (assert-package-unlocked package "shadowing-importing symbol~P ~
                                            ~{~A~^, ~}" (length symbols) symbols)
-            (setf lock-asserted-p t))
-          (unless (and w (not (eq w :inherited)) (eq s sym))
-            (when (or (eq w :internal) (eq w :external))
-              ;; If it was shadowed, we don't want UNINTERN to flame out...
-              (setf (package-%shadowing-symbols package)
-                    (remove s (the list (package-%shadowing-symbols package))))
-              (unintern s package))
-            (add-symbol internal sym))
-          (pushnew sym (package-%shadowing-symbols package))))))
+              (setf lock-asserted-p t))
+            (unless (and w (not (eq w :inherited)) (eq s sym))
+              (when (or (eq w :internal) (eq w :external))
+                ;; If it was shadowed, we don't want UNINTERN to flame out...
+                (setf (package-%shadowing-symbols package)
+                      (remove s (the list (package-%shadowing-symbols package))))
+                (unintern s package))
+              (add-symbol internal sym))
+            (pushnew sym (package-%shadowing-symbols package)))))))
   t)
 
 (defun shadow (symbols &optional (package (sane-package)))
   #!+sb-doc
-  "Make an internal symbol in PACKAGE with the same name as each of
-  the 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."
-  (let* ((package (find-undeleted-package-or-lose package))
-         (internal (package-internal-symbols package))
-         (symbols (string-listify symbols))
-         (lock-asserted-p nil))
-    (flet ((present-p (w)
-             (and w (not (eq w :inherited)))))
-      (with-single-package-locked-error ()
-        (dolist (name symbols)
-          (multiple-value-bind (s w) (find-symbol name package)
-            (unless (or lock-asserted-p
-                        (and (present-p w)
-                             (member s (package-shadowing-symbols package))))
-              (assert-package-unlocked package "shadowing symbol~P ~{~A~^, ~}"
-                                       (length symbols) symbols)
-              (setf lock-asserted-p t))
-            (unless (present-p w)
-              (setq s (make-symbol name))
-              (%set-symbol-package s package)
-              (add-symbol internal s))
-            (pushnew s (package-%shadowing-symbols package)))))))
+  "Make an internal symbol in PACKAGE with the same name as each of the
+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-package-graph ()
+    (let* ((package (find-undeleted-package-or-lose package))
+           (internal (package-internal-symbols package))
+           (symbols (string-listify symbols))
+           (lock-asserted-p nil))
+      (flet ((present-p (w)
+               (and w (not (eq w :inherited)))))
+        (with-single-package-locked-error ()
+          (dolist (name symbols)
+            (multiple-value-bind (s w) (find-symbol name package)
+              (unless (or lock-asserted-p
+                          (and (present-p w)
+                               (member s (package-shadowing-symbols package))))
+                (assert-package-unlocked package "shadowing symbol~P ~{~A~^, ~}"
+                                         (length symbols) symbols)
+                (setf lock-asserted-p t))
+              (unless (present-p w)
+                (setq s (make-symbol name))
+                (%set-symbol-package s package)
+                (add-symbol internal s))
+              (pushnew s (package-%shadowing-symbols package))))))))
   t)
 
 ;;; Do stuff to use a package, with all kinds of fun name-conflict checking.
 (defun use-package (packages-to-use &optional (package (sane-package)))
   #!+sb-doc
-  "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."
-  (let ((packages (package-listify packages-to-use))
-        (package (find-undeleted-package-or-lose package)))
-
-    ;; Loop over each package, USE'ing one at a time...
-    (with-single-package-locked-error ()
-      (dolist (pkg packages)
-        (unless (member pkg (package-%use-list package))
-          (assert-package-unlocked package "using package~P ~{~A~^, ~}"
-                                   (length packages) packages)
-          (let ((shadowing-symbols (package-%shadowing-symbols package))
-                (use-list (package-%use-list package)))
-
-            ;; If the number of symbols already accessible is less
-            ;; than the number to be inherited then it is faster to
-            ;; run the test the other way. This is particularly
-            ;; valuable in the case of a new package USEing
-            ;; COMMON-LISP.
-            (cond
-              ((< (+ (package-internal-symbol-count package)
-                     (package-external-symbol-count package)
-                     (let ((res 0))
-                       (dolist (p use-list res)
-                         (incf res (package-external-symbol-count p)))))
-                  (package-external-symbol-count pkg))
-               (do-symbols (sym package)
-                 (multiple-value-bind (s w)
-                     (find-external-symbol (symbol-name sym) pkg)
-                   (when (and w
-                              (not (eq s sym))
-                              (not (member sym shadowing-symbols)))
-                     (name-conflict package 'use-package pkg sym s))))
-               (dolist (p use-list)
-                 (do-external-symbols (sym p)
+  "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-package-graph ()
+    (let ((packages (package-listify packages-to-use))
+          (package (find-undeleted-package-or-lose package)))
+
+      ;; Loop over each package, USE'ing one at a time...
+      (with-single-package-locked-error ()
+        (dolist (pkg packages)
+          (unless (member pkg (package-%use-list package))
+            (assert-package-unlocked package "using package~P ~{~A~^, ~}"
+                                     (length packages) packages)
+            (let ((shadowing-symbols (package-%shadowing-symbols package))
+                  (use-list (package-%use-list package)))
+
+              ;; If the number of symbols already accessible is less
+              ;; than the number to be inherited then it is faster to
+              ;; run the test the other way. This is particularly
+              ;; valuable in the case of a new package USEing
+              ;; COMMON-LISP.
+              (cond
+                ((< (+ (package-internal-symbol-count package)
+                       (package-external-symbol-count package)
+                       (let ((res 0))
+                         (dolist (p use-list res)
+                           (incf res (package-external-symbol-count p)))))
+                    (package-external-symbol-count pkg))
+                 (do-symbols (sym package)
                    (multiple-value-bind (s w)
                        (find-external-symbol (symbol-name sym) pkg)
                      (when (and w
                                 (not (eq s sym))
-                                (not (member
-                                      (find-symbol (symbol-name sym) package)
-                                      shadowing-symbols)))
-                       (name-conflict package 'use-package pkg sym s))))))
-              (t
-               (do-external-symbols (sym pkg)
-                 (multiple-value-bind (s w)
-                     (find-symbol (symbol-name sym) package)
-                   (when (and w
-                              (not (eq s sym))
-                              (not (member s shadowing-symbols)))
-                     (name-conflict package 'use-package pkg sym s)))))))
-
-          (push pkg (package-%use-list package))
-          (push (package-external-symbols pkg) (cdr (package-tables package)))
-          (push package (package-%used-by-list pkg))))))
+                                (not (member sym shadowing-symbols)))
+                       (name-conflict package 'use-package pkg sym s))))
+                 (dolist (p use-list)
+                   (do-external-symbols (sym p)
+                     (multiple-value-bind (s w)
+                         (find-external-symbol (symbol-name sym) pkg)
+                       (when (and w
+                                  (not (eq s sym))
+                                  (not (member
+                                        (find-symbol (symbol-name sym) package)
+                                        shadowing-symbols)))
+                         (name-conflict package 'use-package pkg sym s))))))
+                (t
+                 (do-external-symbols (sym pkg)
+                   (multiple-value-bind (s w)
+                       (find-symbol (symbol-name sym) package)
+                     (when (and w
+                                (not (eq s sym))
+                                (not (member s shadowing-symbols)))
+                       (name-conflict package 'use-package pkg sym s)))))))
+
+            (push pkg (package-%use-list package))
+            (push (package-external-symbols pkg) (cdr (package-tables package)))
+            (push package (package-%used-by-list pkg)))))))
   t)
 
 (defun unuse-package (packages-to-unuse &optional (package (sane-package)))
   #!+sb-doc
   "Remove PACKAGES-TO-UNUSE from the USE list for PACKAGE."
-  (let ((package (find-undeleted-package-or-lose package))
-        (packages (package-listify packages-to-unuse)))
-    (with-single-package-locked-error ()
-      (dolist (p packages)
-        (when (member p (package-use-list package))
-          (assert-package-unlocked package "unusing package~P ~{~A~^, ~}"
-                                   (length packages) packages))
-        (setf (package-%use-list package)
-              (remove p (the list (package-%use-list package))))
-        (setf (package-tables package)
-              (delete (package-external-symbols p)
-                      (the list (package-tables package))))
-        (setf (package-%used-by-list p)
-              (remove package (the list (package-%used-by-list p))))))
-    t))
+  (with-package-graph ()
+    (let ((package (find-undeleted-package-or-lose package))
+          (packages (package-listify packages-to-unuse)))
+      (with-single-package-locked-error ()
+        (dolist (p packages)
+          (when (member p (package-use-list package))
+            (assert-package-unlocked package "unusing package~P ~{~A~^, ~}"
+                                     (length packages) packages))
+          (setf (package-%use-list package)
+                (remove p (the list (package-%use-list package))))
+          (setf (package-tables package)
+                (delete (package-external-symbols p)
+                        (the list (package-tables package))))
+          (setf (package-%used-by-list p)
+                (remove package (the list (package-%used-by-list p))))))
+      t)))
 
 (defun find-all-symbols (string-or-symbol)
   #!+sb-doc
   "Return a list of all symbols in the system having the specified name."
   (let ((string (string string-or-symbol))
         (res ()))
-    (maphash (lambda (k v)
-               (declare (ignore k))
-               (multiple-value-bind (s w) (find-symbol string v)
-                 (when w (pushnew s res))))
-             *package-names*)
+    (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))))
+               names))
     res))
 
 ;;;; APROPOS and APROPOS-LIST
@@ -1232,7 +1306,7 @@ error if any of PACKAGES is not a valid package designator."
   of describing them."
   (if package-designator
       (let ((package (find-undeleted-package-or-lose package-designator))
-            (string (stringify-name string-designator "APROPOS search"))
+            (string (stringify-string-designator string-designator))
             (result nil))
         (do-symbols (symbol package)
           (when (and (eq (symbol-package symbol) package)
@@ -1242,10 +1316,10 @@ error if any of PACKAGES is not a valid package designator."
                              :external))
                      (search string (symbol-name symbol) :test #'char-equal))
             (push symbol result)))
-        result)
+        (sort result #'string-lessp))
       (mapcan (lambda (package)
                 (apropos-list string-designator package external-only))
-              (list-all-packages))))
+              (sort (list-all-packages) #'string-lessp :key #'package-name))))
 
 (defun apropos (string-designator &optional package external-only)
   #!+sb-doc
@@ -1310,7 +1384,7 @@ error if any of PACKAGES is not a valid package designator."
   (setq *keyword-package* (find-package "KEYWORD"))
 
   (/show0 "about to MAKUNBOUND *!INITIAL-SYMBOLS*")
-  (makunbound '*!initial-symbols*)       ; (so that it gets GCed)
+  (%makunbound '*!initial-symbols*)       ; (so that it gets GCed)
 
   ;; Make some other packages that should be around in the cold load.
   ;; The COMMON-LISP-USER package is required by the ANSI standard,