mirror of
https://github.com/roswell/roswell.git
synced 2026-09-10 07:16:17 -04:00
260 lines
11 KiB
Common Lisp
260 lines
11 KiB
Common Lisp
#!/bin/sh
|
|
#|-*- mode:lisp -*-|#
|
|
#|Dump image for faster startup or Make Executable
|
|
exec ros -- $0 "$@"
|
|
|#
|
|
|
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(roswell:include "util")
|
|
(unless (find-package :uiop)
|
|
#-quicklisp(require :uiop)
|
|
#+quicklisp(ql:quickload :uiop :silent t))
|
|
#+quicklisp(ql:quickload '(:trivia) :silent t))
|
|
|
|
(defpackage :ros.script.dump
|
|
(:use :cl :roswell.util :trivia)
|
|
(:export :*compression* :*queue*))
|
|
(in-package :ros.script.dump)
|
|
|
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(setf trivia:*arity-check-by-test-call* nil))
|
|
|
|
(defun dump-dir ()
|
|
(merge-pathnames (format nil "impls/~A/~A/~A/dump/"
|
|
(uname-m) (uname) (opt "impl"))
|
|
(homedir)))
|
|
|
|
(defun output (func params &optional force)
|
|
(flet ((%dump (path &optional mode)
|
|
(if (and (not force)
|
|
(probe-file path))
|
|
;; idea??
|
|
;; (y-or-n-p "Output file exists. Overwrite? [Y,n]")
|
|
(if (eql mode :normal)
|
|
(format *error-output* "dump ~s already exists~%" (pathname-name path))
|
|
(format *error-output* "file ~s already exists~%" path))
|
|
(funcall func :output path))))
|
|
(ematch params
|
|
(nil
|
|
(format *error-output* "Usage: ~A [OPTIONS] dump output [-f] [-o OUTPUT] NAME~%" (opt "argv0")))
|
|
((list* "-f" rest)
|
|
(output func rest t))
|
|
((list "-o" output)
|
|
(%dump output))
|
|
((list "-o")
|
|
(format *error-output* "Missing the pathname for an image.~%"))
|
|
(_ (let ((path (merge-pathnames (format nil "~A.~A" (first params) (core-extention))
|
|
(dump-dir))))
|
|
(%dump (ensure-directories-exist path) :normal))))))
|
|
|
|
(defun executable (func params)
|
|
(ematch params
|
|
(nil
|
|
(format *error-output* "Usage: ros dump executable help~%"))
|
|
|
|
((list* script rest)
|
|
(setf script (pathname script))
|
|
(unless (probe-file script)
|
|
(warn "The script ~a does not exist, aborting." script)
|
|
(ros:quit 1))
|
|
(let* ((cmds (let ((*read-eval*))
|
|
(read-from-string
|
|
(format nil "(~A)"
|
|
(opt "restart")))))
|
|
(output (match* (rest script)
|
|
(((list* "-o" output _) _)
|
|
output)
|
|
(((list "-o") _)
|
|
(warn "Missing argument to -o OUTPUT, falling back to the default behavior")
|
|
(trivia.skip:skip))
|
|
((_ (pathname :type (equalp "ros")))
|
|
(make-pathname :type
|
|
#-win32 nil
|
|
#+win32 "exe"
|
|
:defaults script))
|
|
((_ _)
|
|
script))))
|
|
(when (string-equal ; odd people may use uppercase extension...
|
|
(pathname-type script) "ros")
|
|
;; Note: Why CMDS needs to be updated?
|
|
;; If you use -l,-r or other options, information on the
|
|
;; corresponding startup commands are stored in CMDS.
|
|
;; we just augment it with MAIN function information, because
|
|
;; we can for ros file.
|
|
;; Fixme: What is the use case when SCRIPT is not a roswell script?
|
|
(let ((*package* (find-package :cl-user))
|
|
roswell:*cmd*)
|
|
;; loading script
|
|
(roswell:script script)) ; <--- !!!WARNING!!! Side-effect on roswell:*main*
|
|
(let ((main-list (let ((*package* (find-package :keyword)))
|
|
`((:entry ,(format nil "~S" roswell:*main*))))))
|
|
(setf cmds (if (first cmds)
|
|
(append cmds main-list)
|
|
main-list))))
|
|
(unless cmds
|
|
;; Fixme: when STRING-EQUAL is not satisfied, cmds is something like
|
|
;; ((:entry "COMMON-LISP:NIL")), which eventually fails.
|
|
;; it is better to capture this.
|
|
(warn "dumping an executable without specifing the initial behaviour."))
|
|
(funcall func :executable cmds output script)))))
|
|
|
|
(defvar *subcmds*
|
|
'(output
|
|
executable))
|
|
|
|
(defvar *compression* t "
|
|
A flag enabling the core compression. Effective on
|
|
sbcl only, and only effective when sbcl is compiled with
|
|
sb-core-compression.")
|
|
|
|
(defun remove-docstrings ()
|
|
"Docstrings are unnecessary when the resulting binary is expected to be a batch program.
|
|
With this feature, applications that use docstrings may not work properly."
|
|
(do-all-symbols (s)
|
|
(dolist (doc-type '(function compiler-macro setf
|
|
method-combination type structure
|
|
variable))
|
|
(when (documentation s doc-type)
|
|
(setf (documentation s doc-type) nil)))))
|
|
|
|
(defvar *package-blacklist* `("KEYWORD" "ROSWELL" "ROS.SCRIPT.DUMP"
|
|
;; add impl-specific customization
|
|
#+(or) ,@'())
|
|
"A list of package-designators which is not deleted by delete-all-packages.
|
|
The default value contains the minimal blacklist.")
|
|
|
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(ignore-errors
|
|
(when (find-symbol "MAKE-PACKAGE-HASHTABLE" :sb-impl)
|
|
(push :roswell-dump-newer-sbcl *features*))))
|
|
|
|
(defvar *additional-blacklist-for-destroy-packages*
|
|
'("ROS")
|
|
"An additional list of package-designators that needs to be protected from destroy-packages-sbcl.
|
|
These are appended to the blacklist before destroying the package system.
|
|
Notably, it must include all nicknames.")
|
|
|
|
(defun destroy-packages-sbcl ()
|
|
(ematch roswell:*main*
|
|
((symbol :package (package :name name))
|
|
(pushnew name *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*))
|
|
(maphash (lambda (package-name package)
|
|
(unless (member package-name *package-blacklist* :test #'string=)
|
|
(format t "Deleting ~s~%" package-name)
|
|
(setf (sb-impl::package-%use-list package) nil)
|
|
(setf (sb-impl::package-%used-by-list package) nil)
|
|
(setf (sb-impl::package-%shadowing-symbols package) nil)
|
|
(setf (sb-impl::package-internal-symbols package)
|
|
(sb-impl::make-package-hashtable 0))
|
|
(setf (sb-impl::package-external-symbols package)
|
|
(sb-impl::make-package-hashtable 0))
|
|
(setf (sb-impl::package-tables package) #())
|
|
(setf (sb-impl::package-%implementation-packages package) nil)
|
|
(setf (sb-impl::package-%local-nicknames package) nil)
|
|
(setf (sb-impl::package-%locally-nicknamed-by package) nil)
|
|
(push package-name packages)
|
|
(do-symbols (symbol package-name)
|
|
(sb-impl::%set-symbol-package symbol nil)
|
|
(unintern symbol))))
|
|
sb-impl::*package-names*)
|
|
(dolist (package packages)
|
|
(remhash package sb-impl::*package-names*))))
|
|
|
|
(defvar *queue* nil "list of functions to be performed before dumping")
|
|
|
|
(defun makunbound-symbols-and-delete-package (pkg-designator)
|
|
(format t "Deleting ~a~%" pkg-designator)
|
|
(force-output *standard-output*)
|
|
(handler-case
|
|
(progn
|
|
#-ccl
|
|
(do-symbols (symbol pkg-designator)
|
|
(ignore-errors (makunbound symbol))
|
|
(ignore-errors (fmakunbound symbol))
|
|
(ignore-errors (unintern symbol pkg-designator)))
|
|
#+ccl
|
|
(do-symbols (symbol pkg-designator)
|
|
;; f/makunbound causes segv
|
|
(ignore-errors (unintern symbol pkg-designator))))
|
|
(package-error ()))
|
|
(handler-case
|
|
(delete-package pkg-designator)
|
|
(package-error ()))
|
|
;;
|
|
;; alternative: more restrictive error handling, handle the name conflict caused during deleting a package
|
|
;; cf. http://clhs.lisp.se/Body/f_del_pk.htm
|
|
#+(or)
|
|
(handler-bind ((package-error #'continue))
|
|
(delete-package pkg-designator)))
|
|
|
|
(defun delete-all-packages ()
|
|
;; push the package name of the main function (== package of the given script)
|
|
(ematch roswell:*main*
|
|
((symbol :package (package :name name))
|
|
(pushnew name *package-blacklist* :test #'string=)))
|
|
(map nil #'makunbound-symbols-and-delete-package
|
|
(set-difference (list-all-packages)
|
|
(mapcar #'find-package *package-blacklist*))))
|
|
|
|
(defun parse-options (args fn)
|
|
(match args
|
|
((list* (or "--enable-compression" "-c") rest)
|
|
(setf *compression* t)
|
|
(parse-options rest fn))
|
|
((list* "--disable-compression" rest)
|
|
(setf *compression* nil)
|
|
(parse-options rest fn))
|
|
((list* "--remove-docstrings" rest)
|
|
(push #'remove-docstrings *queue*)
|
|
(parse-options rest fn))
|
|
((list* "--delete-package" name rest)
|
|
(push (lambda () (makunbound-symbols-and-delete-package (string-upcase name))) *queue*)
|
|
(parse-options rest fn))
|
|
((list* "--delete-all-packages" rest)
|
|
(push #'delete-all-packages *queue*)
|
|
(parse-options rest fn))
|
|
((list* "--delete-packages-except" name rest)
|
|
(pushnew #'delete-all-packages *queue*)
|
|
(pushnew (string-upcase name) *package-blacklist* :test #'string=)
|
|
(parse-options rest fn))
|
|
((list* "--destroy-packages-sbcl" rest)
|
|
(push #'destroy-packages-sbcl *queue*)
|
|
(parse-options rest fn))
|
|
(_
|
|
(funcall fn args))))
|
|
|
|
(defun main (&rest r)
|
|
(let ((module (module "dump" (or
|
|
#+ccl "ccl"
|
|
#+cmucl "cmucl"
|
|
(remove #\Space (string-downcase (lisp-implementation-type)))))))
|
|
(cond
|
|
((and module r)
|
|
(parse-options
|
|
r (lambda-ematch
|
|
((list* mode args)
|
|
(let ((func (find mode (funcall module :query *subcmds*)
|
|
:test 'equal
|
|
:key 'string-downcase)))
|
|
(if func
|
|
(funcall func module args)
|
|
(format *error-output* "'~A' is not a valid command for '~A' subcommand for ~A ~%"
|
|
mode (pathname-name *load-pathname*) (lisp-implementation-type))))))))
|
|
(module
|
|
(format *error-output* "Possible subcmd~%~%~{~(~A~)~%~}" (funcall module :query *subcmds*)))
|
|
(t
|
|
(format *error-output* "'~A' is not supported for ~A ~%"
|
|
(pathname-name *load-pathname*) (lisp-implementation-type))))))
|
|
;;; vim: set ft=lisp lisp:
|