common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Fix a few package name table glitches

Browse source 
* (make-package "ALREADY-EXISTING") exhibited implausible behavior
  of leaving an inaccessible package around

* (MAKE-PACKAGE "P" :nickname '("P")) was silently allowed, and still is,
  but with less badness. "P" will no longer be considered a nickname.
  I would have liked this to be an error, but some implementations accept it.

* RENAME-PACKAGE tried to be threadsafe but was confusing as heck for it,
  and probably wasn't even safe. CLHS says nothing about RENAME-PACKAGE errors
  being continuable, so now just decide once up front whether the change is
  conflict-free, and either do it or else signal a noncontinuable error.
  Also renamingg had different ideas about whether to signal a package lock
  violation depending on if adding or removing nicknames.
  I saw no reason this shouldn't be made symmetrical in that regard.

* DEFPACKAGE can and should just delegate to RENAME-PACKAGE
  for that part of its job
This commit is contained in:
Douglas Katzman 2023-01-28 23:11:41 -05:00
parent e7d6d21aef
commit 482a5df1df
2 changed files with 161 additions and 166 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

190
src/code/defpackage.lisp
View file

@ -20,6 +20,12 @@
;;; is free to :USE (PACKAGE-USE-LIST :CL-USER) or whatever.
(defglobal *!default-package-use-list* nil)
(defmacro sanitize-nicknames (name list)
`(let ((list ,list))
(when list
(remove ,name (remove-duplicates (stringify-string-designators list) :test 'string=)
:test 'string=))))
(defun make-package (name &key
(use '#.*!default-package-use-list*)
nicknames
@ -31,17 +37,24 @@ 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 ((name (stringify-string-designator name))
(nicks (stringify-string-designators nicknames))
(let* ((name (stringify-string-designator name))
(nicks (sanitize-nicknames name nicknames))
(package
;; a "resolved" package is not in the global name->package mapping yet,
;; which is why the FIND-PACKAGE / CERROR below does not signal.
(or (resolve-deferred-package name)
(%make-package (make-symbol-hashset internal-symbols)
(make-symbol-hashset external-symbols))))
clobber)
:restart
;; FIXME:
(existing-pkg)
(namelist (cons name nicks))
(conflict))
(with-package-names (table) ; get exclusive use of name -> package mapping
;; If the loop runs to completion, then insert all names,
;; which also assigns %NAME and %NICKNAMES into the package.
(dolist (string namelist (alter-package-registry table package namelist))
(when (setq existing-pkg (%get-package string table))
(return (setq conflict string)))))
(when existing-pkg
;; Of the possible ways to continue from the "package already exists" error,
;; I've seen implementations offer these:
;; - pick a different name for the new package
@ -49,64 +62,26 @@ implementation it is ~S." *!default-package-use-list*)
;; Other ways to proceed might be:
;; - rename the existing package to something different (mostly harmless)
;; - first delete the existing package (potentially nontrivial)
;; SBCL does the absolute worst possible thing: the name->package mapping gets
;; the new package, and the old package keeps its name under which it is not findable,
;; thereby causing an extreme amount of print/read inconsistency.
(when (find-package name)
;; ANSI specifies that this error is correctable.
(signal-package-cerror
name
"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))
(setf (package-%name package) name)
;; Do a USE-PACKAGE for each thing in the USE list so that checking for
;; conflicting exports among used packages is done.
(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 nicks)
;; The name table is actually multi-writer concurrent, but due to
;; lazy removal of :DELETED entries we want to enforce a single-writer.
;; We're inside WITH-PACKAGE-GRAPH so this is already synchronized with
;; other MAKE-PACKAGE operations, but we need the additional lock
;; so that it synchronizes with RENAME-PACKAGE.
(with-package-names (table)
(%register-package table name package))
(atomic-incf *package-names-cookie*)
(when (boundp 'sb-c::*compilation*)
(setf (sb-c::package-environment-changed sb-c::*compilation*) t))
(return package))
(bug "never")))
(flet ((remove-names (package name-table keep-primary-name)
;; An INFO-HASHTABLE does not support REMHASH. We can simulate it
;; by changing the value to :DELETED.
;; (NIL would be preferable, but INFO-GETHASH does not return
;; a secondary value indicating whether the NIL was by default
;; or found, not does it take a different default to return).
;; At some point the table might contain more deleted values than
;; useful values. We call %REBUILD-PACKAGE-NAMES to rectify that.
(dx-let ((names (cons (package-name package)
(package-nicknames package)))
(i 0))
(when keep-primary-name (pop names))
(dolist (name names)
;; Aver that the following SETF doesn't insert a new <k,v> pair.
(aver (info-gethash name name-table))
(setf (info-gethash name name-table) :deleted)
(incf i))
(incf (info-env-tombstones name-table) i))
nil))
;; SBCL had the weirdest of all solutions: alter the existing name->package mapping
;; while leaving the old package with a name, but not findable by that name.
;; Imho the safe assumption is that the user wants the same package back.
;; All sorts of crazy restarts would in theory be possible, such as if one nickname
;; that you specified (N1) already finds package P1, and another nickname (N2) finds P2
;; and P1 and P2 are distinct. What are we supposed to do? Figure our that you meant
;; to return the existing P1, but give it an additional nickname, and delete P2?
;; Also bear in mind that for most purposes, a package's multiple "names" are
;; equivalent; one is canonical for printing symbols homed in that package.
;; Global nicknames are an absurdly unnecessary part of the language.
(signal-package-cerror name "Return the existing package."
"A package named ~S already exists" conflict)
;; We don't do the USE in this case.
;; It's OK given the lack of guidance in CLHS about how to "continue".
(return-from make-package existing-pkg))
(atomic-incf *package-names-cookie*)
(when (boundp 'sb-c::*compilation*)
(setf (sb-c::package-environment-changed sb-c::*compilation*) t))
(use-package use package)
package))
;;; Change the name if we can, blast any old nicknames and then
;;; add in any new ones.
@ -133,52 +108,50 @@ implementation it is ~S." *!default-package-use-list*)
;;; was given. I see no reason to be more strict than the spec would have it be.
(defun rename-package (package-designator name &optional (nicknames ()))
"Changes the name and nicknames for a package."
(prog ((nicks (stringify-string-designators nicknames)))
:restart
(let ((package (find-undeleted-package-or-lose package-designator))
;; This is the "weirdness" alluded to. Do it in the loop in case
;; the stringified value changes on restart when NAME is a package.
(name (stringify-package-designator name))
(found (find-package name)))
(unless (or (not found) (eq found package))
(signal-package-error name
"A package named ~S already exists." 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 "renaming as ~A~@[ with nickname~*~P ~1@*~{~A~^, ~}~]"
name nicks (length nicks)))
(with-package-names (table)
;; Check for race conditions now that we have the lock.
(unless (eq package (find-package package-designator))
(go :restart))
;; Do the renaming.
;; As a special case, do not allow the package to transiently disappear
;; if PACKAGE-NAME is unchanged. This avoids glitches with build systems
;; which try to operate on subcomponents in parallel, where one of the
;; built subcomponents needs to add nicknames to an existing package.
;; We could be clever here as well by not removing nicknames that
;; will ultimately be re-added, but that didn't seem as critical.
(let ((keep-primary-name (string= name (package-%name package))))
(remove-names package table keep-primary-name)
(unless keep-primary-name
(%register-package table name package)))
(setf (package-%name package) name
(package-%nicknames package) ()))
;; Adding each nickname acquires and releases the table lock,
;; because it's potentially interactive (on failure) and therefore
;; not ideal to hold the lock for the entire duration.
(%enter-new-nicknames package nicks))
(atomic-incf *package-names-cookie*)
(when (boundp 'sb-c::*compilation*)
(setf (sb-c::package-environment-changed sb-c::*compilation*) t))
(return package))))
;; CLHS says:
;; "The consequences are undefined if new-name or any new-nickname
;; conflicts with any existing package names."
;; Signaling an error is what most implementations do. So shall we now.
;; (There is no portable standard way to proceed)
(let* ((package (find-undeleted-package-or-lose package-designator))
;; This potentially allows the "weirdness" alluded to above
(name (stringify-package-designator name))
(nicknames (sanitize-nicknames name nicknames))
(namelist (cons name nicknames))
(conflict))
(with-single-package-locked-error ()
(unless (and (string= name (package-name package))
(null (set-difference nicknames (package-%nicknames package)
:test #'string=))
(null (set-difference (package-%nicknames package) nicknames
:test #'string=)))
(assert-package-unlocked
package "renaming as ~A~@[ with nickname~*~P ~1@*~{~A~^, ~}~]"
name nicknames (length nicknames))))
(with-package-names (table)
;; get exclusive use of name -> package mapping
;; and also prevent concurrent modification to this package's names.
(dolist (string namelist (alter-package-registry table package namelist))
(let ((found (%get-package string table)))
(cond ((eq found package))
(found (return (setq conflict string)))))))
(cond (conflict
(signal-package-error
;; avoid saying "another package ... has name X" so the pedants
;; don't complain when X is a "nickname" rather than "name"
package "Another package is already accessible via name ~S" conflict))
(t
(atomic-incf *package-names-cookie*)
(when (boundp 'sb-c::*compilation*)
(setf (sb-c::package-environment-changed sb-c::*compilation*) t))
package))))
(defun delete-package (package-designator)
"Delete the package designated by PACKAGE-DESIGNATOR from the package
system data structures."
(when (and (packagep package-designator)
(not (package-%name package-designator))) ; already deleted
(return-from delete-package nil))
(tagbody :restart
(let ((package (find-package package-designator)))
(cond ((not package)
@ -188,8 +161,6 @@ implementation it is ~S." *!default-package-use-list*)
"Ignore."
"There is no package named ~S." 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)
@ -223,9 +194,9 @@ implementation it is ~S." *!default-package-use-list*)
(nullify-home (package-internal-symbols package))
(nullify-home (package-external-symbols package)))
(with-package-names (table)
(alter-package-registry table package nil)
(awhen (package-id package)
(setf (aref *id->package* it) nil (package-id package) nil))
(remove-names package table nil)
(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
@ -244,7 +215,6 @@ implementation it is ~S." *!default-package-use-list*)
(package-external-symbols package)
(make-symbol-hashset 0)))
(return-from delete-package t)))))))
) ; end FLET
;;; Possible FIXME:
;;; After doing these 2 things:
@ -451,7 +421,7 @@ implementation it is ~S." *!default-package-use-list*)
imports interns
exports implement local-nicknames
lock doc-string)
(%enter-new-nicknames package nicknames)
(rename-package package (package-name package) nicknames)
;; 1. :shadow and :shadowing-import-from
;;
;; shadows is a list of strings, shadowing-imports is a list of symbols.

137
src/code/target-package.lisp
View file

@ -9,8 +9,6 @@
;;;; than one candidate symbol. Any time a name conflict is about to
;;;; occur, a correctable error is signaled.
;;;;
;;;; FIXME: The code contains a lot of type declarations. Are they
;;;; all really necessary?
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
@ -214,9 +212,11 @@
(define-load-time-global *package-names-cookie* most-negative-fixnum)
(declaim (fixnum *package-names-cookie*))
;;; Use this only if you need to acquire the mutex. Otherwise just accessing
;;; the var is fine. This no longer allows re-entrance. Let's keep it that way.
(defmacro with-package-names ((table-var &key) &body body)
`(let ((,table-var *package-names*))
(sb-thread::with-recursive-system-lock ((info-env-mutex ,table-var))
(sb-thread::with-system-mutex ((info-env-mutex ,table-var))
,@body)))
;;;; iteration macros
@ -782,8 +782,38 @@ Experimental: interface subject to change."
:format-arguments format-args))
(defmacro do-packages ((package) &body body)
;; INFO-MAPHASH is not intrinsically threadsafe - but actually
;; quite easy to fix - so meanwhile until it's fixed, grab the lock.
;; Even if iterating over the name -> package mapping were threadsafe
;; (which is isn't), there could nonetheless exist a race between iterators
;; and RENAME-PACKAGE. This is true whether first deleting the old name
;; and then inserting the new, or the other way around.
;; The examples below (only 2 out of many schedulings and choices of insert/delete
;; ordering) show that iteration can produce a package twice, or skip it entirely.
;;
;; Consider the table bins could have oldname in an earlier bin:
;; bin 1 -> oldname, bin 2 -> newname
;; and suppose we first delete old, the insert new.
;;
;; Thread1 Thread2
;; ------------ -------------
;; read bin 1 = oldname
;; delete oldname
;; insert newname
;; read bin 2 = newname
;;
;; So it is produced twice even though it was not really in the table twice.
;; Or we can see it not at all. Suppose bin1 -> newname, bin 2 -> oldname
;;
;; Thread1 Thread2
;; ------------ -------------
;; read bin 1 (initially empty)
;; delete oldname
;; insert newname
;; read bin 2 (empty)
;;
;; The situation is further confounded by the fact that the primary name could
;; become a nickname or vice-versa (among all the myriad other things that
;; renaming can do) in which case there is ambiguity about the table cell
;; that is considered the representative one for the package.
`(with-package-names (.table.)
(info-maphash
(lambda (.name. ,package)
@ -982,16 +1012,19 @@ Experimental: interface subject to change."
(decf (symtbl-deleted table))))) ; tombstone
(declare (fixnum i)))))
;;; Insert a mapping from NAME (a string) to OBJECT (a package or singleton
;;; list of a package) into TABLE (the hashtable in *PACKAGE-NAMES*),
;;; taking care to adjust the count of phantom entries.
(defun %register-package (table name object)
;; Registration ensures a non-null id if it can (even for a "deferred" package)
(let ((package (if (listp object) (car object) object)))
(unless (package-id package)
;; manipulation of the id->package vector is hard to do lock-freeely
;; and it's not really a bottleneck, so just grab a lock.
(with-package-names (dummy)
;;; For each name (a string) in NAMELIST, insert a mapping to PACKAGE.
;;; The first element is the primary name and the rest are nicknames.
(defun alter-package-registry (table package namelist)
(aver (sb-thread:holding-mutex-p (info-env-mutex *package-names*)))
(let ((delta 0) ; how many tombstones were added or removed
(former-names
;; a package being created has no names yet
(if (package-%name package)
(cons (package-%name package)
(package-%nicknames package)))))
(when namelist
;; Registration ensures a non-null id if it can (even for a "deferred" package)
(unless (package-id package)
(let* ((vector *id->package*)
;; 30 is an arbitrary constant exceeding the number of builtin packages
(new-id (position nil vector :start 30)))
@ -1005,17 +1038,32 @@ Experimental: interface subject to change."
vector new-vector)))
(when new-id
(setf (package-id package) new-id
(aref vector new-id) package))))))
(let ((oldval (info-gethash name table)))
(unless oldval ; if any value existed, no new physical cell is claimed
(when (> (info-env-tombstones table)
(floor (info-storage-capacity (info-env-storage table)) 4))
;; Otherwise, when >1/4th of the table consists of tombstones,
;; then rebuild the table.
(%rebuild-package-names table)))
(setf (info-gethash name table) object)
(when (eq oldval :deleted)
(decf (info-env-tombstones table)))))
(aref vector new-id) package))))
(let ((primary (car namelist)))
(when (eq (info-gethash primary table) :deleted) (decf delta))
(setf (package-%name package) primary)
(setf (info-gethash primary table) package))
(let ((list-of-package (list package)))
(dolist (name (cdr namelist))
(when (eq (info-gethash name table) :deleted) (decf delta))
(setf (info-gethash name table) list-of-package)))
(setf (package-%nicknames package) (cdr namelist)))
;; Remove names that this package no longer has.
;; An INFO-HASHTABLE does not support REMHASH. We can simulate it
;; by changing the value to :DELETED.
;; (NIL would be preferable, but INFO-GETHASH does not return
;; a secondary value indicating whether the NIL was by default
;; or found, not does it take a different default to return).
(let ((remove (set-difference former-names namelist :test 'string=)))
(when remove
(dolist (name remove)
(aver (%get-package name table)) ; Assert not inserting a new <k,v> pair
(setf (info-gethash name table) :deleted)
(incf delta))
(incf (info-env-tombstones table) delta)
;; If half full of :DELETED markers, rehash
(when (>= (info-env-tombstones table) (ash (info-env-count table) -1))
(%rebuild-package-names table))))))
;;; Rebuild the *PACKAGE-NAMES* table.
;;; The calling thread must own the mutex on *PACKAGE-NAMES* so that
@ -1044,7 +1092,7 @@ Experimental: interface subject to change."
;;; actually clobber old cells while minimizing the number of pseudostatic vectors
;;; that can't ever be freed.
(defun tune-hashset-sizes-of-all-packages ()
(with-package-names (table)
(let ((table *package-names*))
(when (plusp (info-env-tombstones table))
(%rebuild-package-names table)))
(flet ((tune-table-size (desired-lf table)
@ -1177,32 +1225,6 @@ Experimental: interface subject to change."
(when (< used (truncate size 4))
(resize-symbol-hashset table (* used 2) splat))))
;;; 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.
;;; Package names do not affect the uses/used-by relation,
;;; so this can be done without the package graph lock held.
(defun %enter-new-nicknames (package nicknames &aux (val (list package)))
(declare (type list nicknames))
(dolist (nickname nicknames)
(let ((found (or (%get-package (the simple-string nickname) *package-names*)
(with-package-names (table)
(%register-package table nickname val)
(push nickname (package-%nicknames package))
package))))
(cond ((eq found package))
((string= (the string (package-%name found)) nickname)
(signal-package-cerror
package
"Ignore this nickname."
"~S is a package name, so it cannot be a nickname for ~S."
nickname (package-%name package)))
(t
(signal-package-cerror
package
"Leave this nickname alone."
"~S is already a nickname for ~S."
nickname (package-%name found)))))))
(defun list-all-packages ()
"Return a list of all existing packages."
(let ((result ()))
@ -1847,7 +1869,7 @@ PACKAGE."
(setf (sb-thread:mutex-name (info-env-mutex *package-names*)) "package names"
(sb-thread:mutex-name (info-env-mutex (car *package-nickname-ids*)))
"package nicknames")
(with-package-names (names)
(let ((names *package-names*))
(dolist (spec specs)
(let ((pkg (car spec)) (symbols (cdr spec)))
;; the symbol MAKE-TABLE wouldn't magically disappear,
@ -2092,8 +2114,11 @@ PACKAGE."
(or (%get-package name *deferred-package-names*)
(let ((package (%make-package (make-symbol-hashset 0)
(make-symbol-hashset 0))))
(%register-package *deferred-package-names* name package)
(setf (package-%name package) name)
;; Creation of a package ID is synchronized by the regular package table lock
;; (though we're operating on the loader package table)
(sb-thread::with-system-mutex ((info-env-mutex *package-names*))
;; this also assigns the %NAME slot
(alter-package-registry *deferred-package-names* package (list name)))
package)))))
;;; Return the deferred package object for NAME if it exists, otherwise