[prev in list] [next in list] [prev in thread] [next in thread]
List: sbcl-devel
Subject: Re: [Sbcl-devel] Metaspace part 1
From: Douglas Katzman via Sbcl-devel <sbcl-devel () lists ! sourceforge ! net>
Date: 2021-04-09 4:26:27
Message-ID: CAOrNaszu31kbokLnGyBHBjvaZXyE9qoOPr0nmx_70tm_Y36o1A () mail ! gmail ! com
[Download RAW message or body]
[Attachment #2 (multipart/alternative)]
I decided that the aesthetics of the end state outweigh the pain involved
in touching a lot of lines just to steer clear of names that had already
been usurped by the internals of the CLOS implementation.
The picture that I wanted to end up at, and did end up at, is exactly as
documented in doc/internals-notes/metaspace, which suggested LAYOUT and
WRAPPER as the two entities. LAYOUT is the memory-layout-relevant one.
To achieve that I had to first rename the type LAYOUT to something
completely different (not spelled "LAYOUT"), and then found all the places
that PCL meant WRAPPER but named its local variables either LAYOUT or
WRAPPER. and I standardized on WRAPPER.
Everything which was the "old" LAYOUT was renamed to use SB-VM:LAYOUT
to make no mistakes about SB-KERNEL:LAYOUT which was a symbol visible in
all packages but no longer exists.
This took me many commits which I've squashed back into 1 and I don't see
any value to refactoring into pieces, if it's even possible. The result is
that C changes are minimal, the genesis changes are fairly minimal, and the
PCL and DEFSTRUCT changes are big, but that's the way it has to be.
After testing on non-metaspace (ordinary build) for all architectures I
plan to commit this Friday (which it already is here) but at a decent hour,
not :20 past midnite. I suspect there will be no objections raised by the
time I next check email.
[Attachment #5 (text/html)]
<div dir="ltr"><div dir="ltr">I decided that the aesthetics of the end state outweigh \
the pain involved in touching a lot of lines just to steer clear of names that had \
already been usurped by the internals of the CLOS implementation.<div><br><div>The \
picture that I wanted to end up at, and did end up at, is exactly as documented in \
doc/internals-notes/metaspace, which suggested LAYOUT and WRAPPER as the two \
entities. LAYOUT is the memory-layout-relevant one.</div><div><br></div><div>To \
achieve that I had to first rename the type LAYOUT to something completely different \
(not spelled "LAYOUT"), and then found all the places that PCL meant \
WRAPPER but named its local variables either LAYOUT or WRAPPER. and I standardized on \
WRAPPER.</div><div>Everything which was the "old" LAYOUT was renamed to use \
SB-VM:LAYOUT to make no mistakes about SB-KERNEL:LAYOUT which was a symbol visible \
in all packages but no longer exists.</div><div>This took me many commits which \
I've squashed back into 1 and I don't see any value to refactoring into \
pieces, if it's even possible. The result is that C changes are minimal, the \
genesis changes are fairly minimal, and the PCL and DEFSTRUCT changes are big, but \
that's the way it has to be.</div><div><br></div><div>After testing on \
non-metaspace (ordinary build) for all architectures I plan to commit this Friday \
(which it already is here) but at a decent hour, not :20 past midnite. I suspect \
there will be no objections raised by the time I next check \
email.</div></div><div><br></div><div><div><br></div><div></div></div></div></div>
--000000000000f4aa3f05bf8291ca--
["0001-Metaspace-part-1-layouts-split-into-pieces.patch" (application/octet-stream)]
From ee7a86836478d0a3376eed20f37a3ea695df4b88 Mon Sep 17 00:00:00 2001
From: Douglas Katzman <dougk@google.com>
Date: Thu, 8 Apr 2021 23:33:08 -0400
Subject: [PATCH] Metaspace part 1: layouts split into pieces
---
contrib/sb-aclrepl/inspect.lisp | 2 +-
doc/internals-notes/metaspace | 15 --
make-target-2-load.lisp | 4 +-
package-data-list.lisp-expr | 31 ++-
src/code/ansi-stream.lisp | 8 +-
src/code/aprof.lisp | 2 +-
src/code/class.lisp | 245 +++++++++---------
src/code/condition.lisp | 22 +-
src/code/cross-misc.lisp | 19 +-
src/code/defstruct.lisp | 117 ++++-----
src/code/deftypes-for-target.lisp | 2 +
src/code/early-class.lisp | 16 +-
src/code/early-classoid.lisp | 328 ++++++++++++------------
src/code/early-defmethod.lisp | 6 +-
src/code/early-raw-slots.lisp | 4 +-
src/code/early-type.lisp | 6 +-
src/code/error.lisp | 6 +-
src/code/fop.lisp | 4 +-
src/code/inspect.lisp | 2 +-
src/code/interr.lisp | 6 +-
src/code/last-file.lisp | 12 +-
src/code/late-type.lisp | 6 +-
src/code/macros.lisp | 23 +-
src/code/pathname.lisp | 4 +-
src/code/pprint.lisp | 2 +-
src/code/pred.lisp | 71 ++---
src/code/print.lisp | 19 +-
src/code/room.lisp | 28 +-
src/code/sharpm.lisp | 4 +-
src/code/stream.lisp | 6 +-
src/code/stubs.lisp | 11 +-
src/code/target-defstruct.lisp | 71 ++---
src/code/target-hash-table.lisp | 4 +-
src/code/target-pathname.lisp | 2 +-
src/code/target-sxhash.lisp | 23 +-
src/code/typep.lisp | 48 ++--
src/code/warm-error.lisp | 2 +-
src/code/x86-64-vm.lisp | 6 +-
src/cold/shared.lisp | 2 +-
src/compiler/arm/system.lisp | 2 +-
src/compiler/arm64/system.lisp | 6 +-
src/compiler/dump.lisp | 43 ++--
src/compiler/fndb.lisp | 12 +-
src/compiler/fopcompile.lisp | 2 +-
src/compiler/generic/early-vm.lisp | 4 +-
src/compiler/generic/genesis.lisp | 172 +++++++------
src/compiler/generic/interr.lisp | 2 +-
src/compiler/generic/layout-ids.lisp | 4 +-
src/compiler/generic/target-core.lisp | 10 +-
src/compiler/generic/type-error.lisp | 4 +-
src/compiler/generic/vm-fndb.lisp | 24 +-
src/compiler/generic/vm-tran.lisp | 19 +-
src/compiler/generic/vm-typetran.lisp | 4 +-
src/compiler/ir1tran.lisp | 2 +-
src/compiler/ir1util.lisp | 7 +
src/compiler/mips/system.lisp | 2 +-
src/compiler/ppc/system.lisp | 2 +-
src/compiler/ppc64/system.lisp | 6 +-
src/compiler/proclaim.lisp | 4 +-
src/compiler/riscv/system.lisp | 8 +-
src/compiler/sparc/system.lisp | 2 +-
src/compiler/tn.lisp | 2 +-
src/compiler/typetran.lisp | 68 ++---
src/compiler/x86-64/alloc.lisp | 2 +-
src/compiler/x86-64/cell.lisp | 1 +
src/compiler/x86-64/system.lisp | 16 +-
src/compiler/x86-64/type-vops.lisp | 8 +-
src/compiler/x86-64/vm.lisp | 14 +-
src/compiler/x86/system.lisp | 4 +-
src/pcl/braid.lisp | 65 ++---
src/pcl/cache.lisp | 14 +-
src/pcl/ctor.lisp | 14 +-
src/pcl/defs.lisp | 14 +-
src/pcl/dlisp.lisp | 16 +-
src/pcl/env.lisp | 14 +-
src/pcl/fixup.lisp | 4 +-
src/pcl/fngen.lisp | 2 +-
src/pcl/low.lisp | 9 +-
src/pcl/methods.lisp | 6 +-
src/pcl/slots-boot.lisp | 2 +-
src/pcl/slots.lisp | 2 +-
src/pcl/std-class.lisp | 72 +++---
src/pcl/wrapper.lisp | 47 ++--
src/runtime/gc-private.h | 2 +-
src/runtime/print.c | 3 -
tests/classoid-typep.impure.lisp | 6 +-
tests/clos-cache.impure.lisp | 6 +-
tests/clos.impure.lisp | 4 +-
tests/compiler-2.pure.lisp | 2 +-
tests/condition.pure.lisp | 7 +-
tests/defstruct.impure-cload.lisp | 6 +-
tests/defstruct.impure.lisp | 53 ++--
tests/do-refs.impure.lisp | 19 +-
tests/dynamic-extent.impure.lisp | 2 +-
tests/fast-eval.impure.lisp | 2 +-
tests/full-eval.impure.lisp | 2 +-
tests/gc.impure-cload.lisp | 4 +-
tests/hash.pure.lisp | 5 +-
tests/immobile-space.impure.lisp | 4 +-
tests/raw-slots-interleaved.impure.lisp | 8 +-
tests/save3.test.sh | 4 +-
tests/stream.impure.lisp | 12 +-
tests/type.pure.lisp | 10 +-
tests/typep-golden-data.txt | 6 +-
tests/x86-64-codegen.impure.lisp | 12 +-
tools-for-build/editcore.lisp | 8 +-
106 files changed, 1111 insertions(+), 1002 deletions(-)
diff --git a/contrib/sb-aclrepl/inspect.lisp b/contrib/sb-aclrepl/inspect.lisp
index 37cbced7f..24532ee72 100644
--- a/contrib/sb-aclrepl/inspect.lisp
+++ b/contrib/sb-aclrepl/inspect.lisp
@@ -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))
diff --git a/doc/internals-notes/metaspace b/doc/internals-notes/metaspace
index e78e6645b..8342b0c8b 100644
--- a/doc/internals-notes/metaspace
+++ b/doc/internals-notes/metaspace
@@ -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.
diff --git a/make-target-2-load.lisp b/make-target-2-load.lisp
index 59e951dac..61785dde1 100644
--- a/make-target-2-load.lisp
+++ b/make-target-2-load.lisp
@@ -133,9 +133,9 @@
;; can't be uninterned if referenced by a defstruct-description.
;; So loop over all structure classoids and clobber any
;; symbol that should be uninternable.
- (maphash (lambda (classoid wrapper)
+ (maphash (lambda (classoid layout)
(when (structure-classoid-p classoid)
- (let ((dd (wrapper-%info wrapper)))
+ (let ((dd (wrapper-info layout)))
(setf (dd-constructors dd)
(delete-if (lambda (x)
(and (consp x) (uninternable-p (car x))))
diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 61672ae76..3a5e2c8ec 100644
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -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" "LAYOUT-BITMAP-WORDS" "LAYOUT-CLASSOID-NAME"
- "LAYOUT-DEPTHOID" "LAYOUT-EQUALP-IMPL"
+ "LAYOUT-DEPTHOID" ; a type name, not a function
"LAYOUT-ID"
+ "LAYOUT-BITMAP-WORDS"
"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,22 +2236,24 @@ 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"
- "LAYOUT-FLAGS"
+ "WRAPPER-CLASSOID" "WRAPPER-INVALID"
+ "WRAPPER-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"
+ "%INSTANCE-LAYOUT" "WRAPPER-CLOS-HASH" "%INSTANCEOID-LAYOUT"
+ "%INSTANCE-WRAPPER" "%FUN-WRAPPER"
"PROCLAIM-AS-FUN-NAME" "BECOME-DEFINED-FUN-NAME"
"%NUMERATOR" "CLASSOID-TYPEP"
- "LAYOUT-INHERITS" "DD-LENGTH"
- "SET-LAYOUT-INHERITS"
+ "WRAPPER-INHERITS" "DD-LENGTH"
+ "SET-WRAPPER-INHERITS"
"%CODE-ENTRY-POINT"
"%CODE-FUN-OFFSET"
"CODE-N-ENTRIES"
@@ -3101,6 +3107,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
diff --git a/src/code/ansi-stream.lisp b/src/code/ansi-stream.lisp
index 081fe5f9a..8194418d7 100644
--- a/src/code/ansi-stream.lisp
+++ b/src/code/ansi-stream.lisp
@@ -371,7 +371,7 @@
;;; in the simple-stream layering. It is generic at the "device" but not the API.
(defmacro simple-stream-p (x)
`(and (%instancep ,x)
- (logtest (layout-flags (%instance-layout ,x))
+ (logtest (sb-kernel::layout-flags (%instance-layout ,x))
sb-kernel::+simple-stream-layout-flag+)))
;;; This macro is for the first-level of dispatch which usually entails
@@ -390,10 +390,10 @@
(block stream
;; Assume that simple-stream can not inherit funcallable-standard-object.
(when (%instancep ,streamvar)
- (let ((layout (%instance-layout ,streamvar)))
- (cond ((sb-c::%structure-is-a layout ,(find-layout 'ansi-stream))
+ (let ((type (%instance-layout ,streamvar)))
+ (cond ((sb-c::%structure-is-a type ,(find-layout 'ansi-stream))
(let ((,streamvar (truly-the ansi-stream ,streamvar)))
(return-from stream ,native)))
- ((logtest (layout-flags layout) +simple-stream-layout-flag+)
+ ((logtest (sb-kernel::layout-flags type) \
+simple-stream-layout-flag+) (return-from stream ,simple)))))
(let ((,streamvar (the stream ,streamvar))) ,gray))))
diff --git a/src/code/aprof.lisp b/src/code/aprof.lisp
index c63479e69..a27310a94 100644
--- a/src/code/aprof.lisp
+++ b/src/code/aprof.lisp
@@ -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
diff --git a/src/code/class.lisp b/src/code/class.lisp
index 57bef0845..602d0a82f 100644
--- a/src/code/class.lisp
+++ b/src/code/class.lisp
@@ -31,8 +31,6 @@
;;;
;;; In each cons, the car is the symbol naming the layout, and the
;;; cdr is the layout itself.
-;;; If #+metaspace then the cdr is actually of type WRAPPER,
-;;; and if #-metaspace then the wrapper is a LAYOUT.
(defvar *!initial-wrappers*)
;;; a table mapping class names to layouts for classes we have
@@ -49,51 +47,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 +95,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 +114,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 +126,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 +141,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 +165,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
@@ -187,21 +177,24 @@ between the ~A definition and the ~A definition"
;;; and subclasses are invalidated, and the SUBCLASSES slot is cleared.
;;; -- If DESTRUCT-LAYOUT, then this is some old layout, and is to be
;;; destructively modified to hold the same type information.
-(macrolet ((set-bitmap-from-layout (to-layout from-layout)
- `(let ((to-index
- (+ (type-dd-length layout)
- (calculate-extra-id-words (layout-depthoid ,to-layout))))
+(macrolet ((set-bitmap-from-layout (to from)
+ `(let ((to-obj (wrapper-friend ,to))
+ (from-obj (wrapper-friend ,from))
+ (to-index
+ (+ (type-dd-length sb-vm:layout)
+ (calculate-extra-id-words (wrapper-depthoid ,to))))
(from-index
- (+ (type-dd-length layout)
- (calculate-extra-id-words (layout-depthoid ,from-layout)))))
- (dotimes (i (layout-bitmap-words ,from-layout))
- (setf (%raw-instance-ref/word ,to-layout (+ 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))
+ (+ (type-dd-length sb-vm:layout)
+ (calculate-extra-id-words (wrapper-depthoid ,from)))))
+ (dotimes (i (layout-bitmap-words from-obj))
+ (setf (%raw-instance-ref/word to-obj (+ to-index i))
+ (%raw-instance-ref/word from-obj (+ from-index i))))))
+ #-metaspace (layout-flags (x) `(wrapper-flags ,x)))
+(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 +205,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 +240,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 +251,18 @@ 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-wrapper-inherits modify inherits t id)
+ (set-bitmap-from-layout modify wrapper)
+ (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 +278,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 +309,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 +320,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 +331,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))
@@ -441,7 +434,8 @@ between the ~A definition and the ~A definition"
(defun (setf find-classoid) (new-value name)
#-sb-xc (declare (type (or null classoid) new-value))
(aver new-value)
- (with-world-lock ()
+ (let ((table *forward-referenced-wrappers*))
+ (with-world-lock ()
(let ((cell (find-classoid-cell name :create t)))
(ecase (info :type :kind name)
((nil))
@@ -485,7 +479,7 @@ between the ~A definition and the ~A definition"
(clear-info :type :expander name)
(clear-info :type :source-location name)))
- (remhash name *forward-referenced-wrappers*)
+ (remhash name table)
(%note-type-defined name)
;; FIXME: I'm unconvinced of the need to handle either of these.
;; Package locks preclude the latter, and in the former case,
@@ -507,9 +501,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)
@@ -556,11 +550,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
@@ -597,16 +590,15 @@ 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
@@ -632,10 +624,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)
@@ -678,8 +670,8 @@ between the ~A definition and the ~A definition"
(o-sub (classoid-subclasses other)))
(if (and s-sub o-sub)
(collect ((res *empty-type* type-union))
- (dohash ((subclass wrapper) s-sub :locked t)
- (declare (ignore wrapper))
+ (dohash ((subclass layout) s-sub :locked t)
+ (declare (ignore layout))
(when (gethash subclass o-sub)
(res (specifier-type subclass))))
(res))
@@ -1025,7 +1017,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}>
@@ -1144,14 +1136,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
@@ -1189,20 +1181,23 @@ between the ~A definition and the ~A definition"
;;; 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)
+ (declare (type wrapper layout))
+ #+sb-xc-host (error "Why are we invalidating layout ~S?" layout)
+ #-sb-xc-host
+ (progn
+ (setf (wrapper-invalid layout) 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 layout)) 0)
+ (setf (wrapper-clos-hash layout) 0)
+ (let ((inherits (wrapper-inherits layout))
+ (classoid (wrapper-classoid layout)))
(%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
@@ -1213,14 +1208,14 @@ between the ~A definition and the ~A definition"
;;; late in the build-order.lisp-expr sequence, and be put in
;;; !COLD-INIT-FORMS there?
(defun !class-finalize ()
- (dohash ((name wrapper) *forward-referenced-wrappers*)
+ (dohash ((name layout) *forward-referenced-wrappers*)
(let ((class (find-classoid name nil)))
(cond ((not class)
(error "How is there no classoid for ~S ?" name))
- ((eq (classoid-wrapper class) wrapper)
+ ((eq (classoid-wrapper class) layout)
(remhash name *forward-referenced-wrappers*))
(t
(error "Something strange with forward layout for ~S:~% ~S"
- name wrapper))))))
+ name layout))))))
(!defun-from-collected-cold-init-forms !classes-cold-init)
diff --git a/src/code/condition.lisp b/src/code/condition.lisp
index bbd05362e..11dcb0636 100644
--- a/src/code/condition.lisp
+++ b/src/code/condition.lisp
@@ -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
diff --git a/src/code/cross-misc.lisp b/src/code/cross-misc.lisp
index 2811a1e71..009886503 100644
--- a/src/code/cross-misc.lisp
+++ b/src/code/cross-misc.lisp
@@ -235,22 +235,25 @@
;; - 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))
+ (classoid-wrapper (find-classoid (type-of instance))))
+#+nil
(defun %instance-layout (instance)
- (classoid-layout (find-classoid (type-of instance))))
+ #+metaspace (declare (notinline wrapper-friend))
+ (wrapper-friend (%instance-wrapper 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 sb-kernel::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
diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index 0a60c52c6..fd00a23df 100644
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -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))
@@ -1230,10 +1230,10 @@ unless :NAMED is also specified.")))
(let ((subclasses (classoid-subclasses classoid)))
(when subclasses
(collect ((subs))
- (dohash ((classoid wrapper)
+ (dohash ((classoid layout)
subclasses
:locked t)
- (declare (ignore wrapper))
+ (declare (ignore layout))
(undeclare-structure classoid nil)
(subs (classoid-proper-name classoid)))
;; Is it really necessary to warn about
@@ -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,16 +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)))
- (= (layout-bitmap-words new-layout)
- (layout-bitmap-words 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)))
+ (= (layout-bitmap-words (wrapper-friend new-layout))
+ (layout-bitmap-words (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)))))
@@ -1441,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
@@ -1471,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.
@@ -1586,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))
@@ -1626,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))
@@ -1651,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+))
@@ -1663,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))
+ (layout-flags (wrapper-friend ancestor)))
flags)))
(let* ((old-layout (or compiler-layout old-layout))
(new-layout
@@ -1682,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
@@ -2171,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)
@@ -2196,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
@@ -2216,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* ((layout (%instance-wrapper instance))
+ (map (wrapper-index->accessor-map layout)))
(when (zerop (length map)) ; construct it on demand
- (let ((slots (dd-slots (layout-info layout))))
+ (let ((slots (dd-slots (wrapper-%info layout))))
(setf map (make-array (1+ (reduce #'max slots :key #'dsd-index))
:initial-element nil)
- (layout-index->accessor-map layout) map)
+ (wrapper-index->accessor-map layout) map)
(dolist (dsd slots)
(setf (aref map (dsd-index dsd)) (dsd-accessor-name dsd)))))
(funcall (aref map index) instance)))
@@ -2270,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))
@@ -2321,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
diff --git a/src/code/deftypes-for-target.lisp b/src/code/deftypes-for-target.lisp
index a8411a536..26be4391e 100644
--- a/src/code/deftypes-for-target.lisp
+++ b/src/code/deftypes-for-target.lisp
@@ -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")
diff --git a/src/code/early-class.lisp b/src/code/early-class.lisp
index ec5ca4eac..97e50bff2 100644
--- a/src/code/early-class.lisp
+++ b/src/code/early-class.lisp
@@ -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)
diff --git a/src/code/early-classoid.lisp b/src/code/early-classoid.lisp
index 30183115f..9b5ce42fa 100644
--- a/src/code/early-classoid.lisp
+++ b/src/code/early-classoid.lisp
@@ -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-)
@@ -57,8 +57,8 @@
(bitmap +layout-all-tagged+ :type integer)
;; a list of (NAME . INDEX) pairs for accessors of included structures
(inherited-accessor-alist () :type list)
- ;; number of data words, including the layout itself if the layout
- ;; requires an entire word (when no immobile-space)
+ ;; number of data words, including the wrapper, if the wrapper consumes
+ ;; an ordinary payload slot (i.e. when no :compact-instance-header feature)
(length 0 :type index)
;; General kind of implementation.
(type 'structure :type (member structure vector list
@@ -150,9 +150,9 @@
#-metaspace
(progn
-(sb-xc:defstruct (layout (:copier nil)
- ;; Parsing DEFSTRUCT uses a temporary layout
- (:constructor make-temporary-layout
+(sb-xc:defstruct (wrapper (:copier nil)
+ ;; Parsing DEFSTRUCT uses a temporary wrapper
+ (: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,23 +231,24 @@
;;; 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.
-;;; 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
+ (invalid :uninitialized :type (or cons (member nil t :uninitialized))))
+;;; See #-metaspace structure definition for remarks about each slot.
+;;; TYPEID points to WRAPPER and vice-versa.
+;;; The most common TYPEID is 8 words.
+;;; Needing >64 words would be quite unusual - the TYPEID would have
;;; an enormous depthoid or bitmap or both.
-(sb-xc:defstruct (layout (:copier nil)
- ;; Parsing DEFSTRUCT uses a temporary layout
- (:constructor %make-temporary-layout (friend clos-hash)))
- ;; !!! The FRIEND slot in LAYOUT *MUST* BE FIRST !!!
+(sb-xc:defstruct (sb-vm:layout (:copier nil)
+ ;; Parsing DEFSTRUCT uses a temporary layout
+ (:constructor %make-typebits (friend clos-hash)))
+ ;; !!! The FRIEND slot in TYPEID *MUST* BE FIRST !!! (Wired-in assumption in \
genesis) (friend nil :type wrapper)
(clos-hash (missing-arg) :type (and fixnum unsigned-byte))
(flags 0 :type (signed-byte #.sb-vm:n-word-bits))
@@ -257,32 +258,16 @@
;; 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))
+(declaim (freeze-type wrapper sb-vm: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
+(defun make-temporary-wrapper (clos-hash classoid inherits)
+ (let* ((bits (%make-typebits #.(find-layout t) clos-hash))
+ (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)))
+ :friend bits)))
+ (setf (layout-friend bits) wrapper)
+ wrapper)))
;;; The cross-compiler representation of a LAYOUT omits several things:
;;; * BITMAP - obtainable via (DD-BITMAP (LAYOUT-INFO layout)).
@@ -291,19 +276,18 @@
;;; * SLOT-TABLE, and SLOT-LIST - used only by the CLOS implementation.
;;; * ID-WORDn are optimizations for TYPEP.
;;; So none of those really make sense on the host.
-;;; Also, we eschew the packed representation of length+depthoid+flags.
-;;; FLAGS are not even strictly necessary, since they are for optimizing
-;;; various type checks.
#+sb-xc-host
(progn
- ;; 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)
+ #+metaspace
+ (:constructor host-make-wrapper
+ (id clos-hash classoid
+ &key ((:info %info)) friend depthoid inherits length \
invalid)) + #-metaspace
+ (:constructor host-make-wrapper
+ (id clos-hash classoid
+ &key ((:info %info)) depthoid inherits length invalid)))
+ #+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)
@@ -314,35 +298,41 @@
;; But there's no harm in storing it.
(clos-hash nil :type (and sb-xc:fixnum unsigned-byte))
(classoid nil :type classoid)
-; (flags 0 :type word)
(invalid :uninitialized :type (or cons (member nil t :uninitialized)))
(inherits #() :type simple-vector)
(depthoid -1 :type layout-depthoid)
(length 0 :type layout-length)
- (info nil :type (or null defstruct-description)))
- (defun layout-dd (layout)
- (the defstruct-description (layout-info layout)))
- (defun make-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-typebits))
+ 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)))
(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.
@@ -352,6 +342,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
@@ -374,21 +376,12 @@
;;; 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*))
+(macrolet #-metaspace ((layout-flags (x) `(wrapper-flags ,x))
+ (layout-clos-hash (x) `(wrapper-clos-hash ,x)))
+ #+metaspace ()
+;;; NB: for #+metaspace this returns a WRAPPER, not a LAYOUT.
(defun make-layout (clos-hash classoid
&key (depthoid -1) (length 0) (flags 0)
(inherits #())
@@ -399,72 +392,85 @@
(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)
+ #-metaspace #.(find-layout 'wrapper)
+ #+metaspace (wrapper-friend #.(find-layout 'sb-vm:layout)))
+ 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-wrapper-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 layout-bitmap-words))
-(defun layout-bitmap-words (layout)
- (declare (layout layout))
- (- (%instance-length layout) (type-dd-length 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
;; on the platform, and the layout is tagged but a special case.
;; In any event, the bitmap is always 1 word, and there are no "extra ID"
;; words preceding it.
- (t (%raw-instance-ref/signed-word layout (type-dd-length layout))))))
+ (t (%raw-instance-ref/signed-word (wrapper-friend wrapper)
+ (type-dd-length sb-vm:layout)))))
+(declaim (inline layout-bitmap-words))
+(defun layout-bitmap-words (layout)
+ (declare (type sb-vm:layout layout))
+ (- (%instance-length layout) (type-dd-length sb-vm:layout)))
+) ; end PROGN
#+(and (not sb-xc-host) 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))))
(defconstant layout-flags-mask #xffff) ; "strictly flags" bits from the packed field
;;; 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
@@ -490,11 +496,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.
@@ -517,8 +520,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+)
@@ -527,21 +534,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
@@ -668,15 +664,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 (wrapper-friend 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))
@@ -691,47 +689,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-typebits))
+ (wrapper (make :friend layout)))
+ (setf (layout-friend layout) wrapper)
+ wrapper)))
+;; The target reconstructs wrappers using FOP-WRAPPER 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)
diff --git a/src/code/early-defmethod.lisp b/src/code/early-defmethod.lisp
index 156d3142f..242165122 100644
--- a/src/code/early-defmethod.lisp
+++ b/src/code/early-defmethod.lisp
@@ -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.
diff --git a/src/code/early-raw-slots.lisp b/src/code/early-raw-slots.lisp
index 7dbed0844..a8e0900d7 100644
--- a/src/code/early-raw-slots.lisp
+++ b/src/code/early-raw-slots.lisp
@@ -187,10 +187,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
diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp
index 107226dfd..bd8628920 100644
--- a/src/code/early-type.lisp
+++ b/src/code/early-type.lisp
@@ -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
diff --git a/src/code/error.lisp b/src/code/error.lisp
index 38b17e901..1f6e482b3 100644
--- a/src/code/error.lisp
+++ b/src/code/error.lisp
@@ -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
diff --git a/src/code/fop.lisp b/src/code/fop.lisp
index 1d2994ed1..f384f355e 100644
--- a/src/code/fop.lisp
+++ b/src/code/fop.lisp
@@ -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))
diff --git a/src/code/inspect.lisp b/src/code/inspect.lisp
index 086ce1f49..70d754100 100644
--- a/src/code/inspect.lisp
+++ b/src/code/inspect.lisp
@@ -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)
diff --git a/src/code/interr.lisp b/src/code/interr.lisp
index 675d3604f..4db77fac7 100644
--- a/src/code/interr.lisp
+++ b/src/code/interr.lisp
@@ -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))))
diff --git a/src/code/last-file.lisp b/src/code/last-file.lisp
index 583ecbf4a..94f823298 100644
--- a/src/code/last-file.lisp
+++ b/src/code/last-file.lisp
@@ -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)
diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 3dec3f592..31982ecf0 100644
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -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))))
diff --git a/src/code/macros.lisp b/src/code/macros.lisp
index eaee963c9..76a75a533 100644
--- a/src/code/macros.lisp
+++ b/src/code/macros.lisp
@@ -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)
@@ -898,8 +898,8 @@ symbol-case giving up: case=((V U) (F))
(n-pairs (/ (length cells) 2)))
`(if (not (%instancep ,object))
0
- (let* ((layout (%instance-layout ,object))
- (index (ldb ,byte (layout-clos-hash layout)))
+ (let* ((layout (%instance-wrapper ,object))
+ (index (ldb ,byte (wrapper-clos-hash layout)))
(cells ,cells))
(declare (optimize (safety 0)))
(the (mod ,(1+ (length cases)))
@@ -915,7 +915,7 @@ symbol-case giving up: case=((V U) (F))
;;; Given an arbitrary TYPECASE, see if it is a discriminator over
;;; an assortment of structure-object subtypes. If it is, potentially turn it
-;;; into a dispatch based on layout-clos-hash.
+;;; into a dispatch based on wrapper-clos-hash.
;;; The decision to use a hash-based lookup should depend on the number of types
;;; matched, but if there are a lot of types matched all rooted at a common
;;; ancestor, it is not beneficial.
@@ -947,7 +947,7 @@ symbol-case giving up: case=((V U) (F))
(t
(return-from discover-subtypes nil)))))
;; Assume that each "root" type would require its own test based
- ;; on %instance-layout of self and ancestor and that all root types
+ ;; on %INSTANCE-TYPEID of self and ancestor and that all root types
;; are disjoint. This may not be true if a later one includes
;; an earlier one.
(incf n-root-types (length worklist))
@@ -956,8 +956,8 @@ symbol-case giving up: case=((V U) (F))
(let ((classoid (pop worklist)))
(visited classoid)
(awhen (classoid-subclasses classoid)
- (dohash ((classoid wrapper) it)
- (declare (ignore wrapper))
+ (dohash ((classoid layout) it)
+ (declare (ignore layout))
(unless (or (member classoid (visited))
(member classoid worklist))
(setf worklist (nconc worklist (list classoid))))))))
@@ -2262,3 +2262,10 @@ 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 sb-kernel::layout-flags (x) `(sb-kernel::wrapper-flags ,x))
+)
diff --git a/src/code/pathname.lisp b/src/code/pathname.lisp
index 96d596862..0318ac8d0 100644
--- a/src/code/pathname.lisp
+++ b/src/code/pathname.lisp
@@ -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))
diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp
index 6d0a5c090..d40830082 100644
--- a/src/code/pprint.lisp
+++ b/src/code/pprint.lisp
@@ -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)
diff --git a/src/code/pred.lisp b/src/code/pred.lisp
index 12e91d30e..a380e36dc 100644
--- a/src/code/pred.lisp
+++ b/src/code/pred.lisp
@@ -163,8 +163,13 @@
;; 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, this vector stores LAYOUTs, and it is the _only_ \
non-instanceoid + ;; that is allowed to store them. If it contained pointers to \
WRAPPERs, + ;; it would contain pointers into dynamic space that would get corrupted \
on cold boot. + ;; This would be a problem, notwithstanding that after image save, \
pseudo-static + ;; WRAPPERs can't move.
(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,26 +193,27 @@
;;; 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))
#-sb-xc-host
(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
@@ -256,24 +262,28 @@
(type-specifier (ctype-of object)))
(simple-fun 'compiled-function)
(t
- (let ((layout (layout-of object)))
- (if (eq (get-lisp-obj-address layout) 0)
- ;; An empty instance, e.g. created by with-output-to-string
- 'instance
- (let* ((classoid (layout-classoid layout))
- (name (classoid-name classoid)))
- (if (%instancep object)
- (case name
- (sb-alien-internals:alien-value
- `(alien
- ,(sb-alien-internals:unparse-alien-type
- (sb-alien-internals:alien-value-type object))))
- (t
- (let ((pname (classoid-proper-name classoid)))
- (if (classoid-p pname)
- (classoid-pcl-class pname)
- pname))))
- name)))))))
+ #+metaspace
+ (unless (logtest (get-lisp-obj-address (%instanceoid-layout object))
+ sb-vm:widetag-mask)
+ ;; An empty instance, e.g. created by with-output-to-string
+ (return-from type-of (if (functionp object) 'function 'instance)))
+ (let ((layout (wrapper-of object)))
+ #-metaspace
+ (unless (logtest (get-lisp-obj-address layout) sb-vm:widetag-mask) ; same
+ (return-from type-of 'instance))
+ (let* ((classoid (wrapper-classoid layout))
+ (name (classoid-name classoid)))
+ (if (%instancep object)
+ (case name
+ (sb-alien-internals:alien-value
+ `(alien ,(sb-alien-internals:unparse-alien-type
+ (sb-alien-internals:alien-value-type object))))
+ (t
+ (let ((pname (classoid-proper-name classoid)))
+ (if (classoid-p pname)
+ (classoid-pcl-class pname)
+ pname))))
+ name))))))
;;;; equality predicates
@@ -549,11 +559,12 @@ length and have identical components. Other arrays must be EQ \
to be EQUAL." (equalp (cdr x) (cdr y))))
((%instancep x)
(and (%instancep y)
- (let ((layout (%instance-layout x)))
+ (let ((type (%instance-layout x)))
(and (logtest (logior +structure-layout-flag+ \
+pathname-layout-flag+)
- (layout-flags layout))
- (eq (%instance-layout y) layout)
- (funcall (layout-equalp-impl layout) x y)))))
+ (sb-kernel::layout-flags type))
+ (eq (%instance-layout y) type)
+ (funcall (wrapper-equalp-impl (layout-friend type))
+ x y)))))
((arrayp x)
(and (arrayp y)
;; string-equal is nearly 2x the speed of array-equalp for comparing \
strings
diff --git a/src/code/print.lisp b/src/code/print.lisp
index 794aa22d3..1e3aedd93 100644
--- a/src/code/print.lisp
+++ b/src/code/print.lisp
@@ -370,28 +370,29 @@ variable: an unreadable object representing the error is \
printed instead.") ;;; just not for OBJECT itself.
(defun output-ugly-object (stream object)
(when (%instancep object)
- (let ((layout (%instance-layout object)))
- ;; If an instance has no layout, do something sensible. Can't compare layout
+ (let ((type (%instance-layout object)))
+ ;; If an instance has no type, do something sensible. Can't compare type
;; to 0 using EQ or EQL because that would be tautologically NIL as per fndb.
- ;; This is better than declaring EQ or %INSTANCE-LAYOUT notinline.
- (unless (logtest (get-lisp-obj-address layout) sb-vm:widetag-mask)
+ ;; This is better than declaring EQ or %INSTANCE-TYPEID notinline.
+ (unless (logtest (get-lisp-obj-address type) sb-vm:widetag-mask)
(return-from output-ugly-object
(print-unreadable-object (object stream :identity t)
(prin1 'instance stream))))
- (let ((classoid (layout-classoid layout)))
+ (let* ((wrapper (layout-friend type))
+ (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)
- (logtest (layout-flags layout)
+ (and (wrapper-invalid wrapper)
+ (logtest (sb-kernel::layout-flags type)
(logior +structure-layout-flag+
+condition-layout-flag+))))
(return-from output-ugly-object
(print-unreadable-object (object stream :identity t)
(format stream "UNPRINTABLE instance of ~W" classoid)))))))
(when (funcallable-instance-p object)
- (let ((layout (%fun-layout object)))
- (unless (logtest (get-lisp-obj-address layout) sb-vm:widetag-mask)
+ (let ((type (%fun-layout object)))
+ (unless (logtest (get-lisp-obj-address type) sb-vm:widetag-mask)
(return-from output-ugly-object
(print-unreadable-object (object stream :identity t)
(prin1 'funcallable-instance stream))))))
diff --git a/src/code/room.lisp b/src/code/room.lisp
index 2462fa997..50989717e 100644
--- a/src/code/room.lisp
+++ b/src/code/room.lisp
@@ -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))))
diff --git a/src/code/sharpm.lisp b/src/code/sharpm.lisp
index d738662b1..59e77d2bb 100644
--- a/src/code/sharpm.lisp
+++ b/src/code/sharpm.lisp
@@ -298,8 +298,8 @@
(instance
;; Don't refer to the DD-SLOTS unless there is reason to,
;; that is, unless some slot might be raw.
- (if (/= +layout-all-tagged+ (layout-bitmap (%instance-layout tree)))
- (let ((dd (layout-dd (%instance-layout tree))))
+ (if (/= +layout-all-tagged+ (wrapper-bitmap (%instance-wrapper 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))))))
diff --git a/src/code/stream.lisp b/src/code/stream.lisp
index ac505f611..1f50b193c 100644
--- a/src/code/stream.lisp
+++ b/src/code/stream.lisp
@@ -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)
diff --git a/src/code/stubs.lisp b/src/code/stubs.lisp
index 8c58b0a1b..6c76c358f 100644
--- a/src/code/stubs.lisp
+++ b/src/code/stubs.lisp
@@ -86,20 +86,23 @@
(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)
+ #+(and 64-bit (not x86-64)) (def wrapper-depthoid)
+
;; lists
(def %rplaca (x val))
(def %rplacd (x val))
@@ -154,8 +157,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)))))
diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp
index 1238ac6ac..cb30454a4 100644
--- a/src/code/target-defstruct.lisp
+++ b/src/code/target-defstruct.lisp
@@ -16,10 +16,10 @@
;;; 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* ((layout (classoid-wrapper (the structure-classoid (find-classoid type))))
+ (structure (%make-instance (wrapper-length layout))))
+ (setf (%instance-wrapper structure) layout)
+ (dolist (dsd (dd-slots (wrapper-dd layout)) structure)
(when (eq (dsd-raw-type dsd) 't)
(setf (%instance-ref structure (dsd-index dsd)) (make-unbound-marker))))))
@@ -30,33 +30,35 @@
(defun %instance-ref (instance index)
(%instance-ref instance index))
-(defun layout-id (layout)
+(defun layout-id (wrapper)
;; If a structure type at depthoid >= 2, then fetch the INDEXth id
;; where INDEX is depthoid - 2. Otherwise fetch the 0th id.
;; There are a few non-structure types at positive depthoid; those do not store
;; 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 wrapper 'wrapper) (wrapper-friend \
wrapper)) + (t wrapper)))
+ (depth (- (#+metaspace sb-vm::layout-depthoid
+ #-metaspace wrapper-depthoid layout)
+ 2))
(index (if (or (< depth 0) (not (logtest (layout-flags layout)
+structure-layout-flag+)))
- 0 depth)))
+ 0 depth))
+ (word0index (get-dsd-index sb-vm:layout id-word0)))
(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 (+ word0index index))
#+64-bit ; use SAP-ref for lack of half-sized slots
(with-pinned-objects (layout)
(let ((sap (sap+ (int-sap (get-lisp-obj-address layout))
- (- (ash (+ sb-vm:instance-slots-offset
- (get-dsd-index layout id-word0))
+ (- (ash (+ sb-vm:instance-slots-offset word0index)
sb-vm:word-shift)
sb-vm:instance-pointer-lowtag))))
(signed-sap-ref-32 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-wrapper-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
@@ -71,7 +73,8 @@
;; but on 64-bit we have to use SAP-REF, so may as well be consistent here
;; and use a SAP either way.
(let ((sap (sap+ (int-sap (get-lisp-obj-address layout))
- (- (ash (+ sb-vm:instance-slots-offset (get-dsd-index layout \
id-word0)) + (- (ash (+ (get-dsd-index sb-vm:layout id-word0)
+ sb-vm:instance-slots-offset)
sb-vm:word-shift)
sb-vm:instance-pointer-lowtag))))
(cond (structurep
@@ -89,7 +92,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)
@@ -120,10 +123,7 @@
;;; 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))
+ `(setf (%instance-ref ,layout (get-dsd-index wrapper equalp-impl))
,newval))
(defun assign-equalp-impl (type-name function)
@@ -137,11 +137,11 @@
(dd-doc dd)))
(let ((classoid (find-classoid (dd-name dd))))
- (let ((layout (classoid-layout classoid)))
+ (let ((layout (classoid-wrapper classoid)))
(set-layout-equalp-impl
layout
(cond ((compiled-function-p equalp) equalp)
- ((eql (layout-bitmap layout) +layout-all-tagged+)
+ ((eql (wrapper-bitmap layout) +layout-all-tagged+)
#'sb-impl::instance-equalp)
(t
;; Make a vector of EQUALP slots comparators, indexed by
@@ -177,8 +177,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 ((layout (%instance-wrapper structure)))
+ (when (wrapper-invalid layout)
(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
@@ -189,8 +189,8 @@
(let* ((len (%instance-length structure))
(res (%make-instance len)))
(declare (type index len))
- (let ((bitmap (layout-bitmap layout)))
- ;; Don't assume that %INSTANCE-REF can access the layout.
+ (let ((bitmap (wrapper-bitmap layout)))
+ ;; 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
;; registers, we could speed up this code in an obvious way.
@@ -227,6 +227,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
@@ -284,9 +290,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* ((layout (%instance-wrapper structure))
+ (dd (wrapper-info layout))
+ (name (wrapper-classoid-name layout)))
(cond ((not dd)
;; FIXME? this branch may be unnecessary as a consequence
;; of change f02bee325920166b69070e4735a8a3f295f8edfd which
@@ -336,5 +342,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")
diff --git a/src/code/target-hash-table.lisp b/src/code/target-hash-table.lisp
index 06f11d089..100a2871f 100644
--- a/src/code/target-hash-table.lisp
+++ b/src/code/target-hash-table.lisp
@@ -1040,14 +1040,14 @@ if there is no such entry. Entries can be added using SETF."
(non-null-symbol-p key)
(and (%instancep key)
;; Pathnames are descended into by EQUAL.
- (not (logtest (layout-flags (%instance-layout key))
+ (not (logtest (sb-kernel::layout-flags (%instance-layout key))
+pathname-layout-flag+)))))
(equalp
'(or address-based-p
(non-null-symbol-p key)
(and (%instancep key)
;; Structures incl. PATHNAME and HASH-TABLE are descended into.
- (not (logtest (layout-flags (%instance-layout key))
+ (not (logtest (sb-kernel::layout-flags (%instance-layout key))
+structure-layout-flag+)))))
((nil)
;; If the hash-function is nonstandard, it's nonetheless possible
diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp
index a04f254f2..462ea9364 100644
--- a/src/code/target-pathname.lisp
+++ b/src/code/target-pathname.lisp
@@ -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.
diff --git a/src/code/target-sxhash.lisp b/src/code/target-sxhash.lisp
index 4b9630309..3dd591eca 100644
--- a/src/code/target-sxhash.lisp
+++ b/src/code/target-sxhash.lisp
@@ -94,9 +94,14 @@
(declare (inline #+64-bit murmur3-fmix64 #-64-bit murmur3-fmix32))
;; FIXME: this special case might be removable, but there are callers
;; of sxhash on layouts due to the expansion of TYPECASE.
- (when (typep instance 'layout)
+ #-metaspace
+ (when (typep instance 'wrapper)
;; This might be wrong if the clos-hash was clobbered to 0
- (return-from %instance-sxhash (layout-clos-hash instance)))
+ (return-from %instance-sxhash (wrapper-clos-hash instance)))
+ #+metaspace
+ (when (typep instance 'sb-vm:layout)
+ ;; This might be wrong if the clos-hash was clobbered to 0
+ (return-from %instance-sxhash (sb-kernel::layout-clos-hash instance)))
;; Non-simple cases: no hash slot, and either unhashed or hashed-not-moved.
(let* ((header-word (instance-header-word instance))
(addr (with-pinned-objects (instance)
@@ -345,7 +350,8 @@
(logxor 72185131
(sxhash (char-code x)))) ; through DEFTRANSFORM
(funcallable-instance
- (if (layout-for-pcl-obj-p (%fun-layout x))
+ (if (logtest (sb-kernel::layout-flags (%fun-layout x))
+ sb-kernel:+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
@@ -441,15 +447,18 @@
(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))
+ ;; Until I decide for certain whether the clos-hash in the
+ ;; the TYPEID is definitive, or the one is the LAYOUT,
+ ;; let's stick with using the layout.
+ (result (wrapper-clos-hash wrapper)))
(declare (type fixnum result))
(when (plusp depthoid)
(let ((max-iterations depthoid)
(depthoid (1- depthoid)))
(declare (index max-iterations))
- (if (/= (layout-bitmap layout) +layout-all-tagged+)
- (let ((slots (dd-slots (layout-dd layout))))
+ (if (/= (wrapper-bitmap wrapper) +layout-all-tagged+)
+ (let ((slots (dd-slots (wrapper-dd wrapper))))
(loop (unless slots (return))
(let* ((slot (pop slots))
(rsd-index+1 (rsd-index+1 slot))
diff --git a/src/code/typep.lisp b/src/code/typep.lisp
index fcdcadcb4..ab847b881 100644
--- a/src/code/typep.lisp
+++ b/src/code/typep.lisp
@@ -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)))
@@ -170,31 +169,33 @@
;;; Do a type test from a class cell, allowing forward reference and
;;; redefinition.
(defun classoid-cell-typep (cell object)
- (let ((layout (typecase object
- (instance (%instance-layout object))
- (funcallable-instance (%fun-layout object))
- (t (return-from classoid-cell-typep))))
+ (let ((type (typecase object
+ (instance (%instance-layout object))
+ (funcallable-instance (%fun-layout object))
+ (t (return-from classoid-cell-typep))))
(classoid (classoid-cell-classoid cell)))
(unless classoid
(error "The class ~S has not yet been defined."
(classoid-cell-name cell)))
- (classoid-typep layout classoid object)))
+ (classoid-typep (layout-friend type) classoid object)))
;;; Return true of any object which is either a funcallable-instance,
;;; or an ordinary instance that is not a structure-object.
(declaim (inline %pcl-instance-p))
(defun %pcl-instance-p (x)
;; The COND is more efficient than LAYOUT-OF.
- (layout-for-pcl-obj-p (cond ((%instancep x) (%instance-layout x))
- ((function-with-layout-p x) (%fun-layout x))
- (t (return-from %pcl-instance-p nil)))))
+ ;; XXX: use %INTANCEOID-TYPEID
+ (logtest (layout-flags (cond ((%instancep x) (%instance-layout x))
+ ((function-with-layout-p x) (%fun-layout x))
+ (t (return-from %pcl-instance-p nil))))
+ +pcl-object-layout-flag+))
;;; 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.
@@ -226,6 +227,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
@@ -240,24 +242,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)))))))
@@ -297,7 +299,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))
diff --git a/src/code/warm-error.lisp b/src/code/warm-error.lisp
index be25aca87..8af273c24 100644
--- a/src/code/warm-error.lisp
+++ b/src/code/warm-error.lisp
@@ -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
diff --git a/src/code/x86-64-vm.lisp b/src/code/x86-64-vm.lisp
index 044100cab..0614fdc0d 100644
--- a/src/code/x86-64-vm.lisp
+++ b/src/code/x86-64-vm.lisp
@@ -161,7 +161,7 @@
(#.sb-vm:closure-widetag t)
(#.sb-vm:funcallable-instance-widetag
;; if the FIN has no raw words then it has no internal trampoline
- (eql (layout-bitmap (%fun-layout fun)) +layout-all-tagged+))))
+ (eql (wrapper-bitmap (%fun-wrapper fun)) +layout-all-tagged+))))
;; TODO: put a trampoline in all fins and allocate them anywhere.
;; Revision e7cd2bd40f5b9988 caused some FINs to go in dynamic space
@@ -195,9 +195,9 @@
(logior (ash 5 n-widetag-bits)
funcallable-instance-widetag)))))
;; Assert that raw bytes will not cause GC invariant lossage
- (aver (/= (layout-bitmap layout) +layout-all-tagged+))
+ (aver (/= (wrapper-bitmap layout) +layout-all-tagged+))
;; 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))
diff --git a/src/cold/shared.lisp b/src/cold/shared.lisp
index 4571e0afd..7b1437395 100644
--- a/src/cold/shared.lisp
+++ b/src/cold/shared.lisp
@@ -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
diff --git a/src/compiler/arm/system.lisp b/src/compiler/arm/system.lisp
index 79fc0cc31..c4dea3cfb 100644
--- a/src/compiler/arm/system.lisp
+++ b/src/compiler/arm/system.lisp
@@ -72,7 +72,7 @@
(offset (+ (ash (+ (get-dsd-index layout sb-kernel::id-word0)
instance-slots-offset)
word-shift)
- (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.
diff --git a/src/compiler/arm64/system.lisp b/src/compiler/arm64/system.lisp
index 79b7f15d1..02e9871ad 100644
--- a/src/compiler/arm64/system.lisp
+++ b/src/compiler/arm64/system.lisp
@@ -57,8 +57,8 @@
(inst ldrb result (@ object result))
done))
-(define-vop (layout-depthoid)
- (:translate layout-depthoid)
+(define-vop (wrapper-depthoid)
+ (:translate wrapper-depthoid)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg)))
(:results (value :scs (any-reg)))
@@ -89,7 +89,7 @@
(offset (+ (ash (+ (get-dsd-index layout sb-kernel::id-word0)
instance-slots-offset)
word-shift)
- (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))
diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp
index 9957b0d8d..2fbde6d43 100644
--- a/src/compiler/dump.lisp
+++ b/src/compiler/dump.lisp
@@ -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)))
diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp
index c8bbddbe4..6b97b72b1 100644
--- a/src/compiler/fndb.lisp
+++ b/src/compiler/fndb.lisp
@@ -98,10 +98,12 @@
(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))
+#+64-bit (defknown wrapper-depthoid (wrapper) layout-depthoid
+ (flushable #-x86-64 always-translatable))
+(defknown sb-vm::layout-depthoid (sb-vm:layout) layout-depthoid
+ (flushable always-translatable))
+#+(or x86 x86-64) (defknown (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 +1771,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
diff --git a/src/compiler/fopcompile.lisp b/src/compiler/fopcompile.lisp
index 62b99c79e..33302cf04 100644
--- a/src/compiler/fopcompile.lisp
+++ b/src/compiler/fopcompile.lisp
@@ -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)))
diff --git a/src/compiler/generic/early-vm.lisp b/src/compiler/generic/early-vm.lisp
index 9ce25fa4a..c932f1cb0 100644
--- a/src/compiler/generic/early-vm.lisp
+++ b/src/compiler/generic/early-vm.lisp
@@ -116,8 +116,8 @@
stop))
;; The lowest index that you can pass to %INSTANCE-REF accessing
-;; a slot of data that is not the instance-layout.
-;; To get a layout, you must call %INSTANCE-LAYOUT - don't assume index 0.
+;; a slot of data that is not in the header word.
+;; To read the type, you must call %INSTANCE-TYPEID - don't assume that it's index \
0. (defconstant instance-data-start (+ #-compact-instance-header 1))
;;; The largest number that may appear in the header-data for closures
diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp
index 5104272b5..be782bbb9 100644
--- a/src/compiler/generic/genesis.lisp
+++ b/src/compiler/generic/genesis.lisp
@@ -711,9 +711,9 @@
(make-fixnum-descriptor length))
des))
-;;; The COLD-LAYOUT is a reflection of or proxy for the words stored
-;;; in the core for a cold layout, so that we don't have to extract
-;;; them out of the core to compare cold layouts for validity.
+;;; The COLD-LAYOUT is proxy for the words stored in the core for a cold WRAPPER
+;;; and/or LAYOUTso that we don't have to use read-wordindexed to compare cold
+;;; layouts for validity.
(defstruct (cold-layout (:constructor %make-cold-layout))
id name depthoid length bitmap flags inherits descriptor)
@@ -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 #+metaspace sb-vm:layout 2)
+ #+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
@@ -2730,9 +2741,14 @@ Legal values for OFFSET are -4, -8, -12, ..."
(:code-object (descriptor-bits code-obj))
#+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
+ (format t "~&LAYOUT fixup for ~s~%" sym)
+ (cold-layout-descriptor-bits sym))
+ (:layout-id
+ ;; SYM is acutally of type WRAPPER
+ (format t "~&LAYOUT-ID fixup for ~s~%" sym)
+ (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 +3198,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)
@@ -3217,9 +3230,9 @@ Legal values for OFFSET are -4, -8, -12, ..."
c-symbol (ensure-symbol-tls-index symbol))))
;; This #define is relative to the start of the fixedobj space to allow heap \
relocation. #+immobile-space
- (format stream "~@{#define LAYOUT_OF_~A (lispobj)(FIXEDOBJ_SPACE_START+0x~x)~%~}"
- "FUNCTION" (- (cold-layout-descriptor-bits 'function)
- (gspace-byte-address *immobile-fixedobj*)))
+ (format stream "~@{#define LAYOUT_OF_FUNCTION \
(lispobj)(FIXEDOBJ_SPACE_START+0x~x)~%~}" + (- (cold-layout-descriptor-bits \
'function) + (gspace-byte-address *immobile-fixedobj*)))
;; For immobile code, define a constant for the address of the vector of
;; C-callable fdefns, and then fdefns in terms of indices to that vector.
#+immobile-code
@@ -3364,13 +3377,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,12 +3742,12 @@ 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)
- (write-slots (->wrapper (cold-layout-descriptor layout)) :%info dd)))
+ (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~%"
(length *known-structure-classoids*)
@@ -3768,7 +3783,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 +3887,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)
diff --git a/src/compiler/generic/interr.lisp b/src/compiler/generic/interr.lisp
index b5ebfddf3..f1e2a3dff 100644
--- a/src/compiler/generic/interr.lisp
+++ b/src/compiler/generic/interr.lisp
@@ -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
diff --git a/src/compiler/generic/layout-ids.lisp \
b/src/compiler/generic/layout-ids.lisp index 54150f5ad..9dfc03941 100644
--- a/src/compiler/generic/layout-ids.lisp
+++ b/src/compiler/generic/layout-ids.lisp
@@ -218,8 +218,8 @@ SB-ALIEN::SHARED-OBJECT
;;; There are a few wired IDs:
;;; 0 = T
;;; 1 = STRUCTURE-OBJECT
-;;; 2 = WRAPPER
-;;; 3 = LAYOUT
+;;; 2 = SB-VM:LAYOUT if #+metaspace, WRAPPER if #-metaspace
+;;; 3 = WRAPPER if #+metaspace, unused if #-metaspace
;;; 4 = SB-LOCKLESS::LIST-NODE
(ecase layout-id-type
(unsigned-byte
diff --git a/src/compiler/generic/target-core.lisp \
b/src/compiler/generic/target-core.lisp index e1f11803e..0fccf06b6 100644
--- a/src/compiler/generic/target-core.lisp
+++ b/src/compiler/generic/target-core.lisp
@@ -92,8 +92,11 @@
(:foreign-dataref (foreign-symbol-address sym t))
(: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)))
+ (:layout
+ (get-lisp-obj-address
+ (etypecase sym
+ (symbol (wrapper-friend (find-layout sym)))
+ (wrapper (wrapper-friend 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 +138,8 @@
(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
diff --git a/src/compiler/generic/type-error.lisp \
b/src/compiler/generic/type-error.lisp index bde9d843a..7321576e2 100644
--- a/src/compiler/generic/type-error.lisp
+++ b/src/compiler/generic/type-error.lisp
@@ -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))))
diff --git a/src/compiler/generic/vm-fndb.lisp b/src/compiler/generic/vm-fndb.lisp
index 435bdb7c5..f407db77d 100644
--- a/src/compiler/generic/vm-fndb.lisp
+++ b/src/compiler/generic/vm-fndb.lisp
@@ -192,20 +192,22 @@
(flushable always-translatable))
(defknown (%copy-instance %copy-instance-slots) (instance instance) instance
() :result-arg 0)
-(defknown %instance-layout (instance) layout
- (foldable flushable))
-;;; %FUN-LAYOUT is to %INSTANCE-LAYOUT as FUN-POINTER-LOWTAG is to \
INSTANCE-POINTER-LOWTAG +(defknown %instance-layout (instance) sb-vm:layout (foldable \
flushable)) +(defknown %instance-wrapper (instance) wrapper (foldable flushable))
+;;; %FUN-TYPEID is to %INSTANCE-TYPEID 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))
+;;; %FUN-LAYOUT is to %INSTANCE-LAYOUT as FUN-POINTER-LOWTAG is to \
INSTANCE-POINTER-LOWTAG +(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))
+;;; POINTER-LOWTAG returns the layout, otherwise some agreed-upon non-nil thing.
+(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 +220,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)
diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp
index 6a7401a1f..32f07451e 100644
--- a/src/compiler/generic/vm-tran.lisp
+++ b/src/compiler/generic/vm-tran.lisp
@@ -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,19 +150,22 @@
(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.
+;;; with knowledge of the TYPEID slot location.
#+compact-instance-header
(define-source-transform function-with-layout-p (x) `(functionp ,x))
#-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)))
diff --git a/src/compiler/generic/vm-typetran.lisp \
b/src/compiler/generic/vm-typetran.lisp index 56e6a8c7e..b91f85655 100644
--- a/src/compiler/generic/vm-typetran.lisp
+++ b/src/compiler/generic/vm-typetran.lisp
@@ -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
diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index 9f1c55cd3..72dbc3ec1 100644
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -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)))))
diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 0ae0a65dd..58db32fef 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -2403,6 +2403,13 @@ is :ANY, the function name is not checked."
&aux (namespace (if (boundp '*ir1-namespace*) \
*ir1-namespace*)) (output *compile-object*))
+ #+metaspace
+ (when (typep object 'sb-vm:layout)
+ ;; For technical reasons, LAYOUTs should only have ambiguous
+ ;; pointers from the stack, and pointers from word 0 of heap objects
+ ;; and nothing else.
+ (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)
;; acting as a magic mechanism for passing data along.
diff --git a/src/compiler/mips/system.lisp b/src/compiler/mips/system.lisp
index bd84192e5..e429201a0 100644
--- a/src/compiler/mips/system.lisp
+++ b/src/compiler/mips/system.lisp
@@ -71,7 +71,7 @@
(offset (+ (ash (+ (get-dsd-index layout sb-kernel::id-word0)
instance-slots-offset)
word-shift)
- (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)
diff --git a/src/compiler/ppc/system.lisp b/src/compiler/ppc/system.lisp
index dce1b67a7..786cb4f38 100644
--- a/src/compiler/ppc/system.lisp
+++ b/src/compiler/ppc/system.lisp
@@ -62,7 +62,7 @@
(offset (+ (ash (+ (get-dsd-index layout sb-kernel::id-word0)
instance-slots-offset)
word-shift)
- (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.
diff --git a/src/compiler/ppc64/system.lisp b/src/compiler/ppc64/system.lisp
index 81f1882d9..baf5d8cf0 100644
--- a/src/compiler/ppc64/system.lisp
+++ b/src/compiler/ppc64/system.lisp
@@ -48,8 +48,8 @@
DONE))
-(define-vop (layout-depthoid)
- (:translate layout-depthoid)
+(define-vop (wrapper-depthoid)
+ (:translate wrapper-depthoid)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg)))
(:results (res :scs (any-reg)))
@@ -77,7 +77,7 @@
(offset (+ (ash (+ (get-dsd-index layout sb-kernel::id-word0)
instance-slots-offset)
word-shift)
- (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.
diff --git a/src/compiler/proclaim.lisp b/src/compiler/proclaim.lisp
index 65eedde9f..d79609f25 100644
--- a/src/compiler/proclaim.lisp
+++ b/src/compiler/proclaim.lisp
@@ -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)
diff --git a/src/compiler/riscv/system.lisp b/src/compiler/riscv/system.lisp
index 7af28ed7a..d3e34a5bb 100644
--- a/src/compiler/riscv/system.lisp
+++ b/src/compiler/riscv/system.lisp
@@ -66,7 +66,7 @@
(let ((offset (+ (ash (+ (get-dsd-index layout sb-kernel::id-word0)
instance-slots-offset)
word-shift)
- (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))))
@@ -76,8 +76,8 @@
(inst* (if not-p 'bne 'beq) this-id temp target))))
#+64-bit
-(define-vop (layout-depthoid)
- (:translate layout-depthoid)
+(define-vop (wrapper-depthoid)
+ (:translate wrapper-depthoid)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg)))
(:results (values :scs (any-reg)))
@@ -85,7 +85,7 @@
(:generator 1
(inst lw values object
(- (+ (ash (+ instance-slots-offset
- (get-dsd-index layout sb-kernel::flags))
+ (get-dsd-index sb-vm:layout sb-kernel::flags))
word-shift)
4)
instance-pointer-lowtag))))
diff --git a/src/compiler/sparc/system.lisp b/src/compiler/sparc/system.lisp
index 9ff2c4466..9690799ed 100644
--- a/src/compiler/sparc/system.lisp
+++ b/src/compiler/sparc/system.lisp
@@ -62,7 +62,7 @@
(let ((offset (+ (ash (+ (get-dsd-index layout sb-kernel::id-word0)
instance-slots-offset)
word-shift)
- (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))))
diff --git a/src/compiler/tn.lisp b/src/compiler/tn.lisp
index 74db0a95f..12c7af958 100644
--- a/src/compiler/tn.lisp
+++ b/src/compiler/tn.lisp
@@ -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))))
diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp
index b236a84b4..c9759b0ec 100644
--- a/src/compiler/typetran.lisp
+++ b/src/compiler/typetran.lisp
@@ -826,13 +826,18 @@
;;; e.g. a fixnum as representative of class REAL.
;;; 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))
+(defmacro depthoid-ge (layout depthoid)
+ `(>= (wrapper-depthoid ,layout) ,depthoid))
+(symbol-macrolet ((get-flags #-metaspace 'wrapper-flags
+ #+metaspace 'sb-kernel::layout-flags)
+ (get-hash #-metaspace 'wrapper-clos-hash
+ #+metaspace 'sb-kernel::layout-clos-hash))
(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 +845,15 @@
((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))
+ #+nil(format t "~&transform-instance-typep~s: wrapper=~s layout=~s~%" classoid \
wrapper 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 +867,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 +882,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 +897,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 (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
diff --git a/src/compiler/x86-64/alloc.lisp b/src/compiler/x86-64/alloc.lisp
index 178f865ac..4d42946a8 100644
--- a/src/compiler/x86-64/alloc.lisp
+++ b/src/compiler/x86-64/alloc.lisp
@@ -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 (sb-kernel::wrapper-p type)) ; is this an instance type?
(bytes (pad-data-block words)))
(progn name) ; possibly not used
(unless stack-allocate-p
diff --git a/src/compiler/x86-64/cell.lisp b/src/compiler/x86-64/cell.lisp
index 6552abdf9..c959c96ab 100644
--- a/src/compiler/x86-64/cell.lisp
+++ b/src/compiler/x86-64/cell.lisp
@@ -65,6 +65,7 @@
(progn name dx-p)
(cond #+compact-instance-header
((and (eq name '%make-structure-instance) (eql offset :layout))
+ (format t "~&Potatie writing layout~%")
;; The layout is in the upper half of the header word.
(inst mov :dword (ea (- 4 instance-pointer-lowtag) object)
(if (sc-is value immediate)
diff --git a/src/compiler/x86-64/system.lisp b/src/compiler/x86-64/system.lisp
index cd0c8170c..bac4f4a83 100644
--- a/src/compiler/x86-64/system.lisp
+++ b/src/compiler/x86-64/system.lisp
@@ -17,7 +17,7 @@
;;; For lists and non-pointers, return the low 8 descriptor bits.
;;; We need not return exactly list-pointer-lowtag for lists - the high 4 bits
;;; are arbitrary. Similarly we don't care that fixnums return other than 0.
-;;; Provided that the result is the correct index to **PRIMITIVE-OBJECT-LAYOUTS**
+;;; Provided that the result is the correct index to **PRIMITIVE-OBJECT-TYPEIDS**
;;; everything works out fine. All backends should follow this simpler model,
;;; but might or might not opt to use the same technique of producing a native
;;; pointer and doing one memory access for all 3 non-list pointer types.
@@ -46,6 +46,9 @@
(inst movzx '(:byte :dword) result object)
DONE))
+#-sb-xc-host
+(defun wrapper-depthoid (wrapper) (layout-depthoid (wrapper-friend wrapper)))
+
(macrolet ((read-depthoid ()
`(ea (- (+ 4 (ash (+ instance-slots-offset
(get-dsd-index layout sb-kernel::flags))
@@ -60,7 +63,7 @@
(:result-types fixnum)
(:generator 1 (inst movsx '(:dword :qword) res (read-depthoid))))
(define-vop ()
- (:translate sb-c::layout-depthoid-ge)
+ (:translate sb-c::depthoid-ge)
(:policy :fast-safe)
(:args (layout :scs (descriptor-reg)))
(:info k)
@@ -80,7 +83,7 @@
(ea (+ (ash (+ (get-dsd-index layout sb-kernel::id-word0)
instance-slots-offset)
word-shift)
- (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.
@@ -91,7 +94,7 @@
;; I don't think layout-id 0 can get here, but be sure to exclude it.
(if (or (typep (layout-id test) '(and (signed-byte 8) (not (eql 0))))
(not (sb-c::producing-fasl-file)))
- (layout-id test)
+ (sb-kernel::layout-id test)
(make-fixup test :layout-id)))))
#+compact-instance-header
@@ -99,7 +102,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)))
@@ -137,7 +140,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)
diff --git a/src/compiler/x86-64/type-vops.lisp b/src/compiler/x86-64/type-vops.lisp
index 333f4ee5d..e1b961ede 100644
--- a/src/compiler/x86-64/type-vops.lisp
+++ b/src/compiler/x86-64/type-vops.lisp
@@ -534,12 +534,16 @@
(: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,
+ ;; not the wrapper. So we don't need to dump a layout (and can't).
(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)))))
diff --git a/src/compiler/x86-64/vm.lisp b/src/compiler/x86-64/vm.lisp
index acf273cce..633fe7610 100644
--- a/src/compiler/x86-64/vm.lisp
+++ b/src/compiler/x86-64/vm.lisp
@@ -424,9 +424,8 @@
(static-symbol-p value))
immediate-sc-number))
- #+immobile-space
- (layout
- immediate-sc-number)
+ #+(and immobile-space (not metaspace)) (wrapper immediate-sc-number)
+ #+metaspace (sb-vm:layout immediate-sc-number)
(single-float
(if (eql value $0f0) fp-single-zero-sc-number fp-single-immediate-sc-number))
(double-float
@@ -463,8 +462,13 @@
(symbol (if (static-symbol-p val)
(+ nil-value (static-symbol-offset val))
(make-fixup val :immobile-symbol)))
- #+immobile-space
- (layout
+ #+metaspace
+ (sb-vm:layout
+ ;; FIXME: assert what it is rather than what it isn't
+ (aver (not (typep val 'sb-vm:layout)))
+ (make-fixup val :layout))
+ #+(and immobile-space (not metaspace))
+ (wrapper
(make-fixup val :layout))
(character (if tag
(logior (ash (char-code val) n-widetag-bits)
diff --git a/src/compiler/x86/system.lisp b/src/compiler/x86/system.lisp
index 7c11e710b..9b189ac27 100644
--- a/src/compiler/x86/system.lisp
+++ b/src/compiler/x86/system.lisp
@@ -49,7 +49,7 @@
instance-pointer-lowtag)
:base layout)))
(define-vop ()
- (:translate sb-c::layout-depthoid-ge)
+ (:translate sb-c::depthoid-ge)
(:policy :fast-safe)
(:args (layout :scs (descriptor-reg)))
(:info k)
@@ -70,7 +70,7 @@
:disp (+ (ash (+ (get-dsd-index layout sb-kernel::id-word0)
instance-slots-offset)
word-shift)
- (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))))
diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp
index 44225ba9f..61b43214c 100644
--- a/src/pcl/braid.lisp
+++ b/src/pcl/braid.lisp
@@ -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)
- ((/= (layout-bitmap wrapper) +layout-all-tagged+)
+ ((/= (wrapper-bitmap wrapper) +layout-all-tagged+)
(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 (sb-kernel::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
- (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)
+ (let ((classoid (wrapper-classoid wrapper)))
+ (unless (eq (classoid-wrapper classoid) wrapper)
+ (set-wrapper-inherits wrapper
+ (order-layout-inherits
+ (map 'simple-vector #'class-wrapper
+ (reverse (rest (class-precedence-list class)))))
+ nil 0)
+ (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
diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp
index bc51b3c14..fc1b5666d 100644
--- a/src/pcl/cache.lisp
+++ b/src/pcl/cache.lisp
@@ -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)
diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp
index 0fde31569..84f14e599 100644
--- a/src/pcl/ctor.lisp
+++ b/src/pcl/ctor.lisp
@@ -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 ())
diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp
index 19d6b40dd..9ddc85fcd 100644
--- a/src/pcl/defs.lisp
+++ b/src/pcl/defs.lisp
@@ -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,8 @@
(/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)
@@ -195,8 +195,8 @@
(let ((subs (classoid-subclasses class)))
(/noshow subs)
(when subs
- (dohash ((sub wrapper) subs)
- (declare (ignore wrapper))
+ (dohash ((sub v) subs)
+ (declare (ignore v))
(/noshow sub)
(when (member class (direct-supers sub) :test #'eq)
(res sub)))))
@@ -209,8 +209,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)
diff --git a/src/pcl/dlisp.lisp b/src/pcl/dlisp.lisp
index da13d62c2..5fa13f8f5 100644
--- a/src/pcl/dlisp.lisp
+++ b/src/pcl/dlisp.lisp
@@ -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
diff --git a/src/pcl/env.lisp b/src/pcl/env.lisp
index 8d907760a..2e19555b9 100644
--- a/src/pcl/env.lisp
+++ b/src/pcl/env.lisp
@@ -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)
diff --git a/src/pcl/fixup.lisp b/src/pcl/fixup.lisp
index 83cf29cae..0b92a50b2 100644
--- a/src/pcl/fixup.lisp
+++ b/src/pcl/fixup.lisp
@@ -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)
diff --git a/src/pcl/fngen.lisp b/src/pcl/fngen.lisp
index 6a64c5168..076c8825b 100644
--- a/src/pcl/fngen.lisp
+++ b/src/pcl/fngen.lisp
@@ -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)
diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp
index bdcd68a11..0e0af2af7 100644
--- a/src/pcl/low.lisp
+++ b/src/pcl/low.lisp
@@ -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,11 +108,11 @@
(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)
- (logtest (layout-flags (%fun-layout fin))
+ (logtest (sb-kernel::layout-flags (%fun-layout fin))
+pcl-object-layout-flag+))
(error 'type-error :datum fin :expected-type 'funcallable-standard-object))
(setf (%funcallable-instance-fun fin) new-value))
@@ -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)
diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index 3aa23f616..e31f32cf9 100644
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -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)))
diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp
index e09258678..553da7baa 100644
--- a/src/pcl/slots-boot.lisp
+++ b/src/pcl/slots-boot.lisp
@@ -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.
diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp
index be78e9d8a..1fd09371e 100644
--- a/src/pcl/slots.lisp
+++ b/src/pcl/slots.lisp
@@ -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))))))
diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index d1fbd64e7..c30f76384 100644
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -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-wrapper-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))
diff --git a/src/pcl/wrapper.lisp b/src/pcl/wrapper.lisp
index c33548df4..38d1206bb 100644
--- a/src/pcl/wrapper.lisp
+++ b/src/pcl/wrapper.lisp
@@ -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 (sb-kernel::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)))
diff --git a/src/runtime/gc-private.h b/src/runtime/gc-private.h
index 57d20baa3..2875e43a2 100644
--- a/src/runtime/gc-private.h
+++ b/src/runtime/gc-private.h
@@ -423,7 +423,7 @@ static inline int layout_depth2_id(struct layout* layout) {
return vector[0];
}
// Keep in sync with hardwired IDs in src/compiler/generic/genesis.lisp
-#define LAYOUT_LAYOUT_ID 3
+#define LAYOUT_LAYOUT_ID 2
#define LFLIST_NODE_LAYOUT_ID 4
/// Return true if 'thing' is a layout.
diff --git a/src/runtime/print.c b/src/runtime/print.c
index fe3890e5c..0d65d7483 100644
--- a/src/runtime/print.c
+++ b/src/runtime/print.c
@@ -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
diff --git a/tests/classoid-typep.impure.lisp b/tests/classoid-typep.impure.lisp
index c661cc5f7..b22c8810b 100644
--- a/tests/classoid-typep.impure.lisp
+++ b/tests/classoid-typep.impure.lisp
@@ -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)
diff --git a/tests/clos-cache.impure.lisp b/tests/clos-cache.impure.lisp
index 44c309ba6..9dbad73cb 100644
--- a/tests/clos-cache.impure.lisp
+++ b/tests/clos-cache.impure.lisp
@@ -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))
diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index 540da0213..c8ed1164a 100644
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -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)
diff --git a/tests/compiler-2.pure.lisp b/tests/compiler-2.pure.lisp
index 30e81171e..153266b76 100644
--- a/tests/compiler-2.pure.lisp
+++ b/tests/compiler-2.pure.lisp
@@ -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*))
diff --git a/tests/condition.pure.lisp b/tests/condition.pure.lisp
index e28675f5d..fda681b46 100644
--- a/tests/condition.pure.lisp
+++ b/tests/condition.pure.lisp
@@ -425,10 +425,9 @@ is not of type
;;; should resemble ones created normally. Due to a bug, they did not.
;;; (The LENGTH slot had the wrong value)
(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)) + (loop for layout being each hash-value of (sb-kernel:classoid-subclasses
+ (sb-kernel:find-classoid 'condition))
+ for len = (sb-kernel:wrapper-length layout)
minimize len into min
maximize len into max
finally (assert (= min max))))
diff --git a/tests/defstruct.impure-cload.lisp b/tests/defstruct.impure-cload.lisp
index ccdbfd475..c34829a29 100644
--- a/tests/defstruct.impure-cload.lisp
+++ b/tests/defstruct.impure-cload.lisp
@@ -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
diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp
index 65a8c5a9e..63f912635 100644
--- a/tests/defstruct.impure.lisp
+++ b/tests/defstruct.impure.lisp
@@ -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))))
diff --git a/tests/do-refs.impure.lisp b/tests/do-refs.impure.lisp
index 6b7f2762e..761d5708c 100644
--- a/tests/do-refs.impure.lisp
+++ b/tests/do-refs.impure.lisp
@@ -23,11 +23,13 @@
(defstruct foo (z 0 :type sb-ext:word) (x 'x) (y 'y))
+(defmacro layout-for (x) (sb-kernel:wrapper-friend (find-layout x)))
+
(test-util:with-test (:name :walk-slots-trivial) ; lists and vectors
(walk-slots-test '(a . b) '(a b))
(walk-slots-test #(a b c) '(a b c))
(walk-slots-test #(a b c d) '(a b c d))
- (walk-slots-test (make-foo) `(,(find-layout 'foo) x y))
+ (walk-slots-test (make-foo) `(,(layout-for foo) x y))
)
(test-util:with-test (:name :walk-slots-numbers
@@ -96,20 +98,19 @@
(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)
+ `(,(layout-for 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)))
+ (layout (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 layout))
:key 'sb-kernel:dsd-index)))
(setf (sb-kernel:%funcallable-instance-info ctor (1+ max))
(elt sb-vm:+static-symbols+ 0))))
@@ -121,7 +122,7 @@
(test-util:with-test (:name :walk-slots-pcl-ctor)
(let* ((slot-vals '("A" "B" "C" "D" "E" "F"))
(f (apply #'make-random-funinstance slot-vals)))
- (walk-slots-test f `(,(find-layout 'sb-pcl::ctor) ,#'error ,@slot-vals))))
+ (walk-slots-test f `(,(layout-for sb-pcl::ctor) ,#'error ,@slot-vals))))
#+sb-fasteval
(test-util:with-test (:name :walk-slots-interpreted-fun)
@@ -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 'sb-vm:layout)
(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))
diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp
index 5b4854dba..2ef6df5e4 100644
--- a/tests/dynamic-extent.impure.lisp
+++ b/tests/dynamic-extent.impure.lisp
@@ -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)))
diff --git a/tests/fast-eval.impure.lisp b/tests/fast-eval.impure.lisp
index cb9ebde05..946e508b3 100644
--- a/tests/fast-eval.impure.lisp
+++ b/tests/fast-eval.impure.lisp
@@ -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)))
diff --git a/tests/full-eval.impure.lisp b/tests/full-eval.impure.lisp
index 5e229bbeb..c7717d31e 100644
--- a/tests/full-eval.impure.lisp
+++ b/tests/full-eval.impure.lisp
@@ -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)))
diff --git a/tests/gc.impure-cload.lisp b/tests/gc.impure-cload.lisp
index a49eec758..07e610992 100644
--- a/tests/gc.impure-cload.lisp
+++ b/tests/gc.impure-cload.lisp
@@ -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)
diff --git a/tests/hash.pure.lisp b/tests/hash.pure.lisp
index ccc3aa34c..f7588b972 100644
--- a/tests/hash.pure.lisp
+++ b/tests/hash.pure.lisp
@@ -352,10 +352,13 @@
;;; regression in which we returned (SXHASH (LAYOUT-OF X)) if X was a layout,
;;; which essentially meant that all layouts hashed to LAYOUT's hash.
;;; This affected the performance of TYPECASE.
+;;; But we now directly use LAYOUT-CLOS-HASH for dispatch, not SXHASH,
+;;; so the requirement on SXHASH is not important.
+#-metaspace
(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))))))
+ (assert (= (sxhash l) (sb-kernel:wrapper-clos-hash l))))))
(with-test (:name :equalp-table-fixnum-equal-to-float)
(let ((table (make-hash-table :test #'equalp)))
diff --git a/tests/immobile-space.impure.lisp b/tests/immobile-space.impure.lisp
index f0692e402..aa3630a78 100644
--- a/tests/immobile-space.impure.lisp
+++ b/tests/immobile-space.impure.lisp
@@ -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))
diff --git a/tests/raw-slots-interleaved.impure.lisp \
b/tests/raw-slots-interleaved.impure.lisp index 51d117072..28d95490d 100644
--- a/tests/raw-slots-interleaved.impure.lisp
+++ b/tests/raw-slots-interleaved.impure.lisp
@@ -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),
diff --git a/tests/save3.test.sh b/tests/save3.test.sh
index 1a0a3a4ef..0af17b704 100644
--- a/tests/save3.test.sh
+++ b/tests/save3.test.sh
@@ -35,8 +35,8 @@ run_sbcl <<EOF
(defclass subgf (standard-generic-function) (a) ; remove a slot
(:metaclass sb-mop:funcallable-standard-class))
(let ((nl (sb-kernel:find-layout 'subgf))) ; new layout
- (assert (not (eq (sb-kernel:%fun-layout #'myfun) nl)))
- (setf (sb-kernel:%fun-layout #'myfun) nl)
+ (assert (not (eq (sb-kernel:%fun-wrapper #'myfun) nl)))
+ (setf (sb-kernel:%fun-wrapper #'myfun) nl)
(gc)))
(save-lisp-and-die "$tmpcore" :toplevel #'assign-layout)
EOF
diff --git a/tests/stream.impure.lisp b/tests/stream.impure.lisp
index f317d153e..971223272 100644
--- a/tests/stream.impure.lisp
+++ b/tests/stream.impure.lisp
@@ -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
diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp
index 6053895f1..5d1fb0325 100644
--- a/tests/type.pure.lisp
+++ b/tests/type.pure.lisp
@@ -16,15 +16,13 @@
(mapc #'try '(typexpand-1 typexpand typexpand-all))))
(with-test (:name :stream-layout-bits)
- (loop for wrapper being each hash-value
+ (loop for layout 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)))
+ (let ((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)))))))
+ (find ancestor (sb-kernel:wrapper-inherits layout)))
+ (assert (logtest bit (sb-kernel:wrapper-flags layout)))))))
(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))))
diff --git a/tests/typep-golden-data.txt b/tests/typep-golden-data.txt
index 03111eb07..89cc07817 100644
--- a/tests/typep-golden-data.txt
+++ b/tests/typep-golden-data.txt
@@ -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)
diff --git a/tests/x86-64-codegen.impure.lisp b/tests/x86-64-codegen.impure.lisp
index 232235841..d5ec3aa70 100644
--- a/tests/x86-64-codegen.impure.lisp
+++ b/tests/x86-64-codegen.impure.lisp
@@ -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)
diff --git a/tools-for-build/editcore.lisp b/tools-for-build/editcore.lisp
index 7cf45a7a3..0e7b0ce8f 100644
--- a/tools-for-build/editcore.lisp
+++ b/tools-for-build/editcore.lisp
@@ -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:layout-bitmap-words layout) 1) (error "Strange funcallable-instance \
bitmap")) (unless (eql bitmap sb-kernel:+layout-all-tagged+)
--
2.31.1.295.g9ea45b61b8-goog
_______________________________________________
Sbcl-devel mailing list
Sbcl-devel@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/sbcl-devel
[prev in list] [next in list] [prev in thread] [next in thread]
Configure |
About |
News |
Add a list |
Sponsored by KoreLogic