image.lisp 22 KB
Newer Older
1 2 3
;;;; -------------------------------------------------------------------------
;;;; Starting, Stopping, Dumping a Lisp image

4 5 6 7
(uiop/package:define-package :uiop/image
  (:nicknames :asdf/image)
  (:recycle :uiop/image :asdf/image :xcvb-driver)
  (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/pathname :uiop/stream :uiop/os)
8
  (:export
9
   #:*image-dumped-p* #:raw-command-line-arguments #:*command-line-arguments*
10
   #:command-line-arguments #:raw-command-line-arguments #:setup-command-line-arguments #:argv0
11
   #:*lisp-interaction*
12
   #:*fatal-conditions* #:fatal-condition-p #:handle-fatal-condition
13 14 15
   #:call-with-fatal-condition-handler #:with-fatal-condition-handler
   #:*image-restore-hook* #:*image-prelude* #:*image-entry-point*
   #:*image-postlude* #:*image-dump-hook*
16
   #:quit #:die #:raw-print-backtrace #:print-backtrace #:print-condition-backtrace
17 18 19
   #:shell-boolean-exit
   #:register-image-restore-hook #:register-image-dump-hook
   #:call-image-restore-hook #:call-image-dump-hook
20
   #:restore-image #:dump-image #:create-image
21
))
22
(in-package :uiop/image)
23

24 25 26
(with-upgradability ()
  (defvar *lisp-interaction* t
    "Is this an interactive Lisp environment, or is it batch processing?")
27

28 29
  (defvar *command-line-arguments* nil
    "Command-line arguments")
30

31 32
  (defvar *image-dumped-p* nil ; may matter as to how to get to command-line-arguments
    "Is this a dumped image? As a standalone executable?")
33

34 35
  (defvar *image-restore-hook* nil
    "Functions to call (in reverse order) when the image is restored")
36

37 38 39
  (defvar *image-restored-p* nil
    "Has the image been restored? A boolean, or :in-progress while restoring, :in-regress while dumping")

40 41
  (defvar *image-prelude* nil
    "a form to evaluate, or string containing forms to read and evaluate
42 43
when the image is restarted, but before the entry point is called.")

44 45
  (defvar *image-entry-point* nil
    "a function with which to restart the dumped image when execution is restored from it.")
46

47 48
  (defvar *image-postlude* nil
    "a form to evaluate, or string containing forms to read and evaluate
49
before the image dump hooks are called and before the image is dumped.")
50

51 52
  (defvar *image-dump-hook* nil
    "Functions to call (in order) when before an image is dumped")
53

54 55 56
  (defvar *fatal-conditions* '(error)
    "conditions that cause the Lisp image to enter the debugger if interactive,
or to die if not interactive"))
57 58 59


;;; Exiting properly or im-
60 61 62
(with-upgradability ()
  (defun quit (&optional (code 0) (finish-output t))
    "Quits from the Lisp world, with the given exit status if provided.
63
This is designed to abstract away the implementation specific quit forms."
64 65 66 67 68 69 70 71 72
    (when finish-output ;; essential, for ClozureCL, and for standard compliance.
      (finish-outputs))
    #+(or abcl xcl) (ext:quit :status code)
    #+allegro (excl:exit code :quiet t)
    #+clisp (ext:quit code)
    #+clozure (ccl:quit code)
    #+cormanlisp (win32:exitprocess code)
    #+(or cmu scl) (unix:unix-exit code)
    #+ecl (si:quit code)
73
    #+gcl (system:quit code)
74
    #+genera (error "~S: You probably don't want to Halt Genera. (code: ~S)" 'quit code)
75
    #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t)
76
    #+mcl (progn code (ccl:quit)) ;; or should we use FFI to call libc's exit(3) ?
77 78 79 80 81 82 83 84 85 86 87 88 89
    #+mkcl (mk-ext:quit :exit-code code)
    #+sbcl #.(let ((exit (find-symbol* :exit :sb-ext nil))
                   (quit (find-symbol* :quit :sb-ext nil)))
               (cond
                 (exit `(,exit :code code :abort (not finish-output)))
                 (quit `(,quit :unix-status code :recklessly-p (not finish-output)))))
    #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
    (error "~S called with exit code ~S but there's no quitting on this implementation" 'quit code))

  (defun die (code format &rest arguments)
    "Die in error with some error message"
    (with-safe-io-syntax ()
      (ignore-errors
90
       (format! *stderr* "~&~?~&" format arguments)))
91 92
    (quit code))

93
  (defun raw-print-backtrace (&key (stream *debug-io*) count condition)
94
    "Print a backtrace, directly accessing the implementation"
95 96
    (declare (ignorable stream count condition))
    #+abcl
97
    (loop :for i :from 0
98 99
          :for frame :in (sys:backtrace (or count most-positive-fixnum)) :do
            (safe-format! stream "~&~D: ~A~%" i frame))
100 101 102 103 104 105 106 107
    #+allegro
    (let ((*terminal-io* stream)
          (*standard-output* stream)
          (tpl:*zoom-print-circle* *print-circle*)
          (tpl:*zoom-print-level* *print-level*)
          (tpl:*zoom-print-length* *print-length*))
      (tpl:do-command "zoom"
        :from-read-eval-print-loop nil
108
        :count (or count t)
109 110 111 112 113
        :all t))
    #+clisp
    (system::print-backtrace :out stream :limit count)
    #+(or clozure mcl)
    (let ((*debug-io* stream))
114 115
      #+clozure (ccl:print-call-history :count count :start-frame-number 1)
      #+mcl (ccl:print-call-history :detailed-p nil)
116
      (finish-output stream))
117
    #+(or cmu scl)
118 119
    (let ((debug:*debug-print-level* *print-level*)
          (debug:*debug-print-length* *print-length*))
120
      (debug:backtrace (or count most-positive-fixnum) stream))
121
    #+(or ecl mkcl)
122
    (let* ((top (si:ihs-top))
123 124
           (repeats (if count (min top count) top))
           (backtrace (loop :for ihs :from 0 :below top
125 126
                            :collect (list (si::ihs-fun ihs)
                                           (si::ihs-env ihs)))))
127
      (loop :for i :from 0 :below repeats
128 129
            :for frame :in (nreverse backtrace) :do
              (safe-format! stream "~&~D: ~S~%" i frame)))
130 131
    #+gcl
    (let ((*debug-io* stream))
132 133
      (ignore-errors
       (with-safe-io-syntax ()
134 135 136
         (if condition
             (conditions::condition-backtrace condition)
             (system::simple-backtrace)))))
137 138 139 140 141 142 143 144 145 146
    #+lispworks
    (let ((dbg::*debugger-stack*
            (dbg::grab-stack nil :how-many (or count most-positive-fixnum)))
          (*debug-io* stream)
          (dbg:*debug-print-level* *print-level*)
          (dbg:*debug-print-length* *print-length*))
      (dbg:bug-backtrace nil))
    #+sbcl
    (sb-debug:backtrace
     #.(if (find-symbol* "*VERBOSITY*" "SB-DEBUG" nil) :stream '(or count most-positive-fixnum))
147 148
     stream)
    #+xcl
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
149
    (loop :for i :from 0 :below (or count most-positive-fixnum)
150 151
          :for frame :in (extensions:backtrace-as-list) :do
            (safe-format! stream "~&~D: ~S~%" i frame)))
152

153
  (defun print-backtrace (&rest keys &key stream count condition)
154
    "Print a backtrace"
155
    (declare (ignore stream count condition))
156 157 158 159 160 161 162 163 164 165
    (with-safe-io-syntax (:package :cl)
      (let ((*print-readably* nil)
            (*print-circle* t)
            (*print-miser-width* 75)
            (*print-length* nil)
            (*print-level* nil)
            (*print-pretty* t))
        (ignore-errors (apply 'raw-print-backtrace keys)))))

  (defun print-condition-backtrace (condition &key (stream *stderr*) count)
166
    "Print a condition after a backtrace triggered by that condition"
167 168 169
    ;; We print the condition *after* the backtrace,
    ;; for the sake of who sees the backtrace at a terminal.
    ;; It is up to the caller to print the condition *before*, with some context.
170
    (print-backtrace :stream stream :count count :condition condition)
171 172 173 174 175
    (when condition
      (safe-format! stream "~&Above backtrace due to this condition:~%~A~&"
                    condition)))

  (defun fatal-condition-p (condition)
176
    "Is the CONDITION fatal? It is if it matches any in *FATAL-CONDITIONS*"
177 178 179
    (match-any-condition-p condition *fatal-conditions*))

  (defun handle-fatal-condition (condition)
180 181
    "Handle a fatal CONDITION:
depending on whether *LISP-INTERACTION* is set, enter debugger or die"
182 183 184 185 186 187 188 189 190
    (cond
      (*lisp-interaction*
       (invoke-debugger condition))
      (t
       (safe-format! *stderr* "~&Fatal condition:~%~A~%" condition)
       (print-condition-backtrace condition :stream *stderr*)
       (die 99 "~A" condition))))

  (defun call-with-fatal-condition-handler (thunk)
191
    "Call THUNK in a context where fatal conditions are appropriately handled"
192 193 194 195
    (handler-bind (((satisfies fatal-condition-p) #'handle-fatal-condition))
      (funcall thunk)))

  (defmacro with-fatal-condition-handler ((&optional) &body body)
196
    "Execute BODY in a context where fatal conditions are appropriately handled"
197 198 199 200 201
    `(call-with-fatal-condition-handler #'(lambda () ,@body)))

  (defun shell-boolean-exit (x)
    "Quit with a return code that is 0 iff argument X is true"
    (quit (if x 0 1))))
202 203


204
;;; Using image hooks
205 206
(with-upgradability ()
  (defun register-image-restore-hook (hook &optional (call-now-p t))
207
    "Regiter a hook function to be run when restoring a dumped image"
208
    (register-hook-function '*image-restore-hook* hook call-now-p))
209

210
  (defun register-image-dump-hook (hook &optional (call-now-p nil))
211
    "Register a the hook function to be run before to dump an image"
212
    (register-hook-function '*image-dump-hook* hook call-now-p))
213

214
  (defun call-image-restore-hook ()
215
    "Call the hook functions registered to be run when restoring a dumped image"
216
    (call-functions (reverse *image-restore-hook*)))
217

218
  (defun call-image-dump-hook ()
219
    "Call the hook functions registered to be run before to dump an image"
220
    (call-functions *image-dump-hook*)))
221 222 223


;;; Proper command-line arguments
224 225 226 227 228 229
(with-upgradability ()
  (defun raw-command-line-arguments ()
    "Find what the actual command line for this process was."
    #+abcl ext:*command-line-argument-list* ; Use 1.0.0 or later!
    #+allegro (sys:command-line-arguments) ; default: :application t
    #+clisp (coerce (ext:argv) 'list)
230
    #+clozure ccl:*command-line-argument-list*
231 232 233
    #+(or cmu scl) extensions:*command-line-strings*
    #+ecl (loop :for i :from 0 :below (si:argc) :collect (si:argv i))
    #+gcl si:*command-args*
234
    #+(or genera mcl) nil
235
    #+lispworks sys:*line-arguments-list*
236
    #+mkcl (loop :for i :from 0 :below (mkcl:argc) :collect (mkcl:argv i))
237 238
    #+sbcl sb-ext:*posix-argv*
    #+xcl system:*argv*
239
    #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
240 241 242 243
    (error "raw-command-line-arguments not implemented yet"))

  (defun command-line-arguments (&optional (arguments (raw-command-line-arguments)))
    "Extract user arguments from command-line invocation of current process.
244 245
Assume the calling conventions of a generated script that uses --
if we are not called from a directly executable image."
246 247 248 249 250
    (block nil
      #+abcl (return arguments)
      ;; SBCL and Allegro already separate user arguments from implementation arguments.
      #-(or sbcl allegro)
      (unless (eq *image-dumped-p* :executable)
251 252 253 254 255 256 257 258
        ;; LispWorks command-line processing isn't transparent to the user
        ;; unless you create a standalone executable; in that case,
        ;; we rely on cl-launch or some other script to set the arguments for us.
        #+lispworks (return *command-line-arguments*)
        ;; On other implementations, on non-standalone executables,
        ;; we trust cl-launch or whichever script starts the program
        ;; to use -- as a delimiter between implementation arguments and user arguments.
        #-lispworks (setf arguments (member "--" arguments :test 'string-equal)))
259 260
      (rest arguments)))

261
  (defun argv0 ()
262 263 264
    "On supported implementations (most that matter), or when invoked by a proper wrapper script,
return a string that for the name with which the program was invoked, i.e. argv[0] in C.
Otherwise, return NIL."
265 266
    (cond
      ((eq *image-dumped-p* :executable) ; yes, this ARGV0 is our argv0 !
267
       ;; NB: not currently available on ABCL, Corman, Genera, MCL
268 269
       (or #+(or allegro clisp clozure cmu gcl lispworks sbcl scl xcl)
           (first (raw-command-line-arguments))
270
           #+ecl (si:argv 0) #+mkcl (mkcl:argv 0)))
271 272 273
      (t ;; argv[0] is the name of the interpreter.
       ;; The wrapper script can export __CL_ARGV0. cl-launch does as of 4.0.1.8.
       (getenvp "__CL_ARGV0"))))
274

275 276 277 278
  (defun setup-command-line-arguments ()
    (setf *command-line-arguments* (command-line-arguments)))

  (defun restore-image (&key
279
                          (lisp-interaction *lisp-interaction*)
280
                          (restore-hook *image-restore-hook*)
281 282
                          (prelude *image-prelude*)
                          (entry-point *image-entry-point*)
283
                          (if-already-restored '(cerror "RUN RESTORE-IMAGE ANYWAY")))
284
    "From a freshly restarted Lisp image, restore the saved Lisp environment
285 286 287 288 289 290 291 292
by setting appropriate variables, running various hooks, and calling any specified entry point.

If the image has already been restored or is already being restored, as per *IMAGE-RESTORED-P*,
call the IF-ALREADY-RESTORED error handler (by default, a continuable error), and do return
immediately to the surrounding restore process if allowed to continue.

Then, comes the restore process itself:
First, call each function in the RESTORE-HOOK,
293
in the order they were registered with REGISTER-IMAGE-RESTORE-HOOK.
294 295 296 297 298 299 300 301 302 303 304 305 306 307
Second, evaluate the prelude, which is often Lisp text that is read,
as per EVAL-INPUT.
Third, call the ENTRY-POINT function, if any is specified, with no argument.

The restore process happens in a WITH-FATAL-CONDITION-HANDLER, so that if LISP-INTERACTION is NIL,
any unhandled error leads to a backtrace and an exit with an error status.
If LISP-INTERACTION is NIL, the process also exits when no error occurs:
if neither restart nor entry function is provided, the program will exit with status 0 (success);
if a function was provided, the program will exit after the function returns (if it returns),
with status 0 if and only if the primary return value of result is generalized boolean true,
and with status 1 if this value is NIL.

If LISP-INTERACTION is true, unhandled errors will take you to the debugger, and the result
of the function will be returned rather than interpreted as a boolean designating an exit code."
308 309
    (when *image-restored-p*
      (if if-already-restored
310 311
          (call-function if-already-restored "Image already ~:[being ~;~]restored"
                         (eq *image-restored-p* t))
312
          (return-from restore-image)))
313
    (with-fatal-condition-handler ()
314 315 316
      (setf *lisp-interaction* lisp-interaction)
      (setf *image-restore-hook* restore-hook)
      (setf *image-prelude* prelude)
317
      (setf *image-restored-p* :in-progress)
318
      (call-image-restore-hook)
319
      (standard-eval-thunk prelude)
320
      (setf *image-restored-p* t)
321
      (let ((results (multiple-value-list
322 323
                      (if entry-point
                          (call-function entry-point)
324
                          t))))
325
        (if lisp-interaction
326 327
            (apply 'values results)
            (shell-boolean-exit (first results)))))))
328

329 330 331

;;; Dumping an image

332 333
(with-upgradability ()
  (defun dump-image (filename &key output-name executable
334 335
                                (postlude *image-postlude*)
                                (dump-hook *image-dump-hook*)
336
                                #+clozure prepend-symbols #+clozure (purify t)
337
                                #+sbcl compression
338
                                #+(and sbcl os-windows) application-type)
339 340 341 342 343 344 345 346 347
    "Dump an image of the current Lisp environment at pathname FILENAME, with various options.

First, finalize the image, by evaluating the POSTLUDE as per EVAL-INPUT, then calling each of
 the functions in DUMP-HOOK, in reverse order of registration by REGISTER-DUMP-HOOK.

If EXECUTABLE is true, create an standalone executable program that calls RESTORE-IMAGE on startup.

Pass various implementation-defined options, such as PREPEND-SYMBOLS and PURITY on CCL,
or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows."
348 349
    ;; Note: at least SBCL saves only global values of variables in the heap image,
    ;; so make sure things you want to dump are NOT just local bindings shadowing the global values.
350 351
    (declare (ignorable filename output-name executable))
    (setf *image-dumped-p* (if executable :executable t))
352
    (setf *image-restored-p* :in-regress)
353
    (setf *image-postlude* postlude)
354
    (standard-eval-thunk *image-postlude*)
355
    (setf *image-dump-hook* dump-hook)
356
    (call-image-dump-hook)
357
    (setf *image-restored-p* nil)
358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375
    #-(or clisp clozure cmu lispworks sbcl scl)
    (when executable
      (error "Dumping an executable is not supported on this implementation! Aborting."))
    #+allegro
    (progn
      (sys:resize-areas :global-gc t :pack-heap t :sift-old-areas t :tenure t) ; :new 5000000
      (excl:dumplisp :name filename :suppress-allegro-cl-banner t))
    #+clisp
    (apply #'ext:saveinitmem filename
           :quiet t
           :start-package *package*
           :keep-global-handlers nil
           :executable (if executable 0 t) ;--- requires clisp 2.48 or later, still catches --clisp-x
           (when executable
             (list
              ;; :parse-options nil ;--- requires a non-standard patch to clisp.
              :norc t :script nil :init-function #'restore-image)))
    #+clozure
376
    (flet ((dump (prepend-kernel)
377
             (ccl:save-application filename :prepend-kernel prepend-kernel :purify purify
378 379 380 381 382
                                            :toplevel-function (when executable #'restore-image))))
      ;;(setf ccl::*application* (make-instance 'ccl::lisp-development-system))
      (if prepend-symbols
          (with-temporary-file (:prefix "ccl-symbols-" :direction :output :pathname path)
            (require 'elf)
383
            (funcall (fdefinition 'ccl::write-elf-symbols-to-file) path)
384 385
            (dump path))
          (dump t)))
386 387 388 389 390
    #+(or cmu scl)
    (progn
      (ext:gc :full t)
      (setf ext:*batch-mode* nil)
      (setf ext::*gc-run-time* 0)
391 392 393
      (apply 'ext:save-lisp filename
             #+cmu :executable #+cmu t
             (when executable '(:init-function restore-image :process-command-line nil))))
394 395 396 397 398 399 400 401 402 403 404 405 406 407
    #+gcl
    (progn
      (si::set-hole-size 500) (si::gbc nil) (si::sgc-on t)
      (si::save-system filename))
    #+lispworks
    (if executable
        (lispworks:deliver 'restore-image filename 0 :interface nil)
        (hcl:save-image filename :environment nil))
    #+sbcl
    (progn
      ;;(sb-pcl::precompile-random-code-segments) ;--- it is ugly slow at compile-time (!) when the initial core is a big CLOS program. If you want it, do it yourself
      (setf sb-ext::*gc-run-time* 0)
      (apply 'sb-ext:save-lisp-and-die filename
             :executable t ;--- always include the runtime that goes with the core
408 409 410 411
             (append
              (when compression (list :compression compression))
              ;;--- only save runtime-options for standalone executables
              (when executable (list :toplevel #'restore-image :save-runtime-options t))
412
              #+(and sbcl os-windows) ;; passing :application-type :gui will disable the console window.
413 414
              ;; the default is :console - only works with SBCL 1.1.15 or later.
              (when application-type (list :application-type application-type)))))
415
    #-(or allegro clisp clozure cmu gcl lispworks sbcl scl)
416 417
    (error "Can't ~S ~S: UIOP doesn't support image dumping with ~A.~%"
           'dump-image filename (nth-value 1 (implementation-type))))
418

419 420
  (defun create-image (destination lisp-object-files
                       &key kind output-name prologue-code epilogue-code extra-object-files
421
                         (prelude () preludep) (postlude () postludep)
422
                         (entry-point () entry-point-p) build-args no-uiop)
423 424
    (declare (ignorable destination lisp-object-files extra-object-files kind output-name
                        prologue-code epilogue-code prelude preludep postlude postludep
425
                        entry-point entry-point-p build-args no-uiop))
426
    "On ECL, create an executable at pathname DESTINATION from the specified OBJECT-FILES and options"
427 428 429
    ;; Is it meaningful to run these in the current environment?
    ;; only if we also track the object files that constitute the "current" image,
    ;; and otherwise simulate dump-image, including quitting at the end.
430 431
    #-(or ecl mkcl) (error "~S not implemented for your implementation (yet)" 'create-image)
    #+(or ecl mkcl)
432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450
    (let ((epilogue-code
            (if no-uiop
                epilogue-code
                (let ((forms
                        (append
                         (when epilogue-code `(,epilogue-code))
                         (when postludep `((setf *image-postlude* ',postlude)))
                         (when preludep `((setf *image-prelude* ',prelude)))
                         (when entry-point-p `((setf *image-entry-point* ',entry-point)))
                         (case kind
                           ((:image)
                            (setf kind :program) ;; to ECL, it's just another program.
                            `((setf *image-dumped-p* t)
                              (si::top-level #+ecl t) (quit)))
                           ((:program)
                            `((setf *image-dumped-p* :executable)
                              (shell-boolean-exit
                               (restore-image))))))))
                  (when forms `(progn ,@forms))))))
451 452 453 454 455 456 457 458 459 460 461 462
      #+ecl (check-type kind (member :dll :lib :static-library :program :object :fasl))
      (apply #+ecl 'c::builder #+ecl kind
             #+mkcl (ecase kind
                      ((:dll) 'compiler::build-shared-library)
                      ((:lib :static-library) 'compiler::build-static-library)
                      ((:fasl) 'compiler::build-bundle)
                      ((:program) 'compiler::build-program))
             (pathname destination)
             #+ecl :lisp-files #+mkcl :lisp-object-files (append lisp-object-files #+ecl extra-object-files)
             #+ecl :init-name #+ecl (c::compute-init-name (or output-name destination) :kind kind)
             (append
              (when prologue-code `(:prologue-code ,prologue-code))
463
              (when epilogue-code `(:epilogue-code ,epilogue-code))
464 465
              #+mkcl (when extra-object-files `(:object-files ,extra-object-files))
              build-args)))))
466 467


468
;;; Some universal image restore hooks
469 470
(with-upgradability ()
  (map () 'register-image-restore-hook
471 472
       '(setup-stdin setup-stdout setup-stderr
         setup-command-line-arguments setup-temporary-directory
473
         #+abcl detect-os)))