image.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) LICENSE
---
image.lisp (22839B)
---
1 ;;;; -------------------------------------------------------------------------
2 ;;;; Starting, Stopping, Dumping a Lisp image
3
4 (uiop/package:define-package :uiop/image
5 (: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 #:fatal-condition #:fatal-condition-p
11 #:handle-fatal-condition
12 #:call-with-fatal-condition-handler #:with-fatal-condition-handler
13 #:*image-restore-hook* #:*image-prelude* #:*image-entry-point*
14 #:*image-postlude* #:*image-dump-hook*
15 #:quit #:die #:raw-print-backtrace #:print-backtrace #:print-condition-backtrace
16 #:shell-boolean-exit
17 #:register-image-restore-hook #:register-image-dump-hook
18 #:call-image-restore-hook #:call-image-dump-hook
19 #:restore-image #:dump-image #:create-image
20 ))
21 (in-package :uiop/image)
22
23 (with-upgradability ()
24 (defvar *lisp-interaction* t
25 "Is this an interactive Lisp environment, or is it batch processing?")
26
27 (defvar *command-line-arguments* nil
28 "Command-line arguments")
29
30 (defvar *image-dumped-p* nil ; may matter as to how to get to command-line-arguments
31 "Is this a dumped image? As a standalone executable?")
32
33 (defvar *image-restore-hook* nil
34 "Functions to call (in reverse order) when the image is restored")
35
36 (defvar *image-restored-p* nil
37 "Has the image been restored? A boolean, or :in-progress while restoring, :in-regress while dumping")
38
39 (defvar *image-prelude* nil
40 "a form to evaluate, or string containing forms to read and evaluate
41 when the image is restarted, but before the entry point is called.")
42
43 (defvar *image-entry-point* nil
44 "a function with which to restart the dumped image when execution is restored from it.")
45
46 (defvar *image-postlude* nil
47 "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 (defvar *image-dump-hook* nil
51 "Functions to call (in order) when before an image is dumped"))
52
53 (eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
54 (deftype fatal-condition ()
55 `(and serious-condition #+clozure (not ccl:process-reset))))
56
57 ;;; Exiting properly or im-
58 (with-upgradability ()
59 (defun quit (&optional (code 0) (finish-output t))
60 "Quits from the Lisp world, with the given exit status if provided.
61 This is designed to abstract away the implementation specific quit forms."
62 (when finish-output ;; essential, for ClozureCL, and for standard compliance.
63 (finish-outputs))
64 #+(or abcl xcl) (ext:quit :status code)
65 #+allegro (excl:exit code :quiet t)
66 #+(or clasp ecl) (si:quit code)
67 #+clisp (ext:quit code)
68 #+clozure (ccl:quit code)
69 #+cormanlisp (win32:exitprocess code)
70 #+(or cmucl scl) (unix:unix-exit code)
71 #+gcl (system:quit code)
72 #+genera (error "~S: You probably don't want to Halt Genera. (code: ~S)" 'quit code)
73 #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t)
74 #+mcl (progn code (ccl:quit)) ;; or should we use FFI to call libc's exit(3) ?
75 #+mkcl (mk-ext:quit :exit-code code)
76 #+sbcl #.(let ((exit (find-symbol* :exit :sb-ext nil))
77 (quit (find-symbol* :quit :sb-ext nil)))
78 (cond
79 (exit `(,exit :code code :abort (not finish-output)))
80 (quit `(,quit :unix-status code :recklessly-p (not finish-output)))))
81 #-(or abcl allegro clasp clisp clozure cmucl ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
82 (not-implemented-error 'quit "(called with exit code ~S)" code))
83
84 (defun die (code format &rest arguments)
85 "Die in error with some error message"
86 (with-safe-io-syntax ()
87 (ignore-errors
88 (format! *stderr* "~&~?~&" format arguments)))
89 (quit code))
90
91 (defun raw-print-backtrace (&key (stream *debug-io*) count condition)
92 "Print a backtrace, directly accessing the implementation"
93 (declare (ignorable stream count condition))
94 #+abcl
95 (loop :for i :from 0
96 :for frame :in (sys:backtrace (or count most-positive-fixnum)) :do
97 (safe-format! stream "~&~D: ~A~%" i frame))
98 #+allegro
99 (let ((*terminal-io* stream)
100 (*standard-output* stream)
101 (tpl:*zoom-print-circle* *print-circle*)
102 (tpl:*zoom-print-level* *print-level*)
103 (tpl:*zoom-print-length* *print-length*))
104 (tpl:do-command "zoom"
105 :from-read-eval-print-loop nil
106 :count (or count t)
107 :all t))
108 #+(or clasp ecl mkcl)
109 (let* ((top (si:ihs-top))
110 (repeats (if count (min top count) top))
111 (backtrace (loop :for ihs :from 0 :below top
112 :collect (list (si::ihs-fun ihs)
113 (si::ihs-env ihs)))))
114 (loop :for i :from 0 :below repeats
115 :for frame :in (nreverse backtrace) :do
116 (safe-format! stream "~&~D: ~S~%" i frame)))
117 #+clisp
118 (system::print-backtrace :out stream :limit count)
119 #+(or clozure mcl)
120 (let ((*debug-io* stream))
121 #+clozure (ccl:print-call-history :count count :start-frame-number 1)
122 #+mcl (ccl:print-call-history :detailed-p nil)
123 (finish-output stream))
124 #+(or cmucl scl)
125 (let ((debug:*debug-print-level* *print-level*)
126 (debug:*debug-print-length* *print-length*))
127 (debug:backtrace (or count most-positive-fixnum) stream))
128 #+gcl
129 (let ((*debug-io* stream))
130 (ignore-errors
131 (with-safe-io-syntax ()
132 (if condition
133 (conditions::condition-backtrace condition)
134 (system::simple-backtrace)))))
135 #+lispworks
136 (let ((dbg::*debugger-stack*
137 (dbg::grab-stack nil :how-many (or count most-positive-fixnum)))
138 (*debug-io* stream)
139 (dbg:*debug-print-level* *print-level*)
140 (dbg:*debug-print-length* *print-length*))
141 (dbg:bug-backtrace nil))
142 #+mezzano
143 (let ((*standard-output* stream))
144 (sys.int::backtrace count))
145 #+sbcl
146 (sb-debug:print-backtrace :stream stream :count (or count most-positive-fixnum))
147 #+xcl
148 (loop :for i :from 0 :below (or count most-positive-fixnum)
149 :for frame :in (extensions:backtrace-as-list) :do
150 (safe-format! stream "~&~D: ~S~%" i frame)))
151
152 (defun print-backtrace (&rest keys &key stream count condition)
153 "Print a backtrace"
154 (declare (ignore stream count condition))
155 (with-safe-io-syntax (:package :cl)
156 (let ((*print-readably* nil)
157 (*print-circle* t)
158 (*print-miser-width* 75)
159 (*print-length* nil)
160 (*print-level* nil)
161 (*print-pretty* t))
162 (ignore-errors (apply 'raw-print-backtrace keys)))))
163
164 (defun print-condition-backtrace (condition &key (stream *stderr*) count)
165 "Print a condition after a backtrace triggered by that condition"
166 ;; We print the condition *after* the backtrace,
167 ;; for the sake of who sees the backtrace at a terminal.
168 ;; It is up to the caller to print the condition *before*, with some context.
169 (print-backtrace :stream stream :count count :condition condition)
170 (when condition
171 (safe-format! stream "~&Above backtrace due to this condition:~%~A~&"
172 condition)))
173
174 (defun fatal-condition-p (condition)
175 "Is the CONDITION fatal?"
176 (typep condition 'fatal-condition))
177
178 (defun handle-fatal-condition (condition)
179 "Handle a fatal CONDITION:
180 depending on whether *LISP-INTERACTION* is set, enter debugger or die"
181 (cond
182 (*lisp-interaction*
183 (invoke-debugger condition))
184 (t
185 (safe-format! *stderr* "~&Fatal condition:~%~A~%" condition)
186 (print-condition-backtrace condition :stream *stderr*)
187 (die 99 "~A" condition))))
188
189 (defun call-with-fatal-condition-handler (thunk)
190 "Call THUNK in a context where fatal conditions are appropriately handled"
191 (handler-bind ((fatal-condition #'handle-fatal-condition))
192 (funcall thunk)))
193
194 (defmacro with-fatal-condition-handler ((&optional) &body body)
195 "Execute BODY in a context where fatal conditions are appropriately handled"
196 `(call-with-fatal-condition-handler #'(lambda () ,@body)))
197
198 (defun shell-boolean-exit (x)
199 "Quit with a return code that is 0 iff argument X is true"
200 (quit (if x 0 1))))
201
202
203 ;;; Using image hooks
204 (with-upgradability ()
205 (defun register-image-restore-hook (hook &optional (call-now-p t))
206 "Regiter a hook function to be run when restoring a dumped image"
207 (register-hook-function '*image-restore-hook* hook call-now-p))
208
209 (defun register-image-dump-hook (hook &optional (call-now-p nil))
210 "Register a the hook function to be run before to dump an image"
211 (register-hook-function '*image-dump-hook* hook call-now-p))
212
213 (defun call-image-restore-hook ()
214 "Call the hook functions registered to be run when restoring a dumped image"
215 (call-functions (reverse *image-restore-hook*)))
216
217 (defun call-image-dump-hook ()
218 "Call the hook functions registered to be run before to dump an image"
219 (call-functions *image-dump-hook*)))
220
221
222 ;;; Proper command-line arguments
223 (with-upgradability ()
224 (defun raw-command-line-arguments ()
225 "Find what the actual command line for this process was."
226 #+abcl ext:*command-line-argument-list* ; Use 1.0.0 or later!
227 #+allegro (sys:command-line-arguments) ; default: :application t
228 #+(or clasp ecl) (loop :for i :from 0 :below (si:argc) :collect (si:argv i))
229 #+clisp (coerce (ext:argv) 'list)
230 #+clozure ccl:*command-line-argument-list*
231 #+(or cmucl scl) extensions:*command-line-strings*
232 #+gcl si:*command-args*
233 #+(or genera mcl mezzano) nil
234 #+lispworks sys:*line-arguments-list*
235 #+mkcl (loop :for i :from 0 :below (mkcl:argc) :collect (mkcl:argv i))
236 #+sbcl sb-ext:*posix-argv*
237 #+xcl system:*argv*
238 #-(or abcl allegro clasp clisp clozure cmucl ecl gcl genera lispworks mcl mezzano mkcl sbcl scl xcl)
239 (not-implemented-error 'raw-command-line-arguments))
240
241 (defun command-line-arguments (&optional (arguments (raw-command-line-arguments)))
242 "Extract user arguments from command-line invocation of current process.
243 Assume the calling conventions of a generated script that uses --
244 if we are not called from a directly executable image."
245 (block nil
246 #+abcl (return arguments)
247 ;; SBCL and Allegro already separate user arguments from implementation arguments.
248 #-(or sbcl allegro)
249 (unless (eq *image-dumped-p* :executable)
250 ;; LispWorks command-line processing isn't transparent to the user
251 ;; unless you create a standalone executable; in that case,
252 ;; we rely on cl-launch or some other script to set the arguments for us.
253 #+lispworks (return *command-line-arguments*)
254 ;; On other implementations, on non-standalone executables,
255 ;; we trust cl-launch or whichever script starts the program
256 ;; to use -- as a delimiter between implementation arguments and user arguments.
257 #-lispworks (setf arguments (member "--" arguments :test 'string-equal)))
258 (rest arguments)))
259
260 (defun argv0 ()
261 "On supported implementations (most that matter), or when invoked by a proper wrapper script,
262 return a string that for the name with which the program was invoked, i.e. argv[0] in C.
263 Otherwise, return NIL."
264 (cond
265 ((eq *image-dumped-p* :executable) ; yes, this ARGV0 is our argv0 !
266 ;; NB: not currently available on ABCL, Corman, Genera, MCL
267 (or #+(or allegro clisp clozure cmucl gcl lispworks sbcl scl xcl)
268 (first (raw-command-line-arguments))
269 #+(or clasp ecl) (si:argv 0) #+mkcl (mkcl:argv 0)))
270 (t ;; argv[0] is the name of the interpreter.
271 ;; The wrapper script can export __CL_ARGV0. cl-launch does as of 4.0.1.8.
272 (getenvp "__CL_ARGV0"))))
273
274 (defun setup-command-line-arguments ()
275 (setf *command-line-arguments* (command-line-arguments)))
276
277 (defun restore-image (&key
278 (lisp-interaction *lisp-interaction*)
279 (restore-hook *image-restore-hook*)
280 (prelude *image-prelude*)
281 (entry-point *image-entry-point*)
282 (if-already-restored '(cerror "RUN RESTORE-IMAGE ANYWAY")))
283 "From a freshly restarted Lisp image, restore the saved Lisp environment
284 by setting appropriate variables, running various hooks, and calling any specified entry point.
285
286 If the image has already been restored or is already being restored, as per *IMAGE-RESTORED-P*,
287 call the IF-ALREADY-RESTORED error handler (by default, a continuable error), and do return
288 immediately to the surrounding restore process if allowed to continue.
289
290 Then, comes the restore process itself:
291 First, call each function in the RESTORE-HOOK,
292 in the order they were registered with REGISTER-IMAGE-RESTORE-HOOK.
293 Second, evaluate the prelude, which is often Lisp text that is read,
294 as per EVAL-INPUT.
295 Third, call the ENTRY-POINT function, if any is specified, with no argument.
296
297 The restore process happens in a WITH-FATAL-CONDITION-HANDLER, so that if LISP-INTERACTION is NIL,
298 any unhandled error leads to a backtrace and an exit with an error status.
299 If LISP-INTERACTION is NIL, the process also exits when no error occurs:
300 if neither restart nor entry function is provided, the program will exit with status 0 (success);
301 if a function was provided, the program will exit after the function returns (if it returns),
302 with status 0 if and only if the primary return value of result is generalized boolean true,
303 and with status 1 if this value is NIL.
304
305 If LISP-INTERACTION is true, unhandled errors will take you to the debugger, and the result
306 of the function will be returned rather than interpreted as a boolean designating an exit code."
307 (when *image-restored-p*
308 (if if-already-restored
309 (call-function if-already-restored "Image already ~:[being ~;~]restored"
310 (eq *image-restored-p* t))
311 (return-from restore-image)))
312 (with-fatal-condition-handler ()
313 (setf *lisp-interaction* lisp-interaction)
314 (setf *image-restore-hook* restore-hook)
315 (setf *image-prelude* prelude)
316 (setf *image-restored-p* :in-progress)
317 (call-image-restore-hook)
318 (standard-eval-thunk prelude)
319 (setf *image-restored-p* t)
320 (let ((results (multiple-value-list
321 (if entry-point
322 (call-function entry-point)
323 t))))
324 (if lisp-interaction
325 (values-list results)
326 (shell-boolean-exit (first results)))))))
327
328
329 ;;; Dumping an image
330
331 (with-upgradability ()
332 (defun dump-image (filename &key output-name executable
333 (postlude *image-postlude*)
334 (dump-hook *image-dump-hook*)
335 #+clozure prepend-symbols #+clozure (purify t)
336 #+sbcl compression
337 #+(and sbcl os-windows) application-type)
338 "Dump an image of the current Lisp environment at pathname FILENAME, with various options.
339
340 First, finalize the image, by evaluating the POSTLUDE as per EVAL-INPUT, then calling each of
341 the functions in DUMP-HOOK, in reverse order of registration by REGISTER-DUMP-HOOK.
342
343 If EXECUTABLE is true, create an standalone executable program that calls RESTORE-IMAGE on startup.
344
345 Pass various implementation-defined options, such as PREPEND-SYMBOLS and PURITY on CCL,
346 or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows."
347 ;; Note: at least SBCL saves only global values of variables in the heap image,
348 ;; so make sure things you want to dump are NOT just local bindings shadowing the global values.
349 (declare (ignorable filename output-name executable))
350 (setf *image-dumped-p* (if executable :executable t))
351 (setf *image-restored-p* :in-regress)
352 (setf *image-postlude* postlude)
353 (standard-eval-thunk *image-postlude*)
354 (setf *image-dump-hook* dump-hook)
355 (call-image-dump-hook)
356 (setf *image-restored-p* nil)
357 #-(or clisp clozure (and cmucl executable) lispworks sbcl scl)
358 (when executable
359 (not-implemented-error 'dump-image "dumping an executable"))
360 #+allegro
361 (progn
362 (sys:resize-areas :global-gc t :pack-heap t :sift-old-areas t :tenure t) ; :new 5000000
363 (excl:dumplisp :name filename :suppress-allegro-cl-banner t))
364 #+clisp
365 (apply #'ext:saveinitmem filename
366 :quiet t
367 :start-package *package*
368 :keep-global-handlers nil
369 :executable (if executable 0 t) ;--- requires clisp 2.48 or later, still catches --clisp-x
370 (when executable
371 (list
372 ;; :parse-options nil ;--- requires a non-standard patch to clisp.
373 :norc t :script nil :init-function #'restore-image)))
374 #+clozure
375 (flet ((dump (prepend-kernel)
376 (ccl:save-application filename :prepend-kernel prepend-kernel :purify purify
377 :toplevel-function (when executable #'restore-image))))
378 ;;(setf ccl::*application* (make-instance 'ccl::lisp-development-system))
379 (if prepend-symbols
380 (with-temporary-file (:prefix "ccl-symbols-" :direction :output :pathname path)
381 (require 'elf)
382 (funcall (fdefinition 'ccl::write-elf-symbols-to-file) path)
383 (dump path))
384 (dump t)))
385 #+(or cmucl scl)
386 (progn
387 (ext:gc :full t)
388 (setf ext:*batch-mode* nil)
389 (setf ext::*gc-run-time* 0)
390 (apply 'ext:save-lisp filename
391 :allow-other-keys t ;; hush SCL and old versions of CMUCL
392 #+(and cmucl executable) :executable #+(and cmucl executable) t
393 (when executable '(:init-function restore-image :process-command-line nil
394 :quiet t :load-init-file nil :site-init nil))))
395 #+gcl
396 (progn
397 (si::set-hole-size 500) (si::gbc nil) (si::sgc-on t)
398 (si::save-system filename))
399 #+lispworks
400 (if executable
401 (lispworks:deliver 'restore-image filename 0 :interface nil)
402 (hcl:save-image filename :environment nil))
403 #+sbcl
404 (progn
405 ;;(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
406 (setf sb-ext::*gc-run-time* 0)
407 (apply 'sb-ext:save-lisp-and-die filename
408 :executable t ;--- always include the runtime that goes with the core
409 (append
410 (when compression (list :compression compression))
411 ;;--- only save runtime-options for standalone executables
412 (when executable (list :toplevel #'restore-image :save-runtime-options t))
413 #+(and sbcl os-windows) ;; passing :application-type :gui will disable the console window.
414 ;; the default is :console - only works with SBCL 1.1.15 or later.
415 (when application-type (list :application-type application-type)))))
416 #-(or allegro clisp clozure cmucl gcl lispworks sbcl scl)
417 (not-implemented-error 'dump-image))
418
419 (defun create-image (destination lisp-object-files
420 &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 (declare (ignorable destination lisp-object-files extra-object-files kind output-name
424 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 ;; Is it meaningful to run these in the current environment?
428 ;; only if we also track the object files that constitute the "current" image,
429 ;; and otherwise simulate dump-image, including quitting at the end.
430 #-(or clasp ecl mkcl) (not-implemented-error 'create-image)
431 #+(or clasp ecl mkcl)
432 (let ((epilogue-code
433 (if no-uiop
434 epilogue-code
435 (let ((forms
436 (append
437 (when epilogue-code `(,epilogue-code))
438 (when postludep `((setf *image-postlude* ',postlude)))
439 (when preludep `((setf *image-prelude* ',prelude)))
440 (when entry-point-p `((setf *image-entry-point* ',entry-point)))
441 (case kind
442 ((:image)
443 (setf kind :program) ;; to ECL, it's just another program.
444 `((setf *image-dumped-p* t)
445 (si::top-level #+(or clasp ecl) t) (quit)))
446 ((:program)
447 `((setf *image-dumped-p* :executable)
448 (shell-boolean-exit
449 (restore-image))))))))
450 (when forms `(progn ,@forms))))))
451 (check-type kind (member :dll :shared-library :lib :static-library
452 :fasl :fasb :program))
453 (apply #+clasp 'cmp:builder #+clasp kind
454 #+(or ecl mkcl)
455 (ecase kind
456 ((:dll :shared-library)
457 #+ecl 'c::build-shared-library #+mkcl 'compiler:build-shared-library)
458 ((:lib :static-library)
459 #+ecl 'c::build-static-library #+mkcl 'compiler:build-static-library)
460 ((:fasl #+ecl :fasb)
461 #+ecl 'c::build-fasl #+mkcl 'compiler:build-fasl)
462 #+mkcl ((:fasb) 'compiler:build-bundle)
463 ((:program)
464 #+ecl 'c::build-program #+mkcl 'compiler:build-program))
465 (pathname destination)
466 #+(or clasp ecl) :lisp-files #+mkcl :lisp-object-files
467 (append lisp-object-files #+(or clasp ecl) extra-object-files)
468 #+ecl :init-name
469 #+ecl (getf build-args :init-name)
470 (append
471 (when prologue-code `(:prologue-code ,prologue-code))
472 (when epilogue-code `(:epilogue-code ,epilogue-code))
473 #+mkcl (when extra-object-files `(:object-files ,extra-object-files))
474 build-args)))))
475
476
477 ;;; Some universal image restore hooks
478 (with-upgradability ()
479 (map () 'register-image-restore-hook
480 '(setup-stdin setup-stdout setup-stderr
481 setup-command-line-arguments setup-temporary-directory
482 #+abcl detect-os)))