From 8acb47c2c8865a27edf22ca3b6fde9999db40e4a Mon Sep 17 00:00:00 2001 From: Douglas Katzman Date: Sat, 20 Mar 2021 00:34:49 -0400 Subject: [PATCH] Change *forward-referenced-layouts* to wrappers No functional change if #-metaspace --- doc/internals-notes/metaspace | 17 ++++--- package-data-list.lisp-expr | 2 +- src/code/class.lisp | 83 ++++++++++++++++--------------- src/code/cross-misc.lisp | 2 + src/code/early-classoid.lisp | 4 ++ src/compiler/generic/genesis.lisp | 16 +++--- 6 files changed, 70 insertions(+), 54 deletions(-) diff --git a/doc/internals-notes/metaspace b/doc/internals-notes/metaspace index cd43c58a9..700b0786b 100644 --- a/doc/internals-notes/metaspace +++ b/doc/internals-notes/metaspace @@ -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. diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 03c5fdfb2..99d41d726 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -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" diff --git a/src/code/class.lisp b/src/code/class.lisp index fb4abdb45..067294e72 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -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) diff --git a/src/code/cross-misc.lisp b/src/code/cross-misc.lisp index 13737dcaf..b04a3ab15 100644 --- a/src/code/cross-misc.lisp +++ b/src/code/cross-misc.lisp @@ -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) diff --git a/src/code/early-classoid.lisp b/src/code/early-classoid.lisp index 67dc75bdc..17c7d2d74 100644 --- a/src/code/early-classoid.lisp +++ b/src/code/early-classoid.lisp @@ -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. diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index c6e21b2d9..b7a5fd4c9 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -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*)