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

Reduce conditionalization for compact-symbol

Browse source 
Use PACKAGE-IDs for 32-bit architectures. Now #+compact-symbol means that
package is encoded in the NAME slot, but otherwise the handling of IDs
is fairly consistent.
This commit is contained in:
Douglas Katzman 2022-01-05 16:44:46 -05:00
parent 9eda138f01
commit 1ac38acd3f
15 changed files with 48 additions and 74 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
src/code/save.lisp
View file

@ -70,7 +70,6 @@
(export 'sb-kernel::*save-lisp-clobbered-globals* 'sb-kernel)
(define-load-time-global sb-kernel::*save-lisp-clobbered-globals*
'#(sb-impl::*exit-lock*
sb-impl::*id->package*
sb-thread::*make-thread-lock*
sb-thread::*initial-thread*
;; Saving *JOINABLE-THREADS* could cause catastophic failure on restart.

31
src/code/symbol.lisp
View file

@ -289,28 +289,21 @@ distinct from the global value. Can also be SETF."
"Return SYMBOL's name as a string."
(symbol-name symbol))
;; FIXME: I think it would almost certainly be _less_ confusing
;; if this were strictly a C variable, and not in both Lisp and C.
;; C can't do without it for backtraces, and we could always use an alien var
;; from lisp, whereas the other way (only a Lisp symbol) has a chicken-and-egg
;; problem: C can't find a Lisp symbol unless it can find the package.
(define-load-time-global *id->package* #())
(declaim (simple-vector *id->package*))
(define-symbol-macro *id->package*
(truly-the simple-vector
(sap-ref-lispobj (foreign-symbol-sap "lisp_package_vector" t) 0)))
(export '*id->package*)
(defun sb-xc:symbol-package (symbol)
"Return SYMBOL's home package, or NIL if none."
#+compact-symbol
(let ((id (symbol-package-id symbol)))
(truly-the (or null package)
(if (= id +package-id-overflow+)
(values (info :symbol :package symbol))
(aref *id->package* id))))
#-compact-symbol
(sb-xc:symbol-package symbol))
(aref *id->package* id)))))
(defun %set-symbol-package (symbol package)
(declare (type symbol symbol))
#+compact-symbol
(let* ((new-id (cond ((not package) +package-id-none+)
((package-id package))
(t +package-id-overflow+)))
@ -319,8 +312,11 @@ distinct from the global value. Can also be SETF."
(with-pinned-objects (name)
(let ((name-bits (logior (ash new-id (- sb-vm:n-word-bits package-id-bits))
(get-lisp-obj-address name))))
(declare (ignorable name-bits))
(when (= new-id +package-id-overflow+) ; put the package in the dbinfo
(setf (info :symbol :package symbol) package))
#-compact-symbol (set-symbol-package-id symbol new-id)
#+compact-symbol
(with-pinned-objects (symbol)
(setf (sap-ref-word (int-sap (get-lisp-obj-address symbol))
(- (ash sb-vm:symbol-name-slot sb-vm:word-shift)
@ -329,9 +325,7 @@ distinct from the global value. Can also be SETF."
;; CLEAR-INFO is inefficient, so try not to call it.
(when (and (= old-id +package-id-overflow+) (/= new-id +package-id-overflow+))
(clear-info :symbol :package symbol))
package)
#-compact-symbol ; vop translates
(%set-symbol-package symbol package))
package))
;;; MAKE-SYMBOL is the external API, %MAKE-SYMBOL is the internal function receiving
;;; a known simple-string, and %%MAKE-SYMBOL is the primitive constructor.
@ -376,7 +370,7 @@ distinct from the global value. Can also be SETF."
(char= (char name (1- (length name))) #\*)))
(sb-vm::make-immobile-symbol name)
(sb-vm::%%make-symbol name)))))
#+compact-symbol (%set-symbol-package symbol nil)
(%set-symbol-package symbol nil)
symbol))
(defun get (symbol indicator &optional (default nil))
@ -486,10 +480,7 @@ distinct from the global value. Can also be SETF."
(defun keywordp (object)
"Return true if Object is a symbol in the \"KEYWORD\" package."
#+compact-symbol (keywordp object) ; transformed
#-compact-symbol
(and (symbolp object)
(eq (sb-xc:symbol-package object) *keyword-package*)))
(keywordp object)) ; transformed
;;;; GENSYM and friends

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

@ -1048,12 +1048,9 @@ implementation it is ~S." *!default-package-use-list*)
(new-length (min (+ current-length 10) +package-id-overflow+))
(new-vector (make-array new-length :initial-element nil)))
(replace new-vector vector)
(with-pinned-objects (vector)
(setf (extern-alien "lisp_package_vector" unsigned)
(get-lisp-obj-address new-vector)))
(setf *id->package* new-vector)
(setf new-id current-length
vector new-vector
*id->package* vector)))
vector new-vector)))
(when new-id
(setf (package-id package) new-id
(aref vector new-id) package)))
@ -1887,10 +1884,7 @@ PACKAGE."
(let ((id (package-id pkg)))
(when id (setq max-id (max id max-id)))))
(let ((a (make-array (1+ max-id) :initial-element nil)))
(setq *id->package* a)
(with-pinned-objects (a)
(setf (extern-alien "lisp_package_vector" unsigned)
(get-lisp-obj-address a)))
(setf *id->package* a)
(do-packages (pkg)
(let ((id (package-id pkg)))
(when id

2
src/cold/exports.lisp
View file

@ -574,7 +574,7 @@ structure representations")
"STATIC-SYMBOL-OFFSET" "STATIC-SYMBOL-P"
"+STATIC-SYMBOLS+"
"SYMBOL-HASH-SLOT" "SYMBOL-WIDETAG" "SYMBOL-NAME-SLOT"
"SYMBOL-PACKAGE-SLOT" "SYMBOL-INFO-SLOT" "SYMBOL-FDEFN-SLOT"
"SYMBOL-PACKAGE-ID-SLOT" "SYMBOL-INFO-SLOT" "SYMBOL-FDEFN-SLOT"
"SYMBOL-SIZE" "SYMBOL-VALUE-SLOT" "SYMBOL-TLS-INDEX-SLOT"
"AUGMENTED-SYMBOL-SIZE"
"*BINDING-STACK-START*"

2
src/cold/shared.lisp
View file

@ -281,7 +281,7 @@
;; Win32 conditionally adds :sb-futex in grovel-features.sh
(when (target-featurep '(:and :sb-thread (:or :linux :freebsd)))
(pushnew :sb-futex sb-xc:*features*))
(when (target-featurep '(:or :x86-64 :ppc64 :arm64 (:and :riscv :64-bit)))
(when (target-featurep :64-bit)
(push :compact-symbol sb-xc:*features*))
(when (target-featurep '(:and :sb-thread (:not :win32)))
(push :pauseless-threadstart sb-xc:*features*))

24
src/compiler/generic/genesis.lisp
View file

@ -1049,6 +1049,9 @@ core and return a descriptor to it."
(let ((symbol (allocate-otherptr gspace size sb-vm:symbol-widetag)))
(when core-file-name
(let* ((cold-name (set-readonly (base-string-to-core name *dynamic*)))
(pkg-id (if cold-package
(descriptor-fixnum (read-slot cold-package :id))
sb-impl::+package-id-none+))
(hash (make-fixnum-descriptor
(if core-file-name (sb-c::symbol-name-hash name) 0))))
(write-wordindexed symbol sb-vm:symbol-value-slot *unbound-marker*)
@ -1056,13 +1059,10 @@ core and return a descriptor to it."
(write-wordindexed symbol sb-vm:symbol-info-slot *nil-descriptor*)
#+compact-symbol
(write-wordindexed/raw symbol sb-vm:symbol-name-slot
(encode-symbol-name
(if cold-package
(descriptor-fixnum (read-slot cold-package :id))
sb-impl::+package-id-none+)
cold-name))
(encode-symbol-name pkg-id cold-name))
#-compact-symbol
(progn (write-wordindexed symbol sb-vm:symbol-package-slot cold-package)
(progn (write-wordindexed symbol sb-vm:symbol-package-id-slot
(make-fixnum-descriptor pkg-id))
(write-wordindexed symbol sb-vm:symbol-name-slot cold-name))))
symbol))
@ -1778,8 +1778,8 @@ core and return a descriptor to it."
(let ((target-cl-pkg-info (gethash "COMMON-LISP" *cold-package-symbols*)))
;; -1 is magic having to do with nil-as-cons vs. nil-as-symbol
#-compact-symbol
(write-wordindexed *nil-descriptor* (- sb-vm:symbol-package-slot 1)
(cdr target-cl-pkg-info))
(write-wordindexed *nil-descriptor* (- sb-vm:symbol-package-id-slot 1)
(make-fixnum-descriptor sb-impl::+package-id-lisp+))
(when core-file-name
(record-accessibility :external target-cl-pkg-info *nil-descriptor*)))
;; Intern the others.
@ -3194,15 +3194,15 @@ lispobj symbol_function(struct symbol* symbol);
#include \"genesis/vector.h\"
struct vector *symbol_name(struct symbol*);~%
lispobj symbol_package(struct symbol*);~%")
(format stream "static inline int symbol_package_id(struct symbol* s) { return ~A; }~%"
#+compact-symbol (format nil "s->name >> ~D" sb-impl::symbol-name-bits)
#-compact-symbol "fixnum_value(s->package_id)")
#+compact-symbol
(progn (format stream "#define decode_symbol_name(ptr) (ptr & (uword_t)0x~X)~%"
(mask-field (byte sb-impl::symbol-name-bits 0) -1))
(format stream "static inline void set_symbol_name(struct symbol*s, lispobj name) {
s->name = (s->name & (uword_t)0x~X) | name;~%}~%"
(mask-field (byte sb-impl::package-id-bits sb-impl::symbol-name-bits) -1))
(format stream
"static inline int symbol_package_id(struct symbol* s) { return s->name >> ~D; }~%"
sb-impl::symbol-name-bits))
(mask-field (byte sb-impl::package-id-bits sb-impl::symbol-name-bits) -1)))
#-compact-symbol
(progn (format stream "#define decode_symbol_name(ptr) ptr~%")
(format stream "static inline void set_symbol_name(struct symbol*s, lispobj name) {

6
src/compiler/generic/objdef.lisp
View file

@ -398,9 +398,9 @@ during backtrace.
(fdefn :ref-trans %symbol-fdefn :ref-known ()
:cas-trans cas-symbol-fdefn)
#-compact-symbol
(package :ref-trans sb-xc:symbol-package
:set-trans %set-symbol-package
:init :null)
(package-id :type index ; actually 16 bits. (Could go in the header)
:ref-trans sb-impl::symbol-package-id
:set-trans sb-impl::set-symbol-package-id :set-known ())
;; 0 tls-index means no tls-index is allocated
;; 64-bit put the tls-index in the header word.
;; For the 32-bit architectures, reading this slot as a descriptor

4
src/compiler/generic/vm-fndb.lisp
View file

@ -123,8 +123,8 @@
(defknown %set-symbol-hash (symbol hash-code)
t ())
;;; SYMBOL-PACKAGE-ID demands a vop so as to avoid placing a raw bit value
;;; in a descriptor register on precise GC. (The SLOT vop returns a descriptor)
;;; SYMBOL-PACKAGE-ID for #+compact-symbol demands a vop which avoids loading
;;; a raw bit value in a descriptor register (the SLOT vop returns a descriptor)
(defknown sb-impl::symbol-package-id (symbol) (unsigned-byte 16))
;;; TODO: I'd like to eliminate the (OR NULL) from this return type.
;;; For that to happen, I probably need +nil-packed-infos+ to become

1
src/compiler/generic/vm-tran.lisp
View file

@ -33,7 +33,6 @@
(deftransform make-symbol ((string) (simple-string))
`(%make-symbol 0 string))
#+compact-symbol
(define-source-transform keywordp (x)
`(let ((object ,x))
(and (symbolp object)

3
src/compiler/target-disassem.lisp
View file

@ -2219,8 +2219,7 @@
(define-load-time-global *grokked-symbol-slots*
(sort (copy-list `((,sb-vm:symbol-value-slot . symbol-value)
(,sb-vm:symbol-info-slot . symbol-info)
(,sb-vm:symbol-name-slot . symbol-name)
#-compact-symbol (,sb-vm:symbol-package-slot . symbol-package)))
(,sb-vm:symbol-name-slot . symbol-name)))
#'<
:key #'car))

19
src/runtime/backtrace.c
View file

@ -123,10 +123,10 @@ lispobj debug_print(lispobj string)
lispobj symbol_package(struct symbol* s)
{
#ifdef LISP_FEATURE_COMPACT_SYMBOL
static int warned;
// if using ldb when debugging cold-init, this can be confusing to see all symbols
// as if they were uninterned
// If using ldb when debugging cold-init, this can be confusing to see all symbols
// as if they were uninterned, but package-IDs are always available in the symbol.
// End-users should never see this failure.
if (!lisp_package_vector) {
if (!warned) {
fprintf(stderr, "Warning: package vector has not been initialized yet\n");
@ -136,21 +136,10 @@ lispobj symbol_package(struct symbol* s)
}
struct vector* v = VECTOR(lisp_package_vector);
int id = symbol_package_id(s);
if (id < fixnum_value(v->length_)) return v->data[id];
if (id < vector_len(v)) return v->data[id];
lose("can't decode package ID %d", id);
#else
return s->package;
#endif
}
#ifndef LISP_FEATURE_COMPACT_SYMBOL
static int symbol_package_id(struct symbol* s) {
lispobj pkg = s->package;
if (pkg == NIL) return PACKAGE_ID_NONE;
return fixnum_value(((struct package*)native_pointer(pkg))->id);
}
#endif
static void
print_entry_name (lispobj name, FILE *f)
{

1
src/runtime/fullcgc.c
View file

@ -432,7 +432,6 @@ void execute_full_mark_phase()
where += listp(obj) ? 2 : sizetab[widetag_of(where)](where);
}
#endif
// In case this is not the same as (symbol-value '*id->package*)
gc_mark_obj(lisp_package_vector);
do {
lispobj ptr = gc_dequeue();

2
src/runtime/globals.c
View file

@ -87,7 +87,7 @@ lispobj *current_auto_gc_trigger;
lispobj *current_dynamic_space;
#endif
lispobj lisp_package_vector; // needed if #+compact-symbol
lispobj lisp_package_vector;
void globals_init(void)
{

2
src/runtime/save.c
View file

@ -263,7 +263,7 @@ void unwind_binding_stack()
fprintf(stderr, "warning: bad value in %s\n", symbol_name);
else for(i=vector_len(VECTOR(value))-1; i>=0; --i)
SYMBOL(VECTOR(value)->data[i])->value = UNBOUND_MARKER_WIDETAG;
// these lisp pointers in C variables are like weak-pointers
// these are akin to weak-pointers
lisp_package_vector = 0;
alloc_profile_data = 0;
if (verbose) printf("done]\n");

12
tests/packages.impure.lisp
View file

@ -1012,11 +1012,15 @@ if a restart was invoked."
(assert (eq (foo-intern "X") (find-symbol "X" "PKG-B")))))
;;; It's extremely unlikely that a user would make >2^16 packages, but test that it works.
(with-test (:name :ridiculous-amount-of-packages :skipped-on (:not :compact-symbol))
(make-package "WATPACKAGE")
(defun grow-id->package-vector ()
(let ((table (make-array 65535 :initial-element nil))) ; grow once only. Sorry for cheating
(replace table sb-impl::*id->package*)
(setf sb-impl::*id->package* table))
(replace table sb-impl:*id->package*)
(setf sb-impl:*id->package* table)))
(compile 'grow-id->package-vector)
(with-test (:name :ridiculous-amount-of-packages)
(make-package "WATPACKAGE")
(grow-id->package-vector) ; grow once only. Sorry for cheating
(loop
;; This loop unfortunately takes 2 seconds, which kind of speaks to
;; the slowness of package creation. I don't think we need to improve that,