From 132d1c042a54012191c463972204d726ea3ee8db Mon Sep 17 00:00:00 2001 From: Douglas Katzman Date: Thu, 12 Sep 2024 12:22:52 -0400 Subject: [PATCH] Improve package iteration per lp#2080387 Allow changing accessibility from :INTERNAL to :EXTERNAL during iteration without messing up the iterator. But now we have a duplicates problem which it's unclear whether runs slightly afoul of the spec. e.g. DO-ALL-SYMBOLS "may cause a symbol that is present in several packages to be processed more than once". Since that's not phrased as if-and-only-if, we take the liberty of returning a symbol more than once even when NOT present in more than one package. Apparently so do some other Common-Lisp implementations. --- src/code/defpackage.lisp | 2 +- src/code/shaketree.lisp | 6 +-- src/code/target-package.lisp | 71 +++++++++++++++--------------------- tests/pkgiter.impure.lisp | 12 ++++++ tests/run-tests.lisp | 1 + tests/unintern.impure.lisp | 2 +- 6 files changed, 48 insertions(+), 46 deletions(-) create mode 100644 tests/pkgiter.impure.lisp diff --git a/src/code/defpackage.lisp b/src/code/defpackage.lisp index 674337ff9..f92bd877b 100644 --- a/src/code/defpackage.lisp +++ b/src/code/defpackage.lisp @@ -798,7 +798,7 @@ specifies to signal a warning if SWANK package is in variance, and an error othe ;;; (defun tune-hashset-sizes-of-all-packages () (flet ((tune-table-size (desired-lf table) - (resize-symbol-table table (%symtbl-count table) t desired-lf) + (resize-symbol-table table (%symtbl-count table) 'intern desired-lf) ;; The APROPOS-LIST R/O scan optimization is inadmissible if no R/O space #-darwin-jit (setf (symtbl-modified table) nil))) (dolist (package (list-all-packages)) diff --git a/src/code/shaketree.lisp b/src/code/shaketree.lisp index 7b6b95949..cdee5ad3e 100644 --- a/src/code/shaketree.lisp +++ b/src/code/shaketree.lisp @@ -16,7 +16,7 @@ (push x result) ; keep a strong reference to this symbol (push (cons (string x) (make-weak-pointer x)) result)))) (fill cells 0) - (resize-symbol-table table 0 t) + (resize-symbol-table table 0 'intern) result))) (dolist (package (list-all-packages)) ;; Never discard standard symbols @@ -33,10 +33,10 @@ (declare (ignore package)) (dolist (item symbols) (if (symbolp item) - (add-symbol table item) + (add-symbol table item 'intern) (let ((symbol (weak-pointer-value (cdr item)))) (cond (symbol - (add-symbol table symbol)) + (add-symbol table symbol 'intern)) (t (when print (format t " (~a)~A~%" access (car item))) diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp index 002049e5b..35cf9a3a2 100644 --- a/src/code/target-package.lisp +++ b/src/code/target-package.lisp @@ -307,6 +307,7 @@ ;;;; iteration macros +(define-thread-local *clear-resized-symbol-tables* t) (defmacro with-package-iterator ((mname package-list &rest symbol-types) &body body) "Within the lexical scope of the body forms, MNAME is defined via macrolet such that successive invocations of (MNAME) will return the symbols, one by @@ -325,7 +326,7 @@ of :INHERITED :EXTERNAL :INTERNAL." (if (member :external symbol-types) 2 0) (if (member :inherited symbol-types) 4 0)))) `(multiple-value-bind ,state (package-iter-init ,select ,package-list) - (let (,symbol ,kind) + (let (*clear-resized-symbol-tables* ,symbol ,kind) (macrolet ((,mname () '(if (eql 0 (multiple-value-setq (,@state ,symbol ,kind) @@ -533,7 +534,7 @@ of :INHERITED :EXTERNAL :INTERNAL." ;;; calls to ADD-SYMBOL make no attempt to preserve Robinhood's minimization ;;; of the maximum probe sequence length. We can do it now because the ;;; entire vector will be swapped, which is concurrent reader safe. -(defun resize-symbol-table (table size splat &optional (load-factor 3/4)) +(defun resize-symbol-table (table size reason &optional (load-factor 3/4)) (when (zerop size) (return-from resize-symbol-table ;; Don't need a barrier here. Suppose a reader finished probing with a miss. @@ -597,14 +598,17 @@ of :INHERITED :EXTERNAL :INTERNAL." (setf (symtbl-size table) (symtbl-size temp-table) (symtbl-free table) (symtbl-free temp-table) (symtbl-deleted table) 0) - ;; Splat with 0 to reduce garbage tenuring. Readers who searched the old VEC - ;; may miss spuriously, but will retry because they can detect that %CELLS changed. - ;; Exception: UNINTERN must not splat the vector because it is permitted to - ;; UNINTERN while iterating over symbols. We never re-fetch the vector, as doing - ;; that would cause extreme complications in deciding what symbols to produce. - ;; As such, we simply avoid splatting if called by UNINTERN. - ;; (Also, the constant vector of an empty package hashtable.) - (when (and splat (not (read-only-space-obj-p old))) + ;; Try to splat with 0 to reduce garbage tenuring based on a pre-test: + ;; - If the current thread has bound *CLEAR-RESIZED-SYMBOL-TABLES* to NIL, + ;; meaning that it is within the dynamic extent of WITH-PACKAGE-ITERATOR, + ;; splat only if the package modification is NOT a permissible one. + ;; - If the currrent thread has NOT bound the special variable, always splat. + ;; Concurrent readers who searched the old VEC may miss spuriously, but will retry + ;; because they can detect that %CELLS changed. In this manner, FIND-SYMBOL + ;; remains lock-free while allowing resizing and splatting. + (when (and (or *clear-resized-symbol-tables* + (not (memq reason '(unintern export unexport)))) ; permissible + (not (read-only-space-obj-p old))) (fill old 0)) new))))) @@ -1104,7 +1108,7 @@ Experimental: interface subject to change." ;;; Add a symbol to a hashset. The symbol MUST NOT be present. ;;; This operation is under the WITH-PACKAGE-GRAPH lock if called by %INTERN. -(defun add-symbol (table symbol) +(defun add-symbol (table symbol reason) (setf (symtbl-modified table) t) (when (zerop (symtbl-free table)) ;; The hashtable is full. Resize it to be able to hold twice the @@ -1114,7 +1118,7 @@ Experimental: interface subject to change." ;; N.B.: Never pass 0 for the new size, as that will assign the ;; constant read-only vector #(0 0 0) into the cells. (let ((new-size (max 1 (* (- (symtbl-size table) (symtbl-deleted table)) 2)))) - (resize-symbol-table table new-size t))) + (resize-symbol-table table new-size reason))) (let* ((cells (symtbl-%cells table)) (reciprocals (car cells)) (vec (truly-the simple-vector (cdr cells))) @@ -1304,25 +1308,10 @@ Experimental: interface subject to change." (probe))))))))) ;;; Delete SYMBOL from TABLE, storing -1 in its place. SYMBOL must exist. -;;; -;;; NOTE: It's possible that NUKE-SYMBOL should never 0-fill the old symbol-table if downsizing. -;;; CLHS nowhere implies that altering accessability of a symbol already _present_ in a package -;;; counts as INTERNing. Iterating over directly present symbols of a package permits UNINTERN on -;;; the current symbol, which might rehash the storage vector, creating a new one. To allow it, -;;; UNINTERN does not 0-fill the old vector, so any observers of that vector still see all symbols -;;; beyond the cursor. But what if the operation is EXPORT or UNEXPORT? This moves the symbol from -;;; one table to the other for that same package. EXPORT would remove from internals and move to -;;; externals. If the internals can down-size and 0-fill (as we do), then symbols beyond the cursor -;;; are missed. The argument in favaor of allowing EXPORT would seem to be that EXPORT is not -;;; technically INTERNing in this case. But the argument _against_ allowing EXPORT or UNEXPORT -;;; is that there is one and only one exception specifically called out as permissible, namely: -;;; "the current symbol may be uninterned from the package being traversed." -;;; If it were _also_ intended to be permissible to EXPORT or UNEXPORT, would it not have said -;;; that it is permissible to change accessibility ? I'm not sure. -(defun nuke-symbol (table symbol splat) +(defun nuke-symbol (table symbol reason) (let ((cells (symtbl-%cells table))) (when (functionp (car cells)) ; change table back to not-perfectly-hashed - (resize-symbol-table table (length (cdr cells)) splat))) + (resize-symbol-table table (length (cdr cells)) reason))) (let* ((string (symbol-name symbol)) (length (length string)) (hash (symbol-name-hash symbol))) @@ -1339,7 +1328,7 @@ Experimental: interface subject to change." (let ((size (symtbl-size table)) (used (%symtbl-count table))) (when (< used (truncate size 4)) - (resize-symbol-table table (* used 2) splat)))) + (resize-symbol-table table (* used 2) reason)))) (defun list-all-packages () "Return a list of all existing packages." @@ -1425,10 +1414,10 @@ Experimental: interface subject to change." ;; This matters in the case of concurrent INTERN. (%set-symbol-package symbol package) (if ignore-lock - (add-symbol table symbol) + (add-symbol table symbol 'intern) (with-single-package-locked-error (:package package "interning ~A" symbol-name) - (add-symbol table symbol))) + (add-symbol table symbol 'intern))) (values symbol nil))))))) (macrolet ((find/intern (function package-lookup &rest more-args) @@ -1664,7 +1653,7 @@ uninterned." (package-internal-symbols package) (package-external-symbols package)) symbol - nil) + 'unintern) (if (eq (sb-xc:symbol-package symbol) package) (%set-symbol-package symbol nil)) t) @@ -1742,8 +1731,8 @@ uninterned." ;; mean that some symbols in the original export list are ;; not exportable. (when (eql (find-symbol (symbol-name sym) package) sym) - (add-symbol external sym) - (nuke-symbol internal sym t))))) + (add-symbol external sym 'export) + (nuke-symbol internal sym 'export))))) t))) ;;; Check that all symbols are accessible, then move from external to internal. @@ -1768,8 +1757,8 @@ uninterned." (let ((internal (package-internal-symbols package)) (external (package-external-symbols package))) (dolist (sym syms) - (add-symbol internal sym) - (nuke-symbol external sym t)))) + (add-symbol internal sym 'unexport) + (nuke-symbol external sym 'unexport)))) t))) ;;; Check for name conflict caused by the import and let the user @@ -1817,7 +1806,7 @@ the importation, then a correctable error is signalled." ;; Add the new symbols to the internal hashtable. (let ((internal (package-internal-symbols package))) (dolist (sym syms) - (add-symbol internal sym))) + (add-symbol internal sym 'import))) ;; If any of the symbols are uninterned, make them be owned by PACKAGE. (dolist (sym homeless) (%set-symbol-package sym package)) @@ -1848,7 +1837,7 @@ the importation, then a correctable error is signalled." (setf (package-%shadowing-symbols package) (remove s (the list (package-%shadowing-symbols package)))) (unintern s package)) - (add-symbol internal sym)) + (add-symbol internal sym 'shadowing-import)) (pushnew sym (package-%shadowing-symbols package))))))) t) @@ -1876,7 +1865,7 @@ it is not already present." (unless (present-p w) (setq s (%make-symbol 2 name)) ; 2 = random interned symbol (%set-symbol-package s package) - (add-symbol internal s)) + (add-symbol internal s 'shadow)) (pushnew s (package-%shadowing-symbols package)))))))) t) @@ -1996,7 +1985,7 @@ PACKAGE." (flet ((!make-table (input) (let ((table (make-symbol-table (length (the simple-vector input))))) (dovector (symbol input table) - (add-symbol table symbol))))) + (add-symbol table symbol 'intern))))) (let ((externals (!make-table external-v))) (setf (package-external-symbols pkg) externals (package-internal-symbols pkg) (!make-table internal-v) diff --git a/tests/pkgiter.impure.lisp b/tests/pkgiter.impure.lisp new file mode 100644 index 000000000..6ee65451b --- /dev/null +++ b/tests/pkgiter.impure.lisp @@ -0,0 +1,12 @@ +;; lp# 2080387 but using the code of CSR, not the UB case +(make-package :som :use nil) +(setf *package* (find-package :som)) +(cl:defparameter *mmm* cl:nil) +(cl:do-symbols (sym (cl:find-package :som)) + (cl:push sym *mmm*) + (cl:export sym)) + +(cl:assert (cl:find '*mmm* *mmm*)) +(cl:assert (cl:find 'sym *mmm*)) +(cl:assert (cl:eq (cl:nth-value 1 (cl:find-symbol "*MMM*" "SOM")) + :external)) diff --git a/tests/run-tests.lisp b/tests/run-tests.lisp index e7b622f3c..a8dc3235c 100644 --- a/tests/run-tests.lisp +++ b/tests/run-tests.lisp @@ -236,6 +236,7 @@ sb-impl::*user-hash-table-tests* sb-impl::*pn-dir-table* sb-impl::*pn-table* + sb-impl::*clear-resized-symbol-tables* sb-vm::*immobile-codeblob-tree* sb-vm::*dynspace-codeblob-tree* ,(maybe "SB-KERNEL" "*EVAL-CALLS*") diff --git a/tests/unintern.impure.lisp b/tests/unintern.impure.lisp index 3939bfd25..a5e6d0090 100644 --- a/tests/unintern.impure.lisp +++ b/tests/unintern.impure.lisp @@ -6,7 +6,7 @@ (defun extern (name) (let ((s (make-symbol name)) (p *package*)) - (sb-impl::add-symbol (sb-impl::package-external-symbols *package*) s) + (sb-impl::add-symbol (sb-impl::package-external-symbols *package*) s 'intern) (sb-impl::%set-symbol-package s p) s))