mirror of
https://github.com/roswell/roswell.git
synced 2026-09-10 07:16:17 -04:00
204 lines
8.5 KiB
Common Lisp
204 lines
8.5 KiB
Common Lisp
(roswell:include "util-dump")
|
|
(defpackage :roswell.dump.sbcl
|
|
(:use :cl :roswell.util :roswell.util.dump)
|
|
(:export :delete-compiler-information-sbcl :destroy-packages-sbcl :delete-debug-info))
|
|
(in-package :roswell.dump.sbcl)
|
|
|
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(ignore-errors
|
|
(when (find-symbol "MAKE-PACKAGE-HASHTABLE" :sb-impl)
|
|
(pushnew :roswell-dump-newer-sbcl *features*)
|
|
(when (and (find-symbol "INFO-HASHTABLE" :sb-impl)
|
|
(find-symbol "INFO-MAPHASH" :sb-int))
|
|
(pushnew :roswell-dump-sbcl-use-info-hashtable *features*)))))
|
|
|
|
(defun dump-executable (cmds out script)
|
|
(declare (ignore script))
|
|
(preprocess-before-dump)
|
|
(sb-ext:gc :full t)
|
|
(when *bundle-shared*
|
|
(setf sb-sys:*shared-objects*
|
|
(loop for d in sb-sys:*shared-objects*
|
|
for p = (sb-alien::shared-object-pathname d)
|
|
collect (if (find ".cache" (pathname-directory p) :test 'equal)
|
|
(progn
|
|
(uiop:copy-file p (merge-pathnames (file-namestring p)
|
|
(make-pathname :defaults out :type nil :name nil)))
|
|
(sb-alien::make-shared-object
|
|
:pathname (make-pathname :defaults (format nil "./~A" (file-namestring p)))
|
|
:namestring (format nil "./~A" (file-namestring p))
|
|
:handle (sb-alien::shared-object-handle d)
|
|
:dont-save (sb-alien::shared-object-dont-save d)))
|
|
d))))
|
|
(sb-ext:save-lisp-and-die
|
|
out
|
|
:purify *purify*
|
|
; we all want our programs to be small, right?
|
|
#+sb-core-compression :compression
|
|
#+sb-core-compression *compression*
|
|
:toplevel
|
|
#'(lambda ()
|
|
(setf *load-pathname* (pathname (first sb-ext:*posix-argv*)))
|
|
(setf roswell:*argv* (rest sb-ext:*posix-argv*))
|
|
(roswell:run cmds))
|
|
:executable t
|
|
:save-runtime-options t))
|
|
|
|
(defun sbcl (type &rest args)
|
|
(case type
|
|
(:query (first args))
|
|
(:executable
|
|
(apply 'dump-executable args))
|
|
(:output
|
|
(sb-ext:save-lisp-and-die (first args)))))
|
|
|
|
(defun safe-clear-info (category kind name)
|
|
(when (cond
|
|
(;; 1.3.x -
|
|
(find-symbol "META-INFO" :sb-int)
|
|
(funcall (find-symbol "META-INFO" :sb-int) category kind nil))
|
|
(;; 1.2.x - 1.3.x
|
|
(find-symbol "META-INFO" :sb-c)
|
|
(funcall (find-symbol "META-INFO" :sb-c) category kind nil))
|
|
(;; - 1.1.18
|
|
(find-symbol "TYPE-INFO-OR-LOSE" :sb-c)
|
|
(ignore-errors
|
|
(funcall (find-symbol "TYPE-INFO-OR-LOSE" :sb-c) category kind))))
|
|
(sb-int:clear-info category kind name)))
|
|
|
|
(defun delete-compiler-information-sbcl ()
|
|
"This removes the entire compiler information about the functions.
|
|
This includes macro/compiler-macro definitions, inline expansions,
|
|
IR1 (deftransform), IR2 (VOP) information in the infodb."
|
|
;; see src/compiler/globaldb.lisp
|
|
#-sbcl
|
|
(warn "delete-compiler is available only in SBCL")
|
|
#+sbcl
|
|
(declare (sb-ext:muffle-conditions style-warning))
|
|
#+sbcl
|
|
(do-all-symbols (s)
|
|
(when (fboundp s)
|
|
(setf (sb-int:info :function :inlinep s) 'notinline)
|
|
(safe-clear-info :function :inline-expansion-designator s)
|
|
;; Does this have the same effect as proclaiming notinline?
|
|
;; --- seems like so. src/compiler/proclaim.lisp
|
|
;; --- SB-C::PROCESS-INLINE-DECLARATION
|
|
(safe-clear-info :function :source-transform s)
|
|
(safe-clear-info :function :info s)
|
|
(safe-clear-info :function :ir1-convert s)
|
|
(safe-clear-info :function :predicate-truth-constraint s)
|
|
(safe-clear-info :function :macro-function s)
|
|
(safe-clear-info :function :compiler-macro-function s))
|
|
(let ((s `(setf ,s)))
|
|
(when (fboundp s)
|
|
(setf (sb-int:info :function :inlinep s) 'notinline)
|
|
(safe-clear-info :function :inline-expansion-designator s)
|
|
(safe-clear-info :function :source-transform s)
|
|
(safe-clear-info :function :info s)
|
|
(safe-clear-info :function :ir1-convert s)
|
|
(safe-clear-info :function :predicate-truth-constraint s)
|
|
(safe-clear-info :function :macro-function s)
|
|
(safe-clear-info :function :compiler-macro-function s)))))
|
|
|
|
(defun destroy-packages-sbcl ()
|
|
(when roswell:*main*
|
|
(pushnew (package-name (symbol-package roswell:*main*))
|
|
*package-blacklist* :test #'string=))
|
|
(setf *package-blacklist*
|
|
(union *package-blacklist*
|
|
*additional-blacklist-for-destroy-packages*
|
|
:test #'string=))
|
|
#+(and sbcl (not roswell-dump-newer-sbcl))
|
|
(warn "destroying packages is not supported on older versions of sbcl")
|
|
#+(not sbcl)
|
|
(warn "destroying packages is supported only on sbcl")
|
|
#+roswell-dump-newer-sbcl
|
|
(let (packages)
|
|
(setf *features* (delete :roswell-dump-newer-sbcl *features*))
|
|
(flet ((destroyer (package-name package)
|
|
(unless (member package-name *package-blacklist* :test #'string=)
|
|
(format t "~&Deleting ~s ~a " package-name package)
|
|
(dolist (package (if (atom package) (list package) package)) ; in >1.5.0, the second arg could be a list (esp. for nicknamed pkgs)
|
|
(setf (sb-impl::package-%use-list package) nil)
|
|
(format t ".")
|
|
(setf (sb-impl::package-%used-by-list package) nil)
|
|
(format t ".")
|
|
(setf (sb-impl::package-%shadowing-symbols package) nil)
|
|
(format t ".")
|
|
(setf (sb-impl::package-internal-symbols package)
|
|
(sb-impl::make-package-hashtable 0))
|
|
(format t ".")
|
|
(setf (sb-impl::package-external-symbols package)
|
|
(sb-impl::make-package-hashtable 0))
|
|
(format t ".")
|
|
(setf (sb-impl::package-tables package) #())
|
|
(format t ".")
|
|
(setf (sb-impl::package-%implementation-packages package) nil)
|
|
(format t ".")
|
|
(setf (sb-impl::package-%local-nicknames package) nil)
|
|
(format t "."))
|
|
;;(setf (sb-impl::package-%locally-nicknamed-by package) nil)
|
|
(push package-name packages)
|
|
(format t ".")
|
|
(do-symbols (symbol package-name)
|
|
(sb-impl::%set-symbol-package symbol nil)
|
|
(format t ".")
|
|
(unintern symbol)
|
|
(format t ".")))))
|
|
(etypecase sb-impl::*package-names*
|
|
(hash-table
|
|
(maphash #'destroyer sb-impl::*package-names*)
|
|
(dolist (package packages)
|
|
(remhash package sb-impl::*package-names*)))
|
|
|
|
#+roswell-dump-sbcl-use-info-hashtable
|
|
(sb-impl::info-hashtable
|
|
;; sb-int:info-maphash is a macro ... weird
|
|
(sb-int:info-maphash #'destroyer sb-impl::*package-names*)
|
|
;; info-hashtable does not have remhash
|
|
)))))
|
|
|
|
;; TODO: why not just use delete-package? document it
|
|
|
|
(defun delete-fun-debug-info (fun)
|
|
;; cf. src/code/describe.lisp
|
|
;; function-lambda-expression
|
|
(etypecase fun
|
|
#+sb-eval
|
|
(sb-eval::interpreted-function
|
|
)
|
|
#+sb-fasteval
|
|
(sb-interpreter:interpreted-function
|
|
;; src/interpreter/function.lisp
|
|
;; fun-lambda-expression
|
|
)
|
|
(function
|
|
(let* ((fun (sb-impl::%fun-fun fun)) ; obtain the true function from a funcallable-instance
|
|
(code (sb-di::fun-code-header fun)))
|
|
(setf (sb-kernel:%code-debug-info code) nil)))))
|
|
|
|
(defun delete-debug-info ()
|
|
#-sbcl
|
|
(warn "delete-debug-info is available only in SBCL")
|
|
#+sbcl
|
|
(declare (sb-ext:muffle-conditions style-warning))
|
|
#+sbcl
|
|
(do-all-symbols (s)
|
|
(when (fboundp s)
|
|
(delete-fun-debug-info (symbol-function s)))
|
|
(safe-clear-info :source-location :declaration s)
|
|
(safe-clear-info :type :source-location s)
|
|
(safe-clear-info :source-location :variable s)
|
|
(safe-clear-info :source-location :constant s)
|
|
(safe-clear-info :source-location :typed-structure s)
|
|
(safe-clear-info :source-location :symbol-macro s)
|
|
(safe-clear-info :source-location :vop s)
|
|
(safe-clear-info :source-location :declaration s)
|
|
(safe-clear-info :source-location :alien-type s)
|
|
(safe-clear-info :function :deprecated s)
|
|
(safe-clear-info :variable :deprecated s)
|
|
(safe-clear-info :type :deprecated s)
|
|
(safe-clear-info :function :deprecated s)
|
|
(safe-clear-info :function :deprecated s)
|
|
(safe-clear-info :function :deprecated s)))
|