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

Metaspace part 1: layouts split into pieces if #+metaspace

Browse source 
The rationale and mechanics of this change have been adequately hashed
out on sbcl-devel, so nothing further to add here other than that a few
renamings of local variables from LAYOUT to WRAPPER may be worthwhile
depending on how other maintainers feel about the current state.

There are no user-observable differences in the normal configuration.
This commit is contained in:
Douglas Katzman 2021-04-11 20:59:38 -04:00
parent 37b9f28762
commit fc695edb7a
100 changed files with 951 additions and 891 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
contrib/sb-aclrepl/inspect.lisp
View file

@ -757,7 +757,7 @@ cons cells and LIST-TYPE is :normal, :dotted, or :cyclic"
(defun inspected-structure-parts (object)
(let ((components-list '())
(info (sb-kernel:layout-info (sb-kernel:layout-of object))))
(info (sb-kernel:wrapper-info (sb-kernel:wrapper-of object))))
(when (sb-kernel::defstruct-description-p info)
(dolist (dd-slot (sb-kernel:dd-slots info) (nreverse components-list))
(push (cons (string (sb-kernel:dsd-name dd-slot))

15
doc/internals-notes/metaspace
View file

@ -99,18 +99,3 @@ relatively benign to perform a small amount of extra work in GC to facilitate
assigning layouts in object constructors. This is definitely a trade-off,
however, code blobs are not as frequently occurring as say cons cells,
vectors, and general instances.
In light of the above considerations, these are the LAYOUTs in heap object slots
that will need to be changed to wrappers: ('x' indicates completed)
[x] CLASSOID-LAYOUT
[x] *FORWARD-REFERENCED-LAYOUTS*
[ ] elements of a LAYOUT-INHERITS vector
[x] values in the CLASSOID-SUBCLASSES hash-table
[ ] the FASL loader table and stack
[ ] everything in the CLOS implementation
(*) Exception to the preceding: if it is certain that whenever you store a pointer
to L in a slot, you also hold a pointer to W, then GC can't free either one.
This technique is not generally admissible unless W is either pinned or placed
in a non-moving area, because if it is not pinned it may move, and the
reference to it from L would need to be updated.

27
package-data-list.lisp-expr
View file

@ -1858,11 +1858,15 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
"INVALID-UNWIND-ERROR"
"IRRATIONAL" "KEY-INFO"
"KEY-INFO-NAME" "KEY-INFO-P" "KEY-INFO-TYPE"
"LAYOUT-BITMAP" "BITMAP-NWORDS" "LAYOUT-CLASSOID-NAME"
"LAYOUT-DEPTHOID" "LAYOUT-EQUALP-IMPL"
"BITMAP-NWORDS"
"LAYOUT-DEPTHOID"
"LAYOUT-ID"
"LAYOUT-FOR-PCL-OBJ-P"
"LAYOUT-SLOT-TABLE"
"WRAPPER-BITMAP"
"WRAPPER-CLASSOID-NAME"
"WRAPPER-DEPTHOID" "WRAPPER-EQUALP-IMPL"
"WRAPPER-SLOT-TABLE"
"WRAPPER-FRIEND" "LAYOUT-FRIEND"
#+(or x86-64 x86) "%LEA"
"LEXENV" "LEXENV-DESIGNATOR" "LINE-LENGTH"
"LIST-ABSTRACT-TYPE-FUNCTION"
@ -2220,7 +2224,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
"SET-SYMBOL-GLOBAL-VALUE"
"OUTPUT-SYMBOL" "%COERCE-NAME-TO-FUN"
"DEFAULT-STRUCTURE-PRINT"
"LAYOUT" "LAYOUT-LENGTH"
"WRAPPER" "WRAPPER-LENGTH"
"DEFSTRUCT-DESCRIPTION" "UNDECLARE-STRUCTURE"
"UNDEFINE-FUN-NAME" "DD-TYPE" "CLASSOID-STATE" "INSTANCE"
"*TYPE-SYSTEM-INITIALIZED*" "FIND-LAYOUT"
@ -2232,21 +2236,25 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
"DD-SLOTS" "DD-INCLUDE" "SLOT-SETTER-LAMBDA-FORM"
"SLOT-ACCESS-TRANSFORM"
"%IMAGPART" "%CODE-DEBUG-INFO"
"LAYOUT-CLASSOID" "LAYOUT-INVALID"
"WRAPPER-CLASSOID" "WRAPPER-INVALID"
"WRAPPER-FLAGS"
"LAYOUT-FLAGS"
"%INSTANCEP" "DEFSTRUCT-SLOT-DESCRIPTION"
"DD-PREDICATE-NAME"
"CLASSOID-PROPER-NAME" "%NOTE-TYPE-DEFINED" "LAYOUT-INFO"
"LAYOUT-DD"
"CLASSOID-PROPER-NAME" "%NOTE-TYPE-DEFINED" "WRAPPER-INFO"
"WRAPPER-DD"
"%SET-INSTANCE-LAYOUT"
"DD-CONSTRUCTORS" "DD-DEFAULT-CONSTRUCTOR"
"LAYOUT-OF" "%REALPART"
"WRAPPER-OF"
"%REALPART"
"STRUCTURE-CLASSOID" "STRUCTURE-CLASSOID-P"
"GET-DSD-INDEX"
"%INSTANCE-LAYOUT" "LAYOUT-CLOS-HASH" "%INSTANCEOID-LAYOUT"
"WRAPPER-CLOS-HASH"
"%INSTANCE-WRAPPER" "%FUN-WRAPPER"
"PROCLAIM-AS-FUN-NAME" "BECOME-DEFINED-FUN-NAME"
"%NUMERATOR" "CLASSOID-TYPEP"
"LAYOUT-INHERITS" "DD-LENGTH"
"WRAPPER-INHERITS" "DD-LENGTH"
"SET-LAYOUT-INHERITS"
"%CODE-ENTRY-POINT"
"%CODE-FUN-OFFSET"
@ -3101,6 +3109,7 @@ structure representations"
"INTERRUPTED-FLAG"
"IS-LISP-POINTER"
#+gencgc "LARGE-OBJECT-SIZE"
"LAYOUT"
"LIST-ALLOCATED-OBJECTS" "LIST-POINTER-LOWTAG"
;; FIXME: Possibly these other parameters (see
;; compiler/{x86,sparc}/parms.lisp) should be defined

2
src/code/aprof.lisp
View file

@ -136,7 +136,7 @@
(defun layout-name (ptr)
(if (eql (valid-lisp-pointer-p (int-sap ptr)) 0)
'structure
(layout-classoid-name (make-lisp-obj ptr))))
(wrapper-classoid-name (layout-friend (make-lisp-obj ptr)))))
;;; These EAs are s-expressions, not instances of EA or MACHINE-EA.
#-sb-safepoint

216
src/code/class.lisp
View file

@ -49,51 +49,46 @@
(setq *forward-referenced-wrappers* (make-hash-table :test 'equal))
(dovector (x *!initial-wrappers*)
(let ((expected (hash-layout-name (car x)))
(actual (layout-clos-hash (wrapper-friend (cdr x)))))
(actual (wrapper-clos-hash (cdr x))))
(unless (= actual expected) (bug "XC layout hash calculation failed")))
(setf (gethash (car x) *forward-referenced-wrappers*) (cdr x))))
;;; The LAYOUT structure itself is defined in 'early-classoid.lisp'
(defmethod print-object ((layout layout) stream)
(print-unreadable-object (layout stream :type t :identity t)
(format stream
"~@[(ID=~d) ~]for ~S~@[, INVALID=~S~]"
(layout-id layout)
(layout-proper-name layout)
(layout-invalid layout))))
#+(and metaspace (not sb-xc-host))
(defmethod print-object ((wrapper wrapper) stream)
(print-unreadable-object (wrapper stream :type t :identity t)
(write (wrapper-friend wrapper) :stream stream)))
(format stream
"~@[(ID=~d) ~]for ~S~@[, INVALID=~S~]"
(layout-id wrapper)
(wrapper-proper-name wrapper)
(wrapper-invalid wrapper))))
(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
(defun layout-proper-name (layout)
(classoid-proper-name (layout-classoid layout))))
(defun wrapper-proper-name (wrapper)
(classoid-proper-name (wrapper-classoid wrapper))))
;;; Return the layout currently installed in the classoid named NAME.
;;; If there is none, then make a layout referring for an undefined classoid.
(declaim (ftype (sfunction (symbol) layout) find-layout))
;;; NB: for #+metaspace this returns a WRAPPER, not a LAYOUT.
(declaim (ftype (sfunction (symbol) wrapper) find-layout))
(defun find-layout (name)
(binding* ((classoid (find-classoid name nil) :exit-if-null) ; threadsafe
(layout (classoid-layout classoid) :exit-if-null))
(return-from find-layout layout))
(wrapper (classoid-wrapper classoid) :exit-if-null))
(return-from find-layout wrapper))
(let ((table *forward-referenced-wrappers*))
(with-world-lock ()
(let ((classoid (find-classoid name nil)))
(or (and classoid (classoid-layout classoid))
(acond ((gethash name table)
(wrapper-friend it))
(t
(let ((new (make-layout (hash-layout-name name)
(or classoid (make-undefined-classoid name)))))
(setf (gethash name table) (layout-friend new))
new))))))))
(or (and classoid (classoid-wrapper classoid))
(values (ensure-gethash name table
(make-layout
(hash-layout-name name)
(or classoid
(make-undefined-classoid name))))))))))
;;; If LAYOUT's slot values differ from the specified slot values in
;;; any interesting way, then give a warning and return T.
(declaim (ftype (function (simple-string
layout
wrapper
simple-string
index
simple-vector
@ -102,17 +97,17 @@
warn-if-altered-layout))
(defun warn-if-altered-layout (old-context old-layout context
length inherits depthoid bitmap)
(let ((name (layout-proper-name old-layout))
(old-inherits (layout-inherits old-layout)))
(or (when (mismatch old-inherits inherits :key #'layout-proper-name)
(let ((name (wrapper-proper-name old-layout))
(old-inherits (wrapper-inherits old-layout)))
(or (when (mismatch old-inherits inherits :key #'wrapper-proper-name)
(warn "change in superclasses of class ~S:~% ~
~A superclasses: ~S~% ~
~A superclasses: ~S"
name
old-context
(map 'list #'layout-proper-name old-inherits)
(map 'list #'wrapper-proper-name old-inherits)
context
(map 'list #'layout-proper-name inherits))
(map 'list #'wrapper-proper-name inherits))
t)
(let ((diff (mismatch old-inherits inherits)))
(when diff
@ -121,10 +116,10 @@
~A definition."
name
old-context
(layout-proper-name (svref old-inherits diff))
(wrapper-proper-name (svref old-inherits diff))
context)
t))
(let ((old-length (layout-length old-layout)))
(let ((old-length (wrapper-length old-layout)))
(unless (= old-length length)
(warn "change in instance length of class ~S:~% ~
~A length: ~W~% ~
@ -133,13 +128,13 @@
old-context old-length
context length)
t))
(let ((old-bitmap (layout-bitmap old-layout)))
(let ((old-bitmap (wrapper-bitmap old-layout)))
(unless (= old-bitmap bitmap)
(warn "change in placement of raw slots of class ~S ~
between the ~A definition and the ~A definition"
name old-context context)
t))
(unless (= (layout-depthoid old-layout) depthoid)
(unless (= (wrapper-depthoid old-layout) depthoid)
(warn "change in the inheritance structure of class ~S~% ~
between the ~A definition and the ~A definition"
name old-context context)
@ -148,26 +143,23 @@ between the ~A definition and the ~A definition"
(defun load-layout (name depthoid inherits length bitmap flags)
(let* ((layout
(or (binding* ((classoid (find-classoid name nil) :exit-if-null))
(classoid-layout classoid))
(classoid-wrapper classoid))
(let ((table *forward-referenced-wrappers*))
(with-world-lock ()
(let ((classoid (find-classoid name nil)))
(or (and classoid (classoid-layout classoid))
(let ((wrapper (gethash name table)))
(if wrapper
(wrapper-friend wrapper)
(let ((new (make-layout
(hash-layout-name name)
(or classoid (make-undefined-classoid name))
:depthoid depthoid :inherits inherits
:length length :bitmap bitmap :flags flags)))
(setf (gethash name table) (layout-friend new))
new)))))))))
(or (and classoid (classoid-wrapper classoid))
(ensure-gethash
name table
(make-layout
(hash-layout-name name)
(or classoid (make-undefined-classoid name))
:depthoid depthoid :inherits inherits
:length length :bitmap bitmap :flags flags))))))))
(classoid
(or (find-classoid name nil) (layout-classoid layout))))
(if (or (eq (layout-invalid layout) :uninitialized)
(or (find-classoid name nil) (wrapper-classoid layout))))
(if (or (eq (wrapper-invalid layout) :uninitialized)
(not *type-system-initialized*))
(setf (layout-classoid layout) classoid)
(setf (wrapper-classoid layout) classoid)
;; There was an old layout already initialized with old
;; information, and we'll now check that old information
;; which was known with certainty is consistent with current
@ -175,7 +167,7 @@ between the ~A definition and the ~A definition"
(when (warn-if-altered-layout "current" layout "compile time"
length inherits depthoid bitmap)
(error "The loaded code expects an incompatible layout for class ~S."
(layout-proper-name layout))))
(wrapper-proper-name layout))))
layout))
;;; Record LAYOUT as the layout for its class, adding it as a subtype
@ -189,19 +181,19 @@ between the ~A definition and the ~A definition"
;;; destructively modified to hold the same type information.
(macrolet ((set-bitmap-from-layout (to-layout from-layout)
`(let ((to-index
(+ (type-dd-length layout)
(+ (type-dd-length sb-vm:layout)
(calculate-extra-id-words (layout-depthoid ,to-layout))))
(from-index
(+ (type-dd-length layout)
(+ (type-dd-length sb-vm:layout)
(calculate-extra-id-words (layout-depthoid ,from-layout)))))
(dotimes (i (bitmap-nwords ,from-layout))
(setf (%raw-instance-ref/word ,to-layout (+ to-index i))
(%raw-instance-ref/word ,from-layout (+ from-index i)))))))
(defun register-layout (layout &key (invalidate t) destruct-layout)
(declare (type layout layout) (type (or layout null) destruct-layout))
(defun register-layout (wrapper &key (invalidate t) modify)
(declare (type wrapper wrapper) (type (or wrapper null) modify))
(with-world-lock ()
(let* ((classoid (layout-classoid layout))
(classoid-layout (classoid-layout classoid))
(let* ((classoid (wrapper-classoid wrapper))
(classoid-wrapper (classoid-wrapper classoid))
(subclasses (classoid-subclasses classoid)))
;; Attempting to register ourselves with a temporary undefined
@ -212,32 +204,33 @@ between the ~A definition and the ~A definition"
;; This assertion dates from classic CMU CL. The rationale is
;; probably that calling REGISTER-LAYOUT more than once for the
;; same LAYOUT is almost certainly a programmer error.
(aver (not (eq classoid-layout layout)))
(aver (not (eq classoid-wrapper wrapper)))
;; Figure out what classes are affected by the change, and issue
;; appropriate warnings and invalidations.
(when classoid-layout
(when classoid-wrapper
(%modify-classoid classoid)
(when subclasses
(dohash ((subclass subclass-wrapper) subclasses :locked t)
(%modify-classoid subclass)
(when invalidate
(%invalidate-layout (wrapper-friend subclass-wrapper)))))
(%invalidate-layout subclass-wrapper))))
(when invalidate
(%invalidate-layout classoid-layout)
(%invalidate-layout classoid-wrapper)
(setf (classoid-subclasses classoid) nil)))
(if destruct-layout
(if modify
#+sb-xc-host (error "Why mutate a layout in XC host?")
#-sb-xc-host
;; 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)) ; "new" depthoid
(let ((inherits (wrapper-inherits wrapper))
(depthoid (wrapper-depthoid wrapper)) ; "new" depthoid
(extra-id-words ; "old" extra words
(calculate-extra-id-words (layout-depthoid destruct-layout)))
(calculate-extra-id-words (wrapper-depthoid modify)))
(layout (wrapper-friend wrapper))
(id ; read my ID before screwing with the depthoid
(layout-id destruct-layout)))
(layout-id modify)))
(aver (logtest +structure-layout-flag+ (layout-flags layout)))
(aver (= (length inherits) depthoid))
;; DEPTHOID implies the number of words of "extra" IDs preceding the bitmap.
@ -246,10 +239,10 @@ between the ~A definition and the ~A definition"
;; 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))
#-64-bit (setf (wrapper-depthoid modify) (wrapper-depthoid wrapper)
(wrapper-length modify) (wrapper-length wrapper))
(setf (layout-flags (wrapper-friend modify)) (layout-flags layout)
(wrapper-info modify) (wrapper-info wrapper))
;; 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.
@ -257,18 +250,20 @@ between the ~A definition and the ~A definition"
;; (/ (- (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))
(setf (%raw-instance-ref/word (wrapper-friend modify)
(+ (get-dsd-index sb-vm: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-wrapper classoid) (layout-friend destruct-layout)))
(setf (layout-invalid layout) nil
(classoid-wrapper classoid) (layout-friend layout)))
(set-layout-inherits modify inherits t id)
(let ((dst (wrapper-friend modify))
(src (wrapper-friend wrapper)))
(set-bitmap-from-layout dst src))
(setf (wrapper-invalid modify) nil
(classoid-wrapper classoid) modify))
(setf (wrapper-invalid wrapper) nil
(classoid-wrapper classoid) wrapper))
(dovector (super-layout (layout-inherits layout))
(let* ((super (layout-classoid super-layout))
(dovector (super-wrapper (wrapper-inherits wrapper))
(let* ((super (wrapper-classoid super-wrapper))
(subclasses
(or (classoid-subclasses super)
(setf (classoid-subclasses super)
@ -284,8 +279,7 @@ between the ~A definition and the ~A definition"
(warn "unsealing sealed class ~S in order to subclass it"
(classoid-name super))
(setf (classoid-state super) :read-only))
(setf (gethash classoid subclasses)
(layout-friend (or destruct-layout layout)))))))
(setf (gethash classoid subclasses) (or modify wrapper))))))
(values)))
@ -316,7 +310,7 @@ between the ~A definition and the ~A definition"
(let ((length (length layouts))
(max-depth -1))
(dotimes (i length)
(let ((depth (layout-depthoid (svref layouts i))))
(let ((depth (wrapper-depthoid (svref layouts i))))
(when (> depth max-depth)
(setf max-depth depth))))
(let* ((new-length (max (1+ max-depth) length))
@ -327,7 +321,7 @@ between the ~A definition and the ~A definition"
(inherits (make-array new-length :initial-element 0)))
(dotimes (i length)
(let* ((layout (svref layouts i))
(depth (layout-depthoid layout)))
(depth (wrapper-depthoid layout)))
(unless (eql depth -1)
(let ((old-layout (svref inherits depth)))
(unless (or (eql old-layout 0) (eq old-layout layout))
@ -338,7 +332,7 @@ between the ~A definition and the ~A definition"
((>= i length))
(declare (type index i j))
(let* ((layout (svref layouts i))
(depth (layout-depthoid layout)))
(depth (wrapper-depthoid layout)))
(when (eql depth -1)
(loop (when (eql (svref inherits j) 0)
(return))
@ -492,9 +486,9 @@ between the ~A definition and the ~A definition"
(setf (info :type :kind name) :instance)))
(setf (classoid-cell-classoid cell) new-value)
(unless (eq (info :type :compiler-layout name)
(classoid-layout new-value))
(classoid-wrapper new-value))
(setf (info :type :compiler-layout name)
(classoid-layout new-value)))))
(classoid-wrapper new-value)))))
new-value)
(defun %clear-classoid (name cell)
@ -541,11 +535,10 @@ between the ~A definition and the ~A definition"
(res (if (and old (funcall predicate old))
old
(funcall constructor :name name)))
(old-wrapper (or (gethash name table)
(when old (classoid-wrapper old))))
(found (when old-wrapper (wrapper-friend old-wrapper))))
(found (or (gethash name table)
(when old (classoid-wrapper old)))))
(when found
(setf (layout-classoid found) res))
(setf (wrapper-classoid found) res))
(values res found)))))
;;; If the classoid has a proper name, return the name, otherwise return
@ -582,16 +575,16 @@ between the ~A definition and the ~A definition"
(let ((super (if (symbolp super-or-name)
(find-classoid super-or-name)
super-or-name)))
(find (classoid-layout super)
(layout-inherits (classoid-layout sub)))))
(find (classoid-wrapper super)
(wrapper-inherits (classoid-wrapper sub)))))
;;; We might be passed classoids with invalid layouts; in any pairwise
;;; class comparison, we must ensure that both are valid before
;;; proceeding.
(defun %ensure-classoid-valid (classoid layout error-context)
(declare (ignorable error-context)) ; not used on host
(aver (eq classoid (layout-classoid layout)))
(or (not (layout-invalid layout))
(aver (eq classoid (wrapper-classoid layout)))
(or (not (wrapper-invalid layout))
;; Avoid accidentally reaching code that can't work.
#+sb-xc-host (bug "(TYPEP x 'STANDARD-CLASSOID) can't be tested")
#-sb-xc-host
@ -617,10 +610,10 @@ between the ~A definition and the ~A definition"
classoid (or error-context 'subtypep)))))
(defun %ensure-both-classoids-valid (class1 class2 &optional errorp)
(do ((layout1 (classoid-layout class1) (classoid-layout class1))
(layout2 (classoid-layout class2) (classoid-layout class2))
(do ((layout1 (classoid-wrapper class1) (classoid-wrapper class1))
(layout2 (classoid-wrapper class2) (classoid-wrapper class2))
(i 0 (+ i 1)))
((and (not (layout-invalid layout1)) (not (layout-invalid layout2)))
((and (not (wrapper-invalid layout1)) (not (wrapper-invalid layout2)))
t)
(aver (< i 2))
(unless (and (%ensure-classoid-valid class1 layout1 errorp)
@ -1010,7 +1003,7 @@ between the ~A definition and the ~A definition"
;;
;; Essentially the hardwiring corresponds to the indices of the
;; respective types in the inherits vector for FD-STREAM.
;; * (layout-inherits (find-layout 'fd-stream))
;; * (wrapper-inherits (find-layout 'fd-stream))
;; #(#<LAYOUT for T {50300003}>
;; #<LAYOUT for STRUCTURE-OBJECT {50300103}>
;; #<LAYOUT for STREAM {50301003}>
@ -1129,14 +1122,14 @@ between the ~A definition and the ~A definition"
(map 'simple-vector
(lambda (x)
(let ((super-layout
(classoid-layout (find-classoid x))))
(when (minusp (layout-depthoid super-layout))
(classoid-wrapper (find-classoid x))))
(when (minusp (wrapper-depthoid super-layout))
(setf hierarchical-p nil))
super-layout))
inherits-list))
(depthoid (if hierarchical-p
(or depth (length inherits-vector))
-1)))
(or depth (length inherits-vector))
-1)))
(register-layout (load-layout name
depthoid
inherits-vector
@ -1173,21 +1166,24 @@ between the ~A definition and the ~A definition"
;;; nominal superclasses.) We set the layout-clos-hash slots to 0 to
;;; invalidate the wrappers for specialized dispatch functions, which
;;; use those slots as indexes into tables.
(defun %invalidate-layout (layout)
(declare (type layout layout))
#+sb-xc-host (warn "Why are we invalidating layout ~S?" layout)
(setf (layout-invalid layout) t)
(defun %invalidate-layout (wrapper)
(declare (type wrapper wrapper))
#+sb-xc-host (error "Can't invalidate layout ~S" wrapper)
#-sb-xc-host
(progn
(setf (wrapper-invalid wrapper) t)
;; Ensure that the INVALID slot conveying ancillary data describing the
;; invalidity reason is published before causing the invalid layout trap.
(sb-thread:barrier (:write))
(setf (layout-clos-hash layout) 0)
(let ((inherits (layout-inherits layout))
(classoid (layout-classoid layout)))
#+metaspace (setf (layout-clos-hash (wrapper-friend wrapper)) 0)
(setf (wrapper-clos-hash wrapper) 0)
(let ((inherits (wrapper-inherits wrapper))
(classoid (wrapper-classoid wrapper)))
(%modify-classoid classoid)
(dovector (super inherits)
(let ((subs (classoid-subclasses (layout-classoid super))))
(let ((subs (classoid-subclasses (wrapper-classoid super))))
(when subs
(remhash classoid subs)))))
(remhash classoid subs))))))
(values))
;;;; cold loading initializations

22
src/code/condition.lisp
View file

@ -68,21 +68,21 @@
;; right thing is..
(new-inherits
(order-layout-inherits (concatenate 'simple-vector
(layout-inherits cond-layout)
(mapcar #'classoid-layout cpl)))))
(wrapper-inherits cond-layout)
(mapcar #'classoid-wrapper cpl)))))
(if (and olayout
(not (mismatch (layout-inherits olayout) new-inherits)))
(not (mismatch (wrapper-inherits olayout) new-inherits)))
olayout
;; All condition classoid layouts carry the same LAYOUT-INFO - the defstruct
;; description for CONDITION - which is a representation of the primitive object
;; and not the lisp-level object.
(make-layout (hash-layout-name name)
(make-undefined-classoid name)
:info (layout-info cond-layout)
:info (wrapper-info cond-layout)
:flags +condition-layout-flag+
:inherits new-inherits
:depthoid -1
:length (layout-length cond-layout)))))
:length (wrapper-length cond-layout)))))
) ; EVAL-WHEN
@ -152,7 +152,7 @@
(defun set-condition-slot-value (condition new-value name)
(dolist (cslot (condition-classoid-class-slots
(layout-classoid (%instance-layout condition)))
(wrapper-classoid (%instance-wrapper condition)))
(setf (getf (condition-assigned-slots condition) name)
new-value))
(when (eq (condition-slot-name cslot) name)
@ -161,7 +161,7 @@
(defun condition-slot-value (condition name)
(let ((val (getf (condition-assigned-slots condition) name sb-pcl:+slot-unbound+)))
(if (unbound-marker-p val)
(let ((class (layout-classoid (%instance-layout condition))))
(let ((class (wrapper-classoid (%instance-wrapper condition))))
(dolist (cslot
(condition-classoid-class-slots class)
(let ((instance-length (%instance-length condition))
@ -217,11 +217,11 @@
(flet ((stream-err-p (layout)
(let ((stream-err-layout (load-time-value (find-layout 'stream-error))))
(or (eq layout stream-err-layout)
(find stream-err-layout (layout-inherits layout)))))
(find stream-err-layout (wrapper-inherits layout)))))
(type-err-p (layout)
(let ((type-err-layout (load-time-value (find-layout 'type-error))))
(or (eq layout type-err-layout)
(find type-err-layout (layout-inherits layout)))))
(find type-err-layout (wrapper-inherits layout)))))
;; avoid full calls to STACK-ALLOCATED-P here
(stackp (x)
(let ((addr (get-lisp-obj-address x)))
@ -231,7 +231,7 @@
(let* ((any-dx
(loop for arg-index from 1 below (length initargs) by 2
thereis (stackp (fast-&rest-nth arg-index initargs))))
(layout (classoid-layout classoid))
(layout (classoid-wrapper classoid))
(extra (if (and any-dx (type-err-p layout)) 2 0)) ; space for secret initarg
(instance (%make-instance (+ sb-vm:instance-data-start
1 ; ASSIGNED-SLOTS
@ -241,7 +241,7 @@
(arg-index 0)
(have-type-error-datum)
(type-error-datum))
(setf (%instance-layout instance) layout
(setf (%instance-wrapper instance) layout
(condition-assigned-slots instance) nil)
(macrolet ((store-pair (key val)
`(setf (%instance-ref instance data-index) ,key

17
src/code/cross-misc.lisp
View file

@ -235,22 +235,21 @@
;; - DEBUG-SOURCE, COMPILED-DEBUG-INFO, COMPILED-DEBUG-FUN-{something}
;; - HEAP-ALIEN-INFO and ALIEN-{something}-TYPE
;; - COMMA
(defun classoid-layout (x)
#-metaspace (defmacro wrapper-friend (x) x)
(defun %instance-wrapper (instance)
(declare (notinline classoid-wrapper))
(classoid-wrapper x))
(defun layout-friend (x) x)
(defun wrapper-friend (x) x)
(defmacro wrapper-%info (x) `(layout-info ,x))
(defun %instance-layout (instance)
(classoid-layout (find-classoid (type-of instance))))
(classoid-wrapper (find-classoid (type-of instance))))
(defun %instance-length (instance)
(declare (notinline layout-length))
(declare (notinline wrapper-length))
;; In the target, it is theoretically possible to have %INSTANCE-LENGTH
;; exceeed layout length, but in the cross-compiler they're the same.
(layout-length (%instance-layout instance)))
(wrapper-length (%instance-wrapper instance)))
(defun %raw-instance-ref/word (instance index)
(declare (ignore instance index))
(error "No such thing as raw structure access on the host"))
(defun layout-id (x)
(declare (notinline sb-kernel::wrapper-id))
(sb-kernel::wrapper-id x))
(defun %find-position (item seq from-end start end key test)
(let ((position (position item seq :from-end from-end

112
src/code/defstruct.lisp
View file

@ -22,7 +22,7 @@
(let ((res (info :type :compiler-layout name)))
(cond ((not res)
(error "Class is not yet defined or was undefined: ~S" name))
((not (typep (layout-info res) 'defstruct-description))
((not (typep (wrapper-%info res) 'defstruct-description))
(error "Class is not a structure class: ~S" name))
(t
(check-deprecated-type name)
@ -30,7 +30,7 @@
(defun compiler-layout-ready-p (name)
(let ((layout (info :type :compiler-layout name)))
(and layout (typep (layout-info layout) 'defstruct-description))))
(and layout (typep (wrapper-%info layout) 'defstruct-description))))
(sb-xc:defmacro %make-structure-instance-macro (dd slot-specs &rest slot-vars)
(if (compiler-layout-ready-p (dd-name dd))
@ -62,7 +62,7 @@
(values
(compile nil `(lambda ()
(let ((object (%make-funcallable-instance ,(dd-length dd))))
(setf (%fun-layout object) ,(find-layout (dd-name dd)))
(setf (%fun-wrapper object) ,(find-layout (dd-name dd)))
object)))))
;;;; DEFSTRUCT-DESCRIPTION
@ -724,7 +724,7 @@ unless :NAMED is also specified.")))
(let ((super (compiler-layout-or-lose (or (first (dd-include dd))
'structure-object))))
(concatenate 'simple-vector
(layout-inherits super) (vector super)))))
(wrapper-inherits super) (vector super)))))
(proto-classoid
(if (dd-class-p dd)
;; The classoid needs a layout whereby to convey inheritance.
@ -733,9 +733,9 @@ unless :NAMED is also specified.")))
;; It's probably too dangerous to stack-allocate, because references
;; could leak from the type cache machinery.
(let* ((classoid (make-structure-classoid :name (dd-name dd)))
(layout (make-temporary-layout (hash-layout-name (dd-name dd))
(layout (make-temporary-wrapper (hash-layout-name (dd-name dd))
classoid inherits)))
(setf (classoid-wrapper classoid) (layout-friend layout))
(setf (classoid-wrapper classoid) layout)
classoid)))
(ancestor-slot-comparator-list))
#+sb-xc-host
@ -966,7 +966,7 @@ unless :NAMED is also specified.")))
(let* ((type (dd-type dd))
(included-structure
(if (dd-class-p dd)
(layout-info (compiler-layout-or-lose included-name))
(wrapper-info (compiler-layout-or-lose included-name))
(typed-structure-info-or-lose included-name))))
;; checks on legality
@ -980,8 +980,8 @@ unless :NAMED is also specified.")))
;; It's not particularly well-defined to :INCLUDE any of the
;; CMU CL INSTANCE weirdosities like CONDITION or
;; GENERIC-FUNCTION, and it's certainly not ANSI-compliant.
(let* ((included-layout (classoid-layout included-classoid))
(included-dd (layout-dd included-layout)))
(let* ((included-layout (classoid-wrapper included-classoid))
(included-dd (wrapper-dd included-layout)))
(when (dd-alternate-metaclass included-dd)
(error "can't :INCLUDE class ~S (has alternate metaclass)"
included-name)))))
@ -1050,7 +1050,7 @@ unless :NAMED is also specified.")))
(super
(if include
(compiler-layout-or-lose (first include))
(classoid-layout (find-classoid
(classoid-wrapper (find-classoid
(or (first superclass-opt)
'structure-object))))))
(case (dd-name info)
@ -1058,24 +1058,24 @@ unless :NAMED is also specified.")))
;; STREAM is an abstract class and you can't :include it,
;; so the inheritance has to be hardcoded.
(concatenate 'simple-vector
(layout-inherits super)
(vector super (classoid-layout (find-classoid 'stream)))))
(wrapper-inherits super)
(vector super (classoid-wrapper (find-classoid 'stream)))))
((fd-stream) ; Similarly, FILE-STREAM is abstract
(concatenate 'simple-vector
(layout-inherits super)
(wrapper-inherits super)
(vector super
(classoid-layout (find-classoid 'file-stream)))))
(classoid-wrapper (find-classoid 'file-stream)))))
((sb-impl::string-input-stream ; etc
sb-impl::string-output-stream
sb-impl::fill-pointer-output-stream)
(concatenate 'simple-vector
(layout-inherits super)
(wrapper-inherits super)
(vector super
(classoid-layout (find-classoid 'string-stream)))))
(classoid-wrapper (find-classoid 'string-stream)))))
(pathname (vector (find-layout 't)))
(logical-pathname (vector (find-layout 't) (find-layout 'pathname)))
(t (concatenate 'simple-vector
(layout-inherits super)
(wrapper-inherits super)
(vector super))))))
;;; Do miscellaneous (LOAD EVAL) time actions for the structure
@ -1088,17 +1088,17 @@ unless :NAMED is also specified.")))
(multiple-value-bind (classoid layout old-layout)
(ensure-structure-class dd inherits "current" "new")
(cond ((not old-layout)
(unless (eq (classoid-layout classoid) layout)
(unless (eq (classoid-wrapper classoid) layout)
(register-layout layout)))
(t
(%redefine-defstruct classoid old-layout layout)
(let ((old-dd (layout-info old-layout)))
(let ((old-dd (wrapper-info old-layout)))
(when (defstruct-description-p old-dd)
(dolist (slot (dd-slots old-dd))
(fmakunbound (dsd-accessor-name slot))
(unless (dsd-read-only slot)
(fmakunbound `(setf ,(dsd-accessor-name slot)))))))
(setq layout (classoid-layout classoid))))
(setq layout (classoid-wrapper classoid))))
;; Don't want to (setf find-classoid) on a a built-in-classoid
(unless (and (built-in-classoid-p classoid)
(eq (find-classoid (dd-name dd) nil) classoid))
@ -1258,17 +1258,17 @@ unless :NAMED is also specified.")))
"the most recently loaded"
:compiler-layout clayout))
(cond (old-layout
(undeclare-structure (layout-classoid old-layout)
(undeclare-structure (wrapper-classoid old-layout)
(and (classoid-subclasses classoid)
(not (eq layout old-layout))))
(setf (layout-invalid layout) nil)
(setf (wrapper-invalid layout) nil)
;; FIXME: it might be polite to hold onto old-layout and
;; restore it at the end of the file. -- RMK 2008-09-19
;; (International Talk Like a Pirate Day).
(warn "~@<Clobbering the compiler's idea of the layout of ~A.~:@>"
classoid))
(t
(unless (eq (classoid-layout classoid) layout)
(unless (eq (classoid-wrapper classoid) layout)
(register-layout layout :invalidate nil))
;; Don't want to (setf find-classoid) on a a built-in-classoid
(unless (and (built-in-classoid-p classoid)
@ -1420,15 +1420,17 @@ or they must be declared locally notinline at each call site.~@:>"
;;; 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)))
(declare (type wrapper old-layout new-layout))
(if (wrapper-info old-layout)
(let ((old-bitmap (wrapper-bitmap old-layout))
(new-bitmap (wrapper-bitmap new-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)))
(= (bitmap-nwords new-layout) (bitmap-nwords old-layout))
(dotimes (i (dd-length (layout-dd old-layout)) t)
(and (= (calculate-extra-id-words (wrapper-depthoid old-layout))
(calculate-extra-id-words (wrapper-depthoid new-layout)))
(= (bitmap-nwords (wrapper-friend new-layout))
(bitmap-nwords (wrapper-friend old-layout)))
(dotimes (i (dd-length (wrapper-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
(return nil)))))
@ -1440,7 +1442,7 @@ or they must be declared locally notinline at each call site.~@:>"
;;; be used.
(defun %redefine-defstruct (classoid old-layout new-layout)
(declare (type classoid classoid)
(type layout old-layout new-layout))
(type wrapper old-layout new-layout))
(declare (ignorable old-layout)) ; for host
(let ((name (classoid-proper-name classoid)))
(restart-case
@ -1470,7 +1472,7 @@ or they must be declared locally notinline at each call site.~@:>"
;; I hope you know what you're doing..."
(register-layout new-layout
:invalidate nil
:destruct-layout old-layout))))
:modify old-layout))))
(values))
;;; Compute DD's bitmap, storing 1 for each tagged word.
@ -1585,7 +1587,7 @@ or they must be declared locally notinline at each call site.~@:>"
(cond ((eq (dd-name dd) 'sb-lockless::list-node) t)
((dd-include dd)
(has-custom-gc-method
(layout-info (compiler-layout-or-lose (car (dd-include dd))))))))
(wrapper-info (compiler-layout-or-lose (car (dd-include dd))))))))
(aver (eq rest :unspecific))
(return-from calculate-dd-bitmap minimal-bitmap))
@ -1625,6 +1627,7 @@ or they must be declared locally notinline at each call site.~@:>"
&key compiler-layout
&aux (flags 0))
(declare (type defstruct-description info))
;; NB: the variables named "layout" are in fact of type WRAPPER
(multiple-value-bind (classoid old-layout)
(multiple-value-bind (class constructor)
(acond ((cdr (dd-alternate-metaclass info))
@ -1650,10 +1653,10 @@ or they must be declared locally notinline at each call site.~@:>"
fd-stream
sb-impl::string-input-stream sb-impl::string-output-stream
sb-impl::fill-pointer-output-stream)
(list (layout-classoid (svref inherits (1- (length inherits))))
(layout-classoid (svref inherits (- (length inherits) 2)))))
(list (wrapper-classoid (svref inherits (1- (length inherits))))
(wrapper-classoid (svref inherits (- (length inherits) 2)))))
(t
(list (layout-classoid
(list (wrapper-classoid
(svref inherits (1- (length inherits))))))))
(unless (dd-alternate-metaclass info)
(setq flags +structure-layout-flag+))
@ -1662,7 +1665,7 @@ or they must be declared locally notinline at each call site.~@:>"
(setq flags (logior (logand (logior +stream-layout-flag+
+file-stream-layout-flag+
+string-stream-layout-flag+)
(layout-flags ancestor))
(wrapper-flags ancestor))
flags)))
(let* ((old-layout (or compiler-layout old-layout))
(new-layout
@ -1681,31 +1684,31 @@ or they must be declared locally notinline at each call site.~@:>"
;; The assignment of INFO here can almost be deleted,
;; except for a few magical types that don't d.t.r.t. in cold-init:
;; STRUCTURE-OBJECT, CONDITION, ALIEN-VALUE, INTERPRETED-FUNCTION
(setf (layout-info old-layout) info)
(setf (wrapper-info old-layout) info)
(values classoid old-layout nil))
(;; This clause corresponds to an assertion in REDEFINE-LAYOUT-WARNING
;; of classic CMU CL. I moved it out to here because it was only
;; exercised in this code path anyway. -- WHN 19990510
(not (eq (layout-classoid new-layout) (layout-classoid old-layout)))
(not (eq (wrapper-classoid new-layout) (wrapper-classoid old-layout)))
(error "shouldn't happen: weird state of OLD-LAYOUT?"))
((warn-if-altered-layout old-context
old-layout
new-context
(layout-length new-layout)
(layout-inherits new-layout)
(layout-depthoid new-layout)
(layout-bitmap new-layout))
(wrapper-length new-layout)
(wrapper-inherits new-layout)
(wrapper-depthoid new-layout)
(wrapper-bitmap new-layout))
(values classoid new-layout old-layout))
(t
(let ((old-info (layout-info old-layout)))
(let ((old-info (wrapper-info old-layout)))
(if old-info
(cond ((redefine-structure-warning classoid old-info info)
(values classoid new-layout old-layout))
(t
(setf (layout-info old-layout) info)
(setf (wrapper-info old-layout) info)
(values classoid old-layout nil)))
(progn
(setf (layout-info old-layout) info)
(setf (wrapper-info old-layout) info)
(values classoid old-layout nil)))))))))
;;; Return a list of pairs (name . index). Used for :TYPE'd
@ -2170,7 +2173,7 @@ or they must be declared locally notinline at each call site.~@:>"
(%make-funcallable-instance ,(dd-length dd)))
`((macrolet ((the-layout ()
(info :type :compiler-layout ',class-name)))
(setf (%fun-layout object) (the-layout)))))))
(setf (%fun-wrapper object) (the-layout)))))))
`((defun ,constructor (,@slot-names &aux (object ,allocate))
,@set-layout
,@(mapcar (lambda (dsd)
@ -2195,8 +2198,7 @@ or they must be declared locally notinline at each call site.~@:>"
(defun find-defstruct-description (name &optional (errorp t))
(let* ((classoid (find-classoid name errorp))
(info (and classoid
(wrapper-%info (classoid-wrapper classoid)))))
(info (and classoid (wrapper-%info (classoid-wrapper classoid)))))
(cond ((defstruct-description-p info)
info)
(errorp
@ -2215,13 +2217,13 @@ or they must be declared locally notinline at each call site.~@:>"
#+sb-xc-host
(defun %instance-ref (instance index)
(let* ((layout (%instance-layout instance))
(map (layout-index->accessor-map layout)))
(let* ((wrapper (%instance-wrapper instance))
(map (wrapper-index->accessor-map wrapper)))
(when (zerop (length map)) ; construct it on demand
(let ((slots (dd-slots (layout-info layout))))
(let ((slots (dd-slots (wrapper-%info wrapper))))
(setf map (make-array (1+ (reduce #'max slots :key #'dsd-index))
:initial-element nil)
(layout-index->accessor-map layout) map)
(wrapper-index->accessor-map wrapper) map)
(dolist (dsd slots)
(setf (aref map (dsd-index dsd)) (dsd-accessor-name dsd)))))
(funcall (aref map index) instance)))
@ -2269,7 +2271,7 @@ or they must be declared locally notinline at each call site.~@:>"
(val (funcall acc object ind)))
(list `(,acc ,object ,ind)
(if (quote-p val) `',val val)))))
(dd-slots (layout-dd (%instance-layout object))))))
(dd-slots (wrapper-dd (%instance-wrapper object))))))
#-sb-xc-host
(values `(,(if (symbolp type) 'new-instance 'allocate-instance) ,type)
(loop for slot in (sb-mop:class-slots (class-of object))
@ -2320,7 +2322,7 @@ or they must be declared locally notinline at each call site.~@:>"
(eq (second creation-form) (type-of constant))
(typep init-form '(cons (eql setf)))
(canonical-p (cdr init-form)
(dd-slots (layout-dd (%instance-layout constant)))
(dd-slots (wrapper-dd (%instance-wrapper constant)))
constant))
(values nil 'sb-fasl::fop-struct))
(t

2
src/code/deftypes-for-target.lisp
View file

@ -260,4 +260,6 @@
(sb-xc:deftype extended-function-designator ()
'(satisfies extended-function-designator-p))
#-metaspace (sb-xc:deftype sb-vm:layout () 'wrapper)
(/show0 "deftypes-for-target.lisp end of file")

16
src/code/early-class.lisp
View file

@ -88,25 +88,25 @@
(insured-find-classoid name
#'condition-classoid-p
#'make-condition-classoid)
(setf (layout-classoid layout) class)
(setf (wrapper-classoid layout) class)
(setf (classoid-direct-superclasses class)
(mapcar #'find-classoid direct-supers))
(cond ((not old-layout)
(register-layout layout))
((not *type-system-initialized*)
(setf (layout-classoid old-layout) class)
(setf (wrapper-classoid old-layout) class)
(setq layout old-layout)
(unless (eq (classoid-layout class) layout)
(unless (eq (classoid-wrapper class) layout)
(register-layout layout)))
((warn-if-altered-layout "current"
old-layout
"new"
(layout-length layout)
(layout-inherits layout)
(layout-depthoid layout)
(layout-bitmap layout))
(wrapper-length layout)
(wrapper-inherits layout)
(wrapper-depthoid layout)
(wrapper-bitmap layout))
(register-layout layout :invalidate t))
((not (classoid-layout class))
((not (classoid-wrapper class))
(register-layout layout)))
(setf (find-classoid name) class)

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

@ -17,7 +17,7 @@
;;; The DEFSTRUCT-DESCRIPTION structure holds compile-time information
;;; about a structure type.
;;; It is defined prior to LAYOUT because a LAYOUT-INFO slot
;;; It is defined prior to WRAPPER because WRAPPER-INFO
;;; is declared to hold a DEFSTRUCT-DESCRIPTION.
(def!struct (defstruct-description
(:conc-name dd-)
@ -150,9 +150,9 @@
#-metaspace
(progn
(sb-xc:defstruct (layout (:copier nil)
(sb-xc:defstruct (wrapper (:copier nil)
;; Parsing DEFSTRUCT uses a temporary layout
(:constructor make-temporary-layout
(:constructor make-temporary-wrapper
(clos-hash classoid inherits &aux (invalid nil))))
;; A packed field containing the DEPTHOID, LENGTH, and FLAGS
@ -221,7 +221,7 @@
#-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)))
(declaim (freeze-type wrapper)))
#+metaspace
(progn
@ -231,20 +231,21 @@
;;; WRAPPER since it could be reallocated with variable size.
;;; The SLOT-TABLE slot might be a good candidate for trailing tagged slots.
(sb-xc:defstruct (wrapper (:copier nil) (:constructor %make-wrapper))
;; !!! The FRIEND slot in WRAPPER *MUST* BE FIRST !!! (Wired-in assumption in genesis)
(friend nil :type sb-vm:layout)
(clos-hash (missing-arg) :type (and fixnum unsigned-byte)) ; redundant
(classoid (missing-arg) :type classoid)
(inherits #() :type simple-vector)
(equalp-impl #'equalp-err :type (sfunction (t t) boolean) :read-only t)
(slot-table #(1 nil) :type simple-vector)
(%info nil :type (or list defstruct-description))
(invalid :uninitialized :type (or cons (member nil t :uninitialized)))
(friend nil :type layout))
;;; See LAYOUT for the remarks about each slot.
(invalid :uninitialized :type (or cons (member nil t :uninitialized))))
;;; See #-metaspace structure definition for remarks about each slot.
;;; LAYOUT points to WRAPPER and vice-versa.
;;; The most common LAYOUT is 8 words.
;;; Needing >64 words would be quite unusual - the layout would have
;;; an enormous depthoid or bitmap or both.
(sb-xc:defstruct (layout (:copier nil)
(sb-xc:defstruct (sb-vm:layout (:copier nil)
;; Parsing DEFSTRUCT uses a temporary layout
(:constructor %make-temporary-layout (friend clos-hash)))
;; !!! The FRIEND slot in LAYOUT *MUST* BE FIRST !!!
@ -257,32 +258,7 @@
;; There are zero or more raw words if a type needs to store additional layout-ids,
;; and there are one or more raw words for the GC bitmap.
)
(declaim (freeze-type wrapper layout))
#-sb-xc-host
(progn
(defmacro layout-classoid (layout) `(wrapper-classoid (layout-friend ,layout)))
(defmacro layout-slot-table (layout) `(wrapper-slot-table (layout-friend ,layout)))
(defmacro layout-%info (layout) `(wrapper-%info (layout-friend ,layout)))
(defmacro layout-equalp-impl (layout) `(wrapper-equalp-impl (layout-friend ,layout)))
(defun layout-inherits (layout) (wrapper-inherits (layout-friend layout)))
(declaim (inline layout-invalid))
(defun layout-invalid (layout)
(wrapper-invalid (layout-friend layout)))
(defun (setf layout-invalid) (newval layout)
(setf (wrapper-invalid (layout-friend layout)) newval))
(defun make-temporary-layout (clos-hash classoid inherits)
(let* ((wrapper (%make-wrapper :clos-hash clos-hash :classoid classoid
:inherits inherits :invalid nil
:friend #.(find-layout t)))
(layout (%make-temporary-layout wrapper clos-hash)))
(setf (wrapper-friend wrapper) layout)
layout))))
#+(and (not metaspace) (not sb-xc-host))
(progn (defmacro layout-friend (x) x)
(defmacro wrapper-friend (x) x)
(defmacro wrapper-%info (x) `(layout-%info ,x)))
(declaim (freeze-type wrapper sb-vm:layout)))
;;; The cross-compiler representation of a LAYOUT omits several things:
;;; * BITMAP - obtainable via (DD-BITMAP (LAYOUT-INFO layout)).
@ -295,14 +271,12 @@
;;; FLAGS are computed on demand, and not stored.
#+sb-xc-host
(progn
;; As far as the host is concerned, LAYOUT and WRAPPER are always the same.
;; We need this deftype because of the DEF!STRUCT for CLASSOID which states
;; that the type of the slot named WRAPPER is WRAPPER.
#+metaspace (deftype wrapper () 'layout)
(defstruct (layout (:include structure!object)
(:constructor host-make-layout
(id clos-hash classoid &key info depthoid inherits
length invalid)))
(defstruct (wrapper (:include structure!object)
(:constructor host-make-wrapper
(id clos-hash classoid
&key ((:info %info)) depthoid inherits length invalid
#+metaspace friend)))
#+metaspace (friend)
(id nil :type (or null fixnum))
;; Cross-compiler-only translation from slot index to symbol naming
;; the accessor to call. (Since access by position is not a thing)
@ -317,30 +291,40 @@
(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-temporary-layout (clos-hash classoid inherits)
(host-make-layout nil clos-hash classoid :inherits inherits :invalid nil))
(defun layout-bitmap (layout)
(if (layout-info layout) (dd-bitmap (layout-info layout)) +layout-all-tagged+)))
(%info nil :type (or null defstruct-description)))
#+metaspace (defstruct (sb-vm:layout (:include structure!object)
(:constructor %make-layout))
friend)
(defun make-temporary-wrapper (clos-hash classoid inherits)
(host-make-wrapper nil clos-hash classoid :inherits inherits :invalid nil))
(defun wrapper-bitmap (wrapper)
(acond ((wrapper-%info wrapper) (dd-bitmap it)) (t +layout-all-tagged+))))
#+(and metaspace (not sb-xc-host))
(defmacro wrapper-flags (x) `(layout-flags (wrapper-friend ,x)))
#+(and 64-bit (not sb-xc-host))
(defun wrapper-depthoid (wrapper) (layout-depthoid (wrapper-friend wrapper)))
(defun equalp-err (a b)
(bug "EQUALP ~S ~S" a b))
(defmacro name->dd (name)
;; This wants to be a toplevel macrolet but can't be, because the body of
;; the macro (which is run in the host) wouldn't see NAME->DD as a macro
;; when expanding for the target. And it can't be a toplevel FLET because
;; that would demote the two using macros from toplevel.
`(find-defstruct-description (cond #-metaspace ((eq ,name 'sb-vm:layout) 'wrapper)
(t ,name))))
(defmacro type-dd-length (type-name) (dd-length (name->dd 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)))
(dsd-index (find slot-name (dd-slots (name->dd type-name)) :key #'dsd-name)))
;;; Applicable only if bit-packed (for 64-bit architectures)
(defmacro pack-layout-flags (depthoid length flags)
`(logior (ash ,depthoid (+ 32 sb-vm:n-fixnum-tag-bits)) (ash ,length 16) ,flags))
(defmacro type-dd-length (type-name)
(dd-length (find-defstruct-description type-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.
@ -350,6 +334,18 @@
`(ceiling (max 0 (- ,depthoid ,layout-id-vector-fixed-capacity))
,(/ sb-vm:n-word-bytes 4)))
(declaim (inline wrapper-info wrapper-dd))
(defun wrapper-info (wrapper)
(let ((info (wrapper-%info wrapper))) (unless (listp info) info)))
(defun (setf wrapper-info) (newval wrapper)
;; The current value must be nil or a defstruct-description,
;; otherwise we'd clobber a non-nil slot list.
(aver (not (consp (wrapper-%info wrapper))))
(setf (wrapper-%info wrapper) newval))
;; Use WRAPPER-DD to read WRAPPER-INFO and assert that it is non-nil.
(defun wrapper-dd (wrapper)
(the defstruct-description (wrapper-%info wrapper)))
;;; See the pictures above DD-BITMAP in src/code/defstruct for the details.
(defconstant standard-gf-primitive-obj-layout-bitmap
#+compact-instance-header 6
@ -372,21 +368,9 @@
;;; The third one also gets thrown away.
#-sb-xc-host
(progn
(declaim (inline layout-dd layout-info))
;; Use LAYOUT-DD to read LAYOUT-INFO if you want to assert that it is non-nil.
(defun layout-dd (layout)
(the defstruct-description (layout-%info layout)))
(defun layout-info (layout)
(let ((info (layout-%info layout)))
(if (%instancep info) info)))
(defun (setf layout-info) (newval layout)
;; The current value must be nil or a defstruct-description,
;; otherwise we'd clobber a non-nil slot list.
(aver (not (consp (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*))
;;; NB: for #+metaspace this returns a WRAPPER, not a LAYOUT.
(defun make-layout (clos-hash classoid
&key (depthoid -1) (length 0) (flags 0)
(inherits #())
@ -397,60 +381,69 @@
(atomic-incf (car *layout-id-generator*)))))
(unless (typep id '(and layout-id (not (eql 0))))
(error "Layout ID limit reached"))
(let* ((fixed-words (type-dd-length layout))
(let* ((fixed-words (type-dd-length sb-vm: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 extra-id-words bitmap-words))
(layout (truly-the layout
#+immobile-space
(sb-vm::alloc-immobile-fixedobj
(1+ nwords)
(logior (ash nwords sb-vm:instance-length-shift)
sb-vm:instance-widetag))
#-immobile-space (%make-instance nwords))))
(setf (%instance-layout layout) #.(find-layout 'layout))
#+metaspace
(let ((wrapper (%make-wrapper :clos-hash clos-hash :classoid classoid :%info info
:inherits inherits :invalid invalid
:friend layout)))
(setf (layout-friend layout) wrapper))
(layout
(let ((new (truly-the sb-vm:layout
#+immobile-space
(sb-vm::alloc-immobile-fixedobj
(1+ nwords)
(logior (ash nwords sb-vm:instance-length-shift)
sb-vm:instance-widetag))
#-immobile-space (%make-instance nwords))))
(setf (%instance-layout new)
(wrapper-friend #.(find-layout #+metaspace 'sb-vm:layout
#-metaspace 'wrapper)))
new))
(wrapper #+metaspace
(%make-wrapper :clos-hash clos-hash :classoid classoid
:%info info :invalid invalid :friend layout)
#-metaspace layout))
#+metaspace (setf (layout-friend layout) wrapper)
(setf (layout-flags layout) #+64-bit (pack-layout-flags depthoid length flags)
#-64-bit flags)
(setf (layout-clos-hash layout) clos-hash
(layout-classoid layout) classoid
(layout-invalid layout) invalid)
#-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 (logtest flags +structure-layout-flag+) id)
(wrapper-classoid wrapper) classoid
(wrapper-invalid wrapper) invalid)
#-64-bit (setf (wrapper-depthoid wrapper) depthoid
(wrapper-length wrapper) length)
#-metaspace (setf (wrapper-%info wrapper) info ; already set if #+metaspace
(wrapper-slot-table wrapper) #(1 nil))
(set-layout-inherits wrapper 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))))
;; It's not terribly important that we recycle layout IDs, but I have some other
;; changes planned that warrant a finalizer per layout.
;; FIXME: structure IDs should never be recycled because code blobs referencing
;; th ID do not reference the layout, and so the layout could be GCd allowing
;; reuse of an old ID for a new type.
(unless (built-in-classoid-p classoid)
(finalize layout (lambda () (atomic-push id (cdr *layout-id-generator*)))
(finalize wrapper (lambda () (atomic-push id (cdr *layout-id-generator*)))
:dont-save t))
layout))
wrapper))
(declaim (inline bitmap-nwords bitmap-all-taggedp))
(defun bitmap-nwords (layout)
(declare (layout layout))
(- (%instance-length layout) (type-dd-length layout)))
(declare (sb-vm:layout layout))
(- (%instance-length layout) (type-dd-length sb-vm:layout)))
(defun bitmap-all-taggedp (layout)
;; All bitmaps have at least 1 word; read that first.
(and (= (%raw-instance-ref/signed-word layout (type-dd-length layout))
(and (= (%raw-instance-ref/signed-word layout (type-dd-length sb-vm:layout))
+layout-all-tagged+)
;; Then check that there are no additional words.
(= (%instance-length layout) (1+ (type-dd-length layout)))))
(= (%instance-length layout) (1+ (type-dd-length sb-vm:layout)))))
(defun layout-bitmap (layout)
(acond ((layout-info layout) (dd-bitmap it))
(defun wrapper-bitmap (wrapper)
(declare (type wrapper wrapper))
(acond ((wrapper-info wrapper) (dd-bitmap it))
;; Instances lacking DD-INFO are CLOS objects, which can't generally have
;; raw slots, except that funcallable-instances may have 2 raw slots -
;; the trampoline and the layout. The trampoline can have a tag, depending
@ -458,12 +451,11 @@
;; In any event, the bitmap is always 1 word, and there are no "extra ID"
;; words preceding it.
(t (the fixnum
(%raw-instance-ref/signed-word layout (type-dd-length layout))))))
(%raw-instance-ref/signed-word (wrapper-friend wrapper)
(type-dd-length sb-vm:layout))))))
#+64-bit
;;; LAYOUT-DEPTHOID gets a vop and a stub
(defmacro layout-length (layout) ; SETFable
`(ldb (byte 16 16) (layout-flags ,layout)))
(defmacro wrapper-length (wrapper) ; SETFable
`(ldb (byte 16 16) (layout-flags (wrapper-friend ,wrapper))))
) ; end PROGN
(defconstant layout-flags-mask #xffff) ; "strictly flags" bits from the packed field
@ -471,8 +463,10 @@
;;; True of STANDARD-OBJECT, which include generic functions.
;;; This one includes any class that mixes in STANDARD-OBJECT.
(declaim (inline layout-for-pcl-obj-p))
(defun layout-for-pcl-obj-p (x)
(logtest (layout-flags x) +pcl-object-layout-flag+))
(defun layout-for-pcl-obj-p (wrapper)
(declare (type wrapper wrapper))
#-sb-xc-host (logtest (layout-flags (wrapper-friend wrapper)) +pcl-object-layout-flag+)
#+sb-xc-host (declare (ignore wrapper)))
;;; The CLASSOID structure is a supertype of all classoid types. A
;;; CLASSOID is also a CTYPE structure as recognized by the type
@ -498,11 +492,8 @@
#-sb-xc-host (:pure nil))
;; the value to be returned by CLASSOID-NAME.
(name nil :type symbol)
;; the current WRAPPER, or LAYOUT, for this classoid,
;; or NIL if none assigned yet.
;; The name of the slot is always WRAPPER even when WRAPPER = LAYOUT.
;; See doc/internals-notes/metaspace for further details.
(wrapper nil :type (or null #+metaspace wrapper #-metaspace layout))
;; the current WRAPPER for this class, or NIL if none assigned yet
(wrapper nil :type (or null wrapper))
;; How sure are we that this class won't be redefined?
;; :READ-ONLY = We are committed to not changing the effective
;; slots or superclasses.
@ -525,8 +516,12 @@
;; NIL if none assigned yet
(pcl-class nil))
(defun wrapper-classoid-name (x)
(classoid-name (wrapper-classoid x)))
#+sb-xc-host
(defun layout-flags (x)
(defun wrapper-flags (wrapper)
(declare (type wrapper wrapper))
(let ((mapping `((structure-object ,+structure-layout-flag+)
(pathname ,+pathname-layout-flag+)
(condition ,+condition-layout-flag+)
@ -535,21 +530,10 @@
(stream ,+stream-layout-flag+)
(sequence ,+sequence-layout-flag+)))
(flags 0))
(dolist (layout (cons x (coerce (layout-inherits x) 'list)) flags)
(let ((cell (assoc (layout-classoid-name layout) mapping)))
(dolist (x (cons wrapper (coerce (wrapper-inherits wrapper) 'list)) flags)
(let ((cell (assoc (wrapper-classoid-name x) mapping)))
(when cell (setq flags (logior flags (second cell))))))))
;; XC version is defined in cross-misc
#-sb-xc-host
(progn
(declaim (inline classoid-layout))
(defun classoid-layout (classoid)
#-metaspace (classoid-wrapper classoid)
#+metaspace (awhen (classoid-wrapper classoid) (wrapper-friend it))))
(defun layout-classoid-name (x)
(classoid-name (layout-classoid x)))
;;;; object types to represent classes
;;; An UNDEFINED-CLASSOID is a cookie we make up to stick in forward
@ -685,15 +669,17 @@
#-sb-xc-host
(defun id-to-layout (id)
(maphash (lambda (classoid wrapper &aux (layout (wrapper-friend wrapper)))
(declare (ignore classoid))
(when (eql (layout-id layout) id) (return-from id-to-layout layout)))
(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)
#-sb-xc-host
(defun summarize-layouts ()
(flet ((flag-bits (x) (logand (layout-flags x) #xffff)))
(flet ((flag-bits (x) (logand (layout-flags (wrapper-friend x))
layout-flags-mask)))
(let ((prev -1))
(dolist (layout (sort (loop for v being each hash-value
of (classoid-subclasses (find-classoid 't))
@ -708,47 +694,51 @@
#+sb-xc-host
(progn
(defun make-layout (hash classoid &rest keys)
(apply #'host-make-layout
(cdr (assq (classoid-name classoid) *popular-structure-types*))
hash classoid
:allow-other-keys t
keys))
;; The target reconstructs layouts using FOP-LAYOUT, but the host uses MAKE-LOAD-FORM.
(defmethod make-load-form ((layout layout) &optional env)
(macrolet ((make (&rest extra)
`(apply #'host-make-wrapper
(cdr (assq (classoid-name classoid) *popular-structure-types*))
hash classoid ,@extra :allow-other-keys t keys)))
#-metaspace (make)
#+metaspace (let* ((layout (%make-layout))
(wrapper (make :friend layout)))
(setf (layout-friend layout) wrapper)
wrapper)))
;; The target reconstructs wrappers using FOP-LAYOUT but the host uses MAKE-LOAD-FORM.
(defmethod make-load-form ((wrapper wrapper) &optional env)
(declare (ignore env))
(labels ((externalize (layout &aux (classoid (layout-classoid layout))
(name (classoid-name classoid)))
(when (or (layout-invalid layout)
(labels ((externalize (wrapper &aux (classoid (wrapper-classoid wrapper))
(name (classoid-name classoid)))
(when (or (wrapper-invalid wrapper)
(not name)
(typep classoid 'undefined-classoid))
(sb-c:compiler-error "can't dump ~S" layout))
`(xc-load-layout ',name
,(layout-depthoid layout)
(vector ,@(map 'list #'externalize (layout-inherits layout)))
,(layout-length layout)
,(layout-bitmap layout))))
(externalize layout)))
(defun xc-load-layout (name depthoid inherits length bitmap)
(sb-c:compiler-error "can't dump ~S" wrapper))
`(xc-load-wrapper ',name
,(wrapper-depthoid wrapper)
(vector ,@(map 'list #'externalize (wrapper-inherits wrapper)))
,(wrapper-length wrapper)
,(wrapper-bitmap wrapper))))
(externalize wrapper)))
(defun xc-load-wrapper (name depthoid inherits length bitmap)
(let ((classoid (find-classoid name)))
(aver (and classoid (not (undefined-classoid-p classoid))))
(let ((layout (classoid-layout classoid)))
(unless (and (= (layout-depthoid layout) depthoid)
(= (length (layout-inherits layout)) (length inherits))
(every #'eq (layout-inherits layout) inherits)
(= (layout-length layout) length)
(= (layout-bitmap layout) bitmap))
(let ((wrapper (classoid-wrapper classoid)))
(unless (and (= (wrapper-depthoid wrapper) depthoid)
(= (length (wrapper-inherits wrapper)) (length inherits))
(every #'eq (wrapper-inherits wrapper) inherits)
(= (wrapper-length wrapper) length)
(= (wrapper-bitmap wrapper) bitmap))
(error "XC can't reload layout for ~S with ~S vs ~A"
name (list depthoid inherits length bitmap) layout))
layout)))
name (list depthoid inherits length bitmap) wrapper))
wrapper)))
) ; end PROGN
(in-package "SB-C")
;;; layout for this type being used by the compiler
;;; wrapper for this type being used by the compiler
(define-info-type (:type :compiler-layout)
:type-spec (or layout null)
:type-spec (or wrapper null)
:default (lambda (name)
(awhen (find-classoid name nil) (classoid-layout it))))
(awhen (find-classoid name nil) (classoid-wrapper it))))
(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
(defun ftype-from-fdefn (name)

6
src/code/early-defmethod.lisp
View file

@ -100,7 +100,7 @@
;; which is potentially too early in cold init especially if trying
;; to debug to figure out what has been patched in.
(let ((arg-layout (if (%instancep specialized-arg)
(%instance-layout specialized-arg)
(%instance-wrapper specialized-arg)
;; Non-instance types always call a predicate.
#.(find-layout 't))))
(and (null (svref method 1)) ; only primary methods are candidates
@ -108,10 +108,10 @@
(if (fboundp guard)
(funcall guard specialized-arg)
(let ((test-layout (svref method 2)))
(and (sb-kernel::layout-p test-layout)
(and (sb-kernel::wrapper-p test-layout)
(or (eq test-layout arg-layout)
(find test-layout
(layout-inherits arg-layout))))))))))
(wrapper-inherits arg-layout))))))))))
methods)))
(if applicable-method
;; Call using no permutation-vector / no precomputed next method.

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

@ -194,10 +194,10 @@
(,bitmap ,(or bitmap-expr `(%instance-layout ,instance)))
;; Shift out 1 bit if skipping bit 0 of the 0th mask word
;; because it's not user-visible data.
(,mask (ash (%raw-instance-ref/signed-word ,bitmap (type-dd-length layout))
(,mask (ash (%raw-instance-ref/signed-word ,bitmap (type-dd-length sb-vm:layout))
(- sb-vm:instance-data-start)))
;; Start counting from the next bitmap word as we've consumed one already
(,bitmap-index (1+ (type-dd-length layout)))
(,bitmap-index (1+ (type-dd-length sb-vm:layout)))
(,bitmap-limit (%instance-length ,bitmap))
;; If this was the last word of the bitmap, then the high bit
;; is infinitely sign-extended, and we can keep right-shifting

6
src/code/early-type.lisp
View file

@ -869,7 +869,7 @@
#-sb-xc-host
(progn (declaim (inline class-classoid))
(defun class-classoid (class)
(layout-classoid (sb-pcl::class-wrapper class))))
(wrapper-classoid (sb-pcl::class-wrapper class))))
;;; Parsing of type specifiers comes in many variations:
;;; SINGLE-VALUE-SPECIFIER-TYPE:
@ -986,8 +986,8 @@
;; We don't want to create another way of representing
;; the type NULL = (MEMBER NIL), for example.
(sb-pcl::eql-specializer-to-ctype type-specifier))
((layout-p type-specifier)
(layout-classoid type-specifier))
((wrapper-p type-specifier)
(wrapper-classoid type-specifier))
(t (fail type-specifier))))))
(when (atom type-specifier)
;; Try to bypass the cache, which avoids using a cache line for standard

6
src/code/error.lisp
View file

@ -20,12 +20,12 @@
(declare (explicit-check)
(dynamic-extent arguments))
(cond ((and (%instancep datum)
(let ((layout (%instance-layout datum)))
(and (logtest +condition-layout-flag+ (layout-flags layout))
(let ((wrapper (%instance-wrapper datum)))
(and (logtest (wrapper-flags wrapper) +condition-layout-flag+)
;; An invalid layout will drop into the (MAKE-CONDITION) branch
;; which rightly fails because ALLOCATE-CONDITION asserts that
;; the first argument is a condition-designator, which it won't be.
(not (layout-invalid layout)))))
(not (wrapper-invalid wrapper)))))
(when (and arguments (not (eq fun-name 'cerror)))
(cerror "Ignore the additional arguments."
'simple-type-error

4
src/code/fop.lisp
View file

@ -159,10 +159,10 @@
(let ((res (%make-instance size)) ; number of words excluding header
;; Discount the layout from number of user-visible words.
(n-data-words (- size sb-vm:instance-data-start)))
(setf (%instance-layout res) layout)
(setf (%instance-wrapper res) layout)
(with-fop-stack ((stack (operand-stack)) ptr n-data-words)
(declare (type index ptr))
(let ((bitmap (layout-bitmap layout)))
(let ((bitmap (wrapper-bitmap layout)))
;; Values on the stack are in the same order as in the structure itself.
(do ((i sb-vm:instance-data-start (1+ i)))
((>= i size))

2
src/code/inspect.lisp
View file

@ -165,7 +165,7 @@ evaluated expressions.
(defun inspected-structure-elements (object)
(let ((parts-list '())
(info (layout-info (sb-kernel:layout-of object))))
(info (wrapper-info (sb-kernel:wrapper-of object))))
(when (sb-kernel::defstruct-description-p info)
(dolist (dd-slot (dd-slots info) (nreverse parts-list))
(push (cons (dsd-name dd-slot)

6
src/code/interr.lisp
View file

@ -325,7 +325,7 @@
(if (invalid-array-p object)
(invalid-array-error object)
(error (if (and (%instancep object)
(layout-invalid (%instance-layout object)))
(wrapper-invalid (%instance-wrapper object)))
;; Signaling LAYOUT-INVALID is dubious, but I guess it provides slightly
;; more information in that it says that the object may have at some point
;; been TYPE. Anyway, it's not wrong - it's a subtype of TYPE-ERROR.
@ -335,8 +335,8 @@
:expected-type (typecase type
(classoid-cell
(classoid-cell-name type))
(layout
(layout-proper-name type))
(wrapper
(wrapper-proper-name type))
(t
type))
:context (sb-di:error-context))))

12
src/code/last-file.lisp
View file

@ -43,8 +43,8 @@
#'string<
;; pair = (#<classoid> . #<layout>)
:key (lambda (pair) (classoid-name (car pair)))))
(let* ((layout (cdr pair))
(dd (layout-info layout)))
(let* ((wrapper (cdr pair))
(dd (wrapper-info wrapper)))
(cond
(dd
(let* ((*print-pretty* nil) ; output should be insensitive to host pprint
@ -53,10 +53,10 @@
(*package* (cl:symbol-package classoid-name)))
(format output "~/sb-ext:print-symbol-with-prefix/ ~S (~%"
classoid-name
(list* (the (unsigned-byte 16) (layout-flags layout))
(layout-depthoid layout)
(map 'list #'layout-classoid-name
(layout-inherits layout))))
(list* (the (unsigned-byte 16) (wrapper-flags wrapper))
(wrapper-depthoid wrapper)
(map 'list #'sb-kernel::wrapper-classoid-name
(wrapper-inherits wrapper))))
(dolist (dsd (dd-slots dd) (format output ")~%"))
(format output " (~d ~S ~S)~%"
(sb-kernel::dsd-bits dsd)

6
src/code/late-type.lisp
View file

@ -203,10 +203,10 @@
(specifier-type guard)))))
(return
(or (eq type2 (car x))
(let ((inherits (layout-inherits
(classoid-layout (car x)))))
(let ((inherits (wrapper-inherits
(classoid-wrapper (car x)))))
(dotimes (i (length inherits) nil)
(when (eq type2 (layout-classoid (svref inherits i)))
(when (eq type2 (wrapper-classoid (svref inherits i)))
(return t))))))))))
t))))

19
src/code/macros.lisp
View file

@ -868,7 +868,7 @@ symbol-case giving up: case=((V U) (F))
(mapcar (lambda (x) (mapcar #'find-layout x)) type-unions))
(byte (nth-value 1
(pick-best-sxhash-bits (apply #'append layout-lists)
#'layout-clos-hash 1)))
#'wrapper-clos-hash 1)))
(array (make-array (ash 1 (byte-size byte)) :initial-element nil))
(perfectp t)
(seen))
@ -877,7 +877,7 @@ symbol-case giving up: case=((V U) (F))
do (dolist (layout layout-list)
(unless (member layout seen) ; in case of dups / overlaps
(push layout seen)
(let ((bin (ldb byte (layout-clos-hash layout))))
(let ((bin (ldb byte (wrapper-clos-hash layout))))
(when (aref array bin)
(setq perfectp nil))
(setf (aref array bin)
@ -900,17 +900,19 @@ symbol-case giving up: case=((V U) (F))
0
(let* ((layout (%instance-layout ,object))
(index (ldb ,byte (layout-clos-hash layout)))
;; Compare by WRAPPER, not LAYOUT. LAYOUTs can't go in a simple-vector.
(wrapper (layout-friend layout))
(cells ,cells))
(declare (optimize (safety 0)))
(the (mod ,(1+ (length cases)))
,(if perfectp
`(if (eq (aref cells index) layout) (aref cells (+ index ,n-pairs)) 0)
`(if (eq (aref cells index) wrapper) (aref cells (+ index ,n-pairs)) 0)
;; DOLIST performs a leading test, but we're OK with a cell
;; that is NIL. It'll miss and then exit at the end of the loop.
;; This potentially avoids one comparison vs NIL if we hit immediately.
`(let ((list (svref cells index)))
(loop (let ((cell (car list)))
(cond ((eq layout (car cell)) (return (cdr cell)))
(cond ((eq wrapper (car cell)) (return (cdr cell)))
((null (setq list (cdr list))) (return 0))))))))))))
;;; Given an arbitrary TYPECASE, see if it is a discriminator over
@ -2262,3 +2264,12 @@ Works on all CASable places."
(loop (let ((,new (cdr ,old)))
(when (eq ,old (setf ,old ,cas-form))
(return (car (truly-the list ,old)))))))))
#-metaspace
(progn
(sb-xc:defmacro wrapper-friend (x) x)
(sb-xc:defmacro layout-friend (x) x)
(sb-xc:defmacro layout-clos-hash (x) `(wrapper-clos-hash ,x))
#-64-bit (sb-xc:defmacro layout-depthoid (x) `(wrapper-depthoid ,x))
(sb-xc:defmacro layout-flags (x) `(wrapper-flags ,x))
)

4
src/code/pathname.lisp
View file

@ -76,7 +76,7 @@
(let ((to (find-layout 'logical-pathname))
(from (find-layout 'pathname)))
(setf (layout-info to) (layout-info from)
(layout-slot-table to) (layout-slot-table from)))
(setf (wrapper-info to) (wrapper-info from)
(wrapper-slot-table to) (wrapper-slot-table from)))
(declaim (inline logical-pathname-p))
(defun logical-pathname-p (x) (typep x 'logical-pathname))

2
src/code/pprint.lisp
View file

@ -780,7 +780,7 @@ line break."
(or (and (eq (info :type :kind type-spec) :instance)
(let ((layout (info :type :compiler-layout type-spec)))
(and layout
(let ((info (layout-info layout)))
(let ((info (wrapper-info layout)))
(and info
(let ((pred (dd-predicate-name info)))
(and pred (fboundp pred)

39
src/code/pred.lisp
View file

@ -163,8 +163,10 @@
;; This vector is allocated in immobile space when possible. There isn't
;; a way to do that from lisp, so it's special-cased in genesis.
#-immobile-space (setq **primitive-object-layouts** (make-array 256))
;; If #+metaspace, we can't generally store layouts in heap objects except in
;; the instance header, but this vector can because it too will go in metaspace.
(map-into **primitive-object-layouts**
(lambda (name) (classoid-layout (find-classoid name)))
(lambda (name) (wrapper-friend (classoid-wrapper (find-classoid name))))
#.(let ((table (make-array 256 :initial-element 'sb-kernel::random-class)))
(dolist (x sb-kernel::*builtin-classoids*)
(destructuring-bind (name &key codes &allow-other-keys) x
@ -188,25 +190,26 @@
;;; the vector of layouts in the constant pool of the containing code.
#-(and compact-instance-header x86-64)
(progn
(declaim (inline layout-of))
(defun layout-of (x)
(declaim (inline wrapper-of))
(defun wrapper-of (x)
(declare (optimize (speed 3) (safety 0)))
(cond ((%instancep x) (%instance-layout x))
((funcallable-instance-p x) (%fun-layout x))
(cond ((%instancep x) (%instance-wrapper x))
((funcallable-instance-p x) (%fun-wrapper x))
;; Compiler can dump literal layouts, which handily sidesteps
;; the question of when cold-init runs L-T-V forms.
((null x) #.(find-layout 'null))
(t
;; Note that WIDETAG-OF is slightly suboptimal here and could be
;; improved - we've already ruled out some of the lowtags.
(svref (load-time-value **primitive-object-layouts** t)
(widetag-of x))))))
(layout-friend
(svref (load-time-value **primitive-object-layouts** t)
(widetag-of x)))))))
(declaim (inline classoid-of))
(defun classoid-of (object)
"Return the class of the supplied object, which may be any Lisp object, not
just a CLOS STANDARD-OBJECT."
(layout-classoid (layout-of object)))
(wrapper-classoid (wrapper-of object)))
;;; Return the specifier for the type of object. This is not simply
;;; (TYPE-SPECIFIER (CTYPE-OF OBJECT)) because CTYPE-OF has different
@ -255,14 +258,19 @@
(type-specifier (ctype-of object)))
(simple-fun 'compiled-function)
(t
(let ((layout (layout-of object)))
(when (= (get-lisp-obj-address layout) 0)
;; [fun-]instances momentarily have no layout in any code interrupted
;; just after allocating and before assigning slots.
;; OUTPUT-UGLY-OBJECT has a similar precaution as this.
#+metaspace ; WRAPPER-OF can't be called on layoutless objects.
(unless (logtest (get-lisp-obj-address (%instanceoid-layout object))
sb-vm:widetag-mask)
;; [fun-]instances momentarily have no layout in any code interrupted
;; just after allocating and before assigning slots.
;; OUTPUT-UGLY-OBJECT has a similar precaution as this.
(return-from type-of (if (functionp object) 'funcallable-instance 'instance)))
(let ((wrapper (wrapper-of object)))
#-metaspace ; already checked for a good layout if metaspace
(when (= (get-lisp-obj-address wrapper) 0)
(return-from type-of
(if (functionp object) 'funcallable-instance 'instance)))
(let* ((classoid (layout-classoid layout))
(let* ((classoid (wrapper-classoid wrapper))
(name (classoid-name classoid)))
;; FIXME: should the first test be (not (or (%instancep) (%funcallable-instance-p)))?
;; God forbid anyone makes anonymous classes of generic functions.
@ -555,7 +563,8 @@ length and have identical components. Other arrays must be EQ to be EQUAL."
(and (logtest (logior +structure-layout-flag+ +pathname-layout-flag+)
(layout-flags layout))
(eq (%instance-layout y) layout)
(funcall (layout-equalp-impl layout) x y)))))
(funcall (wrapper-equalp-impl (layout-friend layout))
x y)))))
((arrayp x)
(and (arrayp y)
;; string-equal is nearly 2x the speed of array-equalp for comparing strings

5
src/code/print.lisp
View file

@ -378,11 +378,12 @@ variable: an unreadable object representing the error is printed instead.")
(return-from output-ugly-object
(print-unreadable-object (object stream :identity t)
(prin1 'instance stream))))
(let ((classoid (layout-classoid layout)))
(let* ((wrapper (layout-friend layout))
(classoid (wrapper-classoid wrapper)))
;; Additionally, don't crash if the object is an obsolete thing with
;; no update protocol.
(when (or (sb-kernel::undefined-classoid-p classoid)
(and (layout-invalid layout)
(and (wrapper-invalid wrapper)
(logtest (layout-flags layout)
(logior +structure-layout-flag+
+condition-layout-flag+))))

28
src/code/room.lisp
View file

@ -777,9 +777,9 @@ We could try a few things to mitigate this:
(eql type funcallable-instance-widetag))
(incf total-objects)
(let* ((layout (if (eql type funcallable-instance-widetag)
(%fun-layout obj)
(%instance-layout obj)))
(classoid (layout-classoid layout))
(%fun-wrapper obj)
(%instance-wrapper obj)))
(classoid (wrapper-classoid layout))
(found (ensure-gethash classoid totals (cons 0 0)))
(size size))
(declare (fixnum size))
@ -1073,7 +1073,7 @@ We could try a few things to mitigate this:
;; both tricky and unnecessary to generalize iteration.
;; So just hardcode the few cases that exist.
#+compact-instance-header
(ecase (layout-bitmap (%fun-layout ,obj))
(ecase (wrapper-bitmap (%fun-wrapper ,obj))
(-1 ; external trampoline, all slots are tagged
;; In this case, the trampoline word is scanned, with no ill effect.
(loop for .i. from 0
@ -1087,7 +1087,7 @@ We could try a few things to mitigate this:
(,functoid (%funcallable-instance-info ,obj 0) ,@more)))
#-compact-instance-header
(progn
(aver (eql (layout-bitmap (%fun-layout ,obj)) -4))
(aver (eql (wrapper-bitmap (%fun-wrapper ,obj)) -4))
;; v ----trampoline
;; = #b1...1100
;; ^----- layout
@ -1496,10 +1496,10 @@ We could try a few things to mitigate this:
(map-code-objects #'visit)))
(defun show-all-layouts ()
(let ((l (sb-vm::list-allocated-objects :all :test #'sb-kernel::layout-p))
(let ((l (sb-vm::list-allocated-objects :all :test #'sb-kernel::wrapper-p))
zero trailing-raw trailing-tagged vanilla)
(dolist (x l)
(let ((m (sb-kernel::layout-bitmap x)))
(let ((m (wrapper-bitmap x)))
(cond ((eql m +layout-all-tagged+) (push x vanilla))
((eql m 0) (push x zero))
((minusp m) (push x trailing-tagged))
@ -1510,22 +1510,22 @@ We could try a few things to mitigate this:
(format t "~A~%~A~%" s (make-string (length s) :initial-element #\-)))))
(when zero
(legend nil "Zero bitmap (~d):" zero)
(dolist (x zero) (format t "~a~%" (layout-classoid-name x))))
(dolist (x zero) (format t "~a~%" (wrapper-classoid-name x))))
(when trailing-raw
(legend t "Trailing raw (~d):" trailing-raw)
(dolist (x trailing-raw)
(let ((m (sb-kernel::layout-bitmap x)))
(let ((m (wrapper-bitmap x)))
(format t "~30a 0...~v,'0b~%"
(layout-classoid-name x)
(acond ((layout-info x) (1+ (dd-length it))) (t 32))
(wrapper-classoid-name x)
(acond ((wrapper-info x) (1+ (dd-length it))) (t 32))
m))))
(when trailing-tagged
(legend t "Trailing tagged (~d):" trailing-tagged)
(dolist (x trailing-tagged)
(let ((m (sb-kernel::layout-bitmap x)))
(let ((m (wrapper-bitmap x)))
(format t "~30a 1...~b~%"
(layout-classoid-name x)
(acond ((layout-info x) (ldb (byte (dd-length it) 0) m))
(wrapper-classoid-name x)
(acond ((wrapper-info x) (ldb (byte (dd-length it) 0) m))
(t (ldb (byte 32 0) m)))))))
(legend t "Default: (~d) [not shown]" vanilla))))

2
src/code/sharpm.lisp
View file

@ -303,7 +303,7 @@
(i sb-vm:instance-data-start (1+ i)))
((>= i len))
(process (%instance-ref tree i)))
(let ((dd (layout-dd (%instance-layout tree))))
(let ((dd (wrapper-dd (%instance-wrapper tree))))
(dolist (dsd (dd-slots dd))
(when (eq (dsd-raw-type dsd) t)
(process (%instance-ref tree (dsd-index dsd))))))))

6
src/code/stream.lisp
View file

@ -1330,7 +1330,7 @@
;;; dx allocation of structures, this'll have to do.
(defun %init-string-input-stream (stream string &optional (start 0) end)
(declare (string string))
(setf (%instance-layout (truly-the instance stream))
(setf (%instance-wrapper (truly-the instance stream))
#.(find-layout 'string-input-stream))
(macrolet ((initforms ()
`(setf
@ -1402,7 +1402,7 @@
(declare (optimize speed (sb-c::verify-arg-count 0)))
(declare (string buffer)
(ignorable wild-result-type)) ; if #-sb-unicode
(setf (%instance-layout (truly-the instance stream)) #.(find-layout 'string-output-stream))
(setf (%instance-wrapper (truly-the instance stream)) #.(find-layout 'string-output-stream))
(macrolet ((initforms ()
`(setf ,@(mapcan (lambda (dsd)
(list `(%instance-ref stream ,(dsd-index dsd))
@ -1900,7 +1900,7 @@ benefit of the function GET-OUTPUT-STREAM-STRING."
(unless (and (stringp string)
(array-has-fill-pointer-p string))
(error "~S is not a string with a fill-pointer" string))
(setf (%instance-layout (truly-the instance stream))
(setf (%instance-wrapper (truly-the instance stream))
#.(find-layout 'fill-pointer-output-stream))
(macrolet ((initforms ()
`(setf ,@(mapcan (lambda (dsd)

10
src/code/stubs.lisp
View file

@ -86,20 +86,22 @@
(def %make-instance) ; Allocate a new instance with X data slots.
(def %instance-length) ; Given an instance, return its length.
(def %instance-layout)
(def %instance-wrapper)
(def %set-instance-layout (instance new-value))
; (def %instance-ref (instance index)) ; defined in 'target-defstruct'
(def %instance-set (instance index new-value))
;; funcallable instances
(def %make-funcallable-instance)
(def %fun-layout)
(def %fun-wrapper)
(def %set-fun-layout (fin new-value))
(def %funcallable-instance-fun)
(def (setf %funcallable-instance-fun) (fin new-value))
(def %funcallable-instance-info (fin i))
(def %set-funcallable-instance-info (fin i new-value))
#+compact-instance-header (progn (def layout-of)
#+compact-instance-header (progn (def wrapper-of)
(def %instanceoid-layout))
#+64-bit (def layout-depthoid)
;; lists
(def %rplaca (x val))
(def %rplacd (x val))
@ -154,8 +156,8 @@
;;; I shouid add a vop for uint32 access to raw slots.
(defun sb-c::%structure-is-a (object-layout test-layout)
(or (eq object-layout test-layout)
(let ((depthoid (layout-depthoid test-layout))
(inherits (layout-inherits object-layout)))
(let ((depthoid (wrapper-depthoid test-layout))
(inherits (wrapper-inherits object-layout)))
(and (> (length inherits) depthoid)
(eq (svref inherits depthoid) test-layout)))))

71
src/code/target-defstruct.lisp
View file

@ -13,13 +13,22 @@
;;;; structure frobbing primitives
#+metaspace
(defun make-temporary-wrapper (clos-hash classoid inherits)
(let* ((layout (%make-temporary-layout #.(find-layout t) clos-hash))
(wrapper (%make-wrapper :clos-hash clos-hash :classoid classoid
:inherits inherits :invalid nil
:friend layout)))
(setf (layout-friend layout) wrapper)
wrapper))
;;; This allocator is used by the expansion of MAKE-LOAD-FORM-SAVING-SLOTS
;;; when given a STRUCTURE-OBJECT.
(defun allocate-struct (type)
(let* ((layout (classoid-layout (the structure-classoid (find-classoid type))))
(structure (%make-instance (layout-length layout))))
(setf (%instance-layout structure) layout)
(dolist (dsd (dd-slots (layout-dd layout)) structure)
(let* ((wrapper (classoid-wrapper (the structure-classoid (find-classoid type))))
(structure (%make-instance (wrapper-length wrapper))))
(setf (%instance-wrapper structure) wrapper)
(dolist (dsd (dd-slots (wrapper-dd wrapper)) structure)
(when (eq (dsd-raw-type dsd) 't)
(setf (%instance-ref structure (dsd-index dsd)) (make-unbound-marker))))))
@ -40,21 +49,22 @@
;; their ancestors in the vector; they only store self-id at index 0.
;; This isn't performance-critical. If it were, then we should store self-ID
;; at a fixed index. Using it for type-based dispatch remains a possibility.
(let* ((depth (- (layout-depthoid layout) 2))
(let* ((layout (cond #+metaspace ((typep layout 'wrapper) (wrapper-friend layout))
(t layout)))
(depth (- (sb-vm::layout-depthoid layout) 2))
(index (if (or (< depth 0) (not (logtest (layout-flags layout)
+structure-layout-flag+)))
0 depth)))
(truly-the layout-id
#-64-bit
(%raw-instance-ref/signed-word
layout (+ (get-dsd-index layout id-word0) index))
#-64-bit (%raw-instance-ref/signed-word
layout (+ (get-dsd-index sb-vm:layout id-word0) index))
#+64-bit ; use SAP-ref for lack of half-sized slots
(with-pinned-objects (layout)
(signed-sap-ref-32 (bitmap-sap) (ash index 2))))))
(defun set-layout-inherits (layout inherits structurep this-id)
#-metaspace (setf (layout-inherits layout) inherits)
#+metaspace (setf (wrapper-inherits (layout-friend layout)) inherits)
(defun set-layout-inherits (wrapper inherits structurep this-id
&aux (layout (wrapper-friend wrapper)))
(setf (wrapper-inherits wrapper) 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
@ -85,7 +95,7 @@
(let ((instance (%make-instance (dd-length dd))) ; length = sans header word
(value-index 0))
(declare (index value-index))
(setf (%instance-layout instance) (dd-layout-or-lose dd))
(setf (%instance-wrapper instance) (dd-layout-or-lose dd))
(dolist (spec slot-specs instance)
(destructuring-bind (kind raw-type . index) spec
(if (eq kind :unbound)
@ -115,15 +125,11 @@
;;; the part of %DEFSTRUCT which makes sense only on the target SBCL
;;;
(defmacro set-layout-equalp-impl (layout newval)
`(setf #-metaspace (%instance-ref ,layout
(get-dsd-index layout equalp-impl))
#+metaspace (%instance-ref (layout-friend ,layout)
(get-dsd-index wrapper equalp-impl))
,newval))
(defmacro set-wrapper-equalp-impl (wrapper newval)
`(setf (%instance-ref ,wrapper (get-dsd-index wrapper equalp-impl)) ,newval))
(defun assign-equalp-impl (type-name function)
(set-layout-equalp-impl (find-layout type-name) function))
(set-wrapper-equalp-impl (find-layout type-name) function))
(defun %target-defstruct (dd equalp)
(declare (type defstruct-description dd))
@ -133,8 +139,8 @@
(dd-doc dd)))
(let ((classoid (find-classoid (dd-name dd))))
(let ((layout (classoid-layout classoid)))
(set-layout-equalp-impl
(let ((layout (classoid-wrapper classoid)))
(set-wrapper-equalp-impl
layout
(cond ((compiled-function-p equalp) equalp)
((eql (dd-bitmap dd) +layout-all-tagged+) #'sb-impl::instance-equalp)
@ -172,8 +178,8 @@
(defun copy-structure (structure)
"Return a copy of STRUCTURE with the same (EQL) slot values."
(declare (type structure-object structure))
(let ((layout (%instance-layout structure)))
(when (layout-invalid layout)
(let ((wrapper (%instance-wrapper structure)))
(when (wrapper-invalid wrapper)
(error "attempt to copy an obsolete structure:~% ~S" structure))
;; Previously this had to used LAYOUT-LENGTH in the allocation,
;; to avoid copying random bits from the stack to the heap if you had a
@ -184,7 +190,7 @@
(let* ((len (%instance-length structure))
(res (%make-instance len)))
(declare (type index len))
(let ((bitmap (dd-bitmap (layout-dd layout))))
(let ((bitmap (dd-bitmap (wrapper-dd wrapper))))
;; Don't assume that %INSTANCE-REF can access the layout.
(setf (%instance-layout res) (%instance-layout structure))
;; On backends which don't segregate descriptor vs. non-descriptor
@ -222,6 +228,12 @@
(loop for i from sb-vm:instance-data-start below (%instance-length to)
do (setf (%instance-ref to i) (%instance-ref from i)))
to)
(defun (setf %instance-wrapper) (newval x)
(setf (%instance-layout x) (wrapper-friend newval))
newval)
(defun (setf %fun-wrapper) (newval x)
(setf (%fun-layout x) (wrapper-friend newval))
newval)
;;; default PRINT-OBJECT method
@ -279,9 +291,9 @@
(declare (ignore depth))
(if (funcallable-instance-p structure)
(print-unreadable-object (structure stream :identity t :type t))
(let* ((layout (%instance-layout structure))
(dd (layout-info layout))
(name (layout-classoid-name layout)))
(let* ((wrapper (%instance-wrapper structure))
(dd (wrapper-info wrapper))
(name (wrapper-classoid-name wrapper)))
(cond ((not dd)
;; FIXME? this branch may be unnecessary as a consequence
;; of change f02bee325920166b69070e4735a8a3f295f8edfd which
@ -331,5 +343,10 @@
,(+ (- sb-vm:instance-pointer-lowtag)
(* (+ sb-vm:instance-slots-offset index)
sb-vm:n-word-bytes))))))))
#+metaspace
(defmethod print-object ((self sb-vm:layout) stream)
(print-unreadable-object (self stream :type t :identity t)
(write (layout-id self) :stream stream)))
(/show0 "target-defstruct.lisp end of file")

2
src/code/target-pathname.lisp
View file

@ -337,7 +337,7 @@
(or (gethash key table)
(let ((key (!allocate-pathname host device dir+hash name type version)))
(when (typep host 'logical-host)
(setf (%instance-layout key) #.(find-layout 'logical-pathname)))
(setf (%instance-wrapper key) #.(find-layout 'logical-pathname)))
(setf (gethash key table) key)))))))
;;; Vector of logical host objects, each of which contains its translations.

10
src/code/target-sxhash.lisp
View file

@ -97,7 +97,7 @@
;; It would probably be simple to eliminate this as a special case
;; by ensuring that instances of LAYOUT commence life with a trailing
;; hash slot and the SB-VM:HASH-SLOT-PRESENT-FLAG set.
(when (typep instance 'layout)
(when (typep instance 'sb-vm:layout)
;; This might be wrong if the clos-hash was clobbered to 0
(return-from %instance-sxhash (layout-clos-hash instance)))
;; Non-simple cases: no hash slot, and either unhashed or hashed-not-moved.
@ -348,7 +348,7 @@
(logxor 72185131
(sxhash (char-code x)))) ; through DEFTRANSFORM
(funcallable-instance
(if (layout-for-pcl-obj-p (%fun-layout x))
(if (logtest (layout-flags (%fun-layout x)) +pcl-object-layout-flag+)
;; We have a hash code, so might as well use it.
(fsc-instance-hash x)
;; funcallable structure, not funcallable-standard-object
@ -444,13 +444,13 @@
(let ((cplx (%raw-instance-ref/complex-double key i)))
,(mix-float '(realpart cplx) $0d0)
,(mix-float '(imagpart cplx) $0d0)))))))
(let* ((layout (%instance-layout key))
(result (layout-clos-hash layout)))
(let* ((wrapper (%instance-wrapper key))
(result (wrapper-clos-hash wrapper)))
(declare (type fixnum result))
(when (plusp depthoid)
(let ((max-iterations depthoid)
(depthoid (1- depthoid))
(dd (layout-dd layout)))
(dd (wrapper-dd wrapper)))
(declare (index max-iterations))
(if (/= (sb-kernel::dd-bitmap dd) +layout-all-tagged+)
(let ((slots (dd-slots dd)))

32
src/code/typep.lisp
View file

@ -86,7 +86,7 @@
(funcall (built-in-classoid-predicate type) object)
(and (or (%instancep object)
(functionp object))
(classoid-typep (layout-of object) type object))))
(classoid-typep (wrapper-of object) type object))))
(union-type
(some (lambda (union-type-type) (recurse object union-type-type))
(union-type-types type)))
@ -154,9 +154,8 @@
(block nil
(classoid-typep
(typecase object
(instance (%instance-layout object))
(funcallable-instance
(%fun-layout object))
(instance (%instance-wrapper object))
(funcallable-instance (%fun-wrapper object))
(t (return)))
(cdr (truly-the cons cache))
object)))
@ -178,7 +177,7 @@
(unless classoid
(error "The class ~S has not yet been defined."
(classoid-cell-name cell)))
(classoid-typep layout classoid object)))
(classoid-typep (layout-friend layout) classoid object)))
;;; Return true of any object which is either a funcallable-instance,
;;; or an ordinary instance that is not a structure-object.
@ -196,9 +195,9 @@
;;; Try to ensure that the object's layout is up-to-date only if it is an instance
;;; or funcallable-instance of other than a static or structure classoid type.
(defun update-object-layout (object)
(if (%pcl-instance-p object)
(sb-pcl::check-wrapper-validity object)
(layout-of object)))
(wrapper-friend (if (%pcl-instance-p object)
(sb-pcl::check-wrapper-validity object)
(wrapper-of object))))
;;; Test whether OBJ-LAYOUT is from an instance of CLASSOID.
@ -230,6 +229,7 @@
;;; of thousands of iterations of 'classoid-typep.impure.lisp'
(defun classoid-typep (obj-layout classoid object)
(declare (type wrapper obj-layout))
;; FIXME & KLUDGE: We could like to grab the *WORLD-LOCK* here (to ensure that
;; class graph doesn't change while we're doing the typep test), but in
;; practice that causes trouble -- deadlocking against the compiler
@ -244,24 +244,24 @@
;; that we're testing against. Whether obj-layout is "valid" has no relevance.
;; This is racy though because %ENSURE-CLASSOID-VALID should return
;; the most up-to-date layout for the classoid, but it doesn't. Oh well.
(%ensure-classoid-valid classoid (classoid-layout classoid) "typep")
(values obj-layout (classoid-layout classoid)))
(%ensure-classoid-valid classoid (classoid-wrapper classoid) "typep")
(values obj-layout (classoid-wrapper classoid)))
(t
;; And this case is even more racy, naturally.
(do ((layout (classoid-layout classoid) (classoid-layout classoid))
(do ((layout (classoid-wrapper classoid) (classoid-wrapper classoid))
(i 0 (+ i 1))
(obj-layout obj-layout))
((and (not (layout-invalid obj-layout))
(not (layout-invalid layout)))
((and (not (wrapper-invalid obj-layout))
(not (wrapper-invalid layout)))
(values obj-layout layout))
(aver (< i 2))
(%ensure-classoid-valid classoid layout "typep")
(when (zerop (layout-clos-hash obj-layout))
(when (zerop (wrapper-clos-hash obj-layout))
(setq obj-layout (sb-pcl::check-wrapper-validity object))))))
;; FIXME: if LAYOUT is for a structure, use the STRUCTURE-IS-A test
;; which avoids iterating.
(or (eq obj-layout layout)
(let ((obj-inherits (layout-inherits obj-layout)))
(let ((obj-inherits (wrapper-inherits obj-layout)))
(dotimes (i (length obj-inherits) nil)
(when (eq (svref obj-inherits i) layout)
(return t)))))))
@ -301,7 +301,7 @@
(if (if (csubtypep type (specifier-type 'function))
(funcallable-instance-p obj)
(%instancep obj))
(if (eq (classoid-layout type)
(if (eq (classoid-wrapper type)
(info :type :compiler-layout (classoid-name type)))
(values (sb-xc:typep obj type) t)
(values nil nil))

2
src/code/warm-error.lisp
View file

@ -44,7 +44,7 @@
(superclassoid-name (classoid-name super)))
;; CONDITION is necessarily an INSTANCE,
;; but pedantry requires it be the right subtype of instance.
(unless (classoid-typep (%instance-layout condition)
(unless (classoid-typep (%instance-wrapper condition)
super condition)
(error 'simple-type-error
:datum datum :expected-type superclassoid-name

2
src/code/x86-64-vm.lisp
View file

@ -197,7 +197,7 @@
;; Assert that raw bytes will not cause GC invariant lossage
(aver (not (sb-kernel::bitmap-all-taggedp layout)))
;; Set layout prior to writing raw slots
(setf (%fun-layout gf) layout)
(setf (%fun-wrapper gf) layout)
;; just being pedantic - liveness is preserved by the stack reference.
(with-pinned-objects (gf)
(let* ((addr (logandc2 (get-lisp-obj-address gf) lowtag-mask))

2
src/cold/shared.lisp
View file

@ -782,7 +782,7 @@
((and structure-object (not package))
(let ((type-name (string (type-of x))))
;; This "LAYOUT" refers to *our* object, not host-sb-kernel:layout.
(unless (member type-name '("LAYOUT" "FLOAT" "COMPLEXNUM")
(unless (member type-name '("WRAPPER" "LAYOUT" "FLOAT" "COMPLEXNUM")
:test #'string=)
;(Format t "visit a ~/host-sb-ext:print-symbol-with-prefix/~%" (type-of x))
;; This generalizes over any structure. I need it because we

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

@ -70,7 +70,7 @@
(:generator 4
(let ((test-id (layout-id test-layout))
(offset (+ (bitmap-bits-offset)
(ash (- (layout-depthoid test-layout) 2) 2)
(ash (- (wrapper-depthoid test-layout) 2) 2)
(- instance-pointer-lowtag))))
(inst ldr this-id (@ x offset))
;; 8-bit IDs are permanently assigned, so no fixup ever needed for those.

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

@ -87,7 +87,7 @@
(:generator 4
(let ((test-id (layout-id test-layout))
(offset (+ (bitmap-bits-offset)
(ash (- (layout-depthoid test-layout) 2) 2)
(ash (- (wrapper-depthoid test-layout) 2) 2)
(- instance-pointer-lowtag))))
(declare (ignorable test-id))
(inst ldr (32-bit-reg this-id) (@ x offset))

43
src/compiler/dump.lisp
View file

@ -448,8 +448,8 @@
((not (similar-check-table x file))
(dump-list x file t)
(similar-save-object x file))))
(layout
(dump-layout x file)
(wrapper
(dump-wrapper x file)
(eq-save-object x file))
#+sb-xc-host
(ctype
@ -573,6 +573,7 @@
;;; We peek at the object type so that we only pay the circular
;;; detection overhead on types of objects that might be circular.
(defun dump-object (x file)
#+(and metaspace sb-xc-host) (when (cl:typep x 'sb-vm:layout) (error "can't dump sb-vm:layout"))
(if (compound-object-p x)
(let ((*circularities-detected* ())
(circ (fasl-output-circularity-table file)))
@ -1054,8 +1055,14 @@
(ecase flavor
(:code-object (the null name))
(:layout
(if (symbolp name) name (layout-classoid-name name)))
(:layout-id (the layout name))
(if (symbolp name)
name
(wrapper-classoid-name
(cond #+metaspace
((sb-kernel::layout-p name) (layout-friend name))
(t name)))))
(:layout-id
(the wrapper name))
((:assembly-routine :assembly-routine* :asm-routine-nil-offset
:symbol-tls-index
;; Only #+immobile-space can use the following two flavors.
@ -1315,12 +1322,12 @@
struct))
(note-potential-circularity struct file)
(do* ((length (%instance-length struct))
(layout (%instance-layout struct))
(bitmap (layout-bitmap layout))
(wrapper (%instance-wrapper struct))
(bitmap (wrapper-bitmap wrapper))
(circ (fasl-output-circularity-table file))
(index sb-vm:instance-data-start (1+ index)))
((>= index length)
(dump-non-immediate-object layout file)
(dump-non-immediate-object wrapper file)
(dump-fop 'fop-struct file length))
(let* ((obj (if (logbitp index bitmap)
(%instance-ref struct index)
@ -1337,14 +1344,14 @@
(t obj))
file))))
(defun dump-layout (obj file)
(when (layout-invalid obj)
(defun dump-wrapper (obj file &aux (flags (wrapper-flags obj)))
(when (wrapper-invalid obj)
(compiler-error "attempt to dump reference to obsolete class: ~S"
(layout-classoid obj)))
(wrapper-classoid obj)))
;; STANDARD-OBJECT could in theory be dumpable, but nothing else,
;; because all its subclasses can evolve to have new layouts.
(aver (not (logtest (layout-flags obj) +pcl-object-layout-flag+)))
(let ((name (layout-classoid-name obj)))
(aver (not (logtest flags +pcl-object-layout-flag+)))
(let ((name (wrapper-classoid-name obj)))
;; Q: Shouldn't we aver that NAME is the proper name for its classoid?
(unless name
(compiler-error "dumping anonymous layout: ~S" obj))
@ -1354,11 +1361,11 @@
#-sb-xc-host
(let ((fop (known-layout-fop name)))
(when fop
(return-from dump-layout (dump-byte fop file))))
(return-from dump-wrapper (dump-byte fop file))))
(dump-object name file))
(sub-dump-object (layout-bitmap obj) file)
(sub-dump-object (layout-inherits obj) file)
(sub-dump-object (wrapper-bitmap obj) file)
(sub-dump-object (wrapper-inherits obj) file)
(dump-fop 'fop-layout file
(1+ (layout-depthoid obj)) ; non-stack args can't be negative
(logand (layout-flags obj) sb-kernel::layout-flags-mask)
(layout-length obj)))
(1+ (wrapper-depthoid obj)) ; non-stack args can't be negative
(logand flags sb-kernel::layout-flags-mask)
(wrapper-length obj)))

10
src/compiler/fndb.lisp
View file

@ -98,10 +98,10 @@
(defknown find-classoid (name-for-class &optional t)
(or classoid null) ())
(defknown classoid-of (t) classoid (flushable))
(defknown layout-of (t) layout (flushable))
#+64-bit (defknown layout-depthoid (layout) layout-depthoid (flushable always-translatable))
#+(or x86 x86-64) (defknown (layout-depthoid-ge)
(layout integer) boolean (flushable))
(defknown wrapper-of (t) wrapper (flushable))
(defknown wrapper-depthoid (wrapper) layout-depthoid (flushable))
#+64-bit (defknown layout-depthoid (sb-vm:layout) layout-depthoid (flushable always-translatable))
#+(or x86 x86-64) (defknown (layout-depthoid-ge) (sb-vm:layout integer) boolean (flushable))
(defknown %structure-is-a (instance t) boolean (foldable flushable))
(defknown copy-structure (structure-object) structure-object
(flushable)
@ -1769,7 +1769,7 @@
;;; We can't fold this in general because of SATISFIES. There is a
;;; special optimizer anyway.
(defknown %typep (t (or type-specifier ctype)) boolean (movable flushable))
(defknown %instance-typep (t (or type-specifier ctype layout)) boolean
(defknown %instance-typep (t (or type-specifier ctype wrapper)) boolean
(movable flushable always-translatable))
;;; We should never emit a call to %typep-wrapper
(defknown %typep-wrapper (t t (or type-specifier ctype)) t

2
src/compiler/fopcompile.lisp
View file

@ -260,7 +260,7 @@
#+sb-simd-pack-256 simd-pack-256))
;; STANDARD-OBJECT layouts use MAKE-LOAD-FORM, but all other layouts
;; have the same status as symbols - composite objects but leaflike.
(and (typep obj 'layout) (not (layout-for-pcl-obj-p obj)))
(and (typep obj 'wrapper) (not (layout-for-pcl-obj-p obj)))
;; The cross-compiler wants to dump CTYPE instances as leaves,
;; but CLASSOIDs are excluded since they have a MAKE-LOAD-FORM method.
#+sb-xc-host (cl:typep obj '(and ctype (not classoid)))

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

@ -1090,7 +1090,7 @@ core and return a descriptor to it."
(acond ((gethash class-name *cold-layouts*)
(cold-layout-depthoid it))
((info :type :compiler-layout class-name)
(layout-depthoid it))
(wrapper-depthoid it))
(t
(error "Unknown depthoid for ~S" class-name))))))
@ -1171,8 +1171,8 @@ core and return a descriptor to it."
(case name
((t) 0)
(structure-object 1)
(sb-kernel::wrapper 2)
(layout 3)
#+metaspace (wrapper 2)
(#+metaspace sb-vm:layout #-metaspace wrapper 3)
(sb-lockless::list-node 4)
(t (or (cdr (assq name sb-kernel::*popular-structure-types*))
(ecase sb-kernel::layout-id-type
@ -1187,27 +1187,28 @@ core and return a descriptor to it."
(decf *condition-layout-uniqueid-counter*)
(incf *general-layout-uniqueid-counter*))))))))
(defconstant layout-friend-slot 1)
(defun ->wrapper (x) ; cast layout to wrapper, if wrappers are in use
#+metaspace (read-wordindexed x layout-friend-slot)
#-metaspace x)
(defun cold-wrapper-id (wrapper-descriptor)
(let* ((layout-descriptor (->layout wrapper-descriptor))
(proxy (gethash (descriptor-bits layout-descriptor) *cold-layout-by-addr*)))
(cold-layout-id proxy)))
(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))
(let* ((fixed-words (sb-kernel::type-dd-length sb-vm:layout))
(bitmap-words (ceiling (1+ (integer-length bitmap)) sb-vm:n-word-bits))
(result (allocate-struct (+ fixed-words bitmap-words)
(or (awhen (gethash 'layout *cold-layouts*)
(or (awhen (gethash #+metaspace 'sb-vm:layout
#-metaspace 'wrapper *cold-layouts*)
(cold-layout-descriptor it))
(make-fixnum-descriptor 0))
(symbol-value *cold-layout-gspace*)))
(wrapper
#-metaspace result ; WRAPPER and LAYOUT are synonymous in this case
#+metaspace (allocate-struct (sb-kernel::type-dd-length sb-kernel::wrapper)
(or (awhen (gethash 'sb-kernel::wrapper *cold-layouts*)
#+metaspace (allocate-struct (sb-kernel::type-dd-length wrapper)
(or (awhen (gethash 'wrapper *cold-layouts*)
(cold-layout-descriptor it))
(make-fixnum-descriptor 0))))
(this-id (choose-layout-id name (logtest flags +condition-layout-flag+)))
@ -1228,9 +1229,10 @@ core and return a descriptor to it."
(unless core-file-name (return-from make-cold-layout result))
;; Can't use the easier WRITE-SLOTS unfortunately because bootstrapping is hard
(let* ((layout-metadata (type-dd-slots-or-lose 'layout))
(wrapper-metadata #-metaspace layout-metadata
#+metaspace (type-dd-slots-or-lose 'sb-kernel::wrapper)))
(let* ((wrapper-metadata (type-dd-slots-or-lose 'wrapper))
(layout-metadata #-metaspace wrapper-metadata
#+metaspace (type-dd-slots-or-lose 'sb-vm:layout)))
#+64-bit
(%write-slots layout-metadata result
:flags (sb-kernel::pack-layout-flags depthoid length flags))
@ -1264,14 +1266,13 @@ core and return a descriptor to it."
(%write-slots wrapper-metadata wrapper :friend result))
(let ((byte-offset (ash (+ (descriptor-word-offset result)
(get-dsd-index sb-kernel:layout sb-kernel::id-word0)
(get-dsd-index sb-vm:layout sb-kernel::id-word0)
sb-vm:instance-slots-offset)
sb-vm:word-shift)))
(when (logtest flags +structure-layout-flag+)
(loop for i from 2 below (cold-vector-len inherits)
do (setf (bvref-s32 (descriptor-mem result) byte-offset)
(cold-layout-id (gethash (descriptor-bits (cold-svref inherits i))
*cold-layout-by-addr*)))
(cold-wrapper-id (cold-svref inherits i)))
(incf byte-offset 4)))
(setf (bvref-s32 (descriptor-mem result) byte-offset) this-id)))
@ -1283,7 +1284,7 @@ core and return a descriptor to it."
(let ((classoid (find-classoid type-name nil)))
(typecase classoid
(structure-classoid
(dd-predicate-name (layout-info (classoid-layout classoid))))
(dd-predicate-name (sb-kernel::wrapper-%info (classoid-wrapper classoid))))
(built-in-classoid
(let ((translation (specifier-type type-name)))
(aver (not (contains-unknown-type-p translation)))
@ -1343,9 +1344,9 @@ core and return a descriptor to it."
,(make-random-descriptor sb-vm:unbound-marker-widetag))
(,(get-dsd-index classoid sb-kernel::subclasses) . nil)
;; Even though (gethash (classoid-name obj) *cold-layouts*) may exist,
;; we nonetheless must set WRAPPER to NIL or else warm build fails
;; we nonetheless must set LAYOUT to NIL or else warm build fails
;; in the twisty maze of class initializations.
(,(get-dsd-index classoid sb-kernel::wrapper) . nil))))
(,(get-dsd-index classoid wrapper) . nil))))
(if (typep obj 'built-in-classoid)
slots-to-omit
;; :predicate is not a slot. Don't mess up the object
@ -1373,31 +1374,38 @@ core and return a descriptor to it."
(write-wordindexed/raw result (+ sb-vm:instance-slots-offset index)
(or (cdr override) (funcall reader obj)))))))))
;;; Convert a layout to a wrapper and back.
;;; Each points to the other through its first data word.
(defun ->wrapper (x) #+metaspace (read-wordindexed x 1) #-metaspace x)
(defun ->layout (x) #+metaspace (read-wordindexed x 1) #-metaspace x)
(defun initialize-layouts ()
(flet ((chill-layout (name &rest inherits)
;; Check that the number of specified INHERITS matches
;; the length of the layout's inherits in the cross-compiler.
(let ((warm-layout (info :type :compiler-layout name)))
(assert (eql (length (layout-inherits warm-layout))
(let ((wrapper (info :type :compiler-layout name)))
(assert (eql (length (wrapper-inherits wrapper))
(length inherits)))
(make-cold-layout name
(layout-depthoid warm-layout)
(layout-flags warm-layout)
(layout-length warm-layout)
(layout-bitmap warm-layout)
(vector-in-core inherits)))))
(->wrapper
(make-cold-layout name
(wrapper-depthoid wrapper)
(wrapper-flags wrapper)
(wrapper-length wrapper)
(wrapper-bitmap wrapper)
(vector-in-core inherits))))))
;; The variables are named foo-LAYOUT but are actually foo-WRAPPER.
(let* ((t-layout (chill-layout 't))
(s-o-layout (chill-layout 'structure-object t-layout))
#+metaspace (wrapper-layout (chill-layout 'sb-kernel::wrapper t-layout s-o-layout))
(layout-layout (chill-layout 'layout t-layout s-o-layout)))
#+metaspace (layout-layout (chill-layout 'sb-vm:layout t-layout s-o-layout))
(wrapper-layout (chill-layout 'wrapper t-layout s-o-layout)))
(when core-file-name
#-metaspace
(dolist (instance (list t-layout s-o-layout layout-layout))
(set-instance-layout instance layout-layout))
(dolist (instance (list t-layout s-o-layout wrapper-layout))
(set-instance-layout instance wrapper-layout))
#+metaspace
(progn (dolist (instance (list t-layout s-o-layout wrapper-layout layout-layout))
(set-instance-layout (read-wordindexed instance 1) wrapper-layout)
(set-instance-layout instance layout-layout))))
(progn (dolist (instance (list t-layout s-o-layout layout-layout wrapper-layout))
(set-instance-layout instance (->layout wrapper-layout))
(set-instance-layout (->layout instance) (->layout layout-layout)))))
(chill-layout 'function t-layout)
(chill-layout 'sb-kernel::classoid-cell t-layout s-o-layout)
(chill-layout 'package t-layout s-o-layout)
@ -2025,8 +2033,7 @@ core and return a descriptor to it."
(defun attach-classoid-cells-to-symbols (hashtable)
(when (plusp (hash-table-count *classoid-cells*))
(aver (cold-layout-descriptor
(gethash 'sb-kernel::classoid-cell *cold-layouts*)))
(aver (gethash 'sb-kernel::classoid-cell *cold-layouts*))
(let ((type-classoid-cell-info
(sb-c::meta-info-number (sb-c::meta-info :type :classoid-cell)))
(type-kind-info
@ -2280,9 +2287,9 @@ Legal values for OFFSET are -4, -8, -12, ..."
(define-cold-fop (fop-misc-trap) *unbound-marker*)
(define-cold-fop (fop-struct (size)) ; n-words incl. layout, excluding header
(let* ((layout (pop-stack))
(proxy-layout ; our host-structure wrapper on the slots of the cold layout
(gethash (descriptor-bits layout) *cold-layout-by-addr*))
(let* ((wrapper (pop-stack))
(layout (->layout wrapper))
(proxy-layout (gethash (descriptor-bits layout) *cold-layout-by-addr*))
(result (allocate-struct size layout))
(bitmap (cold-layout-bitmap proxy-layout)))
(loop for index downfrom (1- size) to sb-vm:instance-data-start
@ -2296,12 +2303,13 @@ Legal values for OFFSET are -4, -8, -12, ..."
result))
(defun find-in-inherits (typename inherits)
(dotimes (i (cold-vector-len inherits))
(let ((proxy (gethash (descriptor-bits (cold-svref inherits i))
*cold-layout-by-addr*)))
(when (eq (cold-layout-name proxy) typename)
(return proxy)))))
(binding* ((proxy (gethash typename *cold-layouts*) :exit-if-null)
(layout (->wrapper (cold-layout-descriptor proxy))))
(dotimes (i (cold-vector-len inherits))
(when (descriptor= (cold-svref inherits i) layout)
(return t)))))
;;; Always return a WRAPPER if #+metaspace
(define-cold-fop (fop-layout (depthoid flags length))
(decf depthoid) ; was bumped by 1 since non-stack args can't encode negatives
(let* ((inherits (pop-stack))
@ -2311,7 +2319,7 @@ Legal values for OFFSET are -4, -8, -12, ..."
(existing-layout (gethash name *cold-layouts*)))
(declare (type descriptor bitmap-descriptor inherits))
(declare (type symbol name))
;; parameter have to match an existing FOP-LAYOUT invocation if there was one
;; parameters have to match an existing FOP-LAYOUT invocation if there was one
(when existing-layout
(let ((old-flags (cold-layout-flags existing-layout))
(old-depthoid (cold-layout-depthoid existing-layout))
@ -2329,13 +2337,16 @@ Legal values for OFFSET are -4, -8, -12, ..."
(return nil))))
;; Users will never see this.
(format t "old=(flags=~d depthoid=~d length=~d bitmap=~d inherits=~s)~%"
old-flags old-depthoid old-length old-bitmap old-inherits)
old-flags old-depthoid old-length old-bitmap
(vector-from-core old-inherits))
(format t "new=(flags=~d depthoid=~d length=~d bitmap=~d inherits=~s)~%"
flags depthoid length bitmap-value inherits)
flags depthoid length bitmap-value
(vector-from-core inherits))
(bug "Messed up fop-layout for ~s" name))))
(if existing-layout
(cold-layout-descriptor existing-layout)
(make-cold-layout name depthoid flags length bitmap-value inherits))))
(->wrapper
(if existing-layout
(cold-layout-descriptor existing-layout)
(make-cold-layout name depthoid flags length bitmap-value inherits)))))
;;;; cold fops for loading symbols
@ -2731,8 +2742,9 @@ 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*)))
(:layout-id ; SYM is a #<WRAPPER>
(cold-layout-id (gethash (descriptor-bits (->layout sym))
*cold-layout-by-addr*)))
(:immobile-symbol
;; an interned symbol is represented by its host symbol,
;; but an uninterned symbol is a descriptor.
@ -3182,9 +3194,6 @@ Legal values for OFFSET are -4, -8, -12, ..."
(if (string= (car slot) "default") "_default" (car slot))
(cdr slot))))
(format t "};~%")
(when (member (dd-name dd) '(layout))
(write-cast-operator (dd-name dd) (cstring (dd-name dd))
sb-vm:instance-pointer-lowtag))
(format t "~%#endif /* __ASSEMBLER__ */~2%")))
(defun write-thread-init (stream)
@ -3364,13 +3373,15 @@ III. initially undefined function references (alphabetically):
(terpri))))
(format t "~%~|~%V. layout names:~2%")
(format t " Bitmap Depth ID Name [Length]~%")
(format t "~28tBitmap 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 ~5D ~S [~D]~%"
(format t "~10,'0X -> ~10,'0X: ~8d ~2D ~5D ~S [~D]~%"
addr
#+metaspace (descriptor-bits (->wrapper descriptor))
#-metaspace " "
(cold-layout-bitmap proxy)
(cold-layout-depthoid proxy)
(cold-layout-id proxy)
@ -3727,11 +3738,11 @@ III. initially undefined function references (alphabetically):
(sb-cold::check-no-new-cl-symbols)
(when *known-structure-classoids*
;; Fill in LAYOUT-%INFO with each corresponding DEFSTRUCT-DESCRIPTION
;; (Couldn't this be done sooner?)
(dolist (defstruct-args *known-structure-classoids*)
(let* ((dd (first defstruct-args))
(name (warm-symbol (read-slot dd :name)))
(layout (gethash name *cold-layouts*)))
(aver layout)
(layout (gethash (warm-symbol (read-slot dd :name)) *cold-layouts*)))
(write-slots (->wrapper (cold-layout-descriptor layout)) :%info dd)))
(when verbose
(format t "~&; SB-Loader: (~D~@{+~D~}) structs/vars/methods/other~%"
@ -3768,7 +3779,7 @@ III. initially undefined function references (alphabetically):
(and (null qual) (predicate-for-specializer class)))
(cold-intern qual)
(acond ((gethash class *cold-layouts*)
(cold-layout-descriptor it))
(->wrapper (cold-layout-descriptor it)))
(t
(aver (predicate-for-specializer class))
(cold-intern class)))
@ -3872,15 +3883,26 @@ III. initially undefined function references (alphabetically):
(dolist (obj structs)
(format stream "~&#include \"~A.h\"~%"
(string-downcase (sb-vm:primitive-object-name obj))))))
(out-to "layout"
#-metaspace
(write-structure-object (wrapper-info (find-layout 'wrapper)) stream
"layout")
#+metaspace
(progn
(write-structure-object (wrapper-info (find-layout 'sb-vm:layout)) stream)
(write-structure-object (wrapper-info (find-layout 'wrapper)) stream))
(let ((*standard-output* stream))
(write-cast-operator 'layout "layout" sb-vm:instance-pointer-lowtag)))
(dolist (class '(defstruct-description defstruct-slot-description
classoid layout #+metaspace sb-kernel::wrapper
classoid
hash-table package
sb-thread::avlnode sb-thread::mutex
sb-c::compiled-debug-info sb-c::compiled-debug-fun))
(out-to (string-downcase class)
(write-structure-object (layout-info (find-layout class)) stream)))
(write-structure-object (wrapper-info (find-layout class))
stream)))
(out-to "thread-instance"
(write-structure-object (layout-info (find-layout 'sb-thread::thread))
(write-structure-object (wrapper-info (find-layout 'sb-thread::thread))
stream "thread_instance"))
(with-open-file (stream (format nil "~A/thread-init.inc" c-header-dir-name)
:direction :output :if-exists :supersede)

2
src/compiler/generic/interr.lisp
View file

@ -186,7 +186,7 @@
sb-c::vop
sb-c::basic-combination
sb-sys:fd-stream
layout
wrapper
(sb-assem:segment object-not-assem-segment)
sb-c::cblock
sb-disassem:disassem-state

4
src/compiler/generic/layout-ids.lisp
View file

@ -218,8 +218,8 @@ SB-ALIEN::SHARED-OBJECT
;;; There are a few wired IDs:
;;; 0 = T
;;; 1 = STRUCTURE-OBJECT
;;; 2 = WRAPPER
;;; 3 = LAYOUT
;;; 2 = WRAPPER if #+metaspace, unused if #-metaspace
;;; 3 = SB-VM:LAYOUT if #+metaspace, WRAPPER if #-metaspace
;;; 4 = SB-LOCKLESS::LIST-NODE
(ecase layout-id-type
(unsigned-byte

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

@ -93,7 +93,7 @@
(:code-object (get-lisp-obj-address code-obj))
#+sb-thread (:symbol-tls-index (ensure-symbol-tls-index sym))
(:layout (get-lisp-obj-address
(if (symbolp sym) (find-layout sym) sym)))
(wrapper-friend (if (symbolp sym) (find-layout sym) sym))))
(:layout-id (layout-id sym))
(:immobile-symbol (get-lisp-obj-address sym))
(:symbol-value (get-lisp-obj-address (symbol-global-value sym)))
@ -135,7 +135,7 @@
(setf (sap-ref-32 (int-sap (get-lisp-obj-address fun))
(- 4 sb-vm:fun-pointer-lowtag))
(truly-the (unsigned-byte 32)
(get-lisp-obj-address #.(find-layout 'function))))))
(get-lisp-obj-address (wrapper-friend #.(find-layout 'function)))))))
;; And finally, make the memory range executable
#-(or x86 x86-64) (sb-vm:sanctify-for-execution code-obj)
;; Return fixups amenable to static linking

4
src/compiler/generic/type-error.lisp
View file

@ -90,7 +90,7 @@
(cond ((sc-is thing immediate)
(let ((obj (tn-value thing)))
(typecase obj
(layout nil)
(wrapper nil)
;; non-static symbols can be referenced as error-break args
;; because they appear in the code constants.
;; static symbols can't be referenced as error-break args
@ -161,7 +161,7 @@
(make-sc+offset immediate-sc-number (tn-value where)))
(t
(make-sc+offset (if (and (sc-is where immediate)
(typep (tn-value where) '(or symbol layout)))
(typep (tn-value where) '(or symbol wrapper)))
constant-sc-number
(sc-number (tn-sc where)))
(or (tn-offset where) 0))))

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

@ -192,20 +192,21 @@
(flushable always-translatable))
(defknown (%copy-instance %copy-instance-slots) (instance instance) instance
() :result-arg 0)
(defknown %instance-layout (instance) layout
(foldable flushable))
(defknown %instance-layout (instance) sb-vm:layout (foldable flushable))
(defknown %instance-wrapper (instance) wrapper (foldable flushable))
;;; %FUN-LAYOUT is to %INSTANCE-LAYOUT as FUN-POINTER-LOWTAG is to INSTANCE-POINTER-LOWTAG
(defknown %fun-layout (#-compact-instance-header funcallable-instance
#+compact-instance-header function)
layout
sb-vm:layout (foldable flushable))
(defknown %fun-wrapper (#-compact-instance-header funcallable-instance
#+compact-instance-header function)
wrapper
(foldable flushable))
(defknown %set-instance-layout (instance layout) layout
())
(defknown %set-fun-layout (funcallable-instance layout) layout
())
(defknown %set-instance-layout (instance sb-vm:layout) sb-vm:layout ())
(defknown %set-fun-layout (funcallable-instance sb-vm:layout) sb-vm:layout ())
;;; Layout getter that accepts any object, and if it has INSTANCE- or FUN-
;;; POINTER-LOWTAG returns the layout, otherwise some agreed-upon layout.
(defknown %instanceoid-layout (t) layout (flushable))
(defknown %instanceoid-layout (t) sb-vm:layout (flushable))
(defknown layout-eq ((or instance function) t (mod 16)) boolean (flushable))
;;; Caution: This is not exactly the same as instance_length() in C.
;;; The C one is the same as SB-VM::INSTANCE-LENGTH.
@ -218,7 +219,7 @@
(defknown %instance-set (instance index t) t
(always-translatable)
:derive-type #'result-type-last-arg)
(defknown update-object-layout (t) layout)
(defknown update-object-layout (t) sb-vm:layout)
#+(or arm64 ppc ppc64 riscv x86 x86-64)
(defknown %raw-instance-cas/word (instance index sb-vm:word sb-vm:word)

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

@ -99,7 +99,7 @@
(class-eq (and name
(eq (classoid-state classoid) :sealed)
(not (classoid-subclasses classoid))))
(dd (and class-eq (layout-info layout)))
(dd (and class-eq (wrapper-info layout)))
(max-inlined-words 5))
(unless (and result ; could be unused result (but entire call wasn't flushed?)
layout
@ -137,8 +137,10 @@
(defun varying-length-struct-p (classoid)
;; This is a nice feature to have in general, but at present it is only possible
;; to make varying length instances of LAYOUT and nothing else.
(eq (classoid-name classoid) 'layout))
;; to make varying length instances of SB-VM:LAYOUT (or WRAPPER if that is the same type),
;; and nothing else.
(eq classoid (load-time-value (find-classoid #+metaspace 'sb-vm:layout
#-metaspace 'wrapper))))
(deftransform %instance-length ((instance))
(let ((classoid (lvar-type instance)))
@ -148,9 +150,12 @@
(not (varying-length-struct-p classoid))
;; TODO: if sealed with subclasses which add no slots, use the fixed length
(not (classoid-subclasses classoid)))
(dd-length (layout-dd (sb-kernel::compiler-layout-or-lose (classoid-name classoid))))
(dd-length (wrapper-dd (sb-kernel::compiler-layout-or-lose (classoid-name classoid))))
(give-up-ir1-transform))))
(define-source-transform %instance-wrapper (x) `(layout-friend (%instance-layout ,x)))
(define-source-transform %fun-wrapper (x) `(layout-friend (%fun-layout ,x)))
;;; *** These transforms should be the only code, aside from the C runtime
;;; with knowledge of the layout index.
#+compact-instance-header
@ -158,9 +163,9 @@
#-compact-instance-header
(progn
(define-source-transform %instance-layout (x)
`(truly-the layout (%instance-ref ,x 0)))
`(truly-the sb-vm:layout (%instance-ref ,x 0)))
(define-source-transform %set-instance-layout (x val)
`(%instance-set ,x 0 (the layout ,val)))
`(%instance-set ,x 0 (the sb-vm:layout ,val)))
(define-source-transform function-with-layout-p (x)
`(funcallable-instance-p ,x)))

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

@ -126,7 +126,7 @@
(defglobal *backend-type-predicates-grouped*
(let (plist)
(loop for (type . pred) in *backend-type-predicates*
for class = (#-sb-xc-host %instance-layout
for class = (#-sb-xc-host %instance-wrapper
#+sb-xc-host type-of
type)
do (push type (getf plist class))
@ -155,7 +155,7 @@
(declare (inline vector-getf))
(let ((group (truly-the (or simple-vector null)
(vector-getf *backend-type-predicates-grouped*
(#-sb-xc-host %instance-layout
(#-sb-xc-host %instance-wrapper
#+sb-xc-host type-of type)
#'eq))))
(when group

2
src/compiler/ir1tran.lisp
View file

@ -373,7 +373,7 @@
;; user-defined MAKE-LOAD-FORM methods?
(when (emit-make-load-form value)
#+sb-xc-host
(aver (eql (layout-bitmap (%instance-layout value))
(aver (eql (wrapper-bitmap (%instance-wrapper value))
sb-kernel:+layout-all-tagged+))
(do-instance-tagged-slot (i value)
(grovel (%instance-ref value i)))))

2
src/compiler/ir1util.lisp
View file

@ -2402,6 +2402,8 @@ is :ANY, the function name is not checked."
(defun find-constant (object &optional name
&aux (namespace (if (boundp '*ir1-namespace*) *ir1-namespace*))
(output *compile-object*))
(when (or #+metaspace (typep object 'sb-vm:layout))
(error "Cowardly refusing to FIND-CONSTANT on a LAYOUT"))
;; Pick off some objects that aren't actually constants in user code.
;; These things appear as literals in forms such as `(%POP-VALUES ,x)

2
src/compiler/mips/system.lisp
View file

@ -69,7 +69,7 @@
(:generator 4
(let ((label (register-inline-constant :layout-id test-layout))
(offset (+ (bitmap-bits-offset)
(ash (- (layout-depthoid test-layout) 2) 2)
(ash (- (wrapper-depthoid test-layout) 2) 2)
(- instance-pointer-lowtag))))
(inst lw test-id sb-vm::code-tn label)
(inst lw this-id x offset)

2
src/compiler/ppc/system.lisp
View file

@ -60,7 +60,7 @@
(:generator 4
(let ((test-id (layout-id test-layout))
(offset (+ (bitmap-bits-offset)
(ash (- (layout-depthoid test-layout) 2) 2)
(ash (- (wrapper-depthoid test-layout) 2) 2)
(- instance-pointer-lowtag))))
(inst lwz this-id x offset)
;; Always prefer 'cmpwi' if compiling to memory.

2
src/compiler/ppc64/system.lisp
View file

@ -75,7 +75,7 @@
(:generator 4
(let ((test-id (layout-id test-layout))
(offset (+ (bitmap-bits-offset)
(ash (- (layout-depthoid test-layout) 2) 2)
(ash (- (wrapper-depthoid test-layout) 2) 2)
(- instance-pointer-lowtag))))
(inst lwa this-id x offset)
;; Always prefer 'cmpwi' if compiling to memory.

4
src/compiler/proclaim.lisp
View file

@ -247,8 +247,8 @@
(setf (classoid-state class) :sealed)
(let ((subclasses (classoid-subclasses class)))
(when subclasses
(dohash ((subclass wrapper) subclasses :locked t)
(declare (ignore wrapper))
(dohash ((subclass layout) subclasses :locked t)
(declare (ignore layout))
(setf (classoid-state subclass) :sealed)))))
(defun process-freeze-type-declaration (type-specifier)

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

@ -64,7 +64,7 @@
(:temporary (:sc unsigned-reg) this-id temp)
(:generator 4
(let ((offset (+ (bitmap-bits-offset)
(ash (- (layout-depthoid test-layout) 2) 2)
(ash (- (wrapper-depthoid test-layout) 2) 2)
(- instance-pointer-lowtag))))
(inst lw this-id x offset)
(if (or (typep (layout-id test-layout) '(and (signed-byte 8) (not (eql 0))))

2
src/compiler/sparc/system.lisp
View file

@ -60,7 +60,7 @@
(:temporary (:sc unsigned-reg) this-id temp)
(:generator 4
(let ((offset (+ (bitmap-bits-offset)
(ash (- (layout-depthoid test-layout) 2) 2)
(ash (- (wrapper-depthoid test-layout) 2) 2)
(- instance-pointer-lowtag))))
(inst ld this-id x offset)
(if (or (typep (layout-id test-layout) '(and (signed-byte 8) (not (eql 0))))

2
src/compiler/tn.lisp
View file

@ -252,7 +252,7 @@
#+immobile-space
(let ((val (constant-value constant)))
(or (and (symbolp val) (not (sb-vm:static-symbol-p val)))
(typep val 'layout)))))
(typep val 'wrapper)))))
(let ((constants (ir2-component-constants component)))
(setf (tn-offset res)
(vector-push-extend constant constants))))

63
src/compiler/typetran.lisp
View file

@ -827,12 +827,15 @@
;;; So in actual practice, you can't make something that is a pure STREAM, etc.
#-(or x86 x86-64) ; vop-translated for these 2
(defmacro layout-depthoid-ge (layout depthoid)
`(>= (layout-depthoid ,layout) ,depthoid))
`(>= (wrapper-depthoid ,layout) ,depthoid))
(symbol-macrolet ((get-hash #+metaspace 'layout-clos-hash #-metaspace 'wrapper-clos-hash)
(get-flags #+metaspace 'layout-flags #-metaspace 'wrapper-flags))
(defun transform-instance-typep (classoid)
(binding*
((name (classoid-name classoid))
(layout (let ((res (info :type :compiler-layout name)))
(when (and res (not (layout-invalid res))) res)))
(wrapper (let ((res (info :type :compiler-layout name)))
(when (and res (not (wrapper-invalid res))) res)))
(layout (and wrapper (wrapper-friend wrapper)))
((lowtag lowtag-test slot-reader)
(cond ((csubtypep classoid (specifier-type 'funcallable-instance))
(values sb-vm:fun-pointer-lowtag
@ -840,13 +843,14 @@
((csubtypep classoid (specifier-type 'instance))
(values sb-vm:instance-pointer-lowtag
'(%instancep object) '(%instance-layout object)))))
(depthoid (if layout (layout-depthoid layout) -1))
(wrapper (make-symbol "LAYOUT")))
(depthoid (if wrapper (wrapper-depthoid wrapper) -1))
(type (make-symbol "TYPE")))
(declare (ignorable layout))
;; Easiest case first: single bit test.
(cond ((member name '(condition pathname structure-object))
`(and (%instancep object)
(logtest (layout-flags (%instance-layout object))
(logtest (,get-flags (%instance-layout object))
,(case name
(condition +condition-layout-flag+)
(pathname +pathname-layout-flag+)
@ -860,13 +864,14 @@
;; I think that means we should know the lowtag always. Nonetheless, this isn't
;; an important scenario, and only if you _do_ seal a class could this case be
;; reached; users rarely seal their classes since the standard doesn't say how.
((and layout
((and wrapper
(eq (classoid-state classoid) :sealed)
(not (classoid-subclasses classoid)))
(if lowtag-test
`(and ,lowtag-test ,(if (vop-existsp :translate layout-eq)
`(layout-eq object ,layout ,lowtag)
`(eq ,slot-reader ,layout)))
`(and ,lowtag-test
,(if (vop-existsp :translate layout-eq)
`(layout-eq object ,wrapper ,lowtag)
`(eq ,slot-reader ,layout)))
;; `(eq ,layout
;; (if-vop-existsp (:translate %instanceoid-layout)
;; (%instanceoid-layout object)
@ -874,10 +879,10 @@
;; (cond ((%instancep object) (%instance-layout object))
;; ((funcallable-instance-p object) (%fun-layout object))
;; (t ,(find-layout 't)))))
(bug "Unexpected metatype for ~S" layout)))
(bug "Unexpected metatype for ~S" wrapper)))
;; All other structure types
((and (typep classoid 'structure-classoid) layout)
((and (typep classoid 'structure-classoid) wrapper)
;; structure type tests; hierarchical layout depths
(aver (eql lowtag sb-vm:instance-pointer-lowtag))
;; we used to check for invalid layouts here, but in fact that's both unnecessary and
@ -889,45 +894,45 @@
;; this might have to change to consider object invalidation. Probably would
;; want to track structure classoids that would render this code inadmissible.
,(if (<= depthoid sb-kernel::layout-id-vector-fixed-capacity)
`(%structure-is-a (%instance-layout object) ,layout)
`(let ((,wrapper (%instance-layout object)))
(and (layout-depthoid-ge ,wrapper ,depthoid)
(%structure-is-a ,wrapper ,layout))))))
`(%structure-is-a (%instance-layout object) ,wrapper)
`(let ((,type (%instance-layout object)))
(and (layout-depthoid-ge ,type ,depthoid)
(%structure-is-a ,type ,wrapper))))))
((> depthoid 0)
;; fixed-depth ancestors of non-structure types:
;; STREAM, FILE-STREAM, STRING-STREAM, and SEQUENCE.
#+sb-xc-host (when (typep classoid 'static-classoid)
;; should have use :SEALED code above
(bug "Non-frozen static classoids?"))
(let ((guts `((when (zerop (layout-clos-hash ,wrapper))
(setq ,wrapper (update-object-layout object)))
(bug "Non-frozen static classoids ~S" name))
(let ((guts `((when (zerop (,get-hash ,type))
(setq ,type (update-object-layout object)))
,(ecase name
(stream
`(logtest (layout-flags ,wrapper) ,+stream-layout-flag+))
`(logtest (,get-flags ,type) ,+stream-layout-flag+))
(file-stream
`(logtest (layout-flags ,wrapper) ,+file-stream-layout-flag+))
`(logtest (,get-flags ,type) ,+file-stream-layout-flag+))
(string-stream
`(logtest (layout-flags ,wrapper) ,+string-stream-layout-flag+))
`(logtest (,get-flags ,type) ,+string-stream-layout-flag+))
;; Testing the type EXTENDED-SEQUENCE tests for #<LAYOUT of SEQUENCE>.
;; It can only arise from a direct invocation of TRANSFORM-INSTANCE-TYPEP,
;; because the lisp type is not a classoid. It's done this way to define
;; the logic once only, instead of both here and src/code/pred.lisp.
(sequence
`(logtest (layout-flags ,wrapper) ,+sequence-layout-flag+))))))
`(logtest (,get-flags ,type) ,+sequence-layout-flag+))))))
(if lowtag-test
`(and ,lowtag-test (let ((,wrapper ,slot-reader)) ,@guts))
`(and ,lowtag-test (let ((,type ,slot-reader)) ,@guts))
(if-vop-existsp (:translate %instanceoid-layout)
`(let ((,wrapper (%instanceoid-layout object))) ,@guts)
`(let ((,type (%instanceoid-layout object))) ,@guts)
`(block typep
(let ((,wrapper (cond ((%instancep object) (%instance-layout object))
((funcallable-instance-p object) (%fun-layout object))
(t (return-from typep nil)))))
(let ((,type (cond ((%instancep object) (%instance-layout object))
((funcallable-instance-p object) (%fun-layout object))
(t (return-from typep nil)))))
,@guts))))))
(t
`(classoid-cell-typep ',(find-classoid-cell name :create t)
object)))))
object))))))
;;; If the specifier argument is a quoted constant, then we consider
;;; converting into a simple predicate or other stuff. If the type is

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

@ -606,7 +606,7 @@
(:results (result :scs (descriptor-reg)))
(:node-var node)
(:generator 50
(let* ((instancep (typep type 'layout)) ; is this an instance type?
(let* ((instancep (typep type 'wrapper)) ; is this an instance type?
(bytes (pad-data-block words)))
(progn name) ; possibly not used
(unless stack-allocate-p

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

@ -78,7 +78,7 @@
(:generator 1
(inst cmp :dword
(ea (+ (bitmap-bits-offset)
(ash (- (layout-depthoid test) 2) 2)
(ash (- (wrapper-depthoid test) 2) 2)
(- instance-pointer-lowtag))
x)
;; Small layout-ids can only occur for layouts made in genesis.
@ -97,7 +97,7 @@
;; ~17 instructions vs. 35
(define-vop ()
(:policy :fast-safe)
(:translate layout-of)
(:translate wrapper-of)
(:args (object :scs (descriptor-reg)))
(:temporary (:sc unsigned-reg :offset rax-offset) rax)
(:results (result :scs (descriptor-reg)))
@ -135,7 +135,8 @@
(inst jmp done)
NULL
(inst mov result (make-fixup 'null :layout))
DONE))
DONE
#+metaspace (inst mov result (ea +5 result)))) ; layout->wrapper
(define-vop ()
(:policy :fast-safe)
(:translate %instanceoid-layout)

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

@ -534,12 +534,15 @@
(:policy :fast-safe)
(:conditional :e)
(:args (object :scs (descriptor-reg))
(layout :scs (descriptor-reg immediate)))
(layout :scs (descriptor-reg immediate #+metaspace constant)))
(:arg-types * * (:constant t))
(:info lowtag)
(:generator 1
;; With metaspace, the layout argument is actually a #<WRAPPER>
;; which does not have IMMEDIATE sc, but rather CONSTANT sc.
;; But we use a layout fixup which stuffs in the pointer to the layout.
(inst cmp :dword (ea (- 4 lowtag) object)
(if (sc-is layout immediate)
(if (sc-is layout immediate constant)
(make-fixup (tn-value layout) :layout)
layout)))))

9
src/compiler/x86-64/vm.lisp
View file

@ -424,9 +424,8 @@
(static-symbol-p value))
immediate-sc-number))
#+immobile-space
(layout
immediate-sc-number)
#+metaspace (sb-vm:layout (bug "Can't reference layout as a constant"))
#+(and immobile-space (not metaspace)) (wrapper immediate-sc-number)
(single-float
(if (eql value $0f0) fp-single-zero-sc-number fp-single-immediate-sc-number))
(double-float
@ -463,8 +462,8 @@
(symbol (if (static-symbol-p val)
(+ nil-value (static-symbol-offset val))
(make-fixup val :immobile-symbol)))
#+immobile-space
(layout
#+(and immobile-space (not metaspace))
(wrapper
(make-fixup val :layout))
(character (if tag
(logior (ash (char-code val) n-widetag-bits)

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

@ -68,7 +68,7 @@
(inst cmp
(make-ea :dword
:disp (+ (bitmap-bits-offset)
(ash (- (layout-depthoid test) 2) 2)
(ash (- (wrapper-depthoid test) 2) 2)
(- instance-pointer-lowtag))
:base x)
(if (or (typep (layout-id test) '(and (signed-byte 8) (not (eql 0))))

57
src/pcl/braid.lisp
View file

@ -33,8 +33,8 @@
(defun allocate-standard-instance (wrapper)
(let* ((instance (%make-instance (1+ sb-vm:instance-data-start)))
(slots (make-array (layout-length wrapper) :initial-element +slot-unbound+)))
(setf (%instance-layout instance) wrapper)
(slots (make-array (wrapper-length wrapper) :initial-element +slot-unbound+)))
(setf (%instance-wrapper instance) wrapper)
(setf (std-instance-slots instance) slots)
instance))
@ -52,15 +52,15 @@
:format-arguments (list ,fin)))
(defun allocate-standard-funcallable-instance (wrapper name)
(declare (layout wrapper))
(declare (wrapper wrapper))
(let* ((hash (if name
(mix (sxhash name) (sxhash :generic-function)) ; arb. constant
(sb-impl::quasi-random-address-based-hash
(load-time-value (make-array 1 :element-type '(and fixnum unsigned-byte)))
most-positive-fixnum)))
(slots (make-array (layout-length wrapper) :initial-element +slot-unbound+))
(slots (make-array (wrapper-length wrapper) :initial-element +slot-unbound+))
(fin (cond #+(and immobile-code)
((not (sb-kernel::bitmap-all-taggedp wrapper))
((not (sb-kernel::bitmap-all-taggedp (wrapper-friend wrapper)))
(let ((f (truly-the funcallable-instance
(sb-vm::make-immobile-funinstance wrapper slots))))
;; set the upper 4 bytes of wordindex 5
@ -70,7 +70,7 @@
(t
(let ((f (truly-the funcallable-instance
(%make-standard-funcallable-instance slots hash))))
(setf (%fun-layout f) wrapper)
(setf (%fun-wrapper f) wrapper)
f)))))
(setf (%funcallable-instance-fun fin)
(lambda (&rest args)
@ -104,16 +104,15 @@
;;;;
;;;; This function builds the base metabraid from the early class definitions.
(defmacro wrapper-info (x) `(sb-kernel::layout-%info ,x))
(declaim (inline wrapper-slot-list))
(defun wrapper-slot-list (wrapper)
(let ((info (wrapper-info wrapper)))
(let ((info (sb-kernel::wrapper-%info wrapper)))
(if (listp info) info)))
(defun (setf wrapper-slot-list) (newval wrapper)
;; The current value must be a list, otherwise we'd clobber
;; a defstruct-description.
(aver (listp (wrapper-info wrapper)))
(setf (wrapper-info wrapper) newval))
(aver (listp (sb-kernel::wrapper-%info wrapper)))
(setf (sb-kernel::wrapper-%info wrapper) newval))
(macrolet
((with-initial-classes-and-wrappers ((&rest classes) &body body)
@ -224,7 +223,7 @@
name class slots
standard-effective-slot-definition-wrapper t))
(setf (layout-slot-table wrapper) (make-slot-table class slots t))
(setf (wrapper-slot-table wrapper) (make-slot-table class slots t))
(when (layout-for-pcl-obj-p wrapper)
(setf (wrapper-slot-list wrapper) slots))
@ -354,7 +353,7 @@
slot-class))
(set-slot 'direct-slots direct-slots)
(set-slot 'slots slots)
(setf (layout-slot-table wrapper)
(setf (wrapper-slot-table wrapper)
(make-slot-table class slots
(member metaclass-name
'(standard-class funcallable-standard-class))))
@ -558,7 +557,7 @@
(destructuring-bind (name supers subs cpl prototype) e
(let* ((class (find-class name))
(lclass (find-classoid name))
(wrapper (classoid-layout lclass)))
(wrapper (classoid-wrapper lclass)))
(setf (classoid-pcl-class lclass) class)
(!bootstrap-initialize-class 'built-in-class class
@ -569,7 +568,7 @@
(defun class-of (x)
(declare (explicit-check))
(wrapper-class (layout-of x)))
(wrapper-class (wrapper-of x)))
(defun eval-form (form)
(lambda () (eval form)))
@ -656,9 +655,10 @@
(define-load-time-global *simple-stream-root-classoid* :unknown)
(defun set-bitmap-and-flags (layout &aux (inherits (layout-inherits layout))
(flags (layout-flags layout)))
(when (eq (layout-classoid layout) *simple-stream-root-classoid*)
(defun set-bitmap-and-flags (wrapper &aux (inherits (wrapper-inherits wrapper))
(flags (wrapper-flags wrapper))
(layout (wrapper-friend wrapper)))
(when (eq (wrapper-classoid wrapper) *simple-stream-root-classoid*)
(setq flags (logior flags +simple-stream-layout-flag+)))
;; We decide only at class finalization time whether it is funcallable.
;; Picking the right bitmap could probably be done sooner given the metaclass,
@ -667,9 +667,10 @@
;; explains why we differentiate between SGF and everything else.
(dovector (ancestor inherits)
(when (eq ancestor #.(find-layout 'function))
(setf (%raw-instance-ref/signed-word layout (sb-kernel::type-dd-length layout))
(setf (%raw-instance-ref/signed-word
layout (sb-kernel::type-dd-length sb-vm:layout))
#+immobile-code ; there are two possible bitmaps
(if (or (find *sgf-wrapper* inherits) (eq layout *sgf-wrapper*))
(if (or (find *sgf-wrapper* inherits) (eq wrapper *sgf-wrapper*))
sb-kernel::standard-gf-primitive-obj-layout-bitmap
+layout-all-tagged+)
;; there is only one possible bitmap otherwise
@ -679,23 +680,23 @@
+simple-stream-layout-flag+
+file-stream-layout-flag+
+string-stream-layout-flag+)
(layout-flags ancestor))
(wrapper-flags ancestor))
flags)))
(setf (layout-flags layout) flags))
(setf (layout-flags (wrapper-friend wrapper)) flags))
;;; 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)
(defun %update-lisp-class-layout (class wrapper)
;; Protected by *world-lock* in callers.
(let ((classoid (layout-classoid layout)))
(unless (eq (classoid-layout classoid) layout)
(set-layout-inherits layout
(let ((classoid (wrapper-classoid wrapper)))
(unless (eq (classoid-wrapper classoid) wrapper)
(set-layout-inherits wrapper
(order-layout-inherits
(map 'simple-vector #'class-wrapper
(reverse (rest (class-precedence-list class)))))
nil 0)
(set-bitmap-and-flags layout)
(register-layout layout :invalidate t)
(set-bitmap-and-flags wrapper)
(register-layout wrapper :invalidate t)
;; FIXME: I don't think this should be necessary, but without it
;; we are unable to compile (TYPEP foo '<class-name>) in the
@ -722,7 +723,7 @@
(when (classoid-cell-pcl-class x)
(let* ((class (find-class-from-cell name x))
(layout (class-wrapper class))
(lclass (layout-classoid layout))
(lclass (wrapper-classoid layout))
(lclass-pcl-class (classoid-pcl-class lclass))
(olclass (find-classoid name nil)))
(if lclass-pcl-class

14
src/pcl/cache.lisp
View file

@ -160,7 +160,7 @@
(export 'compute-cache-index) ; for a test
(defun compute-cache-index (cache layouts)
(macrolet ((fetch-hash (x)
`(let ((hash (layout-clos-hash ,x)))
`(let ((hash (wrapper-clos-hash ,x)))
(when (zerop hash) (return-from compute-cache-index nil))
hash)))
(let ((index (fetch-hash (car layouts))))
@ -211,7 +211,7 @@
(when (or (> num-keys 1) value-var) (make-symbol "PTR")))
(line-size (power-of-two-ceiling (+ num-keys (if value-var 1 0)))))
;; Why not use PROG* ? are we expressly trying to avoid a new block?
`(let* (,@(mapcar (lambda (x y) `(,x (layout-clos-hash ,y))) hash-vars layout-vars)
`(let* (,@(mapcar (lambda (x y) `(,x (wrapper-clos-hash ,y))) hash-vars layout-vars)
(,n-mask (cache-mask ,cache-var))
(,probe (if (zerop ,(cache-mixer-expression 'logand hash-vars t))
(go ,miss-tag)
@ -278,7 +278,7 @@
(case key-count
(1
(let* ((layout (if (%instancep key) key (car key)))
(hash (layout-clos-hash layout))
(hash (wrapper-clos-hash layout))
(index (logand hash mask)))
(unless (= hash 0)
(probe-loop (eq (svref vector (truly-the index index)) layout)))))
@ -420,14 +420,14 @@
;; Check if the line is in use, and check validity of the keys.
(let ((key1 (svref vector index)))
(when (cache-key-p key1)
(if (zerop (layout-clos-hash key1))
(if (zerop (wrapper-clos-hash key1))
;; First key invalid.
(return-from cache-has-invalid-entries-p t)
;; Line is in use and the first key is valid: check the rest.
(loop for offset from 1 below key-count
do (let ((thing (svref vector (+ index offset))))
(when (or (not (cache-key-p thing))
(zerop (layout-clos-hash thing)))
(zerop (wrapper-clos-hash thing)))
;; Incomplete line or invalid layout.
(return-from cache-has-invalid-entries-p t)))))))
;; Line empty of valid, onwards.
@ -570,7 +570,7 @@
(total-lines (/ size line-size))
(total-n-keys 0) ; a "key" is a tuple of layouts
(n-dirty 0) ; lines that have an unbound marker but are not wholly empty
(n-obsolete 0) ; lines that need to be evicted due to 0 in a layout-clos-hash
(n-obsolete 0) ; lines that need to be evicted due to 0 in a wrapper-clos-hash
(histogram
(when compute-histogram
(make-array (1+ (cache-limit cache)) :initial-element 0))))
@ -583,7 +583,7 @@
(n-misses 0))
(cond ((find-if-not #'cache-key-p layouts)
(incf n-dirty))
((find 0 layouts :key #'layout-clos-hash)
((find 0 layouts :key #'wrapper-clos-hash)
(incf n-obsolete))
(t
(incf total-n-keys)

14
src/pcl/ctor.lisp
View file

@ -544,7 +544,7 @@
;; ...), because part of the deal is that those only happen from
;; FORCE-CACHE-FLUSHES, which create a new valid wrapper for the
;; class. An invalid layout of T needs to be flushed, however.
(when (eq (layout-invalid (class-wrapper class)) t)
(when (eq (wrapper-invalid (class-wrapper class)) t)
(%force-cache-flushes class))
(setf (ctor-class ctor) class)
(pushnew (make-weak-pointer ctor) (plist-value class 'ctors)
@ -572,7 +572,7 @@
;; ...), because part of the deal is that those only happen from
;; FORCE-CACHE-FLUSHES, which create a new valid wrapper for the
;; class. An invalid layout of T needs to be flushed, however.
(when (eq (layout-invalid (class-wrapper class)) t)
(when (eq (wrapper-invalid (class-wrapper class)) t)
(%force-cache-flushes class))
(setf (ctor-class ctor) class)
(pushnew (make-weak-pointer ctor) (plist-value class 'ctors)
@ -754,7 +754,7 @@
`(lambda ,(make-ctor-parameter-list ctor)
(declare #.*optimize-speed*)
(block nil
(when (layout-invalid ,wrapper)
(when (wrapper-invalid ,wrapper)
(install-initial-constructor ,ctor t)
(return (funcall ,ctor ,@(make-ctor-parameter-list ctor))))
,(wrap-in-allocate-forms ctor body early-unbound-markers-p)))
@ -767,7 +767,7 @@
`(lambda ()
(declare #.*optimize-speed*)
(block nil
(when (layout-invalid ,wrapper)
(when (wrapper-invalid ,wrapper)
(install-initial-constructor ,ctor t)
(return (funcall ,ctor)))
,(wrap-in-allocate-forms ctor nil t)))))
@ -784,10 +784,10 @@
(standard-class
`(let ((.instance. (%make-instance (1+ sb-vm:instance-data-start)))
(.slots. (make-array
,(layout-length wrapper)
,(wrapper-length wrapper)
,@(when early-unbound-markers-p
'(:initial-element +slot-unbound+)))))
(setf (%instance-layout .instance.) ,wrapper)
(setf (%instance-wrapper .instance.) ,wrapper)
(setf (std-instance-slots .instance.) .slots.)
,body
.instance.))
@ -914,7 +914,7 @@
(safe-p (ctor-safe-p ctor))
(wrapper (class-wrapper class))
(slot-vector
(make-array (layout-length wrapper) :initial-element nil))
(make-array (wrapper-length wrapper) :initial-element nil))
(class-inits ())
(default-inits ())
(defaulting-initargs ())

9
src/pcl/defs.lisp
View file

@ -122,7 +122,7 @@
((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type
(cdr type))))
((class class-eq) ; class-eq is impossible to do right
(layout-classoid (class-wrapper (cadr type))))
(wrapper-classoid (class-wrapper (cadr type))))
(eql type)
(t (if (null (cdr type))
(car type)
@ -185,8 +185,7 @@
(/noshow "entering DIRECT-SUPERS" (classoid-name class))
(if (typep class 'built-in-classoid)
(built-in-classoid-direct-superclasses class)
(let ((inherits (layout-inherits
(classoid-layout class))))
(let ((inherits (wrapper-inherits (classoid-wrapper class))))
(/noshow inherits)
(list (svref inherits (1- (length inherits)))))))
(direct-subs (class)
@ -209,8 +208,8 @@
`(,name
,(mapcar #'classoid-name (direct-supers class))
,(mapcar #'classoid-name (direct-subs class))
,(map 'list #'layout-classoid-name
(reverse (layout-inherits (classoid-layout class))))
,(map 'list #'wrapper-classoid-name
(reverse (wrapper-inherits (classoid-wrapper class))))
,(eval (getf (cdr kernel-bic-entry) :prototype-form)))))
(remove-if (lambda (kernel-bic-entry)
(member (first kernel-bic-entry)

16
src/pcl/dlisp.lisp
View file

@ -219,15 +219,15 @@
,@(unless class-slot-p
`((setq slots
(std-instance-slots ,instance))))
(%instance-layout ,instance))
(%instance-wrapper ,instance))
((fsc-instance-p ,instance)
,@(unless class-slot-p
`((setq slots
(fsc-instance-slots ,instance))))
(%fun-layout ,instance)))))
(%fun-wrapper ,instance)))))
(block access
(when (and wrapper
(not (zerop (layout-clos-hash wrapper)))
(not (zerop (wrapper-clos-hash wrapper)))
,@(if (eql 1 1-or-2-class)
`((eq wrapper wrapper-0))
`((or (eq wrapper wrapper-0)
@ -385,18 +385,18 @@
(with-unique-names (wrapper)
`(cond ((std-instance-p ,argument)
,(if slots-var
`(let ((,wrapper (%instance-layout ,argument)))
`(let ((,wrapper (%instance-wrapper ,argument)))
(when (layout-for-pcl-obj-p ,wrapper)
(setq ,slots-var (std-instance-slots ,argument)))
,wrapper)
`(%instance-layout ,argument)))
`(%instance-wrapper ,argument)))
((fsc-instance-p ,argument)
,(if slots-var
`(let ((,wrapper (%fun-layout ,argument)))
`(let ((,wrapper (%fun-wrapper ,argument)))
(when (layout-for-pcl-obj-p ,wrapper)
(setq ,slots-var (fsc-instance-slots ,argument)))
,wrapper)
`(%fun-layout ,argument)))
`(%fun-wrapper ,argument)))
(t (go ,miss-tag)))))
;; Sep92 PCL used to distinguish between some of these cases (and
;; spuriously exclude others). Since in SBCL
@ -407,7 +407,7 @@
(when slots-var
(bug "SLOT requested for metatype ~S, but it isn't going to happen."
metatype))
`(layout-of ,argument))
`(wrapper-of ,argument))
;; a metatype of NIL should never be seen here, as NIL is only in
;; the metatypes before a generic function is fully initialized.
;; T should never be seen because we never need to get a wrapper

14
src/pcl/env.lisp
View file

@ -171,8 +171,8 @@
(fmf (svref method 3))
(lambda-list (svref method 4))
(source-loc (svref method 5)))
(when (sb-kernel::layout-p specializer)
(setq specializer (layout-classoid-name specializer)))
(when (sb-kernel::wrapper-p specializer)
(setq specializer (wrapper-classoid-name specializer)))
(unless (member specializer except)
(multiple-value-bind (specializers arg-info)
(case gf-name
@ -194,7 +194,7 @@
mf)
plist ,arg-info simple-next-method-call t)
source-loc))))))
(!install-cross-compiled-methods 'make-load-form :except '(layout))
(!install-cross-compiled-methods 'make-load-form :except '(wrapper))
(defmethod make-load-form ((class class) &optional env)
;; FIXME: should we not instead pass ENV to FIND-CLASS? Probably
@ -206,13 +206,13 @@
(error "~@<Can't use anonymous or undefined class as constant: ~S~:@>"
class))))
(defmethod make-load-form ((object layout) &optional env)
(defmethod make-load-form ((object wrapper) &optional env)
(declare (ignore env))
(let ((pname (classoid-proper-name (layout-classoid object))))
(let ((pname (classoid-proper-name (wrapper-classoid object))))
(unless pname
(error "can't dump wrapper for anonymous class:~% ~S"
(layout-classoid object)))
`(classoid-layout (find-classoid ',pname))))
(wrapper-classoid object)))
`(classoid-wrapper (find-classoid ',pname))))
;; FIXME: this seems wrong. NO-APPLICABLE-METHOD should be signaled.
(defun dont-know-how-to-dump (object)

4
src/pcl/fixup.lisp
View file

@ -60,8 +60,8 @@
(compute-standard-slot-locations)
(dolist (s '(condition function structure-object))
(dohash ((k wrapper) (classoid-subclasses (find-classoid s)))
(declare (ignore wrapper))
(dohash ((k v) (classoid-subclasses (find-classoid s)))
(declare (ignore v))
(find-class (classoid-name k))))
(setq **boot-state** 'complete)

2
src/pcl/fngen.lisp
View file

@ -54,7 +54,7 @@
(defun default-constantp (form)
(and (constantp form)
(not (typep (constant-form-value form) '(or symbol fixnum cons layout)))))
(not (typep (constant-form-value form) '(or symbol fixnum cons wrapper)))))
(defun default-test-converter (form)
(if (default-constantp form)

7
src/pcl/low.lisp
View file

@ -46,8 +46,7 @@
(defun defstruct-classoid-p (classoid)
;; It is non-obvious to me why STRUCTURE-CLASSOID-P doesn't
;; work instead of this. -- NS 2008-03-14
(typep #-metaspace (layout-info (classoid-layout classoid))
#+metaspace (sb-kernel::wrapper-%info (sb-kernel::classoid-wrapper classoid))
(typep (sb-kernel::wrapper-%info (classoid-wrapper classoid))
'defstruct-description))
;;; This excludes structure types created with the :TYPE option to
@ -109,7 +108,7 @@
(defun set-funcallable-instance-function (fin new-value)
(declare (type function new-value))
;; t's not worth bothering to teach the compiler to efficiently transform
;; It's not worth bothering to teach the compiler to efficiently transform
;; a type test involving FUNCALLABLE-STANDARD-OBJECT, not the least
;; of the problems being that the type isn't known during make-host-2.
(unless (and (function-with-layout-p fin)
@ -300,7 +299,7 @@
(let ((setter 0))
(lambda (newval instance)
(if (eql setter 0)
(let* ((dd (layout-info (%instance-layout instance)))
(let* ((dd (wrapper-info (%instance-wrapper instance)))
(f (compile nil (slot-setter-lambda-form dd slotd))))
(if (functionp f)
(funcall (setq setter f) newval instance)

6
src/pcl/methods.lisp
View file

@ -922,9 +922,9 @@
'get-accessor-method-function)))
,optimized-std-fun)))
(wrappers
(let ((wrappers (list (layout-of class)
(let ((wrappers (list (wrapper-of class)
(class-wrapper class)
(layout-of slotd))))
(wrapper-of slotd))))
(if (eq type 'writer)
(cons (class-wrapper *the-class-t*) wrappers)
wrappers)))
@ -1674,7 +1674,7 @@
gf (generic-function-encapsulations gf) (call-next-method)))
(defmethod (setf class-name) (new-value class)
(let ((classoid (layout-classoid (class-wrapper class))))
(let ((classoid (wrapper-classoid (class-wrapper class))))
(if (and new-value (symbolp new-value))
(setf (classoid-name classoid) new-value)
(setf (classoid-name classoid) nil)))

2
src/pcl/slots-boot.lisp
View file

@ -549,7 +549,7 @@
(defun find-slot-cell (wrapper slot-name)
(declare (symbol slot-name))
(declare (optimize (sb-c::insert-array-bounds-checks 0)))
(let* ((vector (layout-slot-table wrapper))
(let* ((vector (wrapper-slot-table wrapper))
(modulus (truly-the index (svref vector 0)))
;; Can elide the 'else' branch of (OR symbol-hash ensure-symbol-hash)
;; because every symbol in the slot-table already got a nonzero hash.

2
src/pcl/slots.lisp
View file

@ -413,7 +413,7 @@
;; in list. The only exceptions are when there are non-local slots
;; before the one we want.
(slot-definition-name
(find position (wrapper-slot-list (layout-of instance))
(find position (wrapper-slot-list (wrapper-of instance))
:key #'slot-definition-location)))
(cons
(car position))))))

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

@ -175,17 +175,17 @@
(with-slots (direct-subclasses) class
(with-world-lock ()
(pushnew subclass direct-subclasses :test #'eq)
(let ((layout (class-wrapper subclass)))
(when layout
(let* ((classoid (layout-classoid layout)))
(dovector (super-layout (layout-inherits layout))
(let* ((super (layout-classoid super-layout))
(let ((wrapper (class-wrapper subclass)))
(when wrapper
(let* ((classoid (wrapper-classoid wrapper)))
(dovector (super-wrapper (wrapper-inherits wrapper))
(let* ((super (wrapper-classoid super-wrapper))
(subclasses (or (classoid-subclasses super)
(setf (classoid-subclasses super)
(make-hash-table :hash-function #'type-hash-value
:test 'eq
:synchronized t)))))
(setf (gethash classoid subclasses) (sb-kernel::layout-friend layout))))))))
(setf (gethash classoid subclasses) wrapper)))))))
subclass))
(defmethod remove-direct-subclass ((class class) (subclass class))
(with-slots (direct-subclasses) class
@ -193,8 +193,8 @@
(setq direct-subclasses (remove subclass direct-subclasses))
;; Remove from classoid subclasses as well.
(let ((classoid (class-classoid subclass)))
(dovector (super-layout (layout-inherits (classoid-layout classoid)))
(let* ((super (layout-classoid super-layout))
(dovector (super-wrapper (wrapper-inherits (classoid-wrapper classoid)))
(let* ((super (wrapper-classoid super-wrapper))
(subclasses (classoid-subclasses super)))
(when subclasses
(remhash classoid subclasses))))))
@ -553,16 +553,16 @@
;; some class is forthcoming, because there are legitimate
;; questions one can ask of the type system, implemented in
;; terms of CLASSOIDs, involving forward-referenced classes. So.
(let ((layout (make-wrapper 0 class)))
(setf (slot-value class 'wrapper) layout)
(let ((wrapper (make-wrapper 0 class)))
(setf (slot-value class 'wrapper) wrapper)
(let ((cpl (compute-preliminary-cpl class)))
(set-layout-inherits layout
(set-layout-inherits wrapper
(order-layout-inherits
(map 'simple-vector #'class-wrapper
(reverse (rest cpl))))
nil 0))
(set-bitmap-and-flags layout)
(register-layout layout :invalidate t))))
(set-bitmap-and-flags wrapper)
(register-layout wrapper :invalidate t))))
(mapc #'make-preliminary-layout (class-direct-subclasses class))))))
@ -622,7 +622,7 @@
finalized-p t
(classoid-pcl-class classoid) class
direct-supers direct-superclasses
wrapper (classoid-layout classoid)
wrapper (classoid-wrapper classoid)
%class-precedence-list (compute-class-precedence-list class)
cpl-available-p t
(getf plist 'direct-default-initargs)
@ -630,7 +630,7 @@
(add-direct-subclasses class direct-superclasses)
(let ((slots (compute-slots class)))
(setf (slot-value class 'slots) slots)
(setf (layout-slot-table wrapper) (make-slot-table class slots)))))
(setf (wrapper-slot-table wrapper) (make-slot-table class slots)))))
;; Comment from Gerd's PCL, 2003-05-15:
;;
;; We don't ADD-SLOT-ACCESSORS here because we don't want to
@ -774,7 +774,7 @@
;; (LAMBDA () (SB-PCL::FAST-MAKE-INSTANCE #<STRUCTURE-CLASS THING>))
;; So maybe we can figure out how to bundle two lambdas together?
(lambda ()
(let* ((dd (layout-dd (class-wrapper class)))
(let* ((dd (wrapper-dd (class-wrapper class)))
(f (%make-structure-instance-allocator dd nil)))
(if (functionp f)
(funcall (setf (slot-value class 'defstruct-constructor) f))
@ -850,10 +850,10 @@
(let ((slots (compute-slots class)))
(setf (slot-value class 'slots) slots)
(let* ((lclass (find-classoid (slot-value class 'name)))
(layout (classoid-layout lclass)))
(layout (classoid-wrapper lclass)))
(setf (classoid-pcl-class lclass) class)
(setf (slot-value class 'wrapper) layout)
(setf (layout-slot-table layout) (make-slot-table class slots))))
(setf (wrapper-slot-table layout) (make-slot-table class slots))))
(setf (slot-value class 'finalized-p) t)
(add-slot-accessors class direct-slots)))
@ -1099,8 +1099,8 @@
(%update-lisp-class-layout class nwrapper)
(setf (slot-value class 'slots) eslotds
(wrapper-slot-list nwrapper) eslotds
(layout-slot-table nwrapper) (make-slot-table class eslotds)
(layout-length nwrapper) nslots
(wrapper-slot-table nwrapper) (make-slot-table class eslotds)
(wrapper-length nwrapper) nslots
(slot-value class 'wrapper) nwrapper)
(style-warn-about-duplicate-slots class)
(setf (slot-value class 'finalized-p) t)
@ -1418,21 +1418,21 @@
(eq (class-of class) *the-class-standard-class*))))
;;; What this does depends on which of the four possible values of
;;; LAYOUT-INVALID the PCL wrapper has; the simplest case is when it
;;; WRAPPER-INVALID the PCL wrapper has; the simplest case is when it
;;; is (:FLUSH <wrapper>) or (:OBSOLETE <wrapper>), when there is
;;; nothing to do, as the new wrapper has already been created. If
;;; LAYOUT-INVALID returns NIL, then we invalidate it (setting it to
;;; WRAPPER-INVALID returns NIL, then we invalidate it (setting it to
;;; (:FLUSH <wrapper>); UPDATE-SLOTS later gets to choose whether or
;;; not to "upgrade" this to (:OBSOLETE <wrapper>).
;;;
;;; This leaves the case where LAYOUT-INVALID returns T, which happens
;;; This leaves the case where WRAPPER-INVALID returns T, which happens
;;; when REGISTER-LAYOUT has invalidated a superclass of CLASS (which
;;; invalidated all the subclasses in SB-KERNEL land). Again, here we
;;; must flush the caches and allow UPDATE-SLOTS to decide whether to
;;; obsolete the wrapper.
;;;
;;; FIXME: either here or in INVALID-WRAPPER-P looks like a good place
;;; for (AVER (NOT (EQ (LAYOUT-INVALID OWRAPPER)
;;; for (AVER (NOT (EQ (WRAPPER-INVALID OWRAPPER)
;;; :UNINITIALIZED)))
;;;
;;; Thanks to Gerd Moellmann for the explanation. -- CSR, 2002-10-29
@ -1449,19 +1449,19 @@
;; a violation of locality or what might be considered
;; good style. There has to be a better way! -- CSR,
;; 2002-10-29
(eq (layout-invalid owrapper) t))
(let ((nwrapper (make-wrapper (layout-length owrapper)
(eq (wrapper-invalid owrapper) t))
(let ((nwrapper (make-wrapper (wrapper-length owrapper)
class)))
(setf (wrapper-slot-list nwrapper) (wrapper-slot-list owrapper))
(setf (layout-slot-table nwrapper) (layout-slot-table owrapper))
(setf (wrapper-slot-table nwrapper) (wrapper-slot-table owrapper))
(%update-lisp-class-layout class nwrapper)
(setf (slot-value class 'wrapper) nwrapper)
;; Use :OBSOLETE instead of :FLUSH if any superclass has
;; been obsoleted.
(if (find-if (lambda (x)
(and (consp x) (eq :obsolete (car x))))
(layout-inherits owrapper)
:key #'layout-invalid)
(wrapper-inherits owrapper)
:key #'wrapper-invalid)
(%invalidate-wrapper owrapper :obsolete nwrapper)
(%invalidate-wrapper owrapper :flush nwrapper))))))
nil)
@ -1472,14 +1472,14 @@
(defmethod make-instances-obsolete ((class std-class))
(with-world-lock ()
(let* ((owrapper (class-wrapper class))
(nwrapper (make-wrapper (layout-length owrapper)
(nwrapper (make-wrapper (wrapper-length owrapper)
class)))
(unless (class-finalized-p class)
(if (class-has-a-forward-referenced-superclass-p class)
(return-from make-instances-obsolete class)
(%update-cpl class (compute-class-precedence-list class))))
(setf (wrapper-slot-list nwrapper) (wrapper-slot-list owrapper))
(setf (layout-slot-table nwrapper) (layout-slot-table owrapper))
(setf (wrapper-slot-table nwrapper) (wrapper-slot-table owrapper))
(%update-lisp-class-layout class nwrapper)
(setf (slot-value class 'wrapper) nwrapper)
(%invalidate-wrapper owrapper :obsolete nwrapper)
@ -1566,10 +1566,10 @@
(macrolet ((replace-wrapper-and-slots (thing layout slot-vector)
`(if (functionp ,thing)
(setf (%fun-layout ,thing) ,layout
(setf (%fun-wrapper ,thing) ,layout
(%fsc-instance-slots ,thing) ,slot-vector)
;; TODO: use a double-wide CAS here if CPU supports it
(setf (%instance-layout ,thing) ,layout
(setf (%instance-wrapper ,thing) ,layout
(std-instance-slots ,thing) ,slot-vector))))
(defun %obsolete-instance-trap (owrapper nwrapper instance)
@ -1578,7 +1578,7 @@
(binding* ((class (wrapper-class nwrapper))
(oslots (get-slots instance))
(nwrapper (class-wrapper class))
(nslots (make-array (layout-length nwrapper)
(nslots (make-array (wrapper-length nwrapper)
:initial-element +slot-unbound+))
(added ())
(discarded ())
@ -1668,9 +1668,9 @@
(defun %change-class (copy instance new-class initargs)
(binding* ((new-wrapper (class-wrapper (ensure-class-finalized new-class)))
(new-slots (make-array (layout-length new-wrapper)
(new-slots (make-array (wrapper-length new-wrapper)
:initial-element +slot-unbound+))
(old-wrapper (layout-of instance))
(old-wrapper (wrapper-of instance))
(old-class (wrapper-class old-wrapper))
(old-slots (get-slots instance))
(safe (safe-p new-class))

47
src/pcl/wrapper.lisp
View file

@ -27,7 +27,7 @@
(in-package "SB-PCL")
(defmacro wrapper-class (wrapper)
`(classoid-pcl-class (layout-classoid ,wrapper)))
`(classoid-pcl-class (wrapper-classoid ,wrapper)))
;;; This is called in BRAID when we are making wrappers for classes
;;; whose slots are not initialized yet, and which may be built-in
@ -36,7 +36,7 @@
(let ((found (find-classoid name nil)))
(cond
(found
(let ((layout (classoid-layout found)))
(let ((layout (classoid-wrapper found)))
(aver layout)
layout))
(t
@ -62,7 +62,7 @@
(classoid
(let ((owrap (class-wrapper class)))
(cond (owrap
(layout-classoid owrap))
(wrapper-classoid owrap))
((or (*subtypep (class-of class) *the-class-standard-class*)
(*subtypep (class-of class) *the-class-funcallable-standard-class*)
(typep class 'forward-referenced-class))
@ -76,7 +76,7 @@
:invalid nil :length length :flags +pcl-object-layout-flag+)))
(t
(let* ((found (find-classoid (slot-value class 'name)))
(layout (classoid-layout found)))
(layout (classoid-wrapper found)))
(unless (classoid-pcl-class found)
(setf (classoid-pcl-class found) class))
(aver (eq (classoid-pcl-class found) class))
@ -99,7 +99,7 @@
;;; This "simple" function hides a horrible inconsistency: we don't have a single
;;; canonical atomically checkable validity indicator. We carry around invalid layouts
;;; with nonzero hashes. Why else would there be so may places that can do:
;;; (setf (layout-invalid layout) nil
;;; (setf (wrapper-invalid layout) nil
;;; whilst the layout in question already has a "valid" hash?
;;; It's hard to know what the right thing is, but since internal code uses
;;; this test to decide how to handle layouts that have been invalidated,
@ -107,7 +107,7 @@
;;; even though logically that *should* be the canonical test.
(declaim (inline invalid-wrapper-p))
(defun invalid-wrapper-p (wrapper)
(not (null (layout-invalid wrapper))))
(not (null (wrapper-invalid wrapper))))
;;; The portable code inherited from the ancient PCL sources used an extremely
;;; clever mechanism to store a mapping from new layouts ("wrappers") to old.
@ -157,10 +157,10 @@
(defun %invalidate-wrapper (owrapper state nwrapper)
(aver (member state '(:flush :obsolete)))
#+sb-thread (aver (sb-thread:holding-mutex-p sb-c::**world-lock**))
(let ((classoid (layout-classoid nwrapper))
(let ((classoid (wrapper-classoid nwrapper))
(new-previous ())
(new-state (cons state nwrapper)))
(aver (eq (layout-classoid owrapper) classoid))
(aver (eq (wrapper-classoid owrapper) classoid))
;; First off, a previous call to INVALIDATE-WRAPPER may have
;; recorded OWRAPPER as an NWRAPPER to update to. Since OWRAPPER
;; is about to be invalid, it no longer makes sense to update to
@ -172,8 +172,8 @@
(dolist (weak-pointer (sb-kernel::standard-classoid-old-layouts classoid))
(let ((previous (weak-pointer-value weak-pointer)))
(when previous
(setf (layout-invalid previous)
(cond ((and (eq (car (layout-invalid previous)) :obsolete)
(setf (wrapper-invalid previous)
(cond ((and (eq (car (wrapper-invalid previous)) :obsolete)
(eq state :flush))
;; :obsolete must stay :obsolete,
;; requiring the protocol for obsolete instances.
@ -187,11 +187,12 @@
;; accessing the wrapper at the same time from outside the lock?
;; Inform readers of the reason for wrapper invalidity before marking
;; the wrapper as invalid.
(setf (layout-invalid owrapper) new-state)
(setf (wrapper-invalid owrapper) new-state)
;; Ensure that the INVALID slot conveying ancillary data describing the
;; invalidity reason is published before causing the invalid layout trap.
(sb-thread:barrier (:write))
(setf (layout-clos-hash owrapper) 0)
#+metaspace (setf (layout-clos-hash (wrapper-friend owrapper)) 0)
(setf (wrapper-clos-hash owrapper) 0)
(push (make-weak-pointer owrapper) new-previous)
;; This function is called for effect; return value is arbitrary.
(setf (sb-kernel::standard-classoid-old-layouts classoid)
@ -202,8 +203,8 @@
;;; (or the names of our callees.)
(defun check-wrapper-validity (instance)
(with-world-lock ()
(let* ((owrapper (layout-of instance))
(state (layout-invalid owrapper)))
(let* ((owrapper (wrapper-of instance))
(state (wrapper-invalid owrapper)))
(aver (not (eq state :uninitialized)))
(cond ((not state)
owrapper)
@ -230,7 +231,7 @@
;; Error message here is trying to figure out a bit more about the
;; situation, since we don't have anything approaching a test-case
;; for the bug.
(let ((new-state (layout-invalid (layout-of instance))))
(let ((new-state (wrapper-invalid (wrapper-of instance))))
(when (eq new-state t)
(cerror "Nevermind and recurse." 'bug
:format-control "~@<~4IProblem forcing cache flushes. Please report ~
@ -239,19 +240,19 @@
~% Wrapper-of: ~S~
~% Class-wrapper: ~S~%~:@>"
:format-arguments (mapcar (lambda (x)
(cons x (layout-invalid x)))
(cons x (wrapper-invalid x)))
(list owrapper
(layout-of instance)
(wrapper-of instance)
(class-wrapper class)))))))
(check-wrapper-validity instance))
((consp state)
(let ((new (the layout (cdr state))))
(let ((new (the wrapper (cdr state))))
(ecase (car state)
(:flush
(cond ((std-instance-p instance)
(setf (%instance-layout instance) new))
(setf (%instance-wrapper instance) new))
((fsc-instance-p instance)
(setf (%fun-layout instance) new))
(setf (%fun-wrapper instance) new))
(t
(bug "unrecognized instance type"))))
(:obsolete
@ -259,11 +260,11 @@
(declaim (inline check-obsolete-instance))
(defun check-obsolete-instance (instance)
(when (invalid-wrapper-p (layout-of instance))
(when (invalid-wrapper-p (wrapper-of instance))
(check-wrapper-validity instance)))
(defun valid-wrapper-of (instance)
(let ((wrapper (layout-of instance)))
(let ((wrapper (wrapper-of instance)))
(if (invalid-wrapper-p wrapper)
(check-wrapper-validity instance)
wrapper)))
@ -353,7 +354,7 @@
`((class *the-class-t*)
(type t))))
(unless (eq mt t)
(setq wrapper (layout-of arg))
(setq wrapper (wrapper-of arg))
(when (invalid-wrapper-p wrapper)
(setq ,invalid-wrapper-p t)
(setq wrapper (check-wrapper-validity arg)))

3
src/runtime/print.c
View file

@ -437,9 +437,6 @@ static void brief_struct(lispobj obj)
#include "genesis/layout.h"
#include "genesis/defstruct-description.h"
#include "genesis/defstruct-slot-description.h"
#ifdef LISP_FEATURE_METASPACE
#include "genesis/wrapper.h"
#endif
static boolean tagged_slot_p(struct layout *layout, int slot_index)
{
// Since we're doing this scan, we could return the name

6
tests/classoid-typep.impure.lisp
View file

@ -35,14 +35,14 @@
(defclass baz () ())
(defclass bar (baz) (a))
(write-to-string *thing*)
(values *thing* (sb-kernel:%instance-layout *thing*)))"))))
(values *thing* (sb-kernel:%instance-wrapper *thing*)))"))))
;;; Given the PCL state set up by the above function,
;;; execute CLASSOID-TYPEP simultaneously in two threads.
(defun concurrent-classoid-typep (obj)
(let* ((sem (sb-thread:make-semaphore))
(obj-layout (sb-kernel:%instance-layout obj))
(classoid (sb-kernel:layout-classoid obj-layout))
(obj-layout (sb-kernel:%instance-wrapper obj))
(classoid (sb-kernel:wrapper-classoid obj-layout))
(fun (lambda ()
(sb-thread:wait-on-semaphore sem)
(handler-case (sb-kernel:classoid-typep obj-layout classoid obj)

6
tests/clos-cache.impure.lisp
View file

@ -27,9 +27,9 @@
;;; (The expression would be wrong if it reduced in the wrong direction, e.g.)
(with-test (:name :compute-index-optimization)
(macrolet ((optimized-way (a b c)
`(let ((a (sb-kernel:layout-clos-hash ,a))
(b (sb-kernel:layout-clos-hash ,b))
(c (sb-kernel:layout-clos-hash ,c)))
`(let ((a (sb-kernel:wrapper-clos-hash ,a))
(b (sb-kernel:wrapper-clos-hash ,b))
(c (sb-kernel:wrapper-clos-hash ,c)))
,(sb-pcl::cache-mixer-expression 'sb-int:mix '(a b c) nil))))
(let* ((l1 (sb-kernel:find-layout 'pathname))
(l2 (sb-kernel:find-layout 'cons))

4
tests/clos.impure.lisp
View file

@ -2635,7 +2635,7 @@
(eval `(defclass ,class2 (,class1) ()))
(let ((instance (make-instance class2)))
(sb-mop:finalize-inheritance (find-class class1))
(assert (not (sb-kernel:layout-invalid (sb-kernel:layout-of instance)))))))
(assert (not (sb-kernel:wrapper-invalid (sb-kernel:wrapper-of instance)))))))
(with-test (:name (allocate-instance :on symbol))
(let ((class (gensym "CLASS-")))
@ -2654,7 +2654,7 @@
unbound-slot))
(with-test (:name :layouf-of-nil)
(assert (eq (sb-kernel:layout-of nil) (sb-kernel:find-layout 'null))))
(assert (eq (sb-kernel:wrapper-of nil) (sb-kernel:find-layout 'null))))
(with-test (:name (defmethod :on-classless-type))
(handler-bind ((timeout (lambda (condition)

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

@ -2680,7 +2680,7 @@
(t :none))))))
;; There should be no #<layout> referenced directly from the code header.
;; There is of course a vector of layouts in there to compare against.
(assert (not (ctu:find-code-constants f :type 'sb-kernel:layout)))
(assert (not (ctu:find-code-constants f :type 'sb-kernel:wrapper)))
;; The function had better work.
(assert (eq (funcall f 'wat) :none))
(assert (equal (funcall f (make-broadcast-stream *error-output*))

3
tests/condition.pure.lisp
View file

@ -427,8 +427,7 @@ is not of type
(with-test (:name :condition-layout-lengths)
(loop for wrapper being each hash-value of (sb-kernel:classoid-subclasses
(sb-kernel:find-classoid 'condition))
for len = (sb-kernel:layout-length
(#+metaspace sb-kernel::wrapper-friend #-metaspace progn wrapper))
for len = (sb-kernel:wrapper-length wrapper)
minimize len into min
maximize len into max
finally (assert (= min max))))

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

@ -24,13 +24,13 @@
(dolist (symbol '(make-s1 make-s2 make-s3))
(let ((constants
(ctu:find-code-constants (symbol-function symbol)
:type 'sb-kernel:layout)))
:type 'sb-kernel:wrapper)))
(assert (= (length constants) 1)))))
(with-test (:name :mutex-owner-typecheck)
(let ((layouts
(ctu:find-code-constants #'(setf sb-thread::mutex-%owner)
:type 'sb-kernel:layout)))
:type 'sb-kernel:wrapper)))
;; expect exactly 1 layout, that of MUTEX, for signaling OBJECT-NOT-TYPE.
;; To be really pedantic we'd want to assert that in the source file
;; the defstruct of MUTEX appears prior to the defstruct of THREAD,
@ -82,7 +82,7 @@ Evaluation took:
(with-test (:name :no-equalp-calls)
(dolist (type '(parent child child2))
(let* ((equalp-impl
(sb-kernel:layout-equalp-impl (sb-kernel:find-layout type)))
(sb-kernel:wrapper-equalp-impl (sb-kernel:find-layout type)))
(constants
(ctu:find-code-constants equalp-impl)))
(case type

53
tests/defstruct.impure.lisp
View file

@ -16,51 +16,48 @@
(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-kernel:get-dsd-index sb-vm: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
(let ((all-wrappers
(delete-if
;; temporary layouts (created for parsing DEFSTRUCT)
;; must be be culled out.
(lambda (x)
(and (typep (sb-kernel:layout-classoid x)
(and (typep (sb-kernel:wrapper-classoid x)
'sb-kernel:structure-classoid)
(eq (sb-kernel::layout-equalp-impl x)
(eq (sb-kernel:wrapper-equalp-impl x)
#'sb-kernel::equalp-err)))
(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)))
:test #'sb-kernel::wrapper-p))))
(dolist (wrapper all-wrappers)
(let ((id (sb-kernel:layout-id wrapper)))
(sb-int:awhen (gethash id hash)
(error "ID ~D is ~A and ~A" id sb-int:it layout))
(setf (gethash id hash) layout)))
(error "ID ~D is ~A and ~A" id sb-int:it wrapper))
(setf (gethash id hash) wrapper)))
;; 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)
(dolist (wrapper all-wrappers)
(when (find structure-object (sb-kernel:wrapper-inherits wrapper))
(let* ((layout (sb-kernel:wrapper-friend wrapper))
(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)
(loop for depthoid from 2 to (sb-kernel:wrapper-depthoid wrapper)
collect (sb-sys:signed-sap-ref-32 sap (ash (- depthoid 2) 2))))))
(expect
(map 'list 'sb-kernel:layout-id
(sb-kernel:layout-inherits layout))))
(unless (equal (list* (sb-kernel:layout-id
(sb-kernel:find-layout 't))
(sb-kernel:layout-id
(sb-kernel:find-layout 'structure-object))
(expected
(map 'list 'sb-kernel:layout-id (sb-kernel:wrapper-inherits wrapper))))
(unless (equal (list* (sb-kernel:layout-id (sb-kernel:find-layout 't))
(sb-kernel:layout-id (sb-kernel:find-layout 'structure-object))
ids)
(append expect (list (sb-kernel:layout-id layout))))
(append expected (list (sb-kernel:layout-id wrapper))))
(error "Wrong IDs for ~A: expect ~D actual ~D~%"
layout expect ids))))))))
wrapper expected ids))))))))
;;;; examples from, or close to, the Common Lisp DEFSTRUCT spec
@ -589,7 +586,7 @@
(eql (huge-manyraw-w1 s) #xffee)
(eql (huge-manyraw-w2 s) #xeeee)))
(dolist (slot (sb-kernel:dd-slots
(sb-kernel:layout-info (sb-kernel:layout-of s))))
(sb-kernel:wrapper-info (sb-kernel:wrapper-of s))))
(let ((name (string (sb-kernel:dsd-name slot))))
(cond ((eql (mismatch name "SLOT-") 5)
(let ((n (parse-integer name :start 5)))
@ -946,7 +943,7 @@ redefinition."
(assert (funcall predicate instance)))
(defun assert-invalid (instance)
(assert (sb-kernel:layout-invalid (sb-kernel:%instance-layout instance))))
(assert (sb-kernel:wrapper-invalid (sb-kernel:%instance-wrapper instance))))
;; Don't try to understand this macro; just look at its expansion.
(defmacro with-defstruct-redefinition-test (name
@ -1480,7 +1477,7 @@ redefinition."
(test-util:with-test (:name :specialized-equalp)
;; make sure we didn't mess up PATHNAME and HASH-TABLE
(let ((f (sb-kernel:layout-equalp-impl (sb-kernel:find-layout 'pathname))))
(let ((f (sb-kernel:wrapper-equalp-impl (sb-kernel:find-layout 'pathname))))
(assert (eq f #'sb-int:pathname=)))
(let ((f (sb-kernel:layout-equalp-impl (sb-kernel:find-layout 'hash-table))))
(let ((f (sb-kernel:wrapper-equalp-impl (sb-kernel:find-layout 'hash-table))))
(assert (eq f #'sb-int:hash-table-equalp))))

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

@ -11,10 +11,12 @@
(in-package sb-vm)
(defun collect-slot-values (obj)
(collect ((slots))
(defun collect-slot-values (obj &aux result)
(flet ((slots (x)
#+metaspace (if (typep x 'sb-vm:layout) (setq x (sb-kernel::layout-friend x)))
(push x result)))
(do-referenced-object (obj slots))
(slots)))
(nreverse result)))
(defun walk-slots-test (obj expect)
(assert (equal (collect-slot-values obj) expect)))
@ -89,27 +91,26 @@
(walk-slots-test* o
(lambda (slots)
(destructuring-bind (layout clos-slots) slots
(and (eq layout (%instance-layout o))
(and (eq layout (%instance-wrapper o))
(eq clos-slots (sb-pcl::std-instance-slots o))))))))
(define-condition cfoo (simple-condition) ((a :initarg :a) (b :initarg :b) (c :initform 'c)))
(test-util:with-test (:name :walk-slots-condition-instance)
(let ((instance (make-condition 'cfoo :a 'ay :b 'bee :format-arguments "wat")))
(walk-slots-test instance
`(,(find-layout 'cfoo)
(c c format-control nil)
`(,(find-layout 'cfoo) (c c format-control nil)
:a ay :b bee :format-arguments "wat"))))
(defun make-random-funinstance (&rest values)
(let* ((ctor (apply #'sb-pcl::%make-ctor values))
(layout (sb-kernel:%fun-layout ctor)))
(wrapper (sb-kernel:%fun-wrapper ctor)))
;; If the number of payload words is even, then there's a padding word
;; because adding the header makes the unaligned total an odd number.
;; Fill that padding word with something - it should not be visible.
;; Whether GC should trace the word is a different question,
;; on whose correct answer I waver back and forth.
(when (evenp (sb-kernel:get-closure-length ctor)) ; payload length
(let ((max (reduce #'max (sb-kernel:dd-slots (sb-kernel:layout-info layout))
(let ((max (reduce #'max (sb-kernel:dd-slots (sb-kernel:wrapper-dd wrapper))
:key 'sb-kernel:dsd-index)))
(setf (sb-kernel:%funcallable-instance-info ctor (1+ max))
(elt sb-vm:+static-symbols+ 0))))
@ -130,9 +131,9 @@
(funcall f 1 2 3) ; compute the digested slots
(walk-slots-test* f
(lambda (slots)
(destructuring-bind (layout fin-fun a b c d) slots
(destructuring-bind (type fin-fun a b c d) slots
(declare (ignore a b c))
(and (typep layout 'layout)
(and (typep type 'wrapper)
(typep fin-fun 'closure)
(typep d '(and integer (not (eql 0))))))))))
@ -146,7 +147,7 @@
(defun deep-size (obj &optional (leafp (lambda (x)
(typep x '(or package symbol fdefn
function code-component
layout classoid)))))
wrapper classoid)))))
(let ((worklist (list obj))
(seen (make-hash-table :test 'eq))
(tot-bytes 0))

2
tests/dynamic-extent.impure.lisp
View file

@ -343,7 +343,7 @@
(let ((thing sb-c::*backend-parsed-vops*))
;; check some preconditions
(assert (typep thing 'hash-table))
(assert (/= (sb-kernel:layout-bitmap (sb-kernel:%instance-layout thing))
(assert (/= (sb-kernel:wrapper-bitmap (sb-kernel:%instance-wrapper thing))
sb-kernel:+layout-all-tagged+))
(assert-no-consing
(sb-int:dx-let ((x (copy-structure thing)))

2
tests/fast-eval.impure.lisp
View file

@ -301,7 +301,7 @@
(defstruct testme x)
(test-util:with-test (:name :compiled-equalp-method)
(assert (compiled-function-p
(sb-kernel:layout-equalp-impl
(sb-kernel:wrapper-equalp-impl
(sb-kernel:find-layout 'testme)))))
(let ((f #'testme-x))
(let ((source-loc (sb-interpreter:fun-source-location f)))

2
tests/full-eval.impure.lisp
View file

@ -122,7 +122,7 @@
(sb-c::cif 'c)
(sb-c::cset 'd)
(sb-c::ref 'e)
(sb-kernel:layout 'winner)))
(sb-kernel:wrapper 'winner)))
(with-test (:name :interpreted-type-constraint)
(assert (eq (typecase-test (sb-kernel:find-layout 'cons)) 'winner)))

4
tests/gc.impure-cload.lisp
View file

@ -11,7 +11,7 @@
;;;; absoluely no warranty. See the COPYING and CREDITS files for
;;;; more information.
#-gencgc
#-(and gencgc (not metaspace))
(eval-when (:compile-toplevel :load-toplevel :execute)
(sb-ext:exit :code 104))
@ -120,7 +120,7 @@
;; don't just COPY-STRUCTURE - that would place it in dynamic space
(let ((new-layout
(sb-kernel:make-layout (sb-kernel::hash-layout-name nil)
(sb-kernel:layout-classoid layout))))
(sb-kernel:wrapper-classoid layout))))
(sb-kernel:%byte-blt
(sb-sys:int-sap
(- (sb-kernel:get-lisp-obj-address layout)

4
tests/hash.pure.lisp
View file

@ -354,8 +354,8 @@
;;; This affected the performance of TYPECASE.
(with-test (:name :sxhash-on-layout)
(dolist (x '(pathname cons array))
(let ((l (sb-kernel:find-layout x)))
(assert (= (sxhash l) (sb-kernel::layout-clos-hash l))))))
(let ((l (sb-kernel:wrapper-friend (sb-kernel:find-layout x))))
(assert (= (sxhash l) (sb-kernel:layout-clos-hash l))))))
(with-test (:name :equalp-table-fixnum-equal-to-float)
(let ((table (make-hash-table :test #'equalp)))

4
tests/immobile-space.impure.lisp
View file

@ -18,7 +18,7 @@
;;; Assign a bitmap that is not the special case for "all tagged"
;;; but does correctly indicate 1 tagged slot.
(let* ((l (sb-kernel:find-layout 'trythis))
(let* ((l (sb-kernel:wrapper-friend (sb-kernel:find-layout 'trythis)))
(slot (1- (sb-kernel:%instance-length l))))
(assert (eql (sb-kernel:%raw-instance-ref/signed-word l slot)
sb-kernel:+layout-all-tagged+))
@ -36,7 +36,7 @@
(compile 'll-alloc) ; low level allocator
(defun make ()
(let ((inst (ll-alloc)))
(setf (sb-kernel:%instance-layout (truly-the trythis inst))
(setf (sb-kernel:%instance-wrapper (truly-the trythis inst))
(sb-kernel:find-layout 'trythis))
(setf (trythis-a inst) (copy-seq "Hello"))
inst))

8
tests/raw-slots-interleaved.impure.lisp
View file

@ -33,7 +33,7 @@
,(format nil "This is ~D" i))))))
(def-100slots))
(assert (typep (sb-kernel:layout-bitmap
(assert (typep (sb-kernel:wrapper-bitmap
(sb-kernel::find-layout 'biggy)) 'bignum))
(defvar *x* nil)
@ -60,14 +60,14 @@
;; Run it twice to make sure things really worked.
(let ((*y* (make-biggy))
(*x* (sb-kernel:layout-bitmap
(*x* (sb-kernel:wrapper-bitmap
(sb-kernel::find-layout 'biggy))))
(sb-ext:gc :gen 1))
(princ 'did-pass-1) (terpri)
(force-output)
(let ((*y* (make-biggy))
(*x* (sb-kernel:layout-bitmap
(*x* (sb-kernel:wrapper-bitmap
(sb-kernel::find-layout 'biggy))))
(sb-ext:gc :gen 1))
(princ 'did-pass-2) (terpri)
@ -99,7 +99,7 @@
(c 'cee)) ; 13 9
(defvar *afoo* (make-foo1))
(assert (= (sb-kernel:layout-length (sb-kernel:layout-of *afoo*))
(assert (= (sb-kernel:wrapper-length (sb-kernel:wrapper-of *afoo*))
(sb-kernel:%instance-length *afoo*)))
(with-test (:name :tagged-slot-iterator-macro)
;; on 32-bit, the logical length is 14, which means 15 words (with header),

2
tests/save3.test.sh
View file

@ -34,7 +34,7 @@ run_sbcl <<EOF
(:metaclass sb-mop:funcallable-standard-class))
(defclass subgf (standard-generic-function) (a) ; remove a slot
(:metaclass sb-mop:funcallable-standard-class))
(let ((nl (sb-kernel:find-layout 'subgf))) ; new layout
(let ((nl (sb-kernel:wrapper-friend (sb-kernel:find-layout 'subgf)))) ; new layout
(assert (not (eq (sb-kernel:%fun-layout #'myfun) nl)))
(setf (sb-kernel:%fun-layout #'myfun) nl)
(gc)))

12
tests/stream.impure.lisp
View file

@ -31,16 +31,16 @@
(assert (streamp *str*))
(defclass astream (fundamental-output-stream) (x y))
(with-test (:name :update-stream-layout)
(assert (sb-kernel:layout-invalid (sb-kernel:%instance-layout *str*)))
(assert (sb-kernel:wrapper-invalid (sb-kernel:%instance-wrapper *str*)))
(assert (streamp *str*))
(assert (/= 0 (sb-kernel:layout-clos-hash (sb-kernel:%instance-layout *str*))))
(assert (/= 0 (sb-kernel:wrapper-clos-hash (sb-kernel:%instance-wrapper *str*))))
(defclass astream () (x y))
(assert (sb-kernel:layout-invalid (sb-kernel:%instance-layout *str*)))
(assert (= 0 (sb-kernel:layout-clos-hash (sb-kernel:%instance-layout *str*))))
(assert (sb-kernel:wrapper-invalid (sb-kernel:%instance-wrapper *str*)))
(assert (= 0 (sb-kernel:wrapper-clos-hash (sb-kernel:%instance-wrapper *str*))))
(assert (not (streamp *str*)))
(assert (/= 0 (sb-kernel:layout-clos-hash (sb-kernel:%instance-layout *str*))))
(assert (/= 0 (sb-kernel:wrapper-clos-hash (sb-kernel:%instance-wrapper *str*))))
(defclass astream (fundamental-output-stream) (x y))
(assert (sb-kernel:layout-invalid (sb-kernel:%instance-layout *str*)))
(assert (sb-kernel:wrapper-invalid (sb-kernel:%instance-wrapper *str*)))
(assert (streamp *str*)))
;;; type errors for inappropriate stream arguments, fixed in

10
tests/type.pure.lisp
View file

@ -19,12 +19,10 @@
(loop for wrapper being each hash-value
of (sb-kernel:classoid-subclasses (sb-kernel:find-classoid 't))
do (flet ((check-bit (bit ancestor-type)
(let* ((layout #+metaspace (sb-kernel::wrapper-friend wrapper)
#-metaspace wrapper)
(ancestor (sb-kernel:find-layout ancestor-type)))
(when (or (eq layout ancestor)
(find ancestor (sb-kernel:layout-inherits layout)))
(assert (logtest bit (sb-kernel:layout-flags layout)))))))
(let ((ancestor (sb-kernel:find-layout ancestor-type)))
(when (or (eq wrapper ancestor)
(find ancestor (sb-kernel:wrapper-inherits wrapper)))
(assert (logtest bit (sb-kernel:wrapper-flags wrapper)))))))
(check-bit sb-kernel:+stream-layout-flag+ 'stream)
(check-bit sb-kernel:+string-stream-layout-flag+ 'string-stream)
(check-bit sb-kernel:+file-stream-layout-flag+ 'file-stream))))

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

@ -390,7 +390,7 @@
12 (NOT FUNCALLABLE-INSTANCE)
10 (NOT INSTANCE)
13 (NOT INTERPRETED-FUNCTION)
13 (NOT LAYOUT)
13 (NOT WRAPPER)
15 (NOT SIMPLE-ARRAY)
12 (NOT SIMPLE-VECTOR)
15 (NOT STRING)
@ -398,7 +398,7 @@
15 (NOT VECTOR)
31 (OR (CONS (MEMBER FUNCTION FUNCTION-DESIGNATOR SB-C::MODIFYING SB-C::INHIBIT-FLUSHING)) (MEMBER TYPE-SPECIFIER SB-C::PROPER-SEQUENCE SB-C::PROPER-LIST SB-C::PROPER-OR-DOTTED-LIST SB-C::PROPER-OR-CIRCULAR-LIST))
21 (OR (ALIEN SB-UNIX:UNIX-OFFSET) (MEMBER NIL :START :END))
30 (OR (AND (NOT SYMBOL) (NOT LAYOUT) ATOM (NOT INTEGER)))
30 (OR (AND (NOT SYMBOL) (NOT WRAPPER) ATOM (NOT INTEGER)))
21 (OR (CONS (EQL DECLARE)) STRING)
! 67 (OR (CONS (EQL FUNCTION) (CONS (SATISFIES LEGAL-FUN-NAME-P) NULL)) (CONS (EQL QUOTE) (CONS SYMBOL NULL)) (CONS (EQL LAMBDA)))
! 60 (OR (CONS (EQL FUNCTION) (CONS (SATISFIES LEGAL-FUN-NAME-P) NULL)) (CONS (EQL QUOTE) (CONS SYMBOL NULL)))
@ -565,7 +565,7 @@
56 (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)
20 (OR SYMBOL WRAPPER)
23 (OR UNSIGNED-BYTE)
15 (OR VECTOR (MEMBER))
! 23 (OR WARNING ERROR)

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

@ -155,7 +155,7 @@
(index
(position "OBJECT-NOT-TYPE-ERROR" lines :test 'search)))
(let ((line (nth (+ index 2) lines)))
(assert (search "; #<SB-KERNEL:LAYOUT " line))
(assert (search "; #<SB-KERNEL:WRAPPER " line))
(assert (search " SB-ASSEM:LABEL" line)))))
#+immobile-code
@ -718,15 +718,15 @@ sb-vm::(define-vop (cl-user::test)
;; component.
(let ((names
(mapcar (lambda (x)
(sb-kernel:classoid-name (sb-kernel:layout-classoid x)))
(ctu:find-code-constants #'sb-kernel:%%typep :type 'sb-kernel:layout))))
(sb-kernel:classoid-name (sb-kernel:wrapper-classoid x)))
(ctu:find-code-constants #'sb-kernel:%%typep :type 'sb-kernel:wrapper))))
(assert (null (set-difference names
'(sb-kernel:ctype
sb-kernel:unknown-type
sb-kernel:fun-designator-type
sb-c::abstract-lexenv
sb-kernel::classoid-cell
sb-kernel:layout
sb-kernel:wrapper
sb-kernel:classoid
sb-kernel:built-in-classoid
#-immobile-space null))))))
@ -745,7 +745,7 @@ sb-vm::(define-vop (cl-user::test)
(loop for line in (split-string (with-output-to-string (string)
(disassemble f :stream string))
#\newline)
thereis (and (search "LAYOUT for" line)
thereis (and (search "WRAPPER for" line)
(search "CMP DWORD PTR" line)))))
(with-test (:name :thread-local-unbound)
@ -804,7 +804,7 @@ sb-vm::(define-vop (cl-user::test)
#+compact-instance-header
(with-test (:name :gf-self-contained-trampoline)
(let ((l (sb-kernel:find-layout 'standard-generic-function)))
(assert (/= (sb-kernel:layout-bitmap l) sb-kernel:+layout-all-tagged+))))
(assert (/= (sb-kernel:wrapper-bitmap l) sb-kernel:+layout-all-tagged+))))
(with-test (:name :known-array-rank)
(flet ((try (type)

8
tools-for-build/editcore.lisp
View file

@ -1527,8 +1527,8 @@
(return-from scan-obj))
(case widetag
(#.instance-widetag
(let ((layout (truly-the layout (translate (%instance-layout obj) spaces))))
(do-instance-tagged-slot (i obj t layout)
(let ((type (translate (%instance-layout obj) spaces)))
(do-instance-tagged-slot (i obj t type)
(scanptr vaddr obj (1+ i))))
(return-from scan-obj))
(#.simple-vector-widetag
@ -1562,9 +1562,9 @@
(+ core-offs n-word-bytes)
word)))
(when (eq widetag funcallable-instance-widetag)
(let* ((layout (truly-the layout (translate (%fun-layout obj) spaces)))
(let* ((layout (truly-the sb-vm:layout (translate (%fun-layout obj) spaces)))
(bitmap (%raw-instance-ref/signed-word
layout (sb-kernel::type-dd-length sb-kernel:layout))))
layout (sb-kernel::type-dd-length sb-vm:layout))))
(unless (= (sb-kernel:bitmap-nwords layout) 1)
(error "Strange funcallable-instance bitmap"))
(unless (eql bitmap sb-kernel:+layout-all-tagged+)