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 *forward-referenced-layouts* to wrappers

Browse source 
No functional change if #-metaspace
This commit is contained in:
Douglas Katzman 2021-03-20 00:34:49 -04:00
parent d3a9421474
commit 8acb47c2c8
6 changed files with 70 additions and 54 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

17
doc/internals-notes/metaspace
View file

@ -101,10 +101,15 @@ 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:
- CLASSOID-LAYOUT
- *FORWARD-REFERENCED-LAYOUTS*
- elements of a LAYOUT-INHERITS vector
- values in the CLASSOID-SUBCLASSES hash-table
- everything in the CLOS implementation
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
[ ] potentially the FASL loader table and stack, however, see exception (*)
[ ] everything in the CLOS implementation
(*) Exception: 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.
The FASL loader could enforce this by extending its structures to hold
a vector of wrappers corresponding to layouts loaded via FOP-LAYOUT.

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

@ -1860,7 +1860,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
"INDEX-TOO-LARGE-ERROR" "*!INITIAL-ASSEMBLER-ROUTINES*"
"*!INITIAL-DEBUG-SOURCES*"
"*!INITIAL-FDEFN-OBJECTS*" "*!INITIAL-FOREIGN-SYMBOLS*"
"*!INITIAL-LAYOUTS*" "*!INITIAL-SYMBOLS*"
"*!INITIAL-SYMBOLS*"
"INTEGER-DECODE-DOUBLE-FLOAT"
#+long-float "INTEGER-DECODE-LONG-FLOAT"
"INTEGER-DECODE-SINGLE-FLOAT" "INTERNAL-ERROR"

83
src/code/class.lisp
View file

@ -31,29 +31,27 @@
;;;
;;; In each cons, the car is the symbol naming the layout, and the
;;; cdr is the layout itself.
(defvar *!initial-layouts*)
;;; 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
;;; referenced but not yet loaded. This is initialized from an alist
;;; created by genesis describing the layouts that genesis created at
;;; cold-load time.
(define-load-time-global *forward-referenced-layouts*
(define-load-time-global *forward-referenced-wrappers*
;; FIXME: why is the test EQUAL and not EQ? Aren't the keys all symbols?
(make-hash-table :test 'equal))
#-sb-xc-host
(!cold-init-forms
;; *forward-referenced-layouts* is protected by *WORLD-LOCK*
;; *forward-referenced-wrappers* is protected by *WORLD-LOCK*
;; so it does not need a :synchronized option.
#-sb-xc-host (progn
(/show0 "processing *!INITIAL-LAYOUTS*")
(setq *forward-referenced-layouts* (make-hash-table :test 'equal))
(dovector (x *!initial-layouts*)
(let ((expected (hash-layout-name (car x)))
(actual (layout-clos-hash (cdr x))))
(unless (= actual expected)
(bug "XC layout hash calculation failed")))
(setf (gethash (car x) *forward-referenced-layouts*)
(cdr x)))
(/show0 "done processing *!INITIAL-LAYOUTS*")))
(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)))))
(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'
@ -78,15 +76,17 @@
(binding* ((classoid (find-classoid name nil) :exit-if-null) ; threadsafe
(layout (classoid-layout classoid) :exit-if-null))
(return-from find-layout layout))
(let ((table *forward-referenced-layouts*))
(let ((table *forward-referenced-wrappers*))
(with-world-lock ()
(let ((classoid (find-classoid name nil)))
(or (and classoid (classoid-layout classoid))
(values (ensure-gethash name table
(make-layout
(hash-layout-name name)
(or classoid
(make-undefined-classoid name))))))))))
(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))))))))
;;; In code for the target Lisp, we don't dump LAYOUTs using the
;;; standard load form mechanism, we use special fops instead, in
@ -195,17 +195,20 @@ between the ~A definition and the ~A definition"
(let* ((layout
(or (binding* ((classoid (find-classoid name nil) :exit-if-null))
(classoid-layout classoid))
(let ((table *forward-referenced-layouts*))
(let ((table *forward-referenced-wrappers*))
(with-world-lock ()
(let ((classoid (find-classoid name nil)))
(or (and classoid (classoid-layout 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))))))))
(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)))))))))
(classoid
(or (find-classoid name nil) (layout-classoid layout))))
(if (or (eq (layout-invalid layout) :uninitialized)
@ -484,8 +487,7 @@ 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)
(let ((table *forward-referenced-layouts*))
(with-world-lock ()
(with-world-lock ()
(let ((cell (find-classoid-cell name :create t)))
(ecase (info :type :kind name)
((nil))
@ -529,7 +531,7 @@ between the ~A definition and the ~A definition"
(clear-info :type :expander name)
(clear-info :type :source-location name)))
(remhash name table)
(remhash name *forward-referenced-wrappers*)
(%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,
@ -553,7 +555,7 @@ between the ~A definition and the ~A definition"
(unless (eq (info :type :compiler-layout name)
(classoid-layout new-value))
(setf (info :type :compiler-layout name)
(classoid-layout new-value))))))
(classoid-layout new-value)))))
new-value)
(defun %clear-classoid (name cell)
@ -594,14 +596,15 @@ between the ~A definition and the ~A definition"
(defun insured-find-classoid (name predicate constructor)
(declare (type function predicate)
(type (or function symbol) constructor))
(let ((table *forward-referenced-layouts*))
(let ((table *forward-referenced-wrappers*))
(with-system-mutex ((hash-table-lock table))
(let* ((old (find-classoid name nil))
(res (if (and old (funcall predicate old))
old
(funcall constructor :name name)))
(found (or (gethash name table)
(when old (classoid-layout old)))))
(old-wrapper (or (gethash name table)
(when old (classoid-wrapper old))))
(found (when old-wrapper (wrapper-friend old-wrapper))))
(when found
(setf (layout-classoid found) res))
(values res found)))))
@ -1213,14 +1216,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 layout) *forward-referenced-layouts*)
(dohash ((name wrapper) *forward-referenced-wrappers*)
(let ((class (find-classoid name nil)))
(cond ((not class)
(setf (layout-classoid layout) (make-undefined-classoid name)))
((eq (classoid-layout class) layout)
(remhash name *forward-referenced-layouts*))
(error "How is there no classoid for ~S ?" name))
((eq (classoid-wrapper class) wrapper)
(remhash name *forward-referenced-wrappers*))
(t
(error "Something strange with forward layout for ~S:~% ~S"
name layout))))))
name wrapper))))))
(!defun-from-collected-cold-init-forms !classes-cold-init)

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

@ -241,6 +241,8 @@
(defun (setf classoid-layout) (newval x)
(declare (notinline (setf classoid-wrapper)))
(setf (classoid-wrapper x) newval))
(defun layout-friend (x) x)
(defun wrapper-friend (x) x)
(defun %instance-layout (instance)
(classoid-layout (find-classoid (type-of instance))))
(defun %instance-length (instance)

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

@ -278,6 +278,10 @@
(setf (wrapper-friend wrapper) layout)
layout))))
#+(and (not metaspace) (not sb-xc-host))
(progn (defmacro layout-friend (x) x)
(defmacro wrapper-friend (x) x))
;;; The cross-compiler representation of a LAYOUT omits several things:
;;; * BITMAP - obtainable via (DD-BITMAP (LAYOUT-INFO layout)).
;;; GC wants it in the layout to avoid double indirection.

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

@ -1061,7 +1061,7 @@ core and return a descriptor to it."
;;; Since we want to be able to dump structure constants and
;;; predicates with reference layouts, we need to create layouts at
;;; cold-load time. We use the name to intern layouts by, and dump a
;;; list of all cold layouts in *!INITIAL-LAYOUTS* so that type system
;;; list of all cold layouts in *!INITIAL-WRAPPERS* so that type system
;;; initialization can find them. The only thing that's tricky [sic --
;;; WHN 19990816] is initializing layout's layout, which must point to
;;; itself.
@ -1188,6 +1188,11 @@ 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 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.
@ -1779,11 +1784,11 @@ core and return a descriptor to it."
;;; Establish initial values for magic symbols.
;;;
(defun finish-symbols ()
(cold-set '*!initial-layouts*
(cold-set 'sb-kernel::*!initial-wrappers*
(vector-in-core
(mapcar (lambda (pair)
(cold-cons (cold-intern (car pair))
(cold-layout-descriptor (cdr pair))))
(->wrapper (cold-layout-descriptor (cdr pair)))))
(sort-cold-layouts))))
;; MAKE-LAYOUT uses ATOMIC-INCF which returns the value in the cell prior to
;; increment, so we need to add 1 to get to the next value for it because
@ -3733,10 +3738,7 @@ III. initially undefined function references (alphabetically):
(name (warm-symbol (read-slot dd :name)))
(layout (gethash name *cold-layouts*)))
(aver layout)
(let* ((des (cold-layout-descriptor layout))
(wrapper #+metaspace (read-wordindexed des 1)
#-metaspace des))
(write-slots wrapper :%info dd))))
(write-slots (->wrapper (cold-layout-descriptor layout)) :%info dd)))
(when verbose
(format t "~&; SB-Loader: (~D~@{+~D~}) structs/vars/funs/methods/other~%"
(length *known-structure-classoids*)