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

Move writing of defstructs.lisp-expr into kernel package

Browse source
This commit is contained in:
Douglas Katzman 2022-01-24 18:41:30 -05:00
parent efad13edb3
commit 9a0648aa93
3 changed files with 44 additions and 44 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

43
make-host-2.lisp
View file

@ -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,

40
src/code/defstruct.lisp
View file

@ -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")

5
src/cold/compile-cold-sbcl.lisp
View file

@ -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)))))