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 some remainng package weirdness.

Browse source 
Get rid of deferred packages and so on. This makes two tests fail
under block compilation mode, but fixes a very real correctness
problem in normal evaluation mode. A serious rethink needs to be done
to figure out how to deal with fasloader and package interaction under
block compilation. At least we solved the accessibility issue
correctly with the use of a new loader op. Now the package mechanisms
are back to what they looked like before the implementation of
deferred packages and should be at least as correct as the state of
affairs before that was added.

Fixes lp#2000004.
This commit is contained in:
Charles Zhang 2022-12-20 01:06:31 +01:00
parent a470c1de9c
commit 5fdf84566e
7 changed files with 50 additions and 118 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

22
src/code/defpackage.lisp
View file

@ -33,11 +33,9 @@ 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))
(package
(or (resolve-deferred-package name)
(resolve-rehoming-package name)
(%make-package (make-symbol-hashset internal-symbols)
(make-symbol-hashset external-symbols))))
(package (%make-package
(make-symbol-hashset internal-symbols)
(make-symbol-hashset external-symbols)))
clobber)
:restart
(when (find-package name)
@ -203,14 +201,12 @@ implementation it is ~S." *!default-package-use-list*)
(dolist (used (package-use-list package))
(unuse-package used package))
(setf (package-%local-nicknames package) nil)
(let ((rehoming-package (make-rehoming-package package)))
(flet ((nullify-home (symbols)
(dovector (x (symtbl-cells symbols))
(when (and (symbolp x)
(eq (symbol-package x) package))
(%set-symbol-package x rehoming-package)))))
(nullify-home (package-internal-symbols package))
(nullify-home (package-external-symbols package))))
(flet ((nullify-home (symbols)
(dovector (x (symtbl-cells symbols))
(when (and (symbolp x) (eq (symbol-package x) package))
(%set-symbol-package x nil)))))
(nullify-home (package-internal-symbols package))
(nullify-home (package-external-symbols package)))
(with-package-names (table)
(awhen (package-id package)
(setf (aref *id->package* it) nil (package-id package) nil))

16
src/code/load.lisp
View file

@ -731,13 +731,12 @@
(error "attempt to load an empty FASL file:~% ~S" (namestring stream)))
(maybe-announce-load stream verbose)
(let ((fasl-input (make-fasl-input stream print)))
(with-loader-package-names
(unwind-protect
(loop while (load-fasl-group fasl-input))
;; Nuke the table and stack to avoid keeping garbage on
;; conservatively collected platforms.
(nuke-fop-vector (%fasl-input-table fasl-input))
(nuke-fop-vector (%fasl-input-stack fasl-input)))))
(unwind-protect
(loop while (load-fasl-group fasl-input))
;; Nuke the table and stack to avoid keeping garbage on
;; conservatively collected platforms.
(nuke-fop-vector (%fasl-input-table fasl-input))
(nuke-fop-vector (%fasl-input-stack fasl-input))))
t)
@ -889,8 +888,7 @@
(define-fop 83 :not-host (fop-named-package-save ((:operands length)) nil)
(let ((package-name (make-string length)))
(read-char-string-as-varints (fasl-input-stream) package-name)
(push-fop-table (find-or-maybe-make-deferred-package package-name)
(fasl-input))))
(push-fop-table (find-package package-name) (fasl-input))))
;;;; fops for loading numbers

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

@ -2038,100 +2038,6 @@ PACKAGE."
(or (null pkg) (and (packagep pkg) (package-%name pkg)))))
;;;; special package hacks for the loader
(defvar *deferred-package-names*)
;;; A deferred package is a package which is not added to the normal
;;; package database until some later point in time. The current
;;; purpose for deferred packages is so that the loader symbol fasl
;;; ops can intern symbols into packages, without the packages
;;; necessarily being created yet. This is important for deferred
;;; top-level form loading, as to not cause loading symbols (which may
;;; appear as literal code constants) to fail early. Since the
;;; deferred package is not added to the normal package database until
;;; the package is actually created, we preserve package environment
;;; semantics at runtime, and give a reasonable error if the package
;;; has not been created by the end of the load.
(defun find-or-maybe-make-deferred-package (name)
(or (find-package name)
(progn
(unless *deferred-package-names* ; bind on demand
(setq *deferred-package-names*
(make-info-hashtable :comparator #'pkg-name=
:hash-function #'sxhash)))
(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)
package)))))
;;; Return the deferred package object for NAME if it exists, otherwise
;;; return NIL.
(defun resolve-deferred-package (name)
(and (boundp '*deferred-package-names*)
*deferred-package-names*
(let ((package (%get-package name *deferred-package-names*)))
(when package
;; To simulate remhash.
(setf (info-gethash name *deferred-package-names*) :deleted))
package)))
(defvar *rehoming-package-names*)
;;; When we are in the loader, DELETE-PACKAGE installs a rehoming
;;; package in the SYMBOL-PACKAGE of its internal symbols. This has
;;; the effect that when a package of the same name is newly redefined
;;; later in the compiled file, the package gets updated and those
;;; internal symbols get rehomed properly.
(defun make-rehoming-package (package)
(and (boundp '*rehoming-package-names*)
(let ((name (package-%name package)))
(unless *rehoming-package-names* ; bind on demand
(setq *rehoming-package-names*
(make-info-hashtable :comparator #'pkg-name=
:hash-function #'sxhash)))
(aver (not (%get-package name *rehoming-package-names*)))
(let ((package (%make-package (package-internal-symbols package)
(package-external-symbols package))))
(%register-package *rehoming-package-names* name package)
(setf (package-%name package) name)
package))))
;;; Return the rehoming object for NAME if it exists, otherwise return
;;; NIL.
(defun resolve-rehoming-package (name)
(and (boundp '*rehoming-package-names*)
*rehoming-package-names*
(let ((package (%get-package name *rehoming-package-names*)))
(when package
;; To simulate remhash.
(setf (info-gethash name *rehoming-package-names*) :deleted))
package)))
;;; Bind the deferred and rehoming package name tables and test to see
;;; if the deferred package table still has any unresolved entries
;;; after FUNCTION is called.
(defun call-with-loader-package-names (function)
(let* ((boundp (boundp '*deferred-package-names*))
;; bind on demand
(*deferred-package-names* (if boundp *deferred-package-names* nil))
(*rehoming-package-names* (if boundp *rehoming-package-names* nil)))
(funcall function)
(when (and (not boundp) *deferred-package-names*)
(info-maphash
(lambda (name package)
(unless (eq package :deleted)
(dovector (sym (symtbl-cells (package-internal-symbols package)))
(when (symbolp sym)
(error 'simple-package-error
:format-control
"The loader tried loading the symbol named ~a ~
into the package named ~a, but the package did ~
not get defined, and does not exist."
:format-arguments (list (symbol-name sym) name))))))
*deferred-package-names*))))
;;; We don't benefit from these transforms because any time we have a constant
;;; package in our code, we refer to it via #.(FIND-PACKAGE).

6
tests/block-compile.impure.lisp
View file

@ -17,7 +17,8 @@
(assert (not (ctu:find-named-callees (symbol-function 'bar-with-foo-inline))))
(assert (ctu:find-named-callees (symbol-function 'bar-with-foo-call))))
(with-test (:name :block-defpackage-then-load-fasl)
(with-test (:name :block-defpackage-then-load-fasl
:fails-on :sbcl)
(ctu:file-compile
`((defpackage block-defpackage (:use :cl :cl-user))
@ -66,7 +67,8 @@
(defpackage block-defpackage3
(:use :cl))
(with-test (:name :block-defpackage-delete-package-redefpackage)
(with-test (:name :block-defpackage-delete-package-redefpackage
:fails-on :sbcl)
(ctu:file-compile
`((when (find-package '#:block-defpackage3)
(delete-package '#:block-defpackage3))

18
tests/package-test-5.lisp Normal file
View file

@ -0,0 +1,18 @@
(defun foo.delete-package-redefpackage ()
(let ((package (find-package :bar-drrfl)))
(when package
(let ((count 0))
(do-symbols (sym package)
(incf count))
(assert (= count 2))
(delete-package package))))
(make-package "BAR-DRRFL" :use ())
(let ((package (find-package :bar-drrfl))
(count 0))
(do-symbols (sym package)
(incf count))
(assert (= count 0))
(eval (read-from-string
"(progn
(defun bar-drrfl::a ())
(defun bar-drrfl::b ()))"))))

1
tests/package-test-6.lisp Normal file
View file

@ -0,0 +1 @@
(foo.delete-package-redefpackage)

11
tests/packages.impure.lisp
View file

@ -1133,3 +1133,14 @@ if a restart was invoked."
(assert (eq (nth-value 1 (find-symbol "BAR" "FOO-NEW"))
:external))
(delete-package "FOO-NEW"))
(with-test (:name :defpackage-delete-package-redefpackage-fasloader)
(with-scratch-file (fasl5 "fasl")
(compile-file "package-test-5.lisp" :output-file fasl5)
(load fasl5)
(if (find-package "BAR-DRRFL") (delete-package "BAR-DRRFL"))
(with-scratch-file (fasl6 "fasl")
(compile-file "package-test-6.lisp" :output-file fasl6)
(load fasl6)
(load fasl6))
(delete-package "BAR-DRRFL")))