From 9a0648aa9318c5ec0c439ceddbeeeebf1c76f4ed Mon Sep 17 00:00:00 2001
From: Douglas Katzman <dougk@google.com>
Date: Mon, 24 Jan 2022 18:41:30 -0500
Subject: [PATCH] Move writing of defstructs.lisp-expr into kernel package

---
 make-host-2.lisp                | 43 ---------------------------------
 src/code/defstruct.lisp         | 40 ++++++++++++++++++++++++++++++
 src/cold/compile-cold-sbcl.lisp |  5 +++-
 3 files changed, 44 insertions(+), 44 deletions(-)

diff --git a/make-host-2.lisp b/make-host-2.lisp
index 7a5ed0c6f..d00d5fc74 100644
--- a/make-host-2.lisp
+++ b/make-host-2.lisp
@@ -162,49 +162,6 @@ Sample output
 ;;; cold init if it wasn't.)
 (load "tests/type.after-xc.lisp")
 
-(in-package "SB-IMPL")
-
-;;; Inform genesis of all defstructs
-(with-open-file (output (sb-cold:stem-object-path "defstructs.lisp-expr"
-                                                  '(:extra-artifact) :target-compile)
-                        :direction :output :if-exists :supersede)
-  (dolist (root '(structure-object function))
-    (dolist (pair (let ((subclassoids (classoid-subclasses (find-classoid root))))
-                    (if (listp subclassoids)
-                        subclassoids
-                        (flet ((pred (x y)
-                                 (or (string< x y)
-                                     (and (string= x y)
-                                          (let ((xpn (package-name (cl:symbol-package x)))
-                                                (ypn (package-name (cl:symbol-package y))))
-                                            (string< xpn ypn))))))
-                          (sort (%hash-table-alist subclassoids)
-                                #'pred
-                                ;; pair = (#<classoid> . #<layout>)
-                                :key (lambda (pair) (classoid-name (car pair))))))))
-      (let* ((wrapper (cdr pair))
-             (dd (wrapper-info wrapper)))
-        (cond
-          (dd
-           (let* ((*print-pretty* nil) ; output should be insensitive to host pprint
-                  (*print-readably* t)
-                  (classoid-name (classoid-name (car pair)))
-                  (*package* (cl:symbol-package classoid-name)))
-             (format output "~/sb-ext:print-symbol-with-prefix/ ~S (~%"
-                     classoid-name
-                     (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)
-                       (dsd-name dsd)
-                       (dsd-accessor-name dsd)))))
-          (t
-           (error "Missing DD for ~S" pair))))))
-  (format output ";; EOF~%"))
-
 ;;; If you're experimenting with the system under a cross-compilation
 ;;; host which supports CMU-CL-style SAVE-LISP, this can be a good
 ;;; time to run it. The resulting core isn't used in the normal build,
diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index b3754c5c3..e9a26b382 100644
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -2294,4 +2294,44 @@ or they must be declared locally notinline at each call site.~@:>"
                  sb-vm:word-shift)
             sb-vm:instance-pointer-lowtag)))
 
+#+sb-xc-host
+(defun write-structure-definitions-as-text (pathname)
+  (with-open-file (output pathname :direction :output :if-exists :supersede)
+    (dolist (root '(structure-object function))
+      (dolist (pair (let ((subclassoids (classoid-subclasses (find-classoid root))))
+                      (if (listp subclassoids)
+                          subclassoids
+                          (flet ((pred (x y)
+                                   (or (string< x y)
+                                       (and (string= x y)
+                                            (let ((xpn (package-name (cl:symbol-package x)))
+                                                  (ypn (package-name (cl:symbol-package y))))
+                                              (string< xpn ypn))))))
+                            (sort (%hash-table-alist subclassoids)
+                                  #'pred
+                                  ;; pair = (#<classoid> . #<layout>)
+                                  :key (lambda (pair) (classoid-name (car pair))))))))
+        (let* ((wrapper (cdr pair))
+               (dd (wrapper-info wrapper)))
+          (cond
+            (dd
+             (let* ((*print-pretty* nil) ; output should be insensitive to host pprint
+                    (*print-readably* t)
+                    (classoid-name (classoid-name (car pair)))
+                    (*package* (cl:symbol-package classoid-name)))
+               (format output "~/sb-ext:print-symbol-with-prefix/ ~S (~%"
+                       classoid-name
+                       (list* (the (unsigned-byte 16) (wrapper-flags wrapper))
+                              (wrapper-depthoid wrapper)
+                              (map 'list #'wrapper-classoid-name
+                                   (wrapper-inherits wrapper))))
+               (dolist (dsd (dd-slots dd) (format output ")~%"))
+                 (format output "  (~d ~S ~S)~%"
+                         (dsd-bits dsd)
+                         (dsd-name dsd)
+                         (dsd-accessor-name dsd)))))
+            (t
+             (error "Missing DD for ~S" pair))))))
+    (format output ";; EOF~%")))
+
 (/show0 "code/defstruct.lisp end of file")
diff --git a/src/cold/compile-cold-sbcl.lisp b/src/cold/compile-cold-sbcl.lisp
index 5ad9a4a3d..c3f6a3f99 100644
--- a/src/cold/compile-cold-sbcl.lisp
+++ b/src/cold/compile-cold-sbcl.lisp
@@ -216,4 +216,7 @@
                 ;; compiler (i.e. making the registry a slot of the fasl-output struct)
                 (clear-specialized-array-registry)))
              (format t "~&~50t ~f~%" total-time))
-           (sb-c::dump/restore-interesting-types 'write))))))
+           (sb-c::dump/restore-interesting-types 'write)))
+     (sb-kernel::write-structure-definitions-as-text
+      (sb-cold:stem-object-path "defstructs.lisp-expr"
+                                '(:extra-artifact) :target-compile)))))