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

Shrink globldb packed infos if #+compact-instance-header

Browse source 
Don't use a simple-vector for storage, as it essentially wasted 12 bytea
per vector (counting all the 0s in the header and length words).
Rather than invent a new primitive object, this change uses a variable-length
INSTANCE, similarly to how CONDITION primitive objects are represented,
yielding somewhere between 5% to 10% space reduction for those data,
which is significant if have >16MiB of 'em eating up heap space.

There is no savings for #-compact-instance-header, but there are easy ways
to remedy that: (1) invent a new headered primitive object that is vector-like
but with the length in the header, (2) put a bit in an instance header saying
that next word which would ordinarily be a LAYOUT is not, (3) just use the
LAYOUT slot for whatever we like, and make GC robust against failure.
Option (3) isn't actually too unsafe - the 0th info element is a fixnum.
Of course there's always option (4) - implement #+compact-instance-header.
And there's no real benefit for 32-bit, since there wasn't as much waste.

A few more points to note:
- SYMBOL-INFO-VECTOR got renamed to SYMBOL-DBINFO, and SYMBOL-INFO to
  SYMBOL-%INFO for the primitive slot to try to keep things clearer
  as to which accesses the globaldb.
- It wasn't worth redoing all the specialized vops for SYMBOL-PLIST
  that would have been needed, so they're all gone.
- these days we don't need so much of the "!" convention for removing
  unnecessary symbols rom the core, since the tree-shaker does that.
This commit is contained in:
Douglas Katzman 2021-11-22 15:52:39 -05:00
parent c8e8dead0d
commit a2d379665d
33 changed files with 443 additions and 484 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

11
make-target-2-load.lisp
View file

@ -327,10 +327,11 @@ Please check that all strings which were not recognizable to the compiler
;; such that it now has neither properties nor globaldb info,
;; can have the slot set back to NIL if it wasn't already.
(do-all-symbols (symbol)
(when (and (sb-kernel:symbol-info symbol)
(null (sb-kernel:symbol-info-vector symbol))
(when (and (sb-kernel:symbol-%info symbol) ; "raw" value is something
;; but both "cooked" values are empty
(null (sb-kernel:symbol-dbinfo symbol))
(null (symbol-plist symbol)))
(setf (sb-kernel:symbol-info symbol) nil)))
(setf (sb-kernel:symbol-%info symbol) nil)))
)
(sb-ext:gc :full t)
@ -395,7 +396,7 @@ Please check that all strings which were not recognizable to the compiler
#+sb-devel
(lambda (symbol accessibility)
(declare (ignore accessibility))
(or (sb-kernel:symbol-info symbol)
(or (sb-kernel:symbol-%info symbol)
(and (boundp symbol) (not (keywordp symbol)))))
;; Release mode: retain all symbols satisfying this intricate test
#-sb-devel
@ -448,7 +449,7 @@ Please check that all strings which were not recognizable to the compiler
sb-assem::*backend-instruction-set-package*)
(or (eq accessibility :external) (asm-inst-p symbol))
;; By default, retain any symbol with any attachments
(or (sb-kernel:symbol-info symbol)
(or (sb-kernel:symbol-%info symbol)
(and (boundp symbol) (not (keywordp symbol))))))))
:verbose nil :print nil)
(unintern 'sb-impl::shake-packages 'sb-impl)

26
src/assembly/arm64/assem-rtns.lisp
View file

@ -178,7 +178,7 @@
(:export tail-call-symbol))
((:temp fun (any-reg descriptor-reg) lexenv-offset)
(:temp length (any-reg descriptor-reg) nl0-offset)
(:temp vector (any-reg descriptor-reg) r7-offset)
(:temp packed-info (any-reg descriptor-reg) r7-offset)
(:temp temp (any-reg descriptor-reg) nl1-offset)
(:temp temp2 (any-reg descriptor-reg) nl2-offset))
(inst str lr-tn (@ cfp-tn 8))
@ -191,24 +191,30 @@
(inst cmp temp symbol-widetag)
(inst b :ne not-callable)
(load-symbol-info-vector vector fun temp)
(load-symbol-dbinfo packed-info fun temp)
;; info-vector-fdefn
(inst cmp vector null-tn)
;; packed-info-fdefn
(inst cmp packed-info null-tn)
(inst b :eq undefined)
(inst ldr temp (@ vector (- (* 2 n-word-bytes) other-pointer-lowtag)))
;; read the 0th info descriptor
(inst ldr temp (@ packed-info
(- (ash (+ instance-slots-offset instance-data-start) word-shift)
instance-pointer-lowtag)))
(inst and temp temp (fixnumize (1- (ash 1 (* info-number-bits 2)))))
(inst movz temp2 (fixnumize (1+ (ash +fdefn-info-num+ info-number-bits))))
(inst cmp temp temp2)
(inst b :lt undefined)
(inst ldr length (@ vector
(- (ash vector-length-slot word-shift) other-pointer-lowtag)))
;; read the instance-length and mask out the extra bits
(inst ldr length (@ packed-info (- instance-pointer-lowtag)))
;; these next two instructions should be one 'ubfx' but I'm not smart enough
(inst lsr length length instance-length-shift)
(inst and length length instance-length-mask)
(inst lsl length length word-shift)
(inst lsl length length (- word-shift n-fixnum-tag-bits))
(inst sub length length (- other-pointer-lowtag 8))
(inst ldr fun (@ vector length))
(inst sub length length instance-pointer-lowtag)
(inst ldr fun (@ packed-info length))
(loadw lr-tn fun fdefn-raw-addr-slot other-pointer-lowtag)
(inst add lr-tn lr-tn 4)
(inst br lr-tn)

33
src/assembly/x86-64/assem-rtns.lisp
View file

@ -229,27 +229,38 @@
#+sb-assembling
(define-assembly-routine (call-symbol
(:return-style :none))
((:temp fun (any-reg descriptor-reg) rax-offset)
((:temp fun (any-reg descriptor-reg) rax-offset) ; FUN = the symbol
(:temp length (any-reg descriptor-reg) rax-offset)
(:temp vector (any-reg descriptor-reg) rbx-offset))
(%lea-for-lowtag-test vector fun other-pointer-lowtag)
(inst test :byte vector lowtag-mask)
(:temp info (any-reg descriptor-reg) rbx-offset)) ; for the packed symbol-info
(%lea-for-lowtag-test info fun other-pointer-lowtag)
(inst test :byte info lowtag-mask)
(inst jmp :nz not-callable)
(inst cmp :byte (ea (- other-pointer-lowtag) fun) symbol-widetag)
(inst jmp :ne not-callable)
(load-symbol-info-vector vector fun)
;; info-vector-fdefn
(inst cmp vector nil-value)
(load-symbol-dbinfo info fun)
;; reimplement by hand PACKED-INFO-FDEFN, q.v.
;; This only has to compare the low byte of INFO,
;; because INSTANCE-POINTER-LOWTAG won't match NIL in the low 8 bits.
(inst cmp :byte info (logand nil-value #xff))
(inst jmp :e undefined)
(inst mov :dword r10-tn (ea (- (* 2 n-word-bytes) other-pointer-lowtag) vector))
;; XXX - WHAT IS R10? ARBITRARY? COMMENT NEEDED
(inst mov :dword r10-tn (ea (- (ash (+ instance-slots-offset instance-data-start) word-shift)
instance-pointer-lowtag) info))
(inst and :dword r10-tn (fixnumize (1- (ash 1 (* info-number-bits 2)))))
(inst cmp :dword r10-tn (fixnumize (1+ (ash +fdefn-info-num+ info-number-bits))))
(inst jmp :b undefined)
(inst mov vector-len-op-size length (vector-len-ea vector))
(inst mov fun (ea (- 8 other-pointer-lowtag) vector length
(ash 1 (- word-shift n-fixnum-tag-bits))))
;; Read the logical instance length, i.e. excluding a stable hash slot if present,
;; but including a LAYOUT slot if #-compact-instance-header.
;; There's a optimization possibility here to eliminate one SHR, which would use
;; a 4-byte unaligned load at byte index 1 of the header, which would put the length
;; in byte index 0 of the register, but over by 2 bits; mask that, adjust the EA SCALE
;; to get the indexing right. That's too abstraction-violating for my taste.
(load-instance-length length info nil)
;; After this MOV, the FUN register will hold the FDEFN.
(inst mov fun (ea (- instance-pointer-lowtag) info length n-word-bytes))
(inst jmp (ea (- (* fdefn-raw-addr-slot n-word-bytes) other-pointer-lowtag) fun))
UNDEFINED

2
src/code/alloc.lisp
View file

@ -432,7 +432,7 @@
(logior (ash (1- symbol-size) n-widetag-bits) symbol-widetag)))))
;; symbol-hash was initialized to 0
(%set-symbol-global-value symbol (make-unbound-marker))
(setf (symbol-info symbol) nil)
(setf (symbol-%info symbol) nil)
(%primitive sb-vm::set-slot symbol name
'make-symbol sb-vm:symbol-name-slot sb-vm:other-pointer-lowtag)
(%set-symbol-package symbol nil)

1
src/code/cas.lisp
View file

@ -39,7 +39,6 @@
(def %raw-instance-cas/signed-word (instance index)
%raw-instance-ref/signed-word
%raw-instance-set/signed-word)
(def %compare-and-swap-symbol-info (symbol) symbol-info)
(def %compare-and-swap-symbol-value (symbol) symbol-value)
(def %compare-and-swap-svref (vector index) svref))

1
src/code/defsetfs.lisp
View file

@ -167,7 +167,6 @@
bits)
(defsetf symbol-value set)
(defsetf symbol-global-value set-symbol-global-value)
(defsetf symbol-plist %set-symbol-plist)
(defsetf fill-pointer %set-fill-pointer)
(defsetf subseq (sequence start &optional end) (v)
`(progn (replace ,sequence ,v :start1 ,start :end1 ,end) ,v))

4
src/code/early-raw-slots.lisp
View file

@ -212,7 +212,7 @@
;; the mask word indefinitely. Most bitmaps will have only 1 word,
;; so this is almost always MOST-POSITIVE-FIXNUM.
(,nbits (if (= ,bitmap-index ,bitmap-limit)
sb-vm::instance-length-mask
sb-vm:instance-length-mask
(- sb-vm:n-word-bits sb-vm:instance-data-start))))
(declare (type sb-vm:signed-word ,mask)
(type fixnum ,nbits))
@ -227,7 +227,7 @@
(when (zerop ,nbits)
(setq ,mask (%raw-instance-ref/signed-word ,bitmap ,bitmap-index)
,nbits (if (= (incf ,bitmap-index) ,bitmap-limit)
sb-vm::instance-length-mask
sb-vm:instance-length-mask
sb-vm:n-word-bits)))
(when (logbitp 0 ,mask) ,@body)
(setq ,mask (ash ,mask -1)

25
src/code/fdefinition.lisp
View file

@ -37,14 +37,14 @@
#+immobile-code (sb-vm::%set-fdefn-fun fdefn fun)
#-immobile-code (setf (fdefn-fun fdefn) fun))
;; Given Info-Vector VECT, return the fdefn that it contains for its root name,
;; Given PACKED-INFO, return the fdefn that it contains for its root name,
;; or nil if there is no value. NIL input is acceptable and will return NIL.
;; (see src/compiler/info-vector for more details)
(declaim (inline info-vector-fdefn))
(defun info-vector-fdefn (vect)
(when vect
;; This is safe: Info-Vector invariant requires that it have length >= 1.
(let ((word (the fixnum (svref vect 0))))
(declaim (inline packed-info-fdefn))
(defun packed-info-fdefn (packed-info)
(when packed-info
;; This is safe: PACKED-INFO invariant requires that it have length >= 1.
(let ((word (the fixnum (%info-ref packed-info 0))))
;; Test that the first info-number is +fdefn-info-num+ and its n-infos
;; field is nonzero. These conditions can be tested simultaneously
;; using a SIMD-in-a-register idea. The low 6 bits must be nonzero
@ -52,16 +52,15 @@
;; as a 12-bit unsigned integer it must be >= #b111111000001
(when (>= (ldb (byte (* info-number-bits 2) 0) word)
(1+ (ash +fdefn-info-num+ info-number-bits)))
;; DATA-REF-WITH-OFFSET doesn't know the info-vector length invariant,
;; so depite (safety 0) eliding bounds check, FOLD-INDEX-ADDRESSING
;; wasn't kicking in without (TRULY-THE (INTEGER 1 *)).
(aref vect (1- (truly-the (integer 1 *) (length vect))))))))
(%info-ref packed-info
(1- (truly-the (integer 1 *)
(packed-info-len packed-info))))))))
;; Return SYMBOL's fdefinition, if any, or NIL. SYMBOL must already
;; have been verified to be a symbol by the caller.
(defun symbol-fdefn (symbol)
(declare (optimize (safety 0)))
(info-vector-fdefn (symbol-info-vector symbol)))
(packed-info-fdefn (symbol-dbinfo symbol)))
;; Return the fdefn object for NAME, or NIL if there is no fdefn.
;; Signal an error if name isn't valid.
@ -80,7 +79,7 @@
(return-from find-fdefn it))
:simple
(progn
(awhen (symbol-info-vector key1)
(awhen (symbol-dbinfo key1)
(multiple-value-bind (data-idx descriptor-idx field-idx)
(info-find-aux-key/packed it key2)
(declare (type index descriptor-idx)
@ -93,7 +92,7 @@
(when (eql (packed-info-field it descriptor-idx field-idx)
+fdefn-info-num+)
(return-from find-fdefn
(aref it (1- (the index data-idx))))))))
(%info-ref it (1- (the index data-idx))))))))
(when (eq key1 'setf) ; bypass the legality test
(return-from find-fdefn nil))))
(legal-fun-name-or-type-error name))

21
src/code/late-globaldb.lisp
View file

@ -9,14 +9,27 @@
(in-package "SB-IMPL")
;; Call FUNCTION once for each Name in globaldb that has information associated
;; with it, passing the function the Name as its only argument.
;;
;; This is in its own file to avoid creating an early dependency on
;; target-package iterators.
(macrolet
((def (&rest situations)
`(eval-when ,situations
;; Return all function names that are stored in SYMBOL's packe-info.
;; As an example, (INFO-NAME-LIST 'SB-PCL::DIRECT-SUPERCLASSES) =>
;; ((SB-PCL::SLOT-ACCESSOR :GLOBAL SB-PCL::DIRECT-SUPERCLASSES SB-PCL::READER)
;; (SB-PCL::SLOT-ACCESSOR :GLOBAL SB-PCL::DIRECT-SUPERCLASSES BOUNDP)
;; (SB-PCL::SLOT-ACCESSOR :GLOBAL SB-PCL::DIRECT-SUPERCLASSES SB-PCL::WRITER))
(defun info-name-list (symbol)
(let ((packed-info (symbol-dbinfo symbol))
(list))
(when packed-info
(do-packed-info-aux-key (packed-info key-index)
(push (construct-globaldb-name (%info-ref packed-info key-index) symbol)
list))
(nconc (and (plusp (packed-info-field packed-info 0 0)) (list symbol))
(nreverse list)))))
;; Call FUNCTION once for each Name in globaldb that has information associated
;; with it, passing the function the Name as its only argument.
(defun call-with-each-globaldb-name (fun-designator)
(let ((function (cl:coerce fun-designator 'function)))
(with-package-iterator (iter (list-all-packages) :internal :external)
@ -28,7 +41,7 @@
;; always keep it since we can't know if it has been seen once.
(when (or (not (sb-xc:symbol-package symbol))
(eq package (sb-xc:symbol-package symbol)))
(dolist (name (info-vector-name-list symbol))
(dolist (name (info-name-list symbol))
(funcall function name))))))
,@(unless (equal situations '(:compile-toplevel))
`((dovector (obj (car *fdefns*))

2
src/code/room.lisp
View file

@ -1039,7 +1039,7 @@ We could try a few things to mitigate this:
,.(make-case 'array)
,.(make-case* 'symbol
`(,functoid (%primitive sb-c:fast-symbol-global-value ,obj) ,@more)
`(,functoid (symbol-info ,obj) ,@more)
`(,functoid (symbol-%info ,obj) ,@more)
`(,functoid (symbol-name ,obj) ,@more)
`(,functoid (symbol-package ,obj) ,@more)
`(when (symbol-extra-slot-p ,obj)

6
src/code/stubs.lisp
View file

@ -162,7 +162,11 @@
(def symbol-hash)
(def sb-vm::symbol-extra)
#+sb-thread (def symbol-tls-index)
#.(if (fboundp 'symbol-info-vector) (values) '(def symbol-info-vector))
(def symbol-%info) ; primitive reader always needs a stub
(def (setf symbol-%info) (info symbol)) ; as does primitive writer
;; but the "wrapped" reader might not need a stub.
;; If it's already a proper function, then it doesn't.
#.(if (fboundp 'symbol-dbinfo) (values) '(def symbol-dbinfo))
#-(or x86 x86-64) (def lra-code-header)
(def %make-lisp-obj)
(def get-lisp-obj-address)

100
src/code/symbol.lisp
View file

@ -149,14 +149,6 @@ distinct from the global value. Can also be SETF."
;; State 2 transitions to state 3 via ({SETF|CAS} SYMBOL-PLIST).
;; There are *no* other permissible state transitions.
(defun symbol-info (symbol)
(symbol-info symbol))
;; An "interpreter stub" for an operation that is only implemented for
;; the benefit of platforms without compare-and-swap-vops.
(defun (setf symbol-info) (new-info symbol)
(setf (symbol-info symbol) new-info))
;; Atomically update SYMBOL's info/plist slot to contain a new info vector.
;; The vector is computed by calling UPDATE-FN on the old vector,
;; repeatedly as necessary, until no conflict happens with other updaters.
@ -164,25 +156,25 @@ distinct from the global value. Can also be SETF."
(defun update-symbol-info (symbol update-fn)
(declare (symbol symbol)
(type (function (t) t) update-fn))
(prog ((info-holder (symbol-info symbol))
(current-vect))
(prog ((info-holder (symbol-%info symbol))
(current-info)) ; a PACKED-INFO or NIL
outer-restart
;; Do not use SYMBOL-INFO-VECTOR - this must not perform a slot read again.
(setq current-vect (if (listp info-holder) (cdr info-holder) info-holder))
;; This _must_ _not_ perform another read of the INFO slot here.
(setq current-info (if (listp info-holder) (cdr info-holder) info-holder))
inner-restart
(let ((new-vect (funcall update-fn (or current-vect +nil-packed-infos+))))
(unless (simple-vector-p new-vect)
(aver (null new-vect))
(let ((new-info (funcall update-fn (or current-info +nil-packed-infos+))))
(unless (%instancep new-info)
(aver (null new-info))
(return)) ; nothing to do
(if (consp info-holder) ; State 3: exchange the CDR
(let ((old (%compare-and-swap-cdr info-holder current-vect new-vect)))
(when (eq old current-vect) (return t)) ; win
(setq current-vect old) ; Don't touch holder- it's still a cons
(let ((old (cas (cdr info-holder) current-info new-info)))
(when (eq old current-info) (return t)) ; win
(setq current-info old) ; Don't touch holder- it's still a cons
(go inner-restart)))
;; State 1 or 2: info-holder is NIL or a vector.
;; Exchange the contents of the info slot. Type-inference derives
;; SIMPLE-VECTOR-P on the args to CAS, so no extra checking.
(let ((old (%compare-and-swap-symbol-info symbol info-holder new-vect)))
;; State 1 or 2: info-holder is NIL or a PACKED-INFO.
;; Exchange the contents of the info slot. Type-inference should have
;; derived that NEW-INFO satisfies the slot type restriction (I hope).
(let ((old (cas-symbol-%info symbol info-holder new-info)))
(when (eq old info-holder) (return t)) ; win
;; Check whether we're in state 2 or 3 now.
;; Impossible to be in state 1: nobody ever puts NIL in the slot.
@ -190,38 +182,25 @@ distinct from the global value. Can also be SETF."
(setq info-holder old)
(go outer-restart)))))
(eval-when (:compile-toplevel)
;; If we're in state 1 or state 3, we can take (CAR (SYMBOL-INFO S))
;; to get the property list. If we're in state 2, this same access
;; gets the fixnum which is the VECTOR-LENGTH of the info vector.
;; So all we have to do is turn any fixnum to NIL, and we have a plist.
;; Ensure that this pun stays working.
#-ppc64 ; ppc64 has unevenly spaced lowtags
(assert (= (- (* sb-vm:n-word-bytes sb-vm:cons-car-slot)
sb-vm:list-pointer-lowtag)
(- (* sb-vm:n-word-bytes sb-vm:vector-length-slot)
sb-vm:other-pointer-lowtag))))
(defun symbol-plist (symbol)
"Return SYMBOL's property list."
(if (sb-c::vop-existsp :translate cl:symbol-plist)
(symbol-plist symbol)
(let ((list (car (truly-the list (symbol-info symbol))))) ; a harmless lie
;; Just ensure the result is not a fixnum, and we're done.
(if (fixnump list) nil list))))
(let ((list (symbol-%info symbol)))
;; See the comments above UPDATE-SYMBOL-INFO for a
;; reminder as to why this logic is right.
(if (%instancep list) nil (car list))))
(declaim (ftype (sfunction (symbol t) cons) %ensure-plist-holder)
(inline %ensure-plist-holder))
;; When a plist update (setf or cas) is first performed on a symbol,
;; a one-time allocation of an extra cons is done which creates two
;; "slots" from one: a slot for the info-vector and a slot for the plist.
;; "slots" from one: a slot for the PACKED-INFO and a slot for the plist.
;; This avoids complications in the implementation of the user-facing
;; (CAS SYMBOL-PLIST) function, which should not have to be aware of
;; competition from globaldb mutators even if no other threads attempt
;; to manipulate the plist per se.
;; Given a SYMBOL and its current INFO of type (OR LIST SIMPLE-VECTOR)
;; Given a SYMBOL and its current INFO of type (OR LIST INSTANCE)
;; ensure that SYMBOL's current info is a cons, and return that.
;; If racing with multiple threads, at most one thread will install the cons.
(defun %ensure-plist-holder (symbol info)
@ -233,54 +212,55 @@ distinct from the global value. Can also be SETF."
;; The pointer from the new cons to the old info must be persisted
;; to memory before the symbol's info slot points to the cons.
;; [x86oid doesn't need the barrier, others might]
(sb-thread:barrier (:write)
(setq newcell (cons nil info)))
(loop (let ((old (%compare-and-swap-symbol-info symbol info newcell)))
(setq newcell (cons nil info))
(sb-thread:barrier (:write)) ; oh such ghastly syntax
(loop (let ((old (cas-symbol-%info symbol info newcell)))
(cond ((eq old info) (return newcell)) ; win
((consp old) (return old))) ; somebody else made a cons!
(setq info old)
(sb-thread:barrier (:write) ; Retry using same newcell
(rplacd newcell info)))))))
(rplacd newcell info)
(sb-thread:barrier (:write))))))) ; Retry using same newcell
(declaim (inline (cas symbol-plist) %set-symbol-plist))
(declaim (inline (cas symbol-plist) (setf symbol-plist)))
(defun (cas symbol-plist) (old new symbol)
;; If SYMBOL's info cell is a cons, we can do (CAS CAR). Otherwise punt.
(declare (symbol symbol) (list old new))
(let ((cell (symbol-info symbol)))
(let ((cell (symbol-%info symbol)))
(if (consp cell)
(%compare-and-swap-car cell old new)
(%compare-and-swap-symbol-plist old new symbol))))
(%cas-symbol-plist old new symbol))))
(defun %compare-and-swap-symbol-plist (old new symbol)
(defun %cas-symbol-plist (old new symbol)
;; This is just the second half of a partially-inline function, to avoid
;; code bloat in the exceptional case. Type assertions should have been
;; done - or not, per policy - by the caller of %COMPARE-AND-SWAP-SYMBOL-PLIST
;; so now use TRULY-THE to avoid further type checking.
(%compare-and-swap-car (%ensure-plist-holder (truly-the symbol symbol)
(symbol-info symbol))
(symbol-%info symbol))
old new))
(defun %set-symbol-plist (symbol new-value)
;; This is the entry point into which (SETF SYMBOL-PLIST) is transformed.
(defun (setf symbol-plist) (new-value symbol)
;; If SYMBOL's info cell is a cons, we can do (SETF CAR). Otherwise punt.
(declare (symbol symbol) (list new-value))
(let ((cell (symbol-info symbol)))
(let ((cell (symbol-%info symbol)))
(if (consp cell)
(setf (car cell) new-value)
(%%set-symbol-plist symbol new-value))))
(%set-symbol-plist symbol new-value))))
(defun %%set-symbol-plist (symbol new-value)
;; Same considerations as for %%COMPARE-AND-SWAP-SYMBOL-PLIST,
(defun %set-symbol-plist (symbol new-value)
;; Same considerations as for %CAS-SYMBOL-PLIST,
;; with a slight efficiency hack: if the symbol has no plist holder cell
;; and the NEW-VALUE is NIL, try to avoid creating a holder cell.
;; Yet we must write something, because omitting a memory operation
;; could have a subtle effect in the presence of multi-threading.
(let ((info (symbol-info (truly-the symbol symbol))))
(let ((info (symbol-%info (truly-the symbol symbol))))
(when (and (not new-value) (atom info)) ; try to treat this as a no-op
(let ((old (%compare-and-swap-symbol-info symbol info info)))
;; INFO is either an INSTANCE (a PACKED-INFO) or NIL.
;; Write the same thing back, to say we set the plist to NIL.
(let ((old (cas-symbol-%info symbol info info)))
(if (eq old info) ; good enough
(return-from %%set-symbol-plist new-value) ; = nil
(return-from %set-symbol-plist new-value) ; = nil
(setq info old))))
(setf (car (%ensure-plist-holder symbol info)) new-value)))

7
src/cold/package-data-list.lisp-expr
View file

@ -1093,6 +1093,7 @@ possibly temporarily, because it might be used internally."
"*RECOGNIZED-DECLARATIONS*"
"+INFOS-PER-WORD+"
"+FDEFN-INFO-NUM+"
"PACKED-INFO"
"+NIL-PACKED-INFOS+"
"ATOMIC-SET-INFO-VALUE"
"CALL-WITH-EACH-GLOBALDB-NAME"
@ -1110,7 +1111,7 @@ possibly temporarily, because it might be used internally."
"INFO-MAPHASH"
"INFO-NUMBER"
"INFO-NUMBER-BITS"
"INFO-VECTOR-FDEFN"
"PACKED-INFO-FDEFN"
"MAKE-INFO-HASHTABLE"
"META-INFO"
"META-INFO-NUMBER"
@ -1589,7 +1590,6 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
"%COMPARE-AND-SWAP-CAR"
"%COMPARE-AND-SWAP-CDR"
"%COMPARE-AND-SWAP-SVREF"
"%COMPARE-AND-SWAP-SYMBOL-INFO"
"%COMPARE-AND-SWAP-SYMBOL-VALUE"
"%CONCATENATE-TO-BASE-STRING"
"%CONCATENATE-TO-STRING"
@ -2281,7 +2281,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
"MAKE-STATIC-CLASSOID"
"%MAKE-SYMBOL"
"%FUNCALLABLE-INSTANCE-FUN" "SYMBOL-HASH" "SYMBOL-HASH*"
"SYMBOL-INFO" "SYMBOL-INFO-VECTOR"
"SYMBOL-%INFO" "SYMBOL-DBINFO" "%INFO-REF"
"EXTENDED-SEQUENCE" "*EXTENDED-SEQUENCE-TYPE*"
"EXTENDED-SEQUENCE-P"
@ -3259,6 +3259,7 @@ structure representations"
"THREAD-SPROF-DATA-SLOT"
"TLS-SIZE" "N-WIDETAG-BITS" "WIDETAG-MASK"
"INSTANCE-LENGTH-SHIFT"
"INSTANCE-LENGTH-MASK"
"UNBOUND-MARKER-WIDETAG"
"UNDEFINED-FUNCTION-TRAP"
"NO-TLS-VALUE-MARKER-WIDETAG"

2
src/cold/set-up-cold-packages.lisp
View file

@ -535,7 +535,7 @@
(cond ((not s)
(push (cons pkg string) nonexistent))
((and (not (boundp s))
(not (sb-kernel:symbol-info s))
(not (sb-kernel:symbol-%info s))
(not (gethash s sb-c::*backend-parsed-vops*)))
(push s uninteresting))))))))
(format t "~&Nonexistent:~%")

17
src/compiler/arm/system.lisp
View file

@ -216,9 +216,9 @@
(inst sub ndescr ndescr (- other-pointer-lowtag fun-pointer-lowtag))
(inst add func code ndescr)))
;;;
(define-vop (symbol-info-vector)
(define-vop (symbol-dbinfo)
(:policy :fast-safe)
(:translate symbol-info-vector)
(:translate symbol-dbinfo)
(:args (x :scs (descriptor-reg)))
(:results (res :scs (descriptor-reg)))
(:temporary (:sc unsigned-reg) temp)
@ -228,19 +228,6 @@
(inst and temp res lowtag-mask)
(inst cmp temp list-pointer-lowtag)
(loadw res res cons-cdr-slot list-pointer-lowtag :eq)))
(define-vop (symbol-plist)
(:policy :fast-safe)
(:translate symbol-plist)
(:args (x :scs (descriptor-reg)))
(:results (res :scs (descriptor-reg)))
(:generator 1
(loadw res x symbol-info-slot other-pointer-lowtag)
;; Instruction pun: (CAR x) is the same as (VECTOR-LENGTH x)
;; so if the info slot holds a vector, this gets a fixnum- it's not a plist.
(loadw res res cons-car-slot list-pointer-lowtag)
(inst tst res fixnum-tag-mask)
(inst mov :eq res null-tn)))
;;;; other miscellaneous VOPs

21
src/compiler/arm64/system.lisp
View file

@ -225,7 +225,7 @@
(inst add func code ndescr)))
;;;
(defun load-symbol-info-vector (result symbol temp)
(defun load-symbol-dbinfo (result symbol temp)
(assemble ()
(loadw result symbol symbol-info-slot other-pointer-lowtag)
;; If RESULT has list-pointer-lowtag, take its CDR. If not, use it as-is.
@ -235,27 +235,14 @@
(loadw result result cons-cdr-slot list-pointer-lowtag)
NE))
(define-vop (symbol-info-vector)
(define-vop (symbol-dbinfo)
(:policy :fast-safe)
(:translate symbol-info-vector)
(:translate symbol-dbinfo)
(:args (x :scs (descriptor-reg)))
(:results (res :scs (descriptor-reg)))
(:temporary (:sc unsigned-reg) temp)
(:generator 1
(load-symbol-info-vector res x temp)))
(define-vop (symbol-plist)
(:policy :fast-safe)
(:translate symbol-plist)
(:args (x :scs (descriptor-reg)))
(:results (res :scs (descriptor-reg)))
(:generator 1
(loadw res x symbol-info-slot other-pointer-lowtag)
;; Instruction pun: (CAR x) is the same as (VECTOR-LENGTH x)
;; so if the info slot holds a vector, this gets a fixnum- it's not a plist.
(loadw res res cons-car-slot list-pointer-lowtag)
(inst tst res fixnum-tag-mask)
(inst csel res null-tn res :eq)))
(load-symbol-dbinfo res x temp)))
;;;; other miscellaneous VOPs

111
src/compiler/early-globaldb.lisp
View file

@ -35,6 +35,66 @@
#-sb-xc-host
(declaim (ftype (sfunction (t) ctype) global-ftype))
;;; A bit about the physical representation of the packed info format:
;;; With #+compact-instance-header it is possible to represent a vector of N things
;;; in a structure using (ALIGN-UP (1+ N) 2) words of memory. This is a saving
;;; of 1 word on average when compared to SIMPLE-VECTOR which needs
;;; (ALIGN-UP (+ N 2) 2) words. Granted that either might have a padding word,
;;; but I've observed 5% to 10% space reduction by eliminating one slot.
;;; Without compact-instance-header, we'e indifferent, in terms of space,
;;; as to whether this is an INSTANCE or a SIMPLE-VECTOR. For consistency,
;;; we use an INSTANCE regardless of presence of the compact-header feature.
;;; This makes assembly routines (e.g. CALL-SYMBOL) slightly less sensitive
;;; to the feature's absence.
;;; Since variable-length instances aren't portably a thing,
;;; we use a structure of one slot holding a vector.
#+sb-xc-host (defstruct (packed-info
(:constructor %make-packed-info (cells))
(:copier nil))
;; These objects are immutable.
(cells #() :type simple-vector :read-only t))
;;; Some abstractions for host/target compatibility of all the defuns.
#+sb-xc-host
(progn
(defmacro make-packed-info (n) `(%make-packed-info (make-array ,n)))
(defmacro copy-packed-info (info)
`(%make-packed-info (copy-seq (packed-info-cells ,info))))
(defmacro packed-info-len (info)
`(length (packed-info-cells ,info)))
(defmacro %info-ref (info index) `(svref (packed-info-cells ,info) ,index)))
#-sb-xc-host
(progn
#+nil
(defmethod print-object ((obj packed-info) stream)
(format stream "[~{~W~^ ~}]"
(loop for i below (%instance-length obj)
collect (%instance-ref obj i))))
(defmethod print-object ((self sb-int:packed-info) stream)
(print-unreadable-object (self stream :type t :identity t)
(format stream "len=~d" (sb-kernel:%instance-length self))))
(eval-when (:compile-toplevel)
(sb-xc:defmacro make-packed-info (n)
;; this file is earlier than early-vm, so we have to take
;; INSTANCE-DATA-START from the value set in make-host-1.
`(let ((new (%make-instance (+ ,n #.sb-vm:instance-data-start))))
(setf (%instance-wrapper new) #.(find-layout 'packed-info))
new))
;; We can't merely call COPY-STRUCTURE due to two issues:
;; 1. bootstrapping- the DEFSTRUCT-DESCRIPTION is not available
;; in cold-init by the first call to COPY-PACKED-INFO,
;; but COPY-STRUCTURE needs it, because of raw slots.
;; 2. the transform for COPY-STRUCTURE would think that
;; it needs to copy exactly 1 slot. Well, it would think that,
;; if the FREEZE-TYPE wasn't commented out.
(sb-xc:defmacro copy-packed-info (info)
;; not bothering with ONCE-ONLY here (doesn't matter)
`(%copy-instance (%make-instance (%instance-length ,info)) ,info)))
(defmacro packed-info-len (info)
`(- (%instance-length ,info) sb-vm:instance-data-start))
(defmacro %info-ref (v i)
`(%instance-ref ,v (+ ,i #.sb-vm:instance-data-start))))
;;; At run time, we represent the type of a piece of INFO in the globaldb
;;; by a small integer between 1 and 63. [0 is reserved for internal use.]
;;; CLISP, and maybe others, need EVAL-WHEN because without it, the constant
@ -85,25 +145,26 @@
;;; presented at the definition of SYMBOL-PLIST, if the object in SYMBOL's
;;; info slot is LISTP, it is in state 1 or 3. Either way, take the CDR.
;;; Otherwise, it is in state 2 so return the value as-is.
;;; In terms of this function being named "-vector", implying always a vector,
;;; it is understood that NIL is a proxy for +NIL-PACKED-INFOS+, a vector.
;;; NIL is an acceptable substitute for +NIL-PACKED-INFOS+,
;;; but I might change that.
;;;
;;; Define SYMBOL-INFO-VECTOR as an inline function unless a vop translates it.
;;; Define SYMBOL-INFO as an inline function unless a vop translates it.
;;; (Inlining occurs first, which would cause the vop not to be used.)
#-sb-xc-host
(sb-c::unless-vop-existsp (:translate sb-kernel:symbol-info-vector)
(declaim (inline symbol-info-vector))
(defun symbol-info-vector (symbol)
(let ((info-holder (symbol-info symbol)))
(truly-the (or null simple-vector)
(sb-c::unless-vop-existsp (:translate sb-kernel:symbol-dbinfo)
(declaim (inline symbol-dbinfo))
(defun symbol-dbinfo (symbol)
(let ((info-holder (symbol-%info symbol)))
(truly-the (or null instance)
(if (listp info-holder) (cdr info-holder) info-holder)))))
;;; SYMBOL-INFO is a primitive object accessor defined in 'objdef.lisp'
;;; But in the host Lisp, there is no such thing as a symbol-info slot.
;;; Instead, symbol-info is kept in the host symbol's plist.
;;; This must be a SETFable place.
;;; %SYMBOL-INFO is a primitive object accessor defined in 'objdef.lisp'
;;; But in the host Lisp, there is no such thing. Instead, SYMBOL-%INFO
;;; is kept as a property on the host symbol.
;;; The compatible "primitive" accessor must be a SETFable place.
#+sb-xc-host
(defmacro symbol-info-vector (symbol) `(get ,symbol :sb-xc-globaldb-info))
(progn (defmacro symbol-%info (symbol) `(get ,symbol :sb-xc-globaldb-info))
(defun symbol-dbinfo (symbol) (symbol-%info symbol)))
;; Perform the equivalent of (GET-INFO-VALUE KIND +INFO-METAINFO-TYPE-NUM+)
;; but skipping the defaulting logic.
@ -111,19 +172,21 @@
;; - though not always - a unique identifier for the (:TYPE :KIND) pair.
;; Note that bypassing of defaults is critical for bootstrapping,
;; since INFO is used to retrieve its own META-INFO at system-build time.
(defmacro !get-meta-infos (kind)
`(let* ((info-vector (symbol-info-vector ,kind))
(index (if info-vector
(packed-info-value-index info-vector +no-auxiliary-key+
(defmacro get-meta-infos (kind)
`(let* ((packed-info (symbol-dbinfo ,kind))
(index (if packed-info
(packed-info-value-index packed-info +no-auxiliary-key+
+info-metainfo-type-num+))))
(if index (svref info-vector index))))
(if index (%info-ref packed-info index))))
;; (UNSIGNED-BYTE 16) is an arbitrarily generous limit on the number of
;; cells in an info-vector. Most vectors have a fewer than a handful of things,
;; (UNSIGNED-BYTE 11) is an arbitrarily generous limit on the number of
;; cells in a packed-info. Most packed-infos have fewer than a handful of things,
;; and performance would need to be re-thought if more than about a dozen
;; cells were in use. (It would want to become hash-based probably)
(declaim (ftype (function (simple-vector (or (eql 0) symbol) info-number)
(or null (unsigned-byte 16)))
;; It has to be smaller than INSTANCE_LENGTH_MASK certainly,
;; plus leaving room for a layout slot if #-compact-instance-header.
(declaim (ftype (function (packed-info (or (eql 0) symbol) info-number)
(or null (unsigned-byte 11)))
packed-info-value-index))
;; Return the META-INFO object for CATEGORY and KIND, signaling an error
@ -136,7 +199,7 @@
;; through, whereas typically no more than 3 or 4 items have the same KIND.
;;
(defun meta-info (category kind &optional (errorp t))
(or (let ((metadata (!get-meta-infos kind)))
(or (let ((metadata (get-meta-infos kind)))
(cond ((listp metadata) ; conveniently handles NIL
(dolist (info metadata nil) ; FIND is slower :-(
(when (eq (meta-info-category (truly-the meta-info info))
@ -144,7 +207,7 @@
(return info))))
((eq (meta-info-category (truly-the meta-info metadata)) category)
metadata)))
;; !GET-META-INFOS enforces that KIND is a symbol, therefore
;; GET-META-INFOS enforces that KIND is a symbol, therefore
;; if a metaobject was found, CATEGORY was necessarily a symbol too.
;; Otherwise, if the caller wants no error to be signaled on missing info,
;; we must nevertheless enforce that CATEGORY was actually a symbol.

7
src/compiler/fndb.lisp
View file

@ -1990,8 +1990,11 @@
(defknown %scharset ((modifying simple-string) index character) character ())
(defknown %set-symbol-value (symbol t) t ())
(defknown (setf symbol-function) (function symbol) function ())
(defknown %set-symbol-plist (symbol list) list ()
:derive-type #'result-type-last-arg)
;; Does this really need a type deriver? It's inline, and returns its 1st arg,
;; i.e. we know exactly what object it returns, which is more precise than
;; just knowing the type.
(defknown (setf symbol-plist) (list symbol) list ()
:derive-type #'result-type-first-arg)
(defknown %setnth (unsigned-byte (modifying list) t) t ()
:derive-type #'result-type-last-arg)
(defknown %set-fill-pointer ((modifying complex-vector) index) index ()

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

@ -1929,7 +1929,7 @@ core and return a descriptor to it."
(sort (%hash-table-alist *cold-package-symbols*)
#'string< :key #'car)))) ; Sort by package-name
(dump-symbol-info-vectors
(dump-symbol-infos
(attach-fdefinitions-to-symbols
(attach-classoid-cells-to-symbols (make-hash-table :test #'eq))))
@ -2101,7 +2101,7 @@ core and return a descriptor to it."
;;
(defun attach-fdefinitions-to-symbols (hashtable)
;; Collect fdefinitions that go with one symbol, e.g. CAR and (SETF CAR),
;; using the host's code for manipulating a packed info-vector.
;; using the host's code for manipulating a packed-info.
(maphash (lambda (warm-name cold-fdefn)
(with-globaldb-name (key1 key2) warm-name
:hairy (error "Hairy fdefn name in genesis: ~S" warm-name)
@ -2113,24 +2113,33 @@ core and return a descriptor to it."
*cold-fdefn-objects*)
hashtable)
(defun dump-symbol-info-vectors (hashtable)
;; Emit in the same order symbols reside in core to avoid
;; sensitivity to the iteration order of host's maphash.
(loop for (warm-sym . info)
(defun dump-packed-info (list)
;; Payload length is the element count + LAYOUT slot if necessary.
;; Header word is added automatically by ALLOCATE-STRUCT
(let ((s (allocate-struct (+ sb-vm:instance-data-start (length list))
(cold-layout-descriptor (gethash 'packed-info *cold-layouts*)))))
(loop for i from (+ sb-vm:instance-slots-offset sb-vm:instance-data-start)
for elt in list do (write-wordindexed s i elt))
s))
(defun dump-symbol-infos (hashtable)
(cold-set 'sb-impl::+nil-packed-infos+
(dump-packed-info (list (make-fixnum-descriptor 0))))
;; Emit in the same order symbols reside in core to avoid
;; sensitivity to the iteration order of host's maphash.
(loop for (warm-sym . info)
in (sort (%hash-table-alist hashtable) #'<
:key (lambda (x) (descriptor-bits (cold-intern (car x)))))
do (write-wordindexed
(cold-intern warm-sym) sb-vm:symbol-info-slot
;; Each vector will have one fixnum, possibly the symbol SETF,
(dump-packed-info
;; Each packed-info will have one fixnum, possibly the symbol SETF,
;; and one or two #<fdefn> objects in it, and/or a classoid-cell.
(vector-in-core
(map 'list (lambda (elt)
(etypecase elt
(symbol (cold-intern elt))
(fixnum (make-fixnum-descriptor elt))
(descriptor elt)))
info)))))
(sb-impl::packed-info-cells info))))))
;;;; fixups and related stuff
@ -3410,7 +3419,7 @@ III. initially undefined function references (alphabetically):
(dolist (classoid dumped-classoids)
(let ((nwords (logand (ash (read-bits-wordindexed classoid 0)
(- sb-vm:instance-length-shift))
sb-vm::instance-length-mask)))
sb-vm:instance-length-mask)))
(format t "Classoid @ ~x, ~d words:~%" (descriptor-bits classoid) (1+ nwords))
(dotimes (i (1+ nwords)) ; include the header word in output
(format t "~2d: ~10x~%" i (read-bits-wordindexed classoid i)))

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

@ -374,11 +374,20 @@ during backtrace.
:set-trans %set-symbol-global-value
:set-known ())
(info :ref-trans symbol-info :ref-known (flushable)
:set-trans (setf symbol-info)
;; The private accessor for INFO reads the slot verbatim.
;; In contrast, the SYMBOL-INFO function always returns a PACKED-INFO
;; instance (see info-vector.lisp) or NIL. The slot itself may hold a cons
;; of the user's PLIST and a PACKED-INFO or just a PACKED-INFO.
;; It can't hold a PLIST alone without wrapping in an extra cons cell.
(info :ref-trans symbol-%info :ref-known (flushable)
:set-trans (setf symbol-%info)
:set-known ()
:cas-trans %compare-and-swap-symbol-info
:type (or simple-vector list)
;; IR2-CONVERT-CASSER only knows the arg order as (OBJECT OLD NEW),
;; so as much as I'd like to name this (CAS SYMBOL-%INFO),
;; it can't be that, because it'd need args of (OLD NEW OBJECT).
;; This is a pretty close approximation of the desired name.
:cas-trans sb-impl::cas-symbol-%info
:type (or instance list)
:init :null)
(name :ref-trans symbol-name :init :arg)
(package :ref-trans sb-xc:symbol-package

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

@ -123,7 +123,12 @@
(defknown %set-symbol-hash (symbol hash-code)
t ())
(defknown symbol-info-vector (symbol) (or null simple-vector))
;;; TODOD: I'd like to eliminate the (OR NULL) from this return type.
;;; For that to happen, I probably need +nil-packed-infos+ to become
;;; placed in static space because assembly routines may need it.
;;; On the other hand, they may not, because there is no special case
;;; code needed when reading from it, which is entire point.
(defknown symbol-dbinfo (symbol) (or null packed-info))
(defknown initialize-vector ((simple-array * (*)) &rest t)
(simple-array * (*))

20
src/compiler/globaldb.lisp
View file

@ -51,9 +51,9 @@
;;; sources partway through bootstrapping, tch tch, overwriting its
;;; version with our version would be unlikely to help, because that
;;; would make the cross-compiler very confused.)
(defun !register-meta-info (metainfo)
(defun register-meta-info (metainfo)
(let* ((name (meta-info-kind metainfo))
(list (!get-meta-infos name)))
(list (get-meta-infos name)))
(set-info-value name +info-metainfo-type-num+
(cond ((not list) metainfo) ; unique, just store it
((listp list) (cons metainfo list)) ; prepend to the list
@ -67,7 +67,7 @@
(return-from !%define-info-type it)) ; do nothing
(let ((id (or id (position nil *info-types* :start 1)
(error "no more INFO type numbers available"))))
(!register-meta-info
(register-meta-info
(setf (aref *info-types* id)
(!make-meta-info id category kind type-spec type-checker
validate-function default)))))
@ -107,7 +107,7 @@
'#'identity
`(named-lambda "check-type" (x) (the ,type-spec x)))
,validate-function ,default
;; Rationale for hardcoding here is explained at INFO-VECTOR-FDEFN.
;; Rationale for hardcoding here is explained at PACKED-INFO-FDEFN.
,(or (and (eq category :function) (eq kind :definition)
+fdefn-info-num+)
#+sb-xc (meta-info-number (meta-info category kind))))))
@ -204,18 +204,18 @@
(hookp (and (and hook
(not (eql 0 (car hook)))
(logbitp info-number (car hook))))))
(multiple-value-bind (vector aux-key)
(multiple-value-bind (packed-info aux-key)
(let ((name (uncross name)))
(with-globaldb-name (key1 key2) name
;; In the :simple branch, KEY1 is no doubt a symbol,
;; but constraint propagation isn't informing the compiler here.
:simple (values (symbol-info-vector (truly-the symbol key1)) key2)
:simple (values (symbol-dbinfo (truly-the symbol key1)) key2)
:hairy (values (info-gethash name *info-environment*)
+no-auxiliary-key+)))
(when vector
(let ((index (packed-info-value-index vector aux-key info-number)))
(when packed-info
(let ((index (packed-info-value-index packed-info aux-key info-number)))
(when index
(let ((answer (svref vector index)))
(let ((answer (%info-ref packed-info index)))
(when hookp
(funcall (truly-the function (cdr hook))
name info-number answer t))
@ -583,7 +583,7 @@
;; This is for the SB-INTROSPECT contrib module, and debugging.
(defun call-with-each-info (function symbol)
(awhen (symbol-info-vector symbol)
(awhen (symbol-dbinfo symbol)
(%call-with-each-info function it symbol)))
;; This is for debugging at the REPL.

257
src/compiler/info-vector.lisp
View file

@ -44,31 +44,31 @@
;;; * Names which are lists of length other than 2, or improper lists,
;;; or whose elements are not both symbols, are disqualified.
;;; Packed vector layout
;;; --------------------
;;; Packed format
;;; -------------
;;; Because the keys to the inner lists are integers in the range 0 to 63,
;;; either 5 or 10 keys will fit into a fixnum depending on word size.
;;; This permits one memory read to retrieve a collection of keys. In packed
;;; format, an ordered set of keys ("fields") is called a "descriptor".
;;;
;;; Descriptors are stored from element 0 upward in the packed vector,
;;; and data are indexed downward from the last element of the vector.
;;; Descriptors are stored from element 0 upward in the packed-info,
;;; and data are indexed downward from the last element.
;;;
;;; #(descriptor0 descriptor1 ... descriptorN valueN ... value1 value0)
;;; [descriptor0 descriptor1 ... descriptorN valueN ... value1 value0]
;;;
;;; e.g. The field at absolute index 3 - vector element 0, bit position 18 -
;;; e.g. The field at absolute index 3 (physical element 0, bit position 18)
;;; will find its data at index (- END 3). In this manner, it doesn't matter
;;; how many more descriptors exist.
;;; A "group" comprises all the info for a particular Name, and its list
;;; of types may may span descriptors, though rarely.
;;; An "auxiliary key" is the first element of a 2-list Name. It is interposed
;;; within the data portion of the vector after the preceding info group.
;;; within the data portion of the packed-info after the preceding info group.
;;; Descriptors are self-delimiting in that the first field in a group
;;; indicates the number of additional fields in the group.
;;; Unpacked vector layout
;;; ----------------------
;;; Unpacked format
;;; ---------------
;;; This representation is used transiently during insertion/deletion.
;;; It is a concatenation of plists as a vector, interposing at the splice
;;; points the auxiliary key for the group, except for the root name which
@ -85,10 +85,14 @@
;;; One can envision that the first info group stores its auxiliary key
;;; at vector index -1 when thinking about the correctness of algorithms
;;; that process unpacked info-vectors.
;;; See !TEST-PACKIFY-INFOS for examples of each format.
;;; See TEST-PACKIFY-INFOS for examples of each format.
;;;;; Some stuff moved from 'globaldb.lisp':
;;; The structure constructor is never called
(sb-xc:defstruct (packed-info (:predicate nil) (:constructor nil) (:copier nil))
cells)
;;(declaim (freeze-type packed-info)) ; crashes?
(defconstant info-num-mask (ldb (byte info-number-bits 0) -1)) ; #b111111
;; Using 6 bits per packed field, 5 infos can be described in a 30-bit fixnum,
@ -101,20 +105,25 @@
(deftype info-descriptor () `(signed-byte ,sb-vm:n-fixnum-bits))
;; An empty info-vector. Its 0th field describes that there are no more fields.
(defconstant-eqx +nil-packed-infos+ #(0) #'equalp)
(defglobal +nil-packed-infos+
(let ((v (make-packed-info 1)))
(setf (%info-ref v 0) 0)
v))
;; FDEFINITIONs have an info-number that admits slightly clever logic
;; for INFO-VECTOR-FDEFN. Do not change this constant without
;; for PACKED-INFO-FDEFN. Do not change this constant without
;; careful examination of that function.
(defconstant +fdefn-info-num+ info-num-mask)
;; Extract a field from a packed info descriptor.
;; A field is either a count of info-numbers, or an info-number.
(declaim (inline packed-info-field))
(defun packed-info-field (vector desc-index field-index)
(defun packed-info-field (packed-info desc-index field-index)
;; (declare (optimize (safety 0))) ; comment out when debugging
(ldb (byte info-number-bits
(* (the (mod #.+infos-per-word+) field-index) info-number-bits))
(the info-descriptor (svref vector desc-index))))
(the info-descriptor
(%info-ref (the packed-info packed-info) desc-index))))
;; Compute the number of elements needed to hold unpacked VECTOR after packing.
;; This is not "compute-packed-info-size" since that could be misconstrued
@ -159,10 +168,10 @@
;;
(defun packify-infos (input &optional (end (length input)))
(declare (simple-vector input))
(let* ((output (make-array (compute-packified-info-size input end)))
(let* ((output (make-packed-info (compute-packified-info-size input end)))
(i -1) ; input index: pre-increment to read the next datum
(j -1) ; descriptor index: pre-increment to write
(k (length output)) ; data index: pre-decrement to write
(k (packed-info-len output)) ; data index: pre-decrement to write
(field-shift 0)
(word 0))
(declare (type index-or-minus-1 i j k end)
@ -174,19 +183,19 @@
(setq word (logior (make-info-descriptor val field-shift) word))
(if (< field-shift (* (1- +infos-per-word+) info-number-bits))
(incf field-shift info-number-bits)
(setf (svref output (incf j)) word field-shift 0 word 0))))
(setf (%info-ref output (incf j)) word field-shift 0 word 0))))
;; Truncating divide by 2: count = n-elements in the group @ 2 per entry,
;; +1 for count itself but not including its aux-key.
(loop (let ((count (ash (the index (svref input (incf i))) -1)))
(put-field count) ; how many infos to follow
(dotimes (iter count)
(put-field (svref input (incf i))) ; an info-number
(setf (svref output (decf k)) (svref input (incf i)))) ; value
(setf (%info-ref output (decf k)) (svref input (incf i)))) ; value
(when (>= (incf i) end)
(return))
(setf (svref output (decf k)) (svref input i))))) ; an aux-key
(setf (%info-ref output (decf k)) (svref input i))))) ; an aux-key
(unless (zerop field-shift) ; store the final descriptor word
(setf (svref output (incf j)) word))
(setf (%info-ref output (incf j)) word))
(aver (eql (1+ j) k)) ; last descriptor must be adjacent final data cell
output))
@ -194,11 +203,11 @@
;; returns the next field from a descriptor in INPUT-VAR, a packed vector.
;; The generator uses DESCRIPTOR-INDEX and updates it as a side-effect.
;;
(defmacro !with-packed-info-iterator ((generator input-var
(defmacro with-packed-info-iterator ((generator input-var
&key descriptor-index)
&body body)
(with-unique-names (input word count)
`(let* ((,input (the simple-vector ,input-var))
`(let* ((,input (the packed-info ,input-var))
(,descriptor-index -1)
(,count 0)
(,word 0))
@ -208,21 +217,21 @@
(flet ((,generator ()
(when (zerop ,count)
(incf ,descriptor-index)
(setq ,word (svref ,input ,descriptor-index)
(setq ,word (%info-ref ,input ,descriptor-index)
,count +infos-per-word+))
(prog1 (logand ,word info-num-mask)
(setq ,word (ash ,word (- info-number-bits)))
(decf ,count))))
,@body))))
;; Iterate over VECTOR, binding DATA-INDEX to the index of each aux-key in turn.
;; Iterate over PACKED-INFO, binding DATA-INDEX to the index of each aux-key in turn.
;; TOTAL-N-FIELDS is deliberately exposed to invoking code.
;;
(defmacro !do-packed-info-vector-aux-key ((vector &optional (data-index (gensym)))
(defmacro do-packed-info-aux-key ((packed-info &optional (data-index (gensym)))
step-form &optional result-form)
(with-unique-names (descriptor-idx field-idx)
(once-only ((vector vector))
`(let ((,data-index (length ,vector))
(with-unique-names (descriptor-idx field-idx info)
`(let* ((,info ,packed-info)
(,data-index (packed-info-len ,info))
(,descriptor-idx 0)
(,field-idx 0)
(total-n-fields 0))
@ -231,8 +240,7 @@
;; Loop through the descriptors in random-access fashion.
;; Skip 1+ n-infos each time, because the 'n-infos' is itself a field
;; that is not accounted for in its own value.
(loop (let ((n (1+ (packed-info-field ,vector
,descriptor-idx ,field-idx))))
(loop (let ((n (1+ (packed-info-field ,info ,descriptor-idx ,field-idx))))
(incf total-n-fields n)
(multiple-value-setq (,descriptor-idx ,field-idx)
(floor total-n-fields +infos-per-word+))
@ -240,36 +248,21 @@
;; Done when the ascending index and descending index meet
(unless (< ,descriptor-idx ,data-index)
(return ,result-form))
,@(if step-form (list step-form)))))))
,@(if step-form (list step-form))))))
;; Return all function names that are stored in SYMBOL's info-vector.
;; As an example, (INFO-VECTOR-NAME-LIST 'SB-PCL::DIRECT-SUPERCLASSES) =>
;; ((SB-PCL::SLOT-ACCESSOR :GLOBAL SB-PCL::DIRECT-SUPERCLASSES SB-PCL::READER)
;; (SB-PCL::SLOT-ACCESSOR :GLOBAL SB-PCL::DIRECT-SUPERCLASSES BOUNDP)
;; (SB-PCL::SLOT-ACCESSOR :GLOBAL SB-PCL::DIRECT-SUPERCLASSES SB-PCL::WRITER))
(defun info-vector-name-list (symbol)
(let ((vector (symbol-info-vector symbol))
(list))
(when vector
(!do-packed-info-vector-aux-key (vector key-index)
(push (construct-globaldb-name (svref vector key-index) symbol)
list))
(nconc (and (plusp (packed-info-field vector 0 0)) (list symbol))
(nreverse list)))))
;; Compute the number of elements needed to hold packed VECTOR after unpacking.
;; Compute the number of elements needed to hold PACKED-INFO after unpacking.
;; The unpacked size is the number of auxiliary keys plus the number of entries
;; @ 2 cells per entry, plus the number of length cells which indicate the
;; number of data cells used (including length cells but not aux key cells).
;; Equivalently, it's the number of packed fields times 2 minus 1.
;;
(defun compute-unpackified-info-size (vector)
(declare (simple-vector vector))
(!do-packed-info-vector-aux-key (vector) ()
(defun compute-unpackified-info-size (packed-info)
(declare (packed-info packed-info))
(do-packed-info-aux-key (packed-info) ()
;; off-by-one: the first info group's auxiliary key is imaginary
(1- (truly-the fixnum (ash total-n-fields 1)))))
;; Convert packed INPUT vector to unpacked.
;; Convert packed INPUT to unpacked.
;; If optional OUTPUT is supplied, it is used, otherwise output is allocated.
;; For efficiency the OUTPUT should be provided as a dynamic-extent array.
;;
@ -277,19 +270,19 @@
(make-array
(compute-unpackified-info-size input))
output-supplied-p))
(declare (simple-vector input output))
(let ((i (length input)) (j -1)) ; input index and output index respectively
(declare (type packed-info input) (simple-vector output))
(let ((i (packed-info-len input)) (j -1)) ; input index and output index respectively
(declare (type index-or-minus-1 i j))
(!with-packed-info-iterator (next-field input :descriptor-index desc-idx)
(with-packed-info-iterator (next-field input :descriptor-index desc-idx)
(loop ; over name
(let ((n-infos (next-field)))
;; store the info group length, including the length cell in the length
(setf (svref output (incf j)) (1+ (ash n-infos 1)))
(dotimes (iter n-infos) ; over info-types
(setf (svref output (incf j)) (next-field) ; type-num
(svref output (incf j)) (svref input (decf i))))) ; value
(svref output (incf j)) (%info-ref input (decf i))))) ; value
(if (< desc-idx (decf i)) ; as long as the indices haven't met
(setf (svref output (incf j)) (svref input i)) ; copy next aux-key
(setf (svref output (incf j)) (%info-ref input i)) ; copy next aux-key
(return (if output-supplied-p nil output))))))) ; else done
;; Return the index of the 'length' item for an info group having
@ -311,20 +304,20 @@
((eq (svref vector (1- index)) key)
(return index)))))))
;; In packed info VECTOR try to find the auxiliary key SYMBOL.
;; Try to find the auxiliary key SYMBOL in PACKED-INFO.
;; If found, return indices of its data, info descriptor word, and field.
;; If not found, the first value is NIL and the descriptor indices
;; arbitrarily point to the next available descriptor field.
;;
(defun info-find-aux-key/packed (vector symbol)
(defun info-find-aux-key/packed (packed-info symbol)
;; explicit bounds checking is done by the code below
(declare (optimize (safety 0)))
(aver (simple-vector-p vector))
(let ((descriptor-idx 0) ; physical index to vector
; (declare (optimize (safety 0)))
(aver (typep packed-info 'packed-info))
(let ((descriptor-idx 0) ; physical index to packed-info
(field-idx 0) ; relative index within current descriptor
;; On each iteration DATA-IDX points to an aux-key cell
;; The first group's imaginary aux-key cell is past the end.
(data-idx (length (the simple-vector vector))))
(data-idx (packed-info-len (the packed-info packed-info))))
(declare (type index descriptor-idx data-idx)
(fixnum field-idx)) ; can briefly exceed +infos-per-word+
;; Efficiently skip past N-INFOS infos. If decrementing the data index
@ -343,28 +336,28 @@
(declare (inline skip))
;; While this could compare aux-keys with #'EQUAL, it is not obvious how
;; in general one would pick a symbol from the name as that which
;; is delegated as the one to hold the info-vector.
(values (cond ((not (skip (packed-info-field vector 0 0))) nil)
;; is delegated as the one to hold the packed-info
(values (cond ((not (skip (packed-info-field packed-info 0 0))) nil)
;; At least one aux key is present.
((eq (aref vector data-idx) symbol) data-idx) ; yay
((eq (%info-ref packed-info data-idx) symbol) data-idx) ; yay
;; aux-key order invariant allows early fail on SETF
((eq symbol 'setf) nil)
(t
(loop
(cond ((not (skip (packed-info-field vector descriptor-idx
(cond ((not (skip (packed-info-field packed-info descriptor-idx
field-idx)))
(return nil))
((eq (aref vector data-idx) symbol)
((eq (%info-ref packed-info data-idx) symbol)
(return data-idx))))))
descriptor-idx field-idx)))) ; can be ignored if 1st val is nil
;; Take a packed info-vector INPUT and insert (AUX-KEY,INFO-NUMBER,VALUE).
;; Take a packed-info INPUT and insert (AUX-KEY,INFO-NUMBER,VALUE).
;; Packed info-vectors are immutable. Any alteration must create a copy.
;; This is done by unpacking/repacking - it's easy enough and fairly
;; efficient since the temporary vector is stack-allocated.
;;
(defun %packed-info-insert (input aux-key info-number value)
(declare (simple-vector input) (type info-number info-number))
(declare (type packed-info input) (type info-number info-number))
(let* ((n-extra-elts
;; Test if the aux-key has been seen before or needs to be added.
(if (and (not (eql aux-key +no-auxiliary-key+))
@ -410,15 +403,15 @@
;; exactly one descriptor for the root name, space for >= 1 more field,
;; and no aux-keys.
(declaim (inline info-quickly-insertable-p))
(defun info-quickly-insertable-p (input)
(let ((n-infos (packed-info-field input 0 0)))
(defun info-quickly-insertable-p (packed-info)
(let ((n-infos (packed-info-field packed-info 0 0)))
;; We can easily determine if the no-aux-keys constraint is satisfied,
;; because a secondary name's info occupies at least two cells,
;; one for its aux-key and >= 1 for info values.
(and (< n-infos (1- +infos-per-word+))
(eql n-infos (1- (length input))))))
(eql n-infos (1- (packed-info-len packed-info))))))
;; Take a packed info-vector INPUT and return a new one with INFO-NUMBER/VALUE
;; Take a packed-info INPUT and return a new one with INFO-NUMBER/VALUE
;; added for the root name. The vector must satisfy INFO-QUICKLY-INSERTABLE-P.
;; This code is separate from PACKED-INFO-INSERT to facilitate writing
;; a unit test of this logic against the complete logic.
@ -426,57 +419,57 @@
(defun quick-packed-info-insert (input info-number value)
;; Because INPUT contains 1 descriptor and its corresponding values,
;; the current length is exactly NEW-N, the new number of fields.
(let* ((descriptor (svref input 0))
(new-n (truly-the info-number (length input)))
(new-vect (make-array (1+ new-n))))
(let* ((descriptor (%info-ref input 0))
(new-n (truly-the info-number (packed-info-len input)))
(output (make-packed-info (1+ new-n))))
;; Two cases: we're either inserting info for the fdefn, or not.
(cond ((eq info-number +fdefn-info-num+)
;; fdefn, if present, must remain the first packed field.
;; Replace the lowest field (the count) with +fdefn-info-num+,
;; shift everything left 6 bits, then OR in the new count.
(setf (svref new-vect 0)
(setf (%info-ref output 0)
(logior (make-info-descriptor
(dpb +fdefn-info-num+ (byte info-number-bits 0)
descriptor) info-number-bits) new-n)
;; Packed vectors are indexed "backwards". The first
;; field's info is in the highest numbered cell.
(svref new-vect new-n) value)
(%info-ref output new-n) value)
(loop for i from 1 below new-n
do (setf (svref new-vect i) (svref input i))))
do (setf (%info-ref output i) (%info-ref input i))))
(t
;; Add a field on the high end and increment the count.
(setf (svref new-vect 0)
(setf (%info-ref output 0)
(logior (make-info-descriptor
info-number (* info-number-bits new-n))
(1+ descriptor))
(svref new-vect 1) value)
(%info-ref output 1) value)
;; Slide the old data up 1 cell.
(loop for i from 2 to new-n
do (setf (svref new-vect i) (svref input (1- i))))))
new-vect))
do (setf (%info-ref output i) (%info-ref input (1- i))))))
output))
(declaim (maybe-inline packed-info-insert))
(defun packed-info-insert (vector aux-key info-number newval)
(defun packed-info-insert (packed-info aux-key info-number newval)
(if (and (eql aux-key +no-auxiliary-key+)
(info-quickly-insertable-p vector))
(quick-packed-info-insert vector info-number newval)
(%packed-info-insert vector aux-key info-number newval)))
(info-quickly-insertable-p packed-info))
(quick-packed-info-insert packed-info info-number newval)
(%packed-info-insert packed-info aux-key info-number newval)))
;; Search packed VECTOR for AUX-KEY and INFO-NUMBER, returning
;; the index of the data if found, or NIL if not found.
;;
(defun packed-info-value-index (vector aux-key type-num)
(declare (optimize (safety 0))) ; vector bounds are AVERed
(let ((data-idx (length vector)) (descriptor-idx 0) (field-idx 0))
(defun packed-info-value-index (packed-info aux-key type-num)
;;(declare (optimize (safetya 0))) ; bounds are AVERed
(let ((data-idx (packed-info-len packed-info)) (descriptor-idx 0) (field-idx 0))
(declare (type index descriptor-idx)
(type (mod #.+infos-per-word+) field-idx))
(unless (eql aux-key +no-auxiliary-key+)
(multiple-value-setq (data-idx descriptor-idx field-idx)
(info-find-aux-key/packed vector aux-key))
(info-find-aux-key/packed packed-info aux-key))
(unless data-idx
(return-from packed-info-value-index nil)))
;; Fetch a descriptor and shift out trailing bits that won't be scanned.
(let* ((descriptor (ash (the info-descriptor (aref vector descriptor-idx))
(let* ((descriptor (ash (the info-descriptor (%info-ref packed-info descriptor-idx))
(* (- info-number-bits) field-idx)))
(n-infos (logand descriptor info-num-mask))
;; Compute n things in this descriptor after extracting one field. e.g.
@ -500,11 +493,11 @@
(incf descriptor-idx)
(decf data-idx swath)
(aver (< descriptor-idx data-idx))
(setq descriptor (svref vector descriptor-idx)
(setq descriptor (%info-ref packed-info descriptor-idx)
swath (min n-infos +infos-per-word+))))))
;; Helper for CLEAR-INFO-VALUES when Name has the efficient form.
;; Given packed info-vector INPUT and auxiliary key KEY2
;; Given packed-info INPUT and auxiliary key KEY2
;; return a new vector in which TYPE-NUMS are absent.
;; When none of TYPE-NUMs were present to begin with, return NIL.
;;
@ -512,8 +505,8 @@
;; clearing does not happen often enough to warrant the pre-check.
;;
(defun packed-info-remove (input key2 type-nums)
(declare (simple-vector input))
(when (or (eql (length input) (length +nil-packed-infos+))
(declare (type packed-info input))
(when (or (eql (packed-info-len input) #.(packed-info-len +nil-packed-infos+))
(and (not (eql key2 +no-auxiliary-key+))
(not (info-find-aux-key/packed input key2))))
(return-from packed-info-remove nil)) ; do nothing
@ -602,27 +595,27 @@
;; Call FUNCTION with each piece of info in packed VECT using ROOT-SYMBOL
;; as the primary name. FUNCTION must accept 3 values (NAME INFO-NUMBER VALUE).
(defun %call-with-each-info (function vect root-symbol)
(defun %call-with-each-info (function packed-info root-symbol)
(let ((name root-symbol)
(data-idx (length vect)))
(data-idx (packed-info-len packed-info)))
(declare (type index data-idx))
(!with-packed-info-iterator (next-field vect :descriptor-index desc-idx)
(with-packed-info-iterator (next-field packed-info :descriptor-index desc-idx)
(loop ; over name
(dotimes (i (next-field)) ; number of infos for this name
(funcall function name (next-field) (svref vect (decf data-idx))))
(funcall function name (next-field) (%info-ref packed-info (decf data-idx))))
(if (< desc-idx (decf data-idx))
(setq name
(construct-globaldb-name (svref vect data-idx) root-symbol))
(construct-globaldb-name (%info-ref packed-info data-idx) root-symbol))
(return))))))
#|
Info packing example. This example has 2 auxiliary-keys: SETF and CAS.
(!test-packify-infos '(13 :XYZ 18 "nine" 28 :BAR 7 T)
'(SETF 8 NIL 17 :FGX)
'(CAS 6 :MUMBLE 2 :BAZ 47 :FOO))
(test-packify-infos '(13 :XYZ 18 "nine" 28 :BAR 7 T)
'(SETF 8 NIL 17 :FGX)
'(CAS 6 :MUMBLE 2 :BAZ 47 :FOO))
=>
#(109006134805865284 3010 :FOO :BAZ :MUMBLE CAS :FGX NIL SETF T :BAR "nine" :XYZ)
[109006134805865284 3010 :FOO :BAZ :MUMBLE CAS :FGX NIL SETF T :BAR "nine" :XYZ]
(format nil "~4,'0o ~20,'0o" 3010 109006134805865284)
=> "5702 06032110020734221504"
@ -633,7 +626,7 @@ Which is interpreted as:
2 infos for SETF auxiliary-key. type numbers: 8, 17
3 infos for CAS auxiliary-key. type numbers: 6, 2, 47
(unpackify-infos (!test-packify-infos ...)) ; same input
(unpackify-infos (test-packify-infos ...)) ; same input
=> #(9 13 :XYZ 18 "nine" 28 :BAR 7 T
SETF 5 8 NIL 17 :FGX
CAS 7 6 :MUMBLE 2 :BAZ 47 :FOO)
@ -647,8 +640,7 @@ This is interpreted as
;; The info for a symbol's fdefn must precede other info-numbers.
;; and SETF must be the first aux key if other aux keys are present.
;; The test function does not enforce these invariants.
#+nil ; for debugging only
(defun !test-packify-infos (&rest lists)
(defun test-packify-infos (&rest lists)
(flet ((check (plist)
(and (evenp (length plist))
(loop for (indicator value) on plist by #'cddr
@ -705,10 +697,9 @@ This is interpreted as
(defun update-symbol-info (symbol update-fn)
;; Never pass NIL to an update-fn. Pass the minimal info-vector instead,
;; a vector describing 0 infos and 0 auxiliary keys.
(let ((newval (funcall update-fn (or (symbol-info-vector symbol)
+nil-packed-infos+))))
(let ((newval (funcall update-fn (or (symbol-%info symbol) +nil-packed-infos+))))
(when newval
(setf (symbol-info-vector symbol) newval))
(setf (symbol-%info symbol) newval))
(values)))
;;; The current *INFO-ENVIRONMENT*, a structure of type INFO-HASHTABLE.
@ -779,14 +770,14 @@ This is interpreted as
(let ((name (uncross name)))
;; If the INFO-NUMBER already exists in VECT, then copy it and
;; alter one cell; otherwise unpack it, grow the vector, and repack.
(dx-flet ((augment (vect aux-key) ; VECT is a packed vector, never NIL
(declare (simple-vector vect))
(dx-flet ((augment (packed-info aux-key) ; PACKED-INFO must not be NIL
(declare (type packed-info packed-info))
(let ((index
(packed-info-value-index vect aux-key info-number)))
(packed-info-value-index packed-info aux-key info-number)))
(if (not index)
(packed-info-insert vect aux-key info-number new-value)
(let ((copy (copy-seq vect)))
(setf (svref copy index) new-value)
(packed-info-insert packed-info aux-key info-number new-value)
(let ((copy (copy-packed-info packed-info)))
(setf (%info-ref copy index) new-value)
copy)))))
(with-globaldb-name (key1 key2) name
:simple
@ -796,8 +787,7 @@ This is interpreted as
:hairy
;; INFO-PUTHASH supplies NIL for OLD-INFO if NAME was absent.
(dx-flet ((hairy-name (old-info)
(augment (or old-info +nil-packed-infos+)
+no-auxiliary-key+)))
(augment (or old-info +nil-packed-infos+) +no-auxiliary-key+)))
(info-puthash *info-environment* name #'hairy-name)))))
new-value)
@ -813,20 +803,20 @@ This is interpreted as
(when (pcl-methodfn-name-p name)
(error "Can't SET-INFO-VALUE on PCL-internal function"))
(let ((name (uncross name)) new-value)
(dx-flet ((augment (vect aux-key) ; VECT is a packed vector, never NIL
(declare (simple-vector vect))
(dx-flet ((augment (packed-info aux-key) ; PACKED-INFO must not be NIL
(declare (type packed-info packed-info))
(let ((index
(packed-info-value-index vect aux-key info-number)))
(packed-info-value-index packed-info aux-key info-number)))
(if (not index)
(packed-info-insert
vect aux-key info-number
packed-info aux-key info-number
(setq new-value (funcall new-value-fun nil nil)))
(let ((oldval (svref vect index)))
(let ((oldval (%info-ref packed-info index)))
(setq new-value (funcall new-value-fun oldval t))
(if (eq new-value oldval)
vect ; return the old vector
(let ((copy (copy-seq vect)))
(setf (svref copy index) new-value)
packed-info ; return the old packed-info
(let ((copy (copy-packed-info packed-info)))
(setf (%info-ref copy index) new-value)
copy)))))))
(with-globaldb-name (key1 key2) name
:simple
@ -855,19 +845,19 @@ This is interpreted as
(error "~D is not a legal INFO name." name))
(let ((name (uncross name))
result)
(dx-flet ((get-or-set (info-vect aux-key)
(dx-flet ((get-or-set (packed-info aux-key)
(let ((index
(packed-info-value-index info-vect aux-key info-number)))
(packed-info-value-index packed-info aux-key info-number)))
(cond (index
(setq result (svref info-vect index))
nil) ; no update to info-vector
(setq result (%info-ref packed-info index))
nil) ; no update
(t
;; Update conflicts possibly for unrelated info-number
;; can force re-execution. (UNLESS result ...) tries
;; to avoid calling the thunk more than once.
(unless result
(setq result (funcall creation-thunk)))
(packed-info-insert info-vect aux-key info-number
(packed-info-insert packed-info aux-key info-number
result))))))
(with-globaldb-name (key1 key2) name
:simple
@ -877,8 +867,7 @@ This is interpreted as
:hairy
;; INFO-PUTHASH supplies NIL for OLD-INFO if NAME was absent.
(dx-flet ((hairy-name (old-info)
(or (get-or-set (or old-info +nil-packed-infos+)
+no-auxiliary-key+)
(or (get-or-set (or old-info +nil-packed-infos+) +no-auxiliary-key+)
;; Return OLD-INFO to elide writeback. Unlike for
;; UPDATE-SYMBOL-INFO, NIL is not a no-op marker.
old-info)))

26
src/compiler/ppc64/cell.lisp
View file

@ -18,14 +18,13 @@
;;; temp-reg-tn to access symbol slots.
;;; Since the NIL-as-CONS is necessary, and efficient accessor to lists and
;;; instances is desirable, we lose a little on symbol access by being forced
;;; to pre-check for NIL. There is trick that can get back some performance
;;; on SYMBOL-VALUE which I plan to implement after this much works right.
;;; to pre-check for NIL.
(define-vop (slot)
(:args (object :scs (descriptor-reg)))
(:info name offset lowtag)
(:results (result :scs (descriptor-reg any-reg)))
(:generator 1
(cond ((member name '(symbol-name symbol-info sb-xc:symbol-package))
(cond ((member name '(symbol-name symbol-%info sb-xc:symbol-package))
(let ((null-label (gen-label))
(done-label (gen-label)))
(inst cmpld object null-tn)
@ -261,27 +260,6 @@
NULL
(inst addi res null-tn (- (logand sb-vm:nil-value sb-vm:fixnum-tag-mask)))
DONE))
(define-vop (symbol-plist)
(:policy :fast-safe)
(:translate symbol-plist)
(:args (symbol :scs (descriptor-reg)))
(:results (res :scs (descriptor-reg)))
(:temporary (:scs (unsigned-reg)) temp)
(:generator 6
(inst cmpld symbol null-tn)
(inst beq NULL)
(loadw res symbol symbol-info-slot other-pointer-lowtag)
(inst andi. temp res lowtag-mask)
(inst cmpwi temp list-pointer-lowtag)
(inst beq take-car)
(move res null-tn) ; if INFO is a non-list, then the PLIST is NIL
(inst b DONE)
NULL
(loadw res symbol (1- symbol-info-slot) list-pointer-lowtag)
;; fallthru. NULL's info slot always holds a cons
TAKE-CAR
(loadw res res cons-car-slot list-pointer-lowtag)
DONE))
;;;; Fdefinition (fdefn) objects.

32
src/compiler/riscv/system.lisp
View file

@ -232,38 +232,6 @@
(inst add ndescr ndescr offset)
(inst subi ndescr ndescr (- other-pointer-lowtag fun-pointer-lowtag))
(inst add func code ndescr)))
;;;
(define-vop (symbol-info-vector)
(:policy :fast-safe)
(:translate symbol-info-vector)
(:args (x :scs (descriptor-reg)))
(:results (res :scs (descriptor-reg)))
(:temporary (:sc unsigned-reg) temp)
(:generator 1
(loadw res x symbol-info-slot other-pointer-lowtag)
;; If RES has list-pointer-lowtag, take its CDR. If not, use it as-is.
(inst andi temp res lowtag-mask)
(inst xori temp temp list-pointer-lowtag)
(inst bne temp zero-tn not-equal)
(loadw res res cons-cdr-slot list-pointer-lowtag)
NOT-EQUAL))
(define-vop (symbol-plist)
(:policy :fast-safe)
(:translate symbol-plist)
(:args (x :scs (descriptor-reg)))
(:results (res :scs (descriptor-reg)))
(:temporary (:sc non-descriptor-reg) temp)
(:generator 1
(loadw res x symbol-info-slot other-pointer-lowtag)
;; Instruction pun: (CAR x) is the same as (VECTOR-LENGTH x)
;; so if the info slot holds a vector, this gets a fixnum- it's not a plist.
(loadw res res cons-car-slot list-pointer-lowtag)
(inst andi temp res fixnum-tag-mask)
(inst bne temp zero-tn not-equal)
(move res null-tn)
NOT-EQUAL))
;;;; Other random VOPs.

18
src/compiler/x86-64/cell.lisp
View file

@ -718,18 +718,24 @@
;;;; structure hackery
(defun load-instance-length (result instance taggedp)
(inst mov :dword result (ea (- instance-pointer-lowtag) instance))
;; Returning fixnum/any-reg elides some REX prefixes due to the shifts
;; being small. Maybe the asm optimizer could figure it out now?
(cond (taggedp
(inst shr :dword result (- instance-length-shift n-fixnum-tag-bits))
(inst and :dword result (fixnumize instance-length-mask)))
(t
(inst shr :dword result instance-length-shift)
(inst and :dword result instance-length-mask))))
(define-vop ()
(:policy :fast-safe)
(:translate %instance-length)
(:args (struct :scs (descriptor-reg)))
(:results (res :scs (any-reg)))
(:result-types positive-fixnum)
(:generator 4
(inst mov :dword res (ea (- instance-pointer-lowtag) struct))
;; Returning fixnum/any-reg elides some REX prefixes due to the shifts
;; being small. Maybe the asm optimizer could figure it out now?
(inst shr :dword res (- instance-length-shift n-fixnum-tag-bits))
(inst and :dword res (fixnumize instance-length-mask))))
(:generator 4 (load-instance-length res struct t)))
(define-full-reffer instance-index-ref * instance-slots-offset
instance-pointer-lowtag (any-reg descriptor-reg) * %instance-ref)

50
src/compiler/x86-64/system.lisp
View file

@ -335,53 +335,27 @@
result))))
;;;; symbol frobbing
(defun load-symbol-info-vector (result symbol)
(defun load-symbol-dbinfo (result symbol)
(loadw result symbol symbol-info-slot other-pointer-lowtag)
;; If RES has list-pointer-lowtag, take its CDR. If not, use it as-is.
;; This CMOV safely reads from memory when it does not move, because if
;; there is an info-vector in the slot, it has at least one element.
;; Use bit index 3 of the lowtag to distinguish list from vector.
;; A vector will have a 1 in that bit.
;; there is a PACKED-INFO in the slot, it has at least 4 data words in total
;; - the header, at least one info descriptor, and at least one datum.
;; And since 3 is odd, that would be aligned up to 4.
;; Use bit index 2 of the lowtag to distinguish list from instance.
;; An instance will have a 0 in that bit.
;; This would compile to almost the same code without a VOP,
;; but using a jmp around a mov instead.
(aver (= (logior list-pointer-lowtag #b1000) other-pointer-lowtag))
(inst test :byte result #b1000)
(inst cmov :e result
(object-slot-ea result cons-cdr-slot list-pointer-lowtag)))
(aver (= (logior instance-pointer-lowtag #b0100) list-pointer-lowtag))
(inst test :byte result #b0100)
(inst cmov :nz result (object-slot-ea result cons-cdr-slot list-pointer-lowtag)))
(define-vop (symbol-info-vector)
(define-vop (symbol-dbinfo)
(:policy :fast-safe)
(:translate symbol-info-vector)
(:translate symbol-dbinfo)
(:args (x :scs (descriptor-reg)))
(:results (res :scs (descriptor-reg)))
(:generator 1 (load-symbol-info-vector res x)))
(define-vop (symbol-plist)
(:policy :fast-safe)
(:translate symbol-plist)
(:args (x :scs (descriptor-reg)))
(:results (res :scs (descriptor-reg)))
(:temporary (:sc unsigned-reg) temp)
(:generator 1
#-ubsan
(progn
(loadw res x symbol-info-slot other-pointer-lowtag)
;; Instruction pun: (CAR x) is the same as (VECTOR-LENGTH x)
;; so if the info slot holds a vector, this gets a fixnum- it's not a plist.
(loadw res res cons-car-slot list-pointer-lowtag)
(inst mov temp nil-value)
(inst test :byte res fixnum-tag-mask)
(inst cmov :e res temp))
;; This way doesn't assume that CAR and VECTOR-LENGTH are the same memory access.
;; (And it's not even clear that using CMOV is preferable)
#+ubsan
(let ((out (gen-label)))
(loadw temp x symbol-info-slot other-pointer-lowtag)
(inst mov res nil-value)
(inst test :byte temp #b1000) ; if temp is a vector, return NIL
(inst jmp :ne out)
(loadw res temp cons-car-slot list-pointer-lowtag)
(emit-label out))))
(:generator 1 (load-symbol-dbinfo res x)))
;;;; other miscellaneous VOPs

33
src/compiler/x86/system.lisp
View file

@ -233,39 +233,6 @@
:disp (- fun-pointer-lowtag
(* simple-fun-insts-offset n-word-bytes))))))
;;;; symbol frobbing
(define-vop (symbol-info-vector)
(:policy :fast-safe)
(:translate symbol-info-vector)
(:args (x :scs (descriptor-reg)))
(:results (res :scs (descriptor-reg)))
(:temporary (:sc unsigned-reg :offset eax-offset) eax)
(:generator 1
(loadw res x symbol-info-slot other-pointer-lowtag)
;; If RES has list-pointer-lowtag, take its CDR. If not, use it as-is.
;; This CMOV safely reads from memory when it does not move, because if
;; there is an info-vector in the slot, it has at least one element.
;; This would compile to almost the same code without a VOP,
;; but using a jmp around a mov instead.
(inst lea eax (make-ea :dword :base res :disp (- list-pointer-lowtag)))
(emit-optimized-test-inst eax lowtag-mask)
(inst cmov :e res
(object-slot-ea res cons-cdr-slot list-pointer-lowtag))))
(define-vop (symbol-plist)
(:policy :fast-safe)
(:translate symbol-plist)
(:args (x :scs (descriptor-reg)))
(:results (res :scs (descriptor-reg)))
(:temporary (:sc unsigned-reg) temp)
(:generator 1
(loadw res x symbol-info-slot other-pointer-lowtag)
;; Instruction pun: (CAR x) is the same as (VECTOR-LENGTH x)
;; so if the info slot holds a vector, this gets a fixnum- it's not a plist.
(loadw res res cons-car-slot list-pointer-lowtag)
(inst mov temp nil-value)
(emit-optimized-test-inst res fixnum-tag-mask)
(inst cmov :e res temp)))
;;;; other miscellaneous VOPs

26
src/runtime/print.c
View file

@ -573,19 +573,19 @@ static void print_slots(char **slots, int count, lispobj *ptr)
lispobj symbol_function(lispobj* symbol)
{
lispobj info = ((struct symbol*)symbol)->info;
if (listp(info))
info = CONS(info)->cdr;
if (lowtag_of(info) == OTHER_POINTER_LOWTAG) {
struct vector* v = VECTOR(info);
int len = vector_len(v);
if (len != 0) {
lispobj elt = v->data[0]; // Just like INFO-VECTOR-FDEFN
if (fixnump(elt) && (fixnum_value(elt) & 07777) >= 07701) {
lispobj fdefn = v->data[len-1];
if (lowtag_of(fdefn) == OTHER_POINTER_LOWTAG)
return FDEFN(fdefn)->fun;
}
lispobj info_holder = ((struct symbol*)symbol)->info;
if (listp(info_holder))
info_holder = CONS(info_holder)->cdr;
if (lowtag_of(info_holder) == INSTANCE_POINTER_LOWTAG) {
struct instance* info = INSTANCE(info_holder);
// Do the same thing as PACKED-INFO-FDEFN
lispobj elt = info->slots[INSTANCE_DATA_START];
if (fixnump(elt) && (fixnum_value(elt) & 07777) >= 07701) {
// FIXME: genesis should be writing a #define for INSTANCE_LENGTH_MASK
int len = (info->header >> INSTANCE_LENGTH_SHIFT) 0x3FF;
lispobj fdefn = info->slots[len-1];
if (lowtag_of(fdefn) == OTHER_POINTER_LOWTAG)
return FDEFN(fdefn)->fun;
}
}
return NIL;

2
tests/do-refs.impure.lisp
View file

@ -51,7 +51,7 @@
(info '((bork 42))))
(import s "CL-USER")
(set s 'hi)
(setf (symbol-info s) info)
(setf (symbol-%info s) info)
(walk-slots-test s `(hi ,info ,name ,(find-package "CL-USER")))))
(test-util:with-test (:name :walk-slots-closure)

2
tests/gc.impure.lisp
View file

@ -44,7 +44,7 @@
(with-test (:name :map-referencing-objs)
(sb-vm::map-referencing-objects (lambda (x) (assert (not (typep x 'afoo))))
:dynamic '*posix-argv*)
(let ((v (sb-kernel:symbol-info 'satisfies)) referers)
(let ((v (sb-kernel:symbol-%info 'satisfies)) referers)
(sb-vm::map-referencing-objects (lambda (referer) (push referer referers))
#+gencgc :dynamic #-gencgc :static v)
#+immobile-space

3
tests/info.before-xc.lisp
View file

@ -38,7 +38,8 @@
;; removing the one info shrinks the vector to nothing
;; and all values of nothing are EQ
(assert (equalp #(0) (packed-info-remove foo-iv +no-auxiliary-key+ '(5))))
(assert (equalp (packed-info-remove foo-iv +no-auxiliary-key+ '(5))
+nil-packed-infos+))
(assert (eq (packed-info-remove foo-iv +no-auxiliary-key+ '(5))
(packed-info-remove bar-iv +no-auxiliary-key+ '(6))))
(assert (eq (packed-info-remove foo-iv +no-auxiliary-key+ '(5))

6
tests/info.impure.lisp
View file

@ -135,7 +135,7 @@
(info :variable :macro-expansion 'fruitbaskets)
(assert (and (not foundp) (not data)))))
;; packed info vector tests
;; packed-info tests
(test-util:with-test (:name :globaldb-info-iterate)
(let ((s (with-output-to-string (*standard-output*) (show-info '*))))
@ -189,10 +189,10 @@
;; The real GET-INFO-VALUE AVERs that INFO-NUMBER is legal. This one doesn't.
(defun cheating-get-info-value (sym aux-key info-number)
(let* ((vector (symbol-info-vector sym))
(let* ((vector (symbol-dbinfo sym))
(index (packed-info-value-index vector aux-key info-number)))
(if index
(values (svref vector index) t)
(values (sb-kernel:%info-ref vector index) t)
(values nil nil))))
;; Info vectors may be concurrently updated. If more than one thread writes