common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Change classoid-subclasses to hold wrappers if #+metaspace

Browse source
This commit is contained in:
Douglas Katzman 2021-03-22 13:03:12 -04:00
parent a43389e747
commit fa7546b572
12 changed files with 36 additions and 27 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
doc/internals-notes/metaspace
View file

@ -105,7 +105,7 @@ that will need to be changed to wrappers: ('x' indicates completed)
[x] CLASSOID-LAYOUT
[x] *FORWARD-REFERENCED-LAYOUTS*
[ ] elements of a LAYOUT-INHERITS vector
[ ] values in the CLASSOID-SUBCLASSES hash-table
[x] values in the CLASSOID-SUBCLASSES hash-table
[ ] the FASL loader table and stack
[ ] everything in the CLOS implementation

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

@ -70,6 +70,7 @@
:PACKAGE-LOCAL-NICKNAMES
;; Developer mode features. A release build will never have them,
;; hence it makes no difference whether they're public or not.
:METASPACE
:SB-FLUID :SB-DEVEL :SB-DEVEL-LOCK-PACKAGES)")))
(removable-features
(append non-target-features public-features)))
@ -132,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 layout)
(maphash (lambda (classoid wrapper)
(when (structure-classoid-p classoid)
(let ((dd (layout-info layout)))
(let ((dd (wrapper-%info wrapper)))
(setf (dd-constructors dd)
(delete-if (lambda (x)
(and (consp x) (uninternable-p (car x))))

14
src/code/class.lisp
View file

@ -64,6 +64,10 @@
#-sb-xc-host (when *print-layout-id* (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)))
(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
(defun layout-proper-name (layout)
@ -265,10 +269,10 @@ between the ~A definition and the ~A definition"
(when classoid-layout
(%modify-classoid classoid)
(when subclasses
(dohash ((subclass subclass-layout) subclasses :locked t)
(dohash ((subclass subclass-wrapper) subclasses :locked t)
(%modify-classoid subclass)
(when invalidate
(%invalidate-layout subclass-layout))))
(%invalidate-layout (wrapper-friend subclass-wrapper)))))
(when invalidate
(%invalidate-layout classoid-layout)
(setf (classoid-subclasses classoid) nil)))
@ -331,7 +335,7 @@ between the ~A definition and the ~A definition"
(classoid-name super))
(setf (classoid-state super) :read-only))
(setf (gethash classoid subclasses)
(or destruct-layout layout))))))
(layout-friend (or destruct-layout layout)))))))
(values)))
@ -724,8 +728,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 layout) s-sub :locked t)
(declare (ignore layout))
(dohash ((subclass wrapper) s-sub :locked t)
(declare (ignore wrapper))
(when (gethash subclass o-sub)
(res (specifier-type subclass))))
(res))

4
src/code/defstruct.lisp
View file

@ -1272,10 +1272,10 @@ unless :NAMED is also specified.")))
(let ((subclasses (classoid-subclasses classoid)))
(when subclasses
(collect ((subs))
(dohash ((classoid layout)
(dohash ((classoid wrapper)
subclasses
:locked t)
(declare (ignore layout))
(declare (ignore wrapper))
(undeclare-structure classoid nil)
(subs (classoid-proper-name classoid)))
;; Is it really necessary to warn about

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

@ -706,9 +706,9 @@
#-sb-xc-host
(defun id-to-layout (id)
(maphash (lambda (k v)
(declare (ignore k))
(when (eql (layout-id v) id) (return-from id-to-layout v)))
(maphash (lambda (classoid wrapper &aux (layout (wrapper-friend wrapper)))
(declare (ignore classoid))
(when (eql (layout-id layout) id) (return-from id-to-layout layout)))
(classoid-subclasses (find-classoid 't))))
(export 'id-to-layout)

4
src/code/macros.lisp
View file

@ -963,8 +963,8 @@ symbol-case giving up: case=((V U) (F))
(let ((classoid (pop worklist)))
(visited classoid)
(awhen (classoid-subclasses classoid)
(dohash ((classoid layout) it)
(declare (ignore layout))
(dohash ((classoid wrapper) it)
(declare (ignore wrapper))
(unless (or (member classoid (visited))
(member classoid worklist))
(setf worklist (nconc worklist (list classoid))))))))

4
src/compiler/proclaim.lisp
View file

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

4
src/pcl/defs.lisp
View file

@ -195,8 +195,8 @@
(let ((subs (classoid-subclasses class)))
(/noshow subs)
(when subs
(dohash ((sub v) subs)
(declare (ignore v))
(dohash ((sub wrapper) subs)
(declare (ignore wrapper))
(/noshow sub)
(when (member class (direct-supers sub) :test #'eq)
(res sub)))))

4
src/pcl/fixup.lisp
View file

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

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

@ -185,7 +185,7 @@
(make-hash-table :hash-function #'type-hash-value
:test 'eq
:synchronized t)))))
(setf (gethash classoid subclasses) layout)))))))
(setf (gethash classoid subclasses) (sb-kernel::layout-friend layout))))))))
subclass))
(defmethod remove-direct-subclass ((class class) (subclass class))
(with-slots (direct-subclasses) class

8
tests/condition.pure.lisp
View file

@ -423,10 +423,12 @@ is not of type
;;; Instances of LAYOUT for condition classoids created by genesis
;;; 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 layout being each hash-value of (sb-kernel:classoid-subclasses
(sb-kernel:find-classoid 'condition))
for len = (sb-kernel:layout-length layout)
(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))
minimize len into min
maximize len into max
finally (assert (= min max))))

6
tests/type.pure.lisp
View file

@ -16,10 +16,12 @@
(mapc #'try '(typexpand-1 typexpand typexpand-all))))
(with-test (:name :stream-layout-bits)
(loop for layout being each hash-value
(loop for wrapper being each hash-value
of (sb-kernel:classoid-subclasses (sb-kernel:find-classoid 't))
do (flet ((check-bit (bit ancestor-type)
(let ((ancestor (sb-kernel:find-layout ancestor-type)))
(let* ((layout #+metaspace (sb-kernel::wrapper-friend wrapper)
#-metaspace wrapper)
(ancestor (sb-kernel:find-layout ancestor-type)))
(when (or (eq layout ancestor)
(find ancestor (sb-kernel:layout-inherits layout)))
(assert (logtest bit (sb-kernel:layout-flags layout)))))))