roswell.roswell/lisp/dump.ros

#!/bin/sh
#|-*- mode:lisp -*-|#
#|Dump image for faster startup or Make Executable
exec ros -- $0 "$@"
|#

(progn
  (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)

(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 *queue* nil "list of functions to be performed before dumping")

(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))
    (_
     (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: