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

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

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

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

30
31
  (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?")
32

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

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

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

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

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

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

53
  (deftype fatal-condition ()
54
    `(and serious-condition #+clozure (not ccl:process-reset))))
55
56

;;; Exiting properly or im-
57
58
59
(with-upgradability ()
  (defun quit (&optional (code 0) (finish-output t))
    "Quits from the Lisp world, with the given exit status if provided.
60
This is designed to abstract away the implementation specific quit forms."
61
62
63
64
    (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)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
65
    #+(or clasp ecl) (si:quit code)
66
67
68
    #+clisp (ext:quit code)
    #+clozure (ccl:quit code)
    #+cormanlisp (win32:exitprocess code)
69
    #+(or cmucl scl) (unix:unix-exit code)
70
    #+gcl (system:quit code)
71
    #+genera (error "~S: You probably don't want to Halt Genera. (code: ~S)" 'quit code)
72
    #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t)
73
    #+mcl (progn code (ccl:quit)) ;; or should we use FFI to call libc's exit(3) ?
74
75
76
77
78
79
    #+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)))))
80
    #-(or abcl allegro clasp clisp clozure cmucl ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
81
    (not-implemented-error 'quit "(called with exit code ~S)" code))
82
83
84
85
86

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

90
  (defun raw-print-backtrace (&key (stream *debug-io*) count condition)
91
    "Print a backtrace, directly accessing the implementation"
92
93
    (declare (ignorable stream count condition))
    #+abcl
94
    (loop :for i :from 0
95
96
          :for frame :in (sys:backtrace (or count most-positive-fixnum)) :do
            (safe-format! stream "~&~D: ~A~%" i frame))
97
98
99
100
101
102
103
104
    #+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
105
        :count (or count t)
106
        :all t))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
107
108
109
110
111
112
113
114
115
    #+(or clasp ecl mkcl)
    (let* ((top (si:ihs-top))
           (repeats (if count (min top count) top))
           (backtrace (loop :for ihs :from 0 :below top
                            :collect (list (si::ihs-fun ihs)
                                           (si::ihs-env ihs)))))
      (loop :for i :from 0 :below repeats
            :for frame :in (nreverse backtrace) :do
              (safe-format! stream "~&~D: ~S~%" i frame)))
116
117
118
119
    #+clisp
    (system::print-backtrace :out stream :limit count)
    #+(or clozure mcl)
    (let ((*debug-io* stream))
120
121
      #+clozure (ccl:print-call-history :count count :start-frame-number 1)
      #+mcl (ccl:print-call-history :detailed-p nil)
122
      (finish-output stream))
123
    #+(or cmucl scl)
124
125
    (let ((debug:*debug-print-level* *print-level*)
          (debug:*debug-print-length* *print-length*))
126
      (debug:backtrace (or count most-positive-fixnum) stream))
127
128
    #+gcl
    (let ((*debug-io* stream))
129
130
      (ignore-errors
       (with-safe-io-syntax ()
131
132
133
         (if condition
             (conditions::condition-backtrace condition)
             (system::simple-backtrace)))))
134
135
136
137
138
139
140
141
    #+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
142
    (sb-debug:print-backtrace :stream stream :count (or count most-positive-fixnum))
143
    #+xcl
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
144
    (loop :for i :from 0 :below (or count most-positive-fixnum)
145
146
          :for frame :in (extensions:backtrace-as-list) :do
            (safe-format! stream "~&~D: ~S~%" i frame)))
147

148
  (defun print-backtrace (&rest keys &key stream count condition)
149
    "Print a backtrace"
150
    (declare (ignore stream count condition))
151
152
153
154
155
156
157
158
159
160
    (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)
161
    "Print a condition after a backtrace triggered by that condition"
162
163
164
    ;; 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.
165
    (print-backtrace :stream stream :count count :condition condition)
166
167
168
169
170
    (when condition
      (safe-format! stream "~&Above backtrace due to this condition:~%~A~&"
                    condition)))

  (defun fatal-condition-p (condition)
171
172
    "Is the CONDITION fatal?"
    (typep condition 'fatal-condition))
173
174

  (defun handle-fatal-condition (condition)
175
176
    "Handle a fatal CONDITION:
depending on whether *LISP-INTERACTION* is set, enter debugger or die"
177
178
179
180
181
182
183
184
185
    (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)
186
    "Call THUNK in a context where fatal conditions are appropriately handled"
187
    (handler-bind ((fatal-condition #'handle-fatal-condition))
188
189
190
      (funcall thunk)))

  (defmacro with-fatal-condition-handler ((&optional) &body body)
191
    "Execute BODY in a context where fatal conditions are appropriately handled"
192
193
194
195
196
    `(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))))
197
198


199
;;; Using image hooks
200
201
(with-upgradability ()
  (defun register-image-restore-hook (hook &optional (call-now-p t))
202
    "Regiter a hook function to be run when restoring a dumped image"
203
    (register-hook-function '*image-restore-hook* hook call-now-p))
204

205
  (defun register-image-dump-hook (hook &optional (call-now-p nil))
206
    "Register a the hook function to be run before to dump an image"
207
    (register-hook-function '*image-dump-hook* hook call-now-p))
208

209
  (defun call-image-restore-hook ()
210
    "Call the hook functions registered to be run when restoring a dumped image"
211
    (call-functions (reverse *image-restore-hook*)))
212

213
  (defun call-image-dump-hook ()
214
    "Call the hook functions registered to be run before to dump an image"
215
    (call-functions *image-dump-hook*)))
216
217
218


;;; Proper command-line arguments
219
220
221
222
223
(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
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
224
    #+(or clasp ecl) (loop :for i :from 0 :below (si:argc) :collect (si:argv i))
225
    #+clisp (coerce (ext:argv) 'list)
226
    #+clozure ccl:*command-line-argument-list*
227
    #+(or cmucl scl) extensions:*command-line-strings*
228
    #+gcl si:*command-args*
229
    #+(or genera mcl) nil
230
    #+lispworks sys:*line-arguments-list*
231
    #+mkcl (loop :for i :from 0 :below (mkcl:argc) :collect (mkcl:argv i))
232
233
    #+sbcl sb-ext:*posix-argv*
    #+xcl system:*argv*
234
    #-(or abcl allegro clasp clisp clozure cmucl ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
235
    (not-implemented-error 'raw-command-line-arguments))
236
237
238

  (defun command-line-arguments (&optional (arguments (raw-command-line-arguments)))
    "Extract user arguments from command-line invocation of current process.
239
240
Assume the calling conventions of a generated script that uses --
if we are not called from a directly executable image."
241
242
243
244
245
    (block nil
      #+abcl (return arguments)
      ;; SBCL and Allegro already separate user arguments from implementation arguments.
      #-(or sbcl allegro)
      (unless (eq *image-dumped-p* :executable)
246
247
248
249
250
251
252
253
        ;; 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)))
254
255
      (rest arguments)))

256
  (defun argv0 ()
257
258
259
    "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."
260
261
    (cond
      ((eq *image-dumped-p* :executable) ; yes, this ARGV0 is our argv0 !
262
       ;; NB: not currently available on ABCL, Corman, Genera, MCL
263
       (or #+(or allegro clisp clozure cmucl gcl lispworks sbcl scl xcl)
264
           (first (raw-command-line-arguments))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
265
           #+(or clasp ecl) (si:argv 0) #+mkcl (mkcl:argv 0)))
266
267
268
      (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"))))
269

270
271
272
273
  (defun setup-command-line-arguments ()
    (setf *command-line-arguments* (command-line-arguments)))

  (defun restore-image (&key
274
                          (lisp-interaction *lisp-interaction*)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
275
                          (restore-hook *image-restore-hook*)
276
277
                          (prelude *image-prelude*)
                          (entry-point *image-entry-point*)
278
                          (if-already-restored '(cerror "RUN RESTORE-IMAGE ANYWAY")))
279
    "From a freshly restarted Lisp image, restore the saved Lisp environment
280
281
282
283
284
285
286
287
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,
288
in the order they were registered with REGISTER-IMAGE-RESTORE-HOOK.
289
290
291
292
293
294
295
296
297
298
299
300
301
302
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."
303
304
    (when *image-restored-p*
      (if if-already-restored
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
305
306
          (call-function if-already-restored "Image already ~:[being ~;~]restored"
                         (eq *image-restored-p* t))
307
          (return-from restore-image)))
308
    (with-fatal-condition-handler ()
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
309
310
311
      (setf *lisp-interaction* lisp-interaction)
      (setf *image-restore-hook* restore-hook)
      (setf *image-prelude* prelude)
312
      (setf *image-restored-p* :in-progress)
313
      (call-image-restore-hook)
314
      (standard-eval-thunk prelude)
315
      (setf *image-restored-p* t)
316
      (let ((results (multiple-value-list
317
318
                      (if entry-point
                          (call-function entry-point)
319
                          t))))
320
        (if lisp-interaction
321
            (values-list results)
322
            (shell-boolean-exit (first results)))))))
323

324
325
326

;;; Dumping an image

327
328
(with-upgradability ()
  (defun dump-image (filename &key output-name executable
329
330
                                (postlude *image-postlude*)
                                (dump-hook *image-dump-hook*)
331
                                #+clozure prepend-symbols #+clozure (purify t)
332
                                #+sbcl compression
333
                                #+(and sbcl os-windows) application-type)
334
335
336
337
338
339
340
341
342
    "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."
343
344
    ;; 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.
345
346
    (declare (ignorable filename output-name executable))
    (setf *image-dumped-p* (if executable :executable t))
347
    (setf *image-restored-p* :in-regress)
348
    (setf *image-postlude* postlude)
349
    (standard-eval-thunk *image-postlude*)
350
    (setf *image-dump-hook* dump-hook)
351
    (call-image-dump-hook)
352
    (setf *image-restored-p* nil)
353
    #-(or clisp clozure (and cmucl executable) lispworks sbcl scl)
354
    (when executable
355
      (not-implemented-error 'dump-image "dumping an executable"))
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
    #+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
371
    (flet ((dump (prepend-kernel)
372
             (ccl:save-application filename :prepend-kernel prepend-kernel :purify purify
373
374
375
376
377
                                            :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)
378
            (funcall (fdefinition 'ccl::write-elf-symbols-to-file) path)
379
380
            (dump path))
          (dump t)))
381
    #+(or cmucl scl)
382
383
384
385
    (progn
      (ext:gc :full t)
      (setf ext:*batch-mode* nil)
      (setf ext::*gc-run-time* 0)
386
      (apply 'ext:save-lisp filename
387
388
389
390
             :allow-other-keys t ;; hush SCL and old versions of CMUCL
             #+(and cmucl executable) :executable #+(and cmucl executable) t
             (when executable '(:init-function restore-image :process-command-line nil
                                :quiet t :load-init-file nil :site-init nil))))
391
392
393
394
395
396
397
398
399
400
401
402
403
404
    #+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
405
406
407
408
             (append
              (when compression (list :compression compression))
              ;;--- only save runtime-options for standalone executables
              (when executable (list :toplevel #'restore-image :save-runtime-options t))
409
              #+(and sbcl os-windows) ;; passing :application-type :gui will disable the console window.
410
411
              ;; the default is :console - only works with SBCL 1.1.15 or later.
              (when application-type (list :application-type application-type)))))
412
    #-(or allegro clisp clozure cmucl gcl lispworks sbcl scl)
413
    (not-implemented-error 'dump-image))
414

415
416
  (defun create-image (destination lisp-object-files
                       &key kind output-name prologue-code epilogue-code extra-object-files
417
                         (prelude () preludep) (postlude () postludep)
418
                         (entry-point () entry-point-p) build-args no-uiop)
419
420
    (declare (ignorable destination lisp-object-files extra-object-files kind output-name
                        prologue-code epilogue-code prelude preludep postlude postludep
421
                        entry-point entry-point-p build-args no-uiop))
422
    "On ECL, create an executable at pathname DESTINATION from the specified OBJECT-FILES and options"
423
424
425
    ;; 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.
426
    #-(or clasp ecl mkcl) (not-implemented-error 'create-image)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
427
    #+(or clasp ecl mkcl)
428
    (let ((epilogue-code
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
           (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 #+(or clasp ecl) t) (quit)))
                         ((:program)
                          `((setf *image-dumped-p* :executable)
                            (shell-boolean-exit
                             (restore-image))))))))
                 (when forms `(progn ,@forms))))))
447
448
449
      #+(or clasp ecl mkcl)
      (check-type kind (member :dll :shared-library :lib :static-library
                               :fasl :fasb :program))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
450
      (apply #+clasp 'cmp:builder #+clasp kind
451
452
453
454
455
456
             #+(or ecl mkcl)
             (ecase kind
               ((:dll :shared-library)
                #+ecl 'c::build-shared-library #+mkcl 'compiler:build-shared-library)
               ((:lib :static-library)
                #+ecl 'c::build-static-library #+mkcl 'compiler:build-static-library)
457
               ((:fasl #+ecl :fasb)
458
                #+ecl 'c::build-fasl #+mkcl 'compiler:build-fasl)
459
               #+mkcl ((:fasb) 'compiler:build-bundle)
460
461
               ((:program)
                #+ecl 'c::build-program #+mkcl 'compiler:build-program))
462
             (pathname destination)
463
464
465
             #+(or clasp ecl) :lisp-files #+mkcl :lisp-object-files
             (append lisp-object-files #+(or clasp ecl) extra-object-files)
             #+ecl :init-name
466
             #+ecl (getf build-args :init-name)
467
468
             (append
              (when prologue-code `(:prologue-code ,prologue-code))
469
              (when epilogue-code `(:epilogue-code ,epilogue-code))
470
471
              #+mkcl (when extra-object-files `(:object-files ,extra-object-files))
              build-args)))))
472
473


474
;;; Some universal image restore hooks
475
476
(with-upgradability ()
  (map () 'register-image-restore-hook
477
478
       '(setup-stdin setup-stdout setup-stderr
         setup-command-line-arguments setup-temporary-directory
479
         #+abcl detect-os)))