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

Reimplement TYPEP on structure-object descendants

Browse source 
Compare layouts by a stable ID instead of the address.

As can be seen from the "perf stat" results accompanying the design notes
in the doc directory, the time for self-build on x86-64 decreases somewhere
between 3% to 8% depending on the build phase.
Since this change is not specific to the compiler, but just type-checking
in general, the results suggest that users may similarly see anything in
that range of speedup for code making heavy use of defstructs.
Code compiled in 0 safety will see less speedup, because there are no type
assertions, while there may be type-based dispatch that is improved.

Additionally, core files tend to be slightly smaller due to having
fewer code header constants that reference layouts, and correspondingly
there are fewer boxed words to examine in GC.
This commit is contained in:
Douglas Katzman 2020-11-16 09:10:40 -05:00
parent 6c675b9a24
commit fdd4ccf01b
24 changed files with 592 additions and 247 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
build-order.lisp-expr
View file

@ -172,6 +172,7 @@
("src/compiler/generic/vm-array" :c-headers)
("src/code/string-hash" :c-headers)
("src/code/primordial-type" :c-headers)
("src/compiler/generic/pinned-objects" :not-host)
("src/code/early-classoid" :c-headers)
("src/code/alieneval" :c-headers)
("src/code/target-error" :not-host)
@ -200,7 +201,6 @@
("src/code/early-float")
("src/code/pred" :not-host)
("src/compiler/generic/pinned-objects" :not-host)
("src/code/list" :not-host)
("src/code/seq" :not-host) ; "code/seq" should come after "code/list".

123
doc/internals-notes/structure-typep-change Normal file
View file

@ -0,0 +1,123 @@
Design for new implementation of TYPEP on structure-objects:
* Assign every layout a permanent stable ID using 29 bits
(N-POSITIVE-FIXNUM-BITS for 32-bit words) and try to recycle the
unused IDs if layouts get GCd.
* Embed all IDs of every type that a layout "is" directly in the layout.
A layout includes its own ID as the last element of the IS-A vector.
In contrast, the INHERITS vector did not include the structure itself
which always required picking off an exactly equal type as a special
case, and then also checking for type inheritance.
In the ID-based approach, (typep x 'THING) need not distinguish
between whether X is THING or a type descended from THING.
* Reserve space for at least 6 IDs in the IS-A vector, which is 2 more
than the former ANCESTOR-n slots held. Additionally, the IS-A vector
can always holds _all_ the IDs, whereas the ANCESTOR-n slots did not,
and would fall back upon lookup in the INHERITS vector.
The IS-A vector is sized as required by the layout constructor.
Variable-length layouts are needed for the trailing bitmap anyway,
so it is no more trouble to further extend layouts with extra words.
Note that depth 0 is implicitly the ID of the type T,
and depth 1 is implicitly the ID of STRUCTURE-OBJECT,
so those are not stored in the ID vector.
* The most common variant of the structure TYPEP test is changed from:
(OR (EQ THIS-LAYOUT EXPECT-LAYOUT)
(AND (> THIS-LAYOUT-DEPTH (LAYOUT-DEPTH EXPECT-LAYOUT))
(EQ (SVREF INHERITS DEPTH) EXPECT-LAYOUT)))
to:
(EQ (NTH-ANCESTOR-ID) EXPECT-LAYOUT-ID)
which can usually execute safely without the depth check.
In case the depth of the type under test exceeds the mandatory minimum
length of the IS-A vector (6), then perform the depth test first
to avoid out-of-bounds indexing.
Lack of the depth check improves branch prediction rate.
Test I: "perf stat" on make-host-1
==================================
Old:
30497.22 msec task-clock # 1.000 CPUs utilized
162 context-switches # 0.005 K/sec
0 cpu-migrations # 0.000 K/sec
358179 page-faults # 0.012 M/sec
85176684440 cycles # 2.793 GHz
49191173035 stalled-cycles-frontend # 57.75% frontend cycles idle
84764154618 instructions # 1.00 insn per cycle
# 0.58 stalled cycles per insn
19746929213 branches # 647.499 M/sec
607098366 branch-misses # 3.07% of all branches
30.503523458 seconds time elapsed
29.206010000 seconds user
1.291911000 seconds sys
New:
28308.70 msec task-clock # 0.999 CPUs utilized
521 context-switches # 0.018 K/sec
3 cpu-migrations # 0.000 K/sec
428089 page-faults # 0.015 M/sec
79067487625 cycles # 2.793 GHz
45445183758 stalled-cycles-frontend # 57.48% frontend cycles idle
80724429510 instructions # 1.02 insn per cycle
# 0.56 stalled cycles per insn
18319117558 branches # 647.120 M/sec
552061322 branch-misses # 3.01% of all branches
28.324995675 seconds time elapsed
26.775357000 seconds user
1.555962000 seconds sys
delta: task-clock: -7.1%
cycles: -7.1%
intructions: -4.7%
branches: -7.2%
branch-miss: -9.0%
user sec: -8.3%
Test II: "perf stat" on make-host-2
===================================
Old:
87641.99 msec task-clock # 1.000 CPUs utilized
403 context-switches # 0.005 K/sec
0 cpu-migrations # 0.000 K/sec
858614 page-faults # 0.010 M/sec
244791150476 cycles # 2.793 GHz
138448804561 stalled-cycles-frontend # 56.56% frontend cycles idle
258526783085 instructions # 1.06 insn per cycle
# 0.54 stalled cycles per insn
58641402544 branches # 669.102 M/sec
1387692425 branch-misses # 2.37% of all branches
87.659365156 seconds time elapsed
84.883404000 seconds user
2.759720000 seconds sys
New:
83026.56 msec task-clock # 1.000 CPUs utilized
1244 context-switches # 0.015 K/sec
7 cpu-migrations # 0.000 K/sec
1119264 page-faults # 0.013 M/sec
231835280270 cycles # 2.792 GHz
129266360060 stalled-cycles-frontend # 55.76% frontend cycles idle
254253852289 instructions # 1.10 insn per cycle
# 0.51 stalled cycles per insn
56393384370 branches # 679.221 M/sec
1281237117 branch-misses # 2.27% of all branches
83.048348272 seconds time elapsed
79.858200000 seconds user
3.187928000 seconds sys
delta: task-clock: -5.2%
cycles: -5.2%
intructions: -1.6%
branches: -3.8%
branch-miss: -7.6%
user sec: -5.9%

29
src/code/class.lisp
View file

@ -57,10 +57,13 @@
;;; The LAYOUT structure itself is defined in 'early-classoid.lisp'
(defvar *print-layout-id* t)
(defmethod print-object ((layout layout) stream)
(print-unreadable-object (layout stream :type t :identity t)
(format stream
"for ~S~@[, INVALID=~S~]"
#+sb-xc-host "for ~S~@[, INVALID=~S~]"
#-sb-xc-host "~@[(ID=~d) ~]for ~S~@[, INVALID=~S~]"
#-sb-xc-host (when *print-layout-id* (layout-id layout))
(layout-proper-name layout)
(layout-invalid layout))))
@ -264,14 +267,34 @@ between the ~A definition and the ~A definition"
;; Destructively modifying a layout is not threadsafe at all.
;; Use at your own risk (interactive use only).
(let ((inherits (layout-inherits layout))
(depthoid (layout-depthoid layout)))
(depthoid (layout-depthoid layout)) ; "new" depthoid
(extra-id-words ; "old" extra words
(calculate-extra-id-words (layout-depthoid destruct-layout)))
(id ; read my ID before screwing with the depthoid
(layout-id destruct-layout)))
(aver (logtest +structure-layout-flag+ (layout-flags layout)))
(aver (= (length inherits) depthoid))
;; DEPTHOID implies the number of words of "extra" IDs preceding the bitmap.
;; Layout alteration is forbidden if it would affect the number of such words.
;; So MUTABLE-LAYOUT-P should have checked that this is OK, but assert it
;; again to be certain. Heap corruption is the greater evil versus a minor
;; inconvenience of not offering the RECKLESSLY-CONTINUE restart.
(aver (= (calculate-extra-id-words depthoid) extra-id-words))
#-64-bit (setf (layout-depthoid destruct-layout) (layout-depthoid layout)
(layout-length destruct-layout) (layout-length layout))
(setf (layout-flags destruct-layout) (layout-flags layout)
(layout-info destruct-layout) (layout-info layout))
(set-layout-inherits destruct-layout inherits)
;; Zero out the inherited ID values one word at a time.
;; This makes self-ID transiently disappear, but what else can we do?
;; It's may be in the wrong slot anyway, depending on whether depthoid changed.
;; The calculation of the min word count of 3 or 6 is done as
;; (/ (- (1+ layout-id-vector-fixed-capacity) 2) number-of-ids-per-word)
;; which is surely more confusing than spelling it as 3 or 6.
(dotimes (i (+ extra-id-words #+64-bit 3 #-64-bit 6))
(setf (%raw-instance-ref/word destruct-layout
(+ (get-dsd-index layout id-word0) i))
0))
(set-layout-inherits destruct-layout inherits t id)
(set-bitmap-from-layout destruct-layout layout)
(setf (layout-invalid destruct-layout) nil
(classoid-layout classoid) destruct-layout))

13
src/code/defstruct.lisp
View file

@ -1464,12 +1464,23 @@ or they must be declared locally notinline at each call site.~@:>"
;;; in the bitmap, depending on whether any raw slot exists.
;;; I can't imagine that many users will complain that they can no longer
;;; incompatibly redefine defstructs involving raw slots.
;;; Additionally, it is no longer possible to RECKLESSLY-CONTINUE on a defstruct
;;; if the number of words in the layout would differ due to extra ID words,
;;; but given that it was already not possible if the bitmaps differ,
;;; it does not seem a big sacrifice to disallow redefining structures
;;; at depthoids in excess of 7 (LAYOUT-ID-VECTOR-FIXED-CAPACITY) unless
;;; both the old and new structure are at the same depthoid.
#-sb-xc-host
(defun mutable-layout-p (old-layout new-layout)
(if (layout-info old-layout)
(let ((old-bitmap (layout-bitmap old-layout))
(new-bitmap (layout-bitmap new-layout)))
(and (= (layout-bitmap-words new-layout) (layout-bitmap-words old-layout))
;; The number of extra ID words has to match, as does the number of bitmap
;; words, or else GC will croak when parsing the bitmap.
(and (= (calculate-extra-id-words (layout-depthoid old-layout))
(calculate-extra-id-words (layout-depthoid new-layout)))
(= (layout-bitmap-words new-layout)
(layout-bitmap-words old-layout))
(dotimes (i (dd-length (layout-dd old-layout)) t)
(when (and (logbitp i new-bitmap) ; a tagged (i.e. scavenged) slot
(not (logbitp i old-bitmap))) ; that was opaque bits

254
src/code/early-classoid.lisp
View file

@ -135,8 +135,6 @@
;;; 32-bit is not done yet. Three slots are still used, instead of two.
;;; Maximum value of N in ANCESTOR_N. Couldn't come up with a better name.
(defconstant sb-c::layout-inherits-max-optimized-depth 5)
(sb-xc:defstruct (layout (:copier nil)
;; Parsing DEFSTRUCT uses a temporary layout
(:constructor make-temporary-layout
@ -202,18 +200,85 @@
;; access to slot-definitions and locations by name, etc.
;; See MAKE-SLOT-TABLE in pcl/slots-boot.lisp for further details.
(slot-table #(1 nil) :type simple-vector)
;; inherited layouts or 0, only pertinent to structure classoids.
;; There is no need to store the layout at depths 0 or 1
;; since they're predetermined to be T and STRUCTURE-OBJECT.
(ancestor_2 0)
(ancestor_3 0)
(ancestor_4 0)
(ancestor_5 0))
(id-word0 0 :type word)
(id-word1 0 :type word)
(id-word2 0 :type word)
#-64-bit (id-word3 0 :type word)
#-64-bit (id-word4 0 :type word)
#-64-bit (id-word5 0 :type word))
(declaim (freeze-type layout))
;;; The cross-compiler representation of a LAYOUT omits several things:
;;; * BITMAP - obtainable via (DD-BITMAP (LAYOUT-INFO layout)).
;;; GC wants it in the layout to avoid double indirection.
;;; * EQUALP-TESTS - needed only for the target's implementation of EQUALP.
;;; * SLOT-TABLE, and SLOT-LIST - used only by the CLOS implementation.
;;; * ID-WORDn are optimizations for TYPEP.
;;; So none of those really make sense on the host.
;;; Also, we eschew the packed representation of length+depthoid+flags.
;;; FLAGS are not even strictly necessary, since they are for optimizing
;;; various type checks.
#+sb-xc-host
(progn
(defstruct (layout (:include structure!object)
(:constructor host-make-layout
(clos-hash classoid &key info depthoid inherits
length flags invalid)))
;; Cross-compiler-only translation from slot index to symbol naming
;; the accessor to call. (Since access by position is not a thing)
(index->accessor-map #() :type simple-vector)
;; CLOS-HASH is needed to convert some TYPECASE forms to jump tables.
;; Theoretically we don't need this in the cross-compiler, because the
;; layout has a classoid which has a name which has a known hash.
;; But there's no harm in storing it.
(clos-hash nil :type (and sb-xc:fixnum unsigned-byte))
(classoid nil :type classoid)
(flags 0 :type word)
(invalid :uninitialized :type (or cons (member nil t :uninitialized)))
(inherits #() :type simple-vector)
(depthoid -1 :type layout-depthoid)
(length 0 :type layout-length)
(info nil :type (or null defstruct-description)))
(defun layout-dd (layout)
(the defstruct-description (layout-info layout)))
(defun make-layout (&rest args)
(let ((args (copy-list args)))
(remf args :bitmap)
(apply #'host-make-layout args)))
(defun make-temporary-layout (clos-hash classoid inherits)
(host-make-layout clos-hash classoid :inherits inherits :invalid nil))
(defun layout-bitmap (layout)
(if (layout-info layout) (dd-bitmap (layout-info layout)) +layout-all-tagged+)))
(defun equalp-err (a b)
(bug "EQUALP ~S ~S" a b))
(defmacro get-dsd-index (type-name slot-name)
(declare (notinline dsd-index)) ; avoid later inlining failure style-warning
(dsd-index (find slot-name
(dd-slots (find-defstruct-description type-name))
:key #'dsd-name)))
(defmacro layout-id-vector-sap (layout)
`(sap+ (int-sap (get-lisp-obj-address ,layout))
(- (ash (+ sb-vm:instance-slots-offset (get-dsd-index layout id-word0))
sb-vm:word-shift)
sb-vm:instance-pointer-lowtag)))
(defconstant structure-object-layout-id 2) ; KLUDGE
(defun layout-id (layout)
#+sb-xc-host (error "Can't call layout-id ~a" layout)
#-sb-xc-host
(let ((depthoid (layout-depthoid layout)))
(truly-the sb-c::layout-id
(cond ((not (logtest (layout-flags layout) +structure-layout-flag+))
;; the 0th word of the ID vector stores the layout id
(layout-id-word0 layout))
((>= depthoid 2)
(with-pinned-objects (layout)
;; Depthoid 2 is in the 0th index and so on.
(sap-ref-32 (layout-id-vector-sap layout) (ash (- depthoid 2) 2))))
(t ; KLUDGE: must be STRUCTURE-OBJECT
structure-object-layout-id)))))
;;; Applicable only if bit-packed (for 64-bit architectures)
(defmacro pack-layout-flags (depthoid length flags)
`(logior (ash ,(or depthoid -1) (+ 32 sb-vm:n-fixnum-tag-bits))
@ -223,58 +288,56 @@
(defmacro type-dd-length (type-name)
(dd-length (find-defstruct-description type-name)))
(defmacro get-dsd-index (type-name slot-name)
(declare (notinline dsd-index)) ; avoid later inlining failure style-warning
(dsd-index (find slot-name
(dd-slots (find-defstruct-description type-name))
:key #'dsd-name)))
(defconstant layout-id-vector-fixed-capacity 7)
(defmacro calculate-extra-id-words (depthoid)
;; There are 1 or 2 ids per word depending on n-word-bytes.
;; We can always store IDs at depthoids 2,3,4,5,6,7,
;; so depthoid less than or equal to 7 needs no extra words.
;; 0 and 1 for T and STRUCTURE-OBJECT respectively are not stored.
`(ceiling (max 0 (- ,depthoid ,layout-id-vector-fixed-capacity))
,(/ sb-vm:n-word-bytes 4)))
;;; FIXME 1: assigning the inherits of a temporary-layout (when parsing DEFSTRUCT)
;;; should not use up an ID.
;;; FIXME 2: probably should never assign IDs to any metaclass except structure-class
(defun set-layout-inherits (layout inherits structurep this-id)
(declare (ignorable structurep this-id))
(setf (layout-inherits layout) inherits)
;;; If structurep, and *only* if, store all the inherited layout IDs.
;;; It looks enticing to try to always store "something", but that goes wrong,
;;; because only structure-object layouts are growable, and only structure-object
;;; can store the self-ID in the proper index.
;;; If the depthoid is -1, the self-ID has to go in index 0.
;;; Standard-object layouts are not growable. The inherited layouts are known
;;; only at class finalization time, at which point we've already made the layout.
;;; Hence, the required indirection to the simple-vector of inherits.
#-sb-xc-host
(cond (structurep
(with-pinned-objects (layout)
(let ((sap (layout-id-vector-sap layout)))
(loop for j from 2 below (length inherits)
do (setf (sap-ref-32 sap 0) (layout-id (svref inherits j))
sap (sap+ sap 4)))
(setf (sap-ref-32 sap 0) this-id))))
((not (eql this-id 0))
(setf (layout-id-word0 layout) this-id))))
(defmacro set-bitmap-from-layout (to-layout from-layout)
#+sb-xc-host (declare (ignore to-layout from-layout))
#-sb-xc-host
`(let ((index (type-dd-length layout)))
`(let ((to-index (+ (type-dd-length layout)
(calculate-extra-id-words (layout-depthoid ,to-layout))))
(from-index (+ (type-dd-length layout)
(calculate-extra-id-words (layout-depthoid ,from-layout)))))
(dotimes (i (layout-bitmap-words ,from-layout))
(setf (%raw-instance-ref/word ,to-layout index)
(%raw-instance-ref/word ,from-layout index))
(incf index))))
(setf (%raw-instance-ref/word ,to-layout (+ to-index i))
(%raw-instance-ref/word ,from-layout (+ from-index i))))))
;;; See the pictures above DD-BITMAP in src/code/defstruct for the details.
(defconstant standard-gf-primitive-obj-layout-bitmap
#+compact-instance-header 6
#-compact-instance-header -4)
#+sb-xc-host
(defmacro set-layout-inherits (layout inherits)
`(setf (layout-inherits ,layout) ,inherits))
#-sb-xc-host
(defmacro set-layout-inherits (layout inherits &optional recompute-bitmap)
`(let* ((l ,layout) (i ,inherits) (d (length i)))
(setf (layout-inherits l) i)
(setf (layout-ancestor_2 l) (if (> d 2) (svref i 2) 0)
(layout-ancestor_3 l) (if (> d 3) (svref i 3) 0)
(layout-ancestor_4 l) (if (> d 4) (svref i 4) 0)
(layout-ancestor_5 l) (if (> d 5) (svref i 5) 0))
;; This part is for PCL where a class can forward-reference its superclasses
;; and we only decide at class finalization time whether it is funcallable.
;; Picking the right bitmap could probably be done sooner given the metaclass,
;; but this approach avoids changing how PCL uses MAKE-LAYOUT.
;; The big comment above MAKE-IMMOBILE-FUNINSTANCE in src/code/x86-64-vm
;; explains why we differentiate between SGF and everything else.
,(when recompute-bitmap
`(when (find ,(find-layout 'function) i)
(let ((bitmap
#+immobile-code ; there are two possible bitmaps
;; *SGF-WRAPPER* isn't defined as yet, but this is just an s-expression.
(if (or (find sb-pcl::*sgf-wrapper* i) (eq l sb-pcl::*sgf-wrapper*))
standard-gf-primitive-obj-layout-bitmap
+layout-all-tagged+)
;; there is only one possible bitmap otherwise
#-immobile-code standard-gf-primitive-obj-layout-bitmap))
(setf (%raw-instance-ref/word l (type-dd-length layout))
(logand sb-ext:most-positive-word bitmap)))))
l))
(push '("SB-KERNEL" set-layout-inherits) *!removable-symbols*)
;;; For lack of any better to place to write up some detail surrounding
;;; layout creation for structure types, I'm putting here.
;;; When you issue a DEFSTRUCT at the REPL, there are *three* instances
@ -312,15 +375,26 @@
;; a defstruct-description.
(aver (listp (layout-%info layout)))
(setf (layout-%info layout) newval))
(define-load-time-global *layout-id-generator* (cons 0 nil))
(declaim (type (cons fixnum) *layout-id-generator*))
(defun make-layout (clos-hash classoid
&key (depthoid -1) (length 0) (flags 0)
(inherits #())
(info nil)
(bitmap (if info (dd-bitmap info) 0))
(invalid :uninitialized))
(invalid :uninitialized)
&aux (id (or (atomic-pop (cdr *layout-id-generator*))
(atomic-incf (car *layout-id-generator*)))))
(unless (typep id '(and sb-c::layout-id (not (eql 0))))
(error "Layout ID limit reached"))
(let* ((fixed-words (type-dd-length layout))
(extra-id-words ; count of additional words needed to store ancestors
(if (logtest flags +structure-layout-flag+)
(calculate-extra-id-words depthoid)
0))
(bitmap-words (ceiling (1+ (integer-length bitmap)) sb-vm:n-word-bits))
(nwords (+ fixed-words bitmap-words))
(nwords (+ fixed-words extra-id-words bitmap-words))
(layout (truly-the layout
#+immobile-space
(sb-vm::alloc-immobile-fixedobj
@ -337,12 +411,18 @@
#-64-bit (setf (layout-depthoid layout) depthoid (layout-length layout) length)
(setf (layout-info layout) info)
(setf (layout-slot-table layout) #(1 nil))
(set-layout-inherits layout inherits)
#-sb-xc-host
(dotimes (i bitmap-words)
(setf (%raw-instance-ref/word layout (+ fixed-words i))
(ldb (byte sb-vm:n-word-bits (* i sb-vm:n-word-bits)) bitmap)))
(set-layout-inherits layout inherits (logtest flags +structure-layout-flag+) id)
(let ((bitmap-base (+ fixed-words extra-id-words)))
(dotimes (i bitmap-words)
(setf (%raw-instance-ref/word layout (+ bitmap-base i))
(ldb (byte sb-vm:n-word-bits (* i sb-vm:n-word-bits)) bitmap))))
(setf (layout-invalid layout) invalid)
#+nil (format t "~&Made layout ID ~D for ~A~%" id (classoid-name classoid))
;; It's not terribly important that we recycle layout IDs, but I have some other
;; changes planned that warrant a finalizer per layout.
(when (>= id 400) ; KLUDGE to get through cold-init, before finalizers work
(finalize layout (lambda () (atomic-push id (cdr *layout-id-generator*)))
:dont-save t))
layout))
(declaim (inline layout-bitmap-words))
(defun layout-bitmap-words (layout)
@ -354,58 +434,10 @@
;; raw slots, except that funcallable-instances may have 2 raw slots -
;; the trampoline and the layout. The trampoline can have a tag, depending
;; on the platform, and the layout is tagged but a special case.
;; In any event, the bitmap is always 1 word.
;; In any event, the bitmap is always 1 word, and there are no "extra ID"
;; words preceding it.
(t (%raw-instance-ref/signed-word layout (type-dd-length layout))))))
;;; The cross-compiler representation of a LAYOUT omits several things:
;;; * BITMAP - obtainable via (DD-BITMAP (LAYOUT-INFO layout)).
;;; GC wants it in the layout to avoid double indirection.
;;; * EQUALP-TESTS - needed only for the target's implementation of EQUALP.
;;; * SLOT-TABLE, and SLOT-LIST - used only by the CLOS implementation.
;;; * ANCESTOR_N are optimizations for TYPEP.
;;; So none of those really make sense on the host.
;;; Also, we eschew the packed representation of length+depthoid+flags.
;;; FLAGS are not even strictly necessary, since they are for optimizing
;;; various type checks.
#+sb-xc-host
(progn
(defstruct (layout (:include structure!object)
(:constructor host-make-layout
(clos-hash classoid &key info depthoid inherits
length flags invalid)))
;; Cross-compiler-only translation from slot index to symbol naming
;; the accessor to call. (Since access by position is not a thing)
(index->accessor-map #() :type simple-vector)
;; CLOS-HASH is needed to convert some TYPECASE forms to jump tables.
;; Theoretically we don't need this in the cross-compiler, because the
;; layout has a classoid which has a name which has a known hash.
;; But there's no harm in storing it.
(clos-hash nil :type (and sb-xc:fixnum unsigned-byte))
(classoid nil :type classoid)
(flags 0 :type word)
(invalid :uninitialized :type (or cons (member nil t :uninitialized)))
(inherits #() :type simple-vector)
(depthoid -1 :type layout-depthoid)
(length 0 :type layout-length)
(info nil :type (or null defstruct-description)))
(defun layout-dd (layout)
(the defstruct-description (layout-info layout)))
(defun make-layout (&rest args)
(let ((args (copy-list args)))
(remf args :bitmap)
(apply #'host-make-layout args)))
(defun make-temporary-layout (clos-hash classoid inherits)
(host-make-layout clos-hash classoid :inherits inherits :invalid nil))
(defun layout-bitmap (layout)
(if (layout-info layout) (dd-bitmap (layout-info layout)) +layout-all-tagged+)))
(defmacro sb-c::layout-nth-ancestor-slot (n)
`(case ,n
(2 'layout-ancestor_2)
(3 'layout-ancestor_3)
(4 'layout-ancestor_4)
(5 'layout-ancestor_5)))
#+(and (not sb-xc-host) 64-bit)
;;; LAYOUT-DEPTHOID gets a vop and a stub
(defmacro layout-length (layout) ; SETFable
@ -613,6 +645,14 @@
(declaim (freeze-type built-in-classoid condition-classoid
standard-classoid static-classoid))
#-sb-xc-host
(defun id-to-layout (id)
(maphash (lambda (k v)
(declare (ignore k))
(when (eql (layout-id v) id) (return-from id-to-layout v)))
(classoid-subclasses (find-classoid 't))))
(export 'id-to-layout)
(in-package "SB-C")
;;; layout for this type being used by the compiler

7
src/compiler/dump.lisp
View file

@ -893,7 +893,8 @@
:symbol-tls-index
:foreign :foreign-dataref :code-object
:layout :immobile-symbol :named-call :static-call
:symbol-value)
:symbol-value
:layout-id)
#'equalp)
;;; Pack the aspects of a fixup into an integer.
@ -933,7 +934,9 @@
(operand
(ecase flavor
(:code-object (the null name))
(:layout (if (symbolp name) name (layout-classoid-name name)))
(:layout
(if (symbolp name) name (layout-classoid-name name)))
(:layout-id (the layout name))
((:assembly-routine :assembly-routine* :asm-routine-nil-offset
:symbol-tls-index
;; Only #+immobile-space can use the following two flavors.

2
src/compiler/early-c.lisp
View file

@ -50,6 +50,8 @@
(def!type layout-depthoid () '(integer -1 #x7FFF))
(def!type layout-length () '(integer 0 #xFFFF))
(def!type layout-bitmap () 'integer)
;;; ID must be an unsigned fixnum for either value of n-word-bits.
(def!type layout-id () '(unsigned-byte 29))
;;; An INLINEP value describes how a function is called. The values
;;; have these meanings:

5
src/compiler/fndb.lisp
View file

@ -99,8 +99,9 @@
(or classoid null) ())
(defknown classoid-of (t) classoid (flushable))
(defknown layout-of (t) layout (flushable))
#+64-bit (defknown layout-depthoid (layout) fixnum (flushable always-translatable))
(defknown layout-depthoid-gt (layout integer) boolean (flushable))
#+64-bit (defknown layout-depthoid (layout) layout-depthoid (flushable always-translatable))
(defknown (layout-depthoid-ge layout-depthoid-gt) (layout integer) boolean (flushable))
(defknown %structure-is-a (instance t) boolean (foldable flushable))
(defknown copy-structure (structure-object) structure-object
(flushable)
:derive-type #'result-type-first-arg)

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

@ -670,7 +670,7 @@
;;; in the core for a cold layout, so that we don't have to extract
;;; them out of the core to compare cold layouts for validity.
(defstruct (cold-layout (:constructor %make-cold-layout))
name depthoid length bitmap flags inherits descriptor)
id name depthoid length bitmap flags inherits descriptor)
;;; the hosts's representation of LAYOUT-of-LAYOUT
(defvar *host-layout-of-layout* (find-layout 'layout))
@ -1112,12 +1112,29 @@ core and return a descriptor to it."
(declaim (ftype (function (symbol layout-depthoid integer index integer descriptor)
descriptor)
make-cold-layout))
(defvar *condition-layout-uniqueid-counter* 0)
(defvar *general-layout-uniqueid-counter* 0)
(defun make-cold-layout (name depthoid flags length bitmap inherits)
;; Layouts created in genesis can't vary in length due to the number of ancestor
;; types in the IS-A vector. They may vary in length due to the bitmap word count.
;; But we can at least assert that there is one less thing to worry about.
(aver (<= depthoid sb-kernel::layout-id-vector-fixed-capacity))
(let* ((fixed-words (sb-kernel::type-dd-length layout))
(bitmap-words (ceiling (1+ (integer-length bitmap)) sb-vm:n-word-bits))
(result (allocate-struct (+ fixed-words bitmap-words)
*layout-layout*
(symbol-value *cold-layout-gspace*))))
(symbol-value *cold-layout-gspace*)))
(this-id
(if (logtest flags +condition-layout-flag+)
;; It doesn't really matter what ID is assigned to a CONDITION
;; because we don't use the IDs for type testing.
;; Nor for standard-object, but those aren't created during genesis.
;; By keep the structure layout IDs smaller than they would be
;; if the space of assigned IDs were shared, it might be possible
;; to emit some type tests using 1-byte immediate operands on x86.
;; Or not. Because we don't do JIT codegen.
(decf *condition-layout-uniqueid-counter*)
(incf *general-layout-uniqueid-counter*))))
#+64-bit
(write-slots result *host-layout-of-layout*
:flags (sb-kernel::pack-layout-flags depthoid length flags))
@ -1152,16 +1169,23 @@ core and return a descriptor to it."
(setq *vacuous-slot-table*
(host-constant-to-core '#(1 nil))))))
(when (and (logtest flags +structure-layout-flag+) (> depthoid 2))
(loop with dsd-index = (get-dsd-index sb-kernel:layout sb-kernel::ancestor_2)
for i from 2 to (min (1- depthoid) sb-c::layout-inherits-max-optimized-depth)
do (write-wordindexed result
(+ sb-vm:instance-slots-offset dsd-index)
(cold-svref inherits i))
(incf dsd-index)))
(if (not (logtest flags +structure-layout-flag+))
(write-slots result *host-layout-of-layout* :id-word0 this-id)
(let ((byte-offset (ash (+ (descriptor-word-offset result)
(get-dsd-index sb-kernel:layout sb-kernel::id-word0)
sb-vm:instance-slots-offset)
sb-vm:word-shift)))
(loop for i from 2 below (cold-vector-len inherits)
do (setf (bvref-32 (descriptor-mem result) byte-offset)
(cold-layout-id (gethash (descriptor-bits (cold-svref inherits i))
*cold-layout-by-addr*)))
(incf byte-offset 4))
(setf (bvref-32 (descriptor-mem result) byte-offset) this-id)))
(integer-bits-to-core result bitmap bitmap-words fixed-words)
(let ((proxy (%make-cold-layout :name name
(let ((proxy (%make-cold-layout :id this-id
:name name
:depthoid depthoid
:length length
:bitmap bitmap
@ -1703,7 +1727,8 @@ core and return a descriptor to it."
(cold-cons (cold-intern (car pair))
(cold-layout-descriptor (cdr pair))))
(sort-cold-layouts))))
(cold-set 'sb-kernel::*layout-id-generator*
(cold-list (make-fixnum-descriptor (1+ *general-layout-uniqueid-counter*))))
(cold-set 'sb-c::*!initial-parsed-types*
(vector-in-core
(mapcar (lambda (x)
@ -2708,6 +2733,8 @@ Legal values for OFFSET are -4, -8, -12, ..."
#+sb-thread ; ENSURE-SYMBOL-TLS-INDEX isn't defined otherwise
(:symbol-tls-index (ensure-symbol-tls-index sym))
(:layout (cold-layout-descriptor-bits sym))
(:layout-id (cold-layout-id (gethash (descriptor-bits sym)
*cold-layout-by-addr*)))
(:immobile-symbol
;; an interned symbol is represented by its host symbol,
;; but an uninterned symbol is a descriptor.
@ -3323,15 +3350,16 @@ III. initially undefined function references (alphabetically):
name)))
(format t "~%~|~%V. layout names:~2%")
(format t " Bitmap Depth Name [Length]~%")
(format t " Bitmap Depth ID Name [Length]~%")
(dolist (pair (sort-cold-layouts))
(let* ((proxy (cdr pair))
(descriptor (cold-layout-descriptor proxy))
(addr (descriptor-bits descriptor)))
(format t "~10,'0X: ~8d ~2D ~S [~D]~%"
(format t "~10,'0X: ~8d ~2D ~5D ~S [~D]~%"
addr
(cold-layout-bitmap proxy)
(cold-layout-depthoid proxy)
(cold-layout-id proxy)
(car pair)
(cold-layout-length proxy))))

1
src/compiler/generic/target-core.lisp
View file

@ -88,6 +88,7 @@
#+sb-thread (:symbol-tls-index (ensure-symbol-tls-index sym))
(:layout (get-lisp-obj-address
(if (symbolp sym) (find-layout sym) sym)))
(:layout-id (sb-kernel::layout-id sym))
(:immobile-symbol (get-lisp-obj-address sym))
(:symbol-value (get-lisp-obj-address (symbol-global-value sym)))
#+immobile-code

49
src/compiler/typetran.lisp
View file

@ -825,6 +825,7 @@
;;; object's layout can ever be EQ to that of the ancestor.
;;; e.g. a fixnum as representative of class REAL.
;;; So in actual practice, you can't make something that is a pure STREAM, etc.
(defvar *use-layout-ids* (or #+(or x86 x86-64) t))
(defun transform-instance-typep (classoid)
(binding*
((name (classoid-name classoid))
@ -856,7 +857,8 @@
((function-with-layout-p object) (%fun-layout object))
(t (return-from typep nil)))))
(depthoid (if layout (layout-depthoid layout) -1))
(n-layout (gensym))
(n-layout (make-symbol "LAYOUT"))
(n-inherits (make-symbol "INHERITS"))
;; In order to efficiently perform the DEEPER-P test without this hack of using
;; a vop (when available for non-risc machines), we'd have to do two things:
;; - have instcombine combine the read and compare as one instruction
@ -871,14 +873,7 @@
`(locally (declare (optimize (safety 0)))
(data-vector-ref (layout-inherits ,n-layout) ,depthoid)))
(ancestor-layout-eq
;; Layouts are immediate constants in immobile space. Again, this is something that
;; an instcombine pass might be able to recognize as having a single instruction.
#+(and immobile-space x86-64) `(sb-vm::layout-inherits-ref-eq
(layout-inherits ,n-layout) ,depthoid ,layout)
#-(and immobile-space x86-64) `(eq ,nth-ancestor ,layout))
;; For shallow depthoid we can avoid checking the depthoid or reading the 'inherits'
;; slot, because the layout has some number of ancestor layouts directly in it.
(ancestor-slot (layout-nth-ancestor-slot depthoid)))
`(eq ,nth-ancestor ,layout)))
;; Easiest case first: single bit test.
(cond ((member name '(condition pathname structure-object))
@ -935,17 +930,21 @@
;; If we allowed structure classes to be mixed in to standard-object,
;; this might have to change to consider object invalidation. Probably would
;; want to track structure classoids that would render this code inadmissible.
(let ((,n-layout (%instance-layout object)))
,(cond ((<= 2 depthoid layout-inherits-max-optimized-depth)
`(or (eq (,ancestor-slot ,n-layout) ,layout)
(eq ,n-layout ,layout)))
((dd-constructors (layout-dd layout))
(let ((,n-layout (%instance-layout object)))
,(if *use-layout-ids*
(if (<= depthoid sb-kernel::layout-id-vector-fixed-capacity)
`(%structure-is-a ,n-layout ,layout)
`(and (layout-depthoid-ge ,n-layout ,depthoid)
(%structure-is-a ,n-layout ,layout)))
;; Distinguish between abstract base types - no DD-CONSTRUCTOR,
;; hence no direct instances - and everything else.
(cond ((dd-constructors (layout-dd layout))
`(cond ((eq ,n-layout ,layout) t)
(,deeper-p ,ancestor-layout-eq)))
(t ; abstract base type deeper than optimized max.
;; Assume that no layout is EQ to the base layout,
;; and unconditionally fetch and dereference layout-inherits.
`(eq (if ,deeper-p ,nth-ancestor ,n-layout) ,layout))))))
`(eq (if ,deeper-p ,nth-ancestor ,n-layout) ,layout)))))))
((> depthoid 0) ; fixed-depth ancestors of non-structure types: STREAM, FILE-STREAM,
;; SEQUENCE; all are abstract base types.
@ -953,21 +952,27 @@
#+sb-xc-host (when (typep classoid 'static-classoid)
;; should have use :SEALED code above
(bug "Non-frozen static classoids?"))
;; quasi-hierarchical layout for other things: STREAM, FILE-STREAM,
;; SEQUENCE, CONDITION; all are abstract base types.
;; There is no need to test the inheritance depth for depthoid 1 because INHERITS
;; will contains at least #<LAYOUT for T> and a padding word if naught else.
;; Though in actual fact it can't have just T, because users have no means to create
;; types that are direct descendants of type T.
;; However, we do have to avoid unsafely dereferencing inherits for FILE-STREAM
;; which is at depth 4. An easy way to avoid this depth test would be requiring at
;; least 5 elements in any INHERITS vector. Alternatively, adding 1 bit each for
;; SEQUENCE, STREAM, and FILE-STREAM to LAYOUT-FLAGS would suffice.
(let ((guts `(,@(unless (eq name 'condition)
`((when (zerop (layout-clos-hash ,n-layout))
(setq ,n-layout
(truly-the layout
(update-object-layout-or-invalid
object ',layout))))))
;; the Nth ancestor for N=1 is not directly stored in the layout.
;; But we don't have to check the layout-inherits length because
;; it has as least two physical data elements even if it has T
;; as the sole ancestor.
,(if (eql depthoid 1)
ancestor-layout-eq
`(eq (,ancestor-slot ,n-layout) ,layout)))))
`(let ((,n-inherits (layout-inherits ,n-layout)))
(and (> (length ,n-inherits) ,depthoid)
(eq (data-vector-ref ,n-inherits ,depthoid)
,layout)))))))
(if primtype-predicate
`(and ,primtype-predicate (let ((,n-layout ,slot-reader)) ,@guts))
`(block typep

2
src/compiler/x86-64/insts.lisp
View file

@ -1871,7 +1871,7 @@
(emit-byte segment it))
((or (integerp src)
(and (fixup-p src)
(memq (fixup-flavor src) '(:layout :immobile-symbol))))
(memq (fixup-flavor src) '(:layout-id :layout :immobile-symbol))))
(emit-prefixes segment dst nil size :lock lockp)
(cond ((accumulator-p dst)
(emit-byte segment

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

@ -52,22 +52,53 @@
word-shift))
instance-pointer-lowtag)
layout)))
(define-vop (layout-depthoid)
(define-vop ()
(:translate layout-depthoid)
(:policy :fast-safe)
(:args (layout :scs (descriptor-reg)))
(:results (res :scs (any-reg)))
(:result-types fixnum)
(:generator 1 (inst movsx '(:dword :qword) res (read-depthoid))))
(define-vop (sb-c::layout-depthoid-gt)
(define-vop ()
(:translate sb-c::layout-depthoid-gt)
(:policy :fast-safe)
(:args (layout :scs (descriptor-reg)))
(:info k)
(:arg-types * (:constant (unsigned-byte 16)))
(:conditional :g)
(:generator 1 (inst cmp :dword (read-depthoid) (fixnumize k))))
(define-vop ()
(:translate sb-c::layout-depthoid-ge)
(:policy :fast-safe)
(:args (layout :scs (descriptor-reg)))
(:info k)
(:arg-types * (:constant (unsigned-byte 16)))
(:conditional :ge)
(:generator 1 (inst cmp :dword (read-depthoid) (fixnumize k)))))
(define-vop ()
(:translate sb-c::%structure-is-a)
(:args (x :scs (descriptor-reg)))
(:arg-types * (:constant t))
(:info test)
(:policy :fast-safe)
(:conditional :e)
(:generator 1
(inst cmp :dword
(ea (+ (ash (+ (get-dsd-index layout sb-kernel::id-word0)
instance-slots-offset)
word-shift)
(ash (- (layout-depthoid test) 2) 2)
(- instance-pointer-lowtag))
x)
;; Todo: in self-build we should be able to wire in layout-ids.
;; Many of them would fall into the <= 127 case.
(if (sb-c::producing-fasl-file)
(make-fixup test :layout-id)
;; If the layout-id is <= 127 then this saves 3 encoding bytes
;; by emitting r/m32,imm8 form.
(sb-kernel::layout-id test)))))
#+compact-instance-header
;; ~20 instructions vs. 35
(define-vop (layout-of) ; no translation

21
src/compiler/x86-64/type-vops.lisp
View file

@ -461,27 +461,6 @@
(make-fixup (tn-value layout) :layout)
layout)))))
(defknown layout-inherits-ref-eq (simple-vector index t) boolean (flushable))
(define-vop (layout-inherits-ref-eq)
(:translate layout-inherits-ref-eq)
(:policy :fast-safe)
(:conditional :e)
(:args (vector :scs (descriptor-reg))
(index :scs (any-reg descriptor-reg immediate))
(thing :scs (descriptor-reg immediate)))
(:generator 1
(inst cmp :dword
(if (sc-is index immediate)
(ea (+ (- other-pointer-lowtag)
(ash (+ vector-data-offset (tn-value index)) word-shift))
vector)
(ea (+ (- other-pointer-lowtag)
(ash vector-data-offset word-shift))
vector index (ash 1 (- word-shift n-fixnum-tag-bits))))
(if (sc-is thing immediate)
(make-fixup (tn-value thing) :layout)
thing))))
(define-vop (fixnump simple-type-predicate)
(:translate fixnump)
(:args-var arg-ref)

29
src/compiler/x86/insts.lisp
View file

@ -1029,23 +1029,26 @@
(let ((size (matching-operand-size dst src)))
(maybe-emit-operand-size-prefix segment size)
(cond
((integerp src)
(cond ((and (not (eq size :byte)) (<= -128 src 127))
((or (integerp src)
(and (fixup-p src) (memq (fixup-flavor src) '(:layout-id))))
(cond ((and (neq size :byte) (typep src '(signed-byte 8)))
(emit-byte segment #b10000011)
(emit-ea segment dst opcode)
(emit-byte segment src))
((accumulator-p dst)
(emit-byte segment
(dpb opcode
(byte 3 3)
(if (eq size :byte)
#b00000100
#b00000101)))
(emit-imm-operand segment src size))
(t
(emit-byte segment (if (eq size :byte) #b10000000 #b10000001))
(emit-ea segment dst opcode)
(emit-imm-operand segment src size))))
(cond ((accumulator-p dst)
(emit-byte segment
(dpb opcode
(byte 3 3)
(if (eq size :byte)
#b00000100
#b00000101))))
(t
(emit-byte segment (if (eq size :byte) #b10000000 #b10000001))
(emit-ea segment dst opcode)))
(if (fixup-p src)
(emit-absolute-fixup segment src)
(emit-imm-operand segment src size)))))
((register-p src)
(emit-byte segment
(dpb opcode

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

@ -48,15 +48,47 @@
word-shift)
instance-pointer-lowtag)
:base layout)))
(define-vop (sb-c::layout-depthoid-gt)
(define-vop ()
(:translate sb-c::layout-depthoid-gt)
(:policy :fast-safe)
(:args (layout :scs (descriptor-reg)))
(:info k)
(:arg-types * (:constant (unsigned-byte 16)))
(:conditional :g)
(:generator 1 (inst cmp (read-depthoid) (fixnumize k))))
(define-vop ()
(:translate sb-c::layout-depthoid-ge)
(:policy :fast-safe)
(:args (layout :scs (descriptor-reg)))
(:info k)
(:arg-types * (:constant (unsigned-byte 16)))
(:conditional :ge)
(:generator 1 (inst cmp (read-depthoid) (fixnumize k)))))
(define-vop ()
(:translate sb-c::%structure-is-a)
(:args (x :scs (descriptor-reg)))
(:arg-types * (:constant t))
(:info test)
(:policy :fast-safe)
(:conditional :e)
(:generator 1
(inst cmp
(make-ea :dword
:disp (+ (ash (+ (get-dsd-index layout sb-kernel::id-word0)
instance-slots-offset)
word-shift)
(ash (- (layout-depthoid test) 2) 2)
(- instance-pointer-lowtag))
:base x)
;; Todo: in self-build we should be able to wire in layout-ids.
;; Many of them would fall into the <= 127 case.
(if (sb-c::producing-fasl-file)
(make-fixup test :layout-id)
;; If the layout-id is <= 127 then this saves 3 encoding bytes
;; by emitting r/m32,imm8 form.
(sb-kernel::layout-id test)))))
(define-vop (%other-pointer-widetag)
(:translate %other-pointer-widetag)
(:policy :fast-safe)

21
src/pcl/braid.lisp
View file

@ -655,6 +655,24 @@
(add-method gf class-method)))
gf))
(defun assign-layout-bitmap (layout)
;; We decide only at class finalization time whether it is funcallable.
;; Picking the right bitmap could probably be done sooner given the metaclass,
;; but this approach avoids changing how PCL uses MAKE-LAYOUT.
;; The big comment above MAKE-IMMOBILE-FUNINSTANCE in src/code/x86-64-vm
;; explains why we differentiate between SGF and everything else.
(let ((inherits (layout-inherits layout)))
(when (find #.(find-layout 'function) inherits)
(let ((bitmap
#+immobile-code ; there are two possible bitmaps
(if (or (find *sgf-wrapper* inherits) (eq layout *sgf-wrapper*))
sb-kernel::standard-gf-primitive-obj-layout-bitmap
+layout-all-tagged+)
;; there is only one possible bitmap otherwise
#-immobile-code sb-kernel::standard-gf-primitive-obj-layout-bitmap))
(setf (%raw-instance-ref/word layout (sb-kernel::type-dd-length layout))
(logand sb-ext:most-positive-word bitmap))))))
;;; Set the inherits from CPL, and register the layout. This actually
;;; installs the class in the Lisp type system.
(defun %update-lisp-class-layout (class layout)
@ -665,7 +683,8 @@
(order-layout-inherits
(map 'simple-vector #'class-wrapper
(reverse (rest (class-precedence-list class)))))
t)
nil 0)
(assign-layout-bitmap layout)
(register-layout layout :invalidate t)
;; FIXME: I don't think this should be necessary, but without it

3
src/pcl/std-class.lisp
View file

@ -562,7 +562,8 @@
(order-layout-inherits
(map 'simple-vector #'class-wrapper
(reverse (rest cpl))))
t))
nil 0))
(assign-layout-bitmap layout)
(register-layout layout :invalidate t))))
(mapc #'make-preliminary-layout (class-direct-subclasses class))))))

23
src/runtime/gc-private.h
View file

@ -243,12 +243,25 @@ struct bitmap { sword_t *bits; unsigned int nwords; };
static inline struct bitmap get_layout_bitmap(struct layout* layout)
{
struct bitmap bitmap;
bitmap.bits = (sword_t*)((char*)layout + sizeof (struct layout));
const int layout_id_vector_fixed_capacity = 7;
#ifdef LISP_FEATURE_64_BIT
sword_t depthoid = layout->flags;
// Depthoid is stored in the upper 4 bytes of the header, as a fixnum.
depthoid >>= (32 + N_FIXNUM_TAG_BITS);
int extra_id_words =
(depthoid > layout_id_vector_fixed_capacity) ?
ALIGN_UP(depthoid - layout_id_vector_fixed_capacity, 2) / 2 : 0;
#else
sword_t depthoid = layout->depthoid;
depthoid >>= N_FIXNUM_TAG_BITS;
int extra_id_words = (depthoid > layout_id_vector_fixed_capacity) ?
depthoid - layout_id_vector_fixed_capacity : 0;
#endif
// The 2 bits for stable address-based hashing can't ever bet set.
bitmap.nwords = (((unsigned int)layout->header >> INSTANCE_LENGTH_SHIFT) & 0x3FFF)
/* subtract one from the struct length in lispwords
* to get the minimum payload length excluding bitmap words. */
- ((sizeof (struct layout) / N_WORD_BYTES) - 1);
const int baseline_payload_words = (sizeof (struct layout) / N_WORD_BYTES) - 1;
int payload_words = ((unsigned int)layout->header >> INSTANCE_LENGTH_SHIFT) & 0x3FFF;
bitmap.bits = (sword_t*)((char*)layout + sizeof (struct layout)) + extra_id_words;
bitmap.nwords = payload_words - baseline_payload_words - extra_id_words;
return bitmap;
}

18
tests/compiler-2.pure.lisp
View file

@ -204,24 +204,6 @@
;; Should not have a call to SET-SYMBOL-GLOBAL-VALUE>
(assert (not (ctu:find-code-constants f :type 'sb-kernel:fdefn))))))
(with-test (:name :layout-constants
:skipped-on (not (and :x86-64 :immobile-space)))
(let ((addr-of-pathname-layout
(write-to-string
(sb-kernel:get-lisp-obj-address
(sb-kernel:find-layout 'hash-table))
:base 16 :radix t))
(count 0))
;; The constant should appear in two CMP instructions
(dolist (line (split-string
(with-output-to-string (s)
(let ((sb-disassem:*disassem-location-column-width* 0))
(disassemble 'hash-table-p :stream s)))
#\newline))
(when (and (search "CMP" line) (search addr-of-pathname-layout line))
(incf count)))
(assert (= count 2))))
(with-test (:name :linkage-table-bogosity)
(let ((strings (map 'list (lambda (x) (if (consp x) (car x) x))
sb-vm::+required-foreign-symbols+)))

14
tests/defstruct.impure-cload.lisp
View file

@ -12,7 +12,16 @@
(eval-when (:compile-toplevel)
(load "compiler-test-util.lisp"))
(with-test (:name (:block-compile :defstruct-slot-type-circularity))
;;; This test asserted that each constructor for a defstruct
;;; involved in a mutually referential cycle with other types
;;; is able to inline the type test of the as-yet-unseen type
;;; when the DEFSTRUCT form is processed.
;;; That's kind of tough to do with the typep optimizations now
;;; because the code header constants will not contain for #<LAYOUT for TYPE>
;;; The architectures that don't get that optimization still pass,
;;; but I need to fix this somehow.
(with-test (:name (:block-compile :defstruct-slot-type-circularity)
:fails-on (:or :x86 :x86-64))
(with-scratch-file (fasl "fasl")
(compile-file "block-compile-defstruct-test.lisp" :output-file fasl :block-compile t)
(load fasl))
@ -25,7 +34,8 @@
;;; Check an organic (not contrived) use of mutually referential types.
;;; NEWLINE is defined after SECTION-START, because it is a subtype.
;;; One of SECTION-START's slot setters refers to type NEWLINE.
(with-test (:name :pretty-stream-structs)
(with-test (:name :pretty-stream-structs
:fails-on (:or :x86 :x86-64)) ; Same issue as the preceding test
(let ((layouts
(ctu:find-code-constants #'(setf sb-pretty::section-start-section-end)
:type 'sb-kernel:layout)))

37
tests/defstruct.impure.lisp
View file

@ -11,6 +11,43 @@
(load "compiler-test-util.lisp")
;;;; Better ensure nothing in messed up in the ID space
;;;; or else everything is suspect.
(defun layout-id-vector-sap (layout)
(sb-sys:sap+ (sb-sys:int-sap (sb-kernel:get-lisp-obj-address layout))
(- (ash (+ sb-vm:instance-slots-offset
(sb-kernel:get-dsd-index
sb-kernel:layout sb-kernel::id-word0))
sb-vm:word-shift)
sb-vm:instance-pointer-lowtag)))
(let ((hash (make-hash-table)))
;; assert that all layout IDs are unique
(let ((all-layouts (sb-vm::list-allocated-objects
:all :type sb-vm:instance-widetag
:test #'sb-kernel::layout-p)))
(dolist (layout all-layouts)
(let ((id (sb-kernel::layout-id layout)))
(assert (not (gethash id hash)))
(setf (gethash id hash) t)))
;; assert that all inherited ID vectors match the layout-inherits vector
(let ((structure-object
(sb-kernel:find-layout 'structure-object)))
(dolist (layout all-layouts)
(when (find structure-object (sb-kernel:layout-inherits layout))
(let ((ids
(sb-sys:with-pinned-objects (layout)
(let ((sap (layout-id-vector-sap layout)))
(loop for depthoid from 2 to (sb-kernel:layout-depthoid layout)
collect (sb-sys:sap-ref-32 sap (ash (- depthoid 2) 2))))))
(expect
(map 'list 'sb-kernel::layout-id
(sb-kernel:layout-inherits layout))))
(unless (equal (append '(1 2) ids)
(append expect (list (sb-kernel::layout-id layout))))
(error "Wrong IDs for ~A: expect ~D actual ~D~%"
layout expect ids))))))))
;;;; examples from, or close to, the Common Lisp DEFSTRUCT spec
;;; Type mismatch of slot default init value isn't an error until the

60
tests/typep-golden-data.txt
View file

@ -408,7 +408,7 @@
57 (OR (CONS (NOT INTEGER) (CONS T NULL)) (CONS INTEGER (CONS (NOT INTEGER) NULL)))
12 (OR (EQL :ALWAYS-THREAD-LOCAL) FIXNUM)
17 (OR (EQL :HOME) (CONS (EQL :HOME)))
18 (OR (EQL :WILD) SB-IMPL::PATTERN)
16 (OR (EQL :WILD) SB-IMPL::PATTERN)
12 (OR (INTEGER -4611686018427387904 4611686018427387903) CHARACTER)
9 (OR (INTEGER 0 0))
18 (OR (INTEGER 1 15) SB-X86-64-ASM::REG)
@ -422,7 +422,7 @@
14 (OR (MEMBER :UNSPECIFIC :WILD NIL))
12 (OR (MEMBER :UNSPECIFIC :WILD))
9 (OR (MEMBER :UNSPECIFIED))
18 (OR (MEMBER :WILD) SB-IMPL::PATTERN)
16 (OR (MEMBER :WILD) SB-IMPL::PATTERN)
9 (OR (MEMBER :WILD))
9 (OR (MEMBER FUNCTION))
14 (OR (MEMBER NIL :UNSPECIFIC :UNC))
@ -455,7 +455,7 @@
15 (OR CHARACTER PACKAGE)
21 (OR CHARACTER SYMBOL FIXNUM SINGLE-FLOAT)
10 (OR CHARACTER)
! 27 (OR CLASS CTYPE)
! 25 (OR CLASS CTYPE)
! 6 (OR CLASS)
37 (OR CONS (AND ARRAY (NOT (OR STRING BIT-VECTOR))) SB-IMPL::COMMA)
29 (OR CONS NUMBER PATHNAME)
@ -464,11 +464,11 @@
! 23 (OR ERROR SB-C:COMPILER-ERROR)
! 23 (OR ERROR SB-DI:DEBUG-CONDITION)
! 23 (OR ERROR PARSE-UNKNOWN-TYPE)
32 (OR FILE-STREAM SYNONYM-STREAM)
34 (OR FILE-STREAM SYNONYM-STREAM)
15 (OR FIXNUM BIGNUM RATIO)
12 (OR FIXNUM CHARACTER)
15 (OR FIXNUM RATIO)
25 (OR FIXNUM SYMBOL HASH-TABLE)
23 (OR FIXNUM SYMBOL HASH-TABLE)
43 (OR FLOAT (COMPLEX FLOAT) BIGNUM SIMD-PACK SIMD-PACK-256 SYSTEM-AREA-POINTER)
17 (OR FLOAT RATIONAL)
18 (OR FUNCTION (CONS (EQL FUNCTION)))
@ -476,7 +476,7 @@
15 (OR INTEGER (MEMBER))
15 (OR INTEGER)
16 (OR LIST SYMBOL)
39 (OR LOGICAL-PATHNAME SYNONYM-STREAM FILE-STREAM)
41 (OR LOGICAL-PATHNAME SYNONYM-STREAM FILE-STREAM)
34 (OR NULL (CONS (EQL QUOTE) (CONS SYMBOL NULL)))
25 (OR NULL (CONS (MEMBER :CHARACTER-SET) STRING))
23 (OR NULL (CONS (UNSIGNED-BYTE 21) SIMPLE-VECTOR))
@ -492,20 +492,20 @@
12 (OR NULL CHARACTER)
! 24 (OR NULL FUNCTION CONDITION SB-PCL::CONDITION-CLASS)
13 (OR NULL FUNCTION)
57 (OR NULL NUMBER CHARACTER (AND ARRAY (NOT (ARRAY T))) SB-C::DEBUG-NAME-MARKER SIMD-PACK SIMD-PACK-256)
54 (OR NULL NUMBER CHARACTER (AND ARRAY (NOT (ARRAY T))) SB-C::DEBUG-NAME-MARKER SIMD-PACK SIMD-PACK-256)
19 (OR NULL NUMBER)
26 (OR NULL SB-IMPL::PATTERN INTEGER)
23 (OR NULL SB-IMPL::PATTERN INTEGER)
17 (OR NULL STRING)
9 (OR NULL)
19 (OR NUMBER CHARACTER)
24 (OR NUMBER PATHNAME)
24 (OR NUMBER SYMBOL)
47 (OR PACKAGE FDEFN CODE-COMPONENT PATHNAME HOST HASH-TABLE)
42 (OR PACKAGE FDEFN CODE-COMPONENT PATHNAME HOST HASH-TABLE)
17 (OR PATHNAME NULL)
35 (OR PATHNAME STREAM)
44 (OR PATHNAME SYNONYM-STREAM FILE-STREAM BOOLEAN)
42 (OR PATHNAME SYNONYM-STREAM FILE-STREAM NULL)
41 (OR PATHNAME SYNONYM-STREAM FILE-STREAM)
37 (OR PATHNAME STREAM)
46 (OR PATHNAME SYNONYM-STREAM FILE-STREAM BOOLEAN)
44 (OR PATHNAME SYNONYM-STREAM FILE-STREAM NULL)
43 (OR PATHNAME SYNONYM-STREAM FILE-STREAM)
13 (OR RATIO)
17 (OR RATIONAL FLOAT)
17 (OR RATIONAL SINGLE-FLOAT)
@ -513,32 +513,32 @@
23 (OR SB-ASSEM:LABEL SB-X86-64-ASM::LABEL+ADDEND SB-C:FIXUP)
18 (OR SB-C::CLAMBDA SB-C::LAMBDA-VAR)
18 (OR SB-C::CRETURN EXIT)
52 (OR SB-C::DEBUG-INFO SB-C::DEBUG-FUN SB-C::DEBUG-SOURCE SB-C:DEFINITION-SOURCE-LOCATION SB-C::DEBUG-NAME-MARKER)
25 (OR SB-C::FUNCTIONAL SB-C::GLOBAL-VAR)
38 (OR SB-C::DEBUG-INFO SB-C::DEBUG-FUN SB-C::DEBUG-SOURCE SB-C:DEFINITION-SOURCE-LOCATION SB-C::DEBUG-NAME-MARKER)
22 (OR SB-C::FUNCTIONAL SB-C::GLOBAL-VAR)
18 (OR SB-C::OPTIONAL-DISPATCH SB-C::CLAMBDA)
27 (OR SB-C:FIXUP NUMBER SB-X86-64-ASM::REG)
25 (OR SB-DI::COMPILED-CODE-LOCATION SB-DI::COMPILED-DEBUG-FUN)
20 (OR SB-DI::COMPILED-CODE-LOCATION SB-DI::COMPILED-DEBUG-FUN)
30 (OR SB-DISASSEM::ADDRESS SYSTEM-AREA-POINTER)
21 (OR SB-IMPL::PATTERN (MEMBER :WILD :WILD-INFERIORS))
19 (OR SB-IMPL::PATTERN (MEMBER :WILD))
25 (OR SB-IMPL::PATTERN (MEMBER NIL :UNSPECIFIC :WILD :UNC))
23 (OR SB-IMPL::PATTERN (MEMBER NIL :UNSPECIFIC :WILD))
18 (OR SB-IMPL::PATTERN (MEMBER :WILD :WILD-INFERIORS))
16 (OR SB-IMPL::PATTERN (MEMBER :WILD))
22 (OR SB-IMPL::PATTERN (MEMBER NIL :UNSPECIFIC :WILD :UNC))
20 (OR SB-IMPL::PATTERN (MEMBER NIL :UNSPECIFIC :WILD))
! 23 (OR BROKEN-PIPE END-OF-FILE)
14 (OR INDEX NULL)
! 20 (OR CLASSOID CLASS)
21 (OR CONSTANT SB-C::FUNCTIONAL)
! 18 (OR CLASSOID CLASS)
19 (OR CONSTANT SB-C::FUNCTIONAL)
18 (OR CONSTANT SB-C::LAMBDA-VAR)
! 5 (OR EXTENDED-SEQUENCE)
19 (OR HOST (MEMBER :UNSPECIFIC))
26 (OR HOST (VECTOR CHARACTER) BASE-STRING (MEMBER :UNSPECIFIC))
19 (OR HOST NULL)
16 (OR HOST (MEMBER :UNSPECIFIC))
23 (OR HOST (VECTOR CHARACTER) BASE-STRING (MEMBER :UNSPECIFIC))
16 (OR HOST NULL)
11 (OR INSTANCE (MEMBER))
14 (OR INSTANCE LIST)
18 (OR SIMPLE-FUN CLOSURE)
18 (OR SB-PRETTY::NEWLINE SB-PRETTY::BLOCK-START)
18 (OR SB-X86-64-ASM::REG SB-X86-64-ASM::EA)
15 (OR SIMPLE-BASE-STRING (SIMPLE-ARRAY CHARACTER (*)))
26 (OR SIMPLE-STRING SB-IMPL::PATTERN (MEMBER :WILD))
23 (OR SIMPLE-STRING SB-IMPL::PATTERN (MEMBER :WILD))
13 (OR SIMPLE-VECTOR (MEMBER))
35 (OR SINGLE-FLOAT DOUBLE-FLOAT (COMPLEX SINGLE-FLOAT) (COMPLEX DOUBLE-FLOAT) SIMD-PACK SIMD-PACK-256)
15 (OR SINGLE-FLOAT DOUBLE-FLOAT)
@ -549,8 +549,8 @@
22 (OR STRING INTEGER)
31 (OR STRING NULL (CONS T (OR STRING NULL)))
17 (OR STRING NULL)
28 (OR STRING SB-IMPL::PATTERN (MEMBER :WILD :WILD-INFERIORS))
23 (OR STRING SB-IMPL::PATTERN)
25 (OR STRING SB-IMPL::PATTERN (MEMBER :WILD :WILD-INFERIORS))
21 (OR STRING SB-IMPL::PATTERN)
34 (OR STRING SYMBOL (CONS (EQL :CHARACTER-SET) STRING))
! 23 (OR STYLE-WARNING COMPILER-NOTE)
! 23 (OR STYLE-WARNING PACKAGE-AT-VARIANCE)
@ -562,7 +562,7 @@
19 (OR SYMBOL FIXNUM CHARACTER)
17 (OR SYMBOL FIXNUM)
29 (OR SYMBOL NUMBER CHARACTER INSTANCE)
64 (OR SYMBOL NUMBER CHARACTER UNBOXED-ARRAY SB-C::DEBUG-NAME-MARKER SYSTEM-AREA-POINTER SIMD-PACK SIMD-PACK-256)
61 (OR SYMBOL NUMBER CHARACTER UNBOXED-ARRAY SB-C::DEBUG-NAME-MARKER SYSTEM-AREA-POINTER SIMD-PACK SIMD-PACK-256)
28 (OR SYMBOL NUMBER STRING)
20 (OR SYMBOL INSTANCE FIXNUM)
20 (OR SYMBOL LAYOUT)
@ -705,7 +705,7 @@
13 SIMPLE-CHARACTER-STRING
13 SIMPLE-FUN
21 STRING-DESIGNATOR
! 28 TYPE-SPECIFIER
! 26 TYPE-SPECIFIER
! 6 SB-MOP:EQL-SPECIALIZER
! 6 SB-MOP:FORWARD-REFERENCED-CLASS
! 6 SB-MOP:FUNCALLABLE-STANDARD-CLASS

3
tests/x86-64-codegen.impure.lisp
View file

@ -148,7 +148,8 @@
(let* ((lines
(split-string
(with-output-to-string (s)
(let ((sb-disassem:*disassem-location-column-width* 0))
(let ((sb-disassem:*disassem-location-column-width* 0)
(sb-kernel::*print-layout-id* nil))
(disassemble '(lambda (x) (the sb-assem:label x))
:stream s)))
#\newline))