image.lisp 16.6 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
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
75
    #+genera (error "You probably don't want to Halt the Machine. (code: ~S)" code)
    #+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
93
94
95
96
    (quit code))

  (defun raw-print-backtrace (&key (stream *debug-io*) count)
    "Print a backtrace, directly accessing the implementation"
    (declare (ignorable stream count))
    #+abcl
97
98
    (dolist (frame (sys:backtrace))
      (println frame stream))
99
100
101
102
103
104
105
106
107
108
109
110
111
112
    #+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
        :count t
        :all t))
    #+clisp
    (system::print-backtrace :out stream :limit count)
    #+(or clozure mcl)
    (let ((*debug-io* stream))
113
114
      #+clozure (ccl:print-call-history :count count :start-frame-number 1)
      #+mcl (ccl:print-call-history :detailed-p nil)
115
      (finish-output stream))
116
    #+(or cmu scl)
117
118
119
120
    (let ((debug:*debug-print-level* *print-level*)
          (debug:*debug-print-length* *print-length*))
      (debug:backtrace most-positive-fixnum stream))
    #+ecl
121
122
123
124
    (let* ((backtrace (loop :for ihs :from 0 :below (si:ihs-top)
                            :collect (list (si::ihs-fun ihs)
                                           (si::ihs-env ihs)))))
      (dolist (frame (nreverse backtrace)) (writeln frame :stream stream)))
125
126
127
    #+gcl
    (let ((*debug-io* stream))
      (system::simple-backtrace))
128
129
130
131
132
133
134
135
136
137
138
139
140
    #+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))
     stream))

  (defun print-backtrace (&rest keys &key stream count)
141
    "Print a backtrace"
142
143
144
145
146
147
148
149
150
151
152
    (declare (ignore stream count))
    (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)
153
    "Print a condition after a backtrace triggered by that condition"
154
155
156
157
158
159
160
161
162
    ;; 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.
    (print-backtrace :stream stream :count count)
    (when condition
      (safe-format! stream "~&Above backtrace due to this condition:~%~A~&"
                    condition)))

  (defun fatal-condition-p (condition)
163
    "Is the CONDITION fatal? It is if it matches any in *FATAL-CONDITIONS*"
164
165
166
    (match-any-condition-p condition *fatal-conditions*))

  (defun handle-fatal-condition (condition)
167
168
    "Handle a fatal CONDITION:
depending on whether *LISP-INTERACTION* is set, enter debugger or die"
169
170
171
172
173
174
175
176
177
    (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)
178
    "Call THUNK in a context where fatal conditions are appropriately handled"
179
180
181
182
    (handler-bind (((satisfies fatal-condition-p) #'handle-fatal-condition))
      (funcall thunk)))

  (defmacro with-fatal-condition-handler ((&optional) &body body)
183
    "Execute BODY in a context where fatal conditions are appropriately handled"
184
185
186
187
188
    `(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))))
189
190


191
;;; Using image hooks
192
193
(with-upgradability ()
  (defun register-image-restore-hook (hook &optional (call-now-p t))
194
    "Regiter a hook function to be run when restoring a dumped image"
195
    (register-hook-function '*image-restore-hook* hook call-now-p))
196

197
  (defun register-image-dump-hook (hook &optional (call-now-p nil))
198
    "Register a the hook function to be run before to dump an image"
199
    (register-hook-function '*image-dump-hook* hook call-now-p))
200

201
  (defun call-image-restore-hook ()
202
    "Call the hook functions registered to be run when restoring a dumped image"
203
    (call-functions (reverse *image-restore-hook*)))
204

205
  (defun call-image-dump-hook ()
206
    "Call the hook functions registered to be run before to dump an image"
207
    (call-functions *image-dump-hook*)))
208
209
210


;;; Proper command-line arguments
211
212
213
214
215
216
217
218
219
220
(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)
    #+clozure (ccl::command-line-arguments)
    #+(or cmu scl) extensions:*command-line-strings*
    #+ecl (loop :for i :from 0 :below (si:argc) :collect (si:argv i))
    #+gcl si:*command-args*
221
    #+(or genera mcl) nil
222
223
224
    #+lispworks sys:*line-arguments-list*
    #+sbcl sb-ext:*posix-argv*
    #+xcl system:*argv*
225
    #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl sbcl scl xcl)
226
227
228
229
    (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.
230
231
Assume the calling conventions of a generated script that uses --
if we are not called from a directly executable image."
232
233
234
235
236
237
238
239
240
241
242
243
244
    #+abcl arguments
    #-abcl
    (let* (#-(or sbcl allegro)
           (arguments
             (if (eq *image-dumped-p* :executable)
                 arguments
                 (member "--" arguments :test 'string-equal))))
      (rest arguments)))

  (defun setup-command-line-arguments ()
    (setf *command-line-arguments* (command-line-arguments)))

  (defun restore-image (&key
245
                          (lisp-interaction *lisp-interaction*)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
246
                          (restore-hook *image-restore-hook*)
247
248
                          (prelude *image-prelude*)
                          (entry-point *image-entry-point*)
249
                          (if-already-restored '(cerror "RUN RESTORE-IMAGE ANYWAY")))
250
251
    "From a freshly restarted Lisp image, restore the saved Lisp environment
by setting appropriate variables, running various hooks, and calling any specified entry point."
252
253
    (when *image-restored-p*
      (if if-already-restored
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
254
255
          (call-function if-already-restored "Image already ~:[being ~;~]restored"
                         (eq *image-restored-p* t))
256
          (return-from restore-image)))
257
    (with-fatal-condition-handler ()
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
258
259
260
      (setf *lisp-interaction* lisp-interaction)
      (setf *image-restore-hook* restore-hook)
      (setf *image-prelude* prelude)
261
      (setf *image-restored-p* :in-progress)
262
      (call-image-restore-hook)
263
      (standard-eval-thunk prelude)
264
      (setf *image-restored-p* t)
265
      (let ((results (multiple-value-list
266
267
                      (if entry-point
                          (call-function entry-point)
268
                          t))))
269
        (if lisp-interaction
270
271
            (apply 'values results)
            (shell-boolean-exit (first results)))))))
272

273
274
275

;;; Dumping an image

276
277
(with-upgradability ()
  (defun dump-image (filename &key output-name executable
278
279
                                (postlude *image-postlude*)
                                (dump-hook *image-dump-hook*)
280
                                #+clozure prepend-symbols #+clozure (purify t))
281
    "Dump an image of the current Lisp environment at pathname FILENAME, with various options"
282
283
    ;; 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.
284
285
    (declare (ignorable filename output-name executable))
    (setf *image-dumped-p* (if executable :executable t))
286
    (setf *image-restored-p* :in-regress)
287
    (setf *image-postlude* postlude)
288
    (standard-eval-thunk *image-postlude*)
289
    (setf *image-dump-hook* dump-hook)
290
    (call-image-dump-hook)
291
    (setf *image-restored-p* nil)
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
    #-(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
310
    (flet ((dump (prepend-kernel)
311
             (ccl:save-application filename :prepend-kernel prepend-kernel :purify purify
312
313
314
315
316
                                            :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)
317
            (funcall (fdefinition 'ccl::write-elf-symbols-to-file) path)
318
319
            (dump path))
          (dump t)))
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
    #+(or cmu scl)
    (progn
      (ext:gc :full t)
      (setf ext:*batch-mode* nil)
      (setf ext::*gc-run-time* 0)
      (apply 'ext:save-lisp filename #+cmu :executable #+cmu t
                                     (when executable '(:init-function restore-image :process-command-line nil))))
    #+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
             (when executable (list :toplevel #'restore-image :save-runtime-options t)))) ;--- only save runtime-options for standalone executables
    #-(or allegro clisp clozure cmu gcl lispworks sbcl scl)
343
344
    (error "Can't ~S ~S: UIOP doesn't support image dumping with ~A.~%"
           'dump-image filename (nth-value 1 (implementation-type))))
345
346

  (defun create-image (destination object-files
347
                       &key kind output-name prologue-code epilogue-code
348
349
                         (prelude () preludep) (postlude () postludep)
                         (entry-point () entry-point-p) build-args)
350
    (declare (ignorable destination object-files kind output-name prologue-code epilogue-code
351
                        prelude preludep postlude postludep entry-point entry-point-p build-args))
352
    "On ECL, create an executable at pathname DESTINATION from the specified OBJECT-FILES and options"
353
354
355
    ;; 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.
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
    #-ecl (error "~S not implemented for your implementation (yet)" 'create-image)
    #+ecl
    (progn
      (check-type kind (member :binary :dll :lib :static-library :program :object :fasl :program))
      (apply 'c::builder
             kind (pathname destination)
             :lisp-files object-files
             :init-name (c::compute-init-name (or output-name destination) :kind kind)
             :prologue-code prologue-code
             :epilogue-code
             `(progn
                ,epilogue-code
                ,@(when (eq kind :program)
                    `((setf *image-dumped-p* :executable)
                      (restore-image ;; default behavior would be (si::top-level)
                       ,@(when preludep `(:prelude ',prelude))
                       ,@(when entry-point-p `(:entry-point ',entry-point))))))
             build-args))))
374
375


376
;;; Some universal image restore hooks
377
378
(with-upgradability ()
  (map () 'register-image-restore-hook
379
380
       '(setup-stdin setup-stdout setup-stderr
         setup-command-line-arguments setup-temporary-directory
381
         #+abcl detect-os)))