source: trunk/source/lib/dumplisp.lisp @ 12130

Last change on this file since 12130 was 12130, checked in by gb, 10 years ago

Define KERNEL-PATH: read the (new) kernel global if it's present, use
realpath of (car *command-line-arguments-list*) otherwise. (The kernel
global should be set going forward, but since we're recycling an old
kernel global that may have a non-NIL value it may not be reliable
to use :prepend-kernel until the kernel is rebuilt.)

Try to open the image file (and possibly prepend the kernel to it) in
the calling thread, so that errors that might occur during the process
are signaled while the lisp is still around. Check for errors that
might occur when opening the kernel.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 11.7 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17; Dumplisp.lisp
18
19(in-package "CCL")
20
21(defvar *save-exit-functions* nil 
22  "List of (0-arg)functions to call before saving memory image")
23
24(defvar *restore-lisp-functions* nil
25  "List of (0-arg)functions to call after restoring saved image")
26
27
28(declaim (special *lisp-system-pointer-functions*)) ; defined in l1-init.
29
30(defun kill-lisp-pointers ()
31  (setq * nil ** nil *** nil + nil ++ nil +++ nil - nil
32        / nil // nil /// nil
33         @ nil)
34  (clear-open-file-streams)
35  (setf (*%saved-method-var%*) nil)
36  (setq *%periodic-tasks%* nil)
37  (setq *event-dispatch-task* nil)
38  (setq *interactive-abort-process* nil)
39  )
40
41(defun clear-ioblock-streams ()
42  (%map-areas (lambda (o)
43                  (if (typep o 'basic-stream)
44                    (let ((s (basic-stream.state o)))
45                      (when (and (typep s 'ioblock)
46                                 (ioblock-device s)
47                                 (>= (ioblock-device s) 0))
48                        (setf (basic-stream.state o) nil)))
49                    ;; Have to be careful with use of TYPEP here (and
50                    ;; in the little bit of Lisp code that runs before
51                    ;; the image is saved.)  We may have just done
52                    ;; things to forget about (per-session) foreign
53                    ;; class addresses, and calling TYPEP on a pointer
54                    ;; to such a class might cause us to remember
55                    ;; those per-session addresses and confuse the
56                    ;; startup code.
57                    (if (and (eql (typecode o) target::subtag-instance)
58                             (typep o 'buffered-stream-mixin))
59                      (let ((s (slot-value o 'ioblock)))
60                        (when (and (typep s 'ioblock)
61                                   (ioblock-device s)
62                                   (>= (ioblock-device s) 0))
63                          (setf (slot-value o 'ioblock) nil))))))))
64
65(defun save-application (filename
66                         &rest rest
67                         &key toplevel-function
68                         init-file
69                         error-handler application-class
70                         clear-clos-caches
71                         (purify t)
72                         impurify
73                         (mode #o644)
74                         prepend-kernel
75                         )
76  (declare (ignore toplevel-function error-handler application-class
77                   clear-clos-caches init-file impurify))
78  (unless (probe-file (make-pathname :defaults nil
79                                     :directory (pathname-directory (translate-logical-pathname filename))))
80    (error "Directory containing ~s does not exist." filename))
81  (let* ((kind (%unix-file-kind (native-translated-namestring filename))))
82    (when (and kind (not (eq kind :file )))
83      (error "~S is not a regular file." filename)))
84  (let* ((ip *initial-process*)
85         (cp *current-process*))
86    (when (process-verify-quit ip)
87      (let* ((fd (open-dumplisp-file filename
88                                     :mode mode
89                                     :prepend-kernel prepend-kernel)))
90        (process-interrupt ip
91                           #'(lambda ()
92                               (process-exit-application
93                                *current-process*
94                                #'(lambda ()
95                                    (apply #'%save-application-internal
96                                           fd
97                                           :purify purify
98                                           rest))))))
99      (unless (eq cp ip)
100        (process-kill cp)))))
101
102(defun %save-application-internal (fd &key
103                                      toplevel-function ;????
104                                      error-handler ; meaningless unless application-class or *application* not lisp-development..
105                                      application-class
106                                      mode
107                                      (purify t)
108                                      (impurify nil)
109                                      (init-file nil init-file-p)
110                                      (clear-clos-caches t)
111                                      prepend-kernel)
112  (declare (ignore mode prepend-kernel))
113  (when (and application-class (neq  (class-of *application*)
114                                     (if (symbolp application-class)
115                                       (find-class application-class)
116                                       application-class)))
117    (setq *application* (make-instance application-class)))
118  (if (not toplevel-function)
119    (setq toplevel-function 
120          #'(lambda ()
121              (toplevel-function *application*
122                                 (if init-file-p
123                                   init-file
124                                   (application-init-file *application*)))))
125    (let* ((user-toplevel-function (coerce-to-function toplevel-function)))
126      (setq toplevel-function
127            (lambda ()
128              (process-run-function "toplevel" (lambda ()
129                                                 (funcall user-toplevel-function)
130                                                 (quit)))
131              (%set-toplevel #'housekeeping-loop)
132              (toplevel)))))
133  (when error-handler
134    (make-application-error-handler *application* error-handler))
135 
136  (if clear-clos-caches (clear-clos-caches))
137  (save-image #'(lambda () (%save-application fd
138                                              (logior (if impurify 2 0)
139                                                      (if purify 1 0))))
140              toplevel-function))
141
142(defun save-image (save-function toplevel-function)
143  (let ((toplevel #'(lambda () (#_exit -1))))
144      (%set-toplevel #'(lambda ()
145                         (setf (interrupt-level) -1)
146                         (%set-toplevel toplevel)       ; in case *save-exit-functions* error
147                         (dolist (f *save-exit-functions*)
148                           (funcall f))
149                         (kill-lisp-pointers)
150                         (clear-ioblock-streams)
151                         (with-deferred-gc
152                             (let* ((pop *termination-population*))
153                               (with-lock-grabbed (*termination-population-lock*)
154                                 (setf (population.data pop) nil
155                                       (population.termination-list pop) nil))))
156                         (%set-toplevel
157                          #'(lambda ()
158                              (%set-toplevel #'(lambda ()
159                                                 (setf (interrupt-level) 0)
160                                                 (funcall toplevel-function)))
161                              (restore-lisp-pointers)))   ; do startup stuff
162                         (funcall save-function)))
163      (toplevel)))
164
165;;; If file in-fd contains an embedded lisp image, return the file position
166;;; of the start of that image; otherwise, return the file's length.
167(defun skip-embedded-image (in-fd)
168  (let* ((len (fd-lseek in-fd 0 #$SEEK_END)))
169    (if (< len 0)
170      (%errno-disp len)
171      (%stack-block ((trailer 16))
172        (let* ((trailer-pos (fd-lseek in-fd -16 #$SEEK_CUR)))
173          (if (< trailer-pos 0)
174            len
175            (if (not (= 16 (the fixnum (fd-read in-fd trailer 16))))
176              len
177              (if (not (dotimes (i 12 t)
178                         (unless (eql (char-code (schar "OpenMCLImage" i))
179                                      (%get-unsigned-byte trailer i))
180                           (return nil))))
181                len
182                (let* ((header-pos (fd-lseek in-fd
183                                             (%get-signed-long
184                                              trailer
185                                              12)
186                                             #$SEEK_CUR)))
187                  (if (< header-pos 0)
188                    len
189                    header-pos))))))))))
190                 
191 
192(defun %prepend-file (out-fd in-fd len)
193  (declare (fixnum out-fd in-fd len))
194  (fd-lseek in-fd 0 #$SEEK_SET)
195  (let* ((bufsize (ash 1 15)))
196    (%stack-block ((buf bufsize))
197      (loop
198          (when (zerop len) (return))
199          (let* ((nread (fd-read in-fd buf (min len bufsize))))
200            (declare (fixnum nread))
201            (if (< nread 0)
202              (%errno-disp nread))
203            (let* ((nwritten (fd-write out-fd buf nread)))
204              (declare (fixnum nwritten))
205              (unless (= nwritten nread)
206                (error "I/O error writing to fd ~d" out-fd)))
207            (decf len nread))))))
208
209
210
211(defun kernel-path ()
212  (let* ((p (%null-ptr)))
213    (declare (dynamic-extent p))
214    (%get-kernel-global-ptr 'kernel-path p)
215    (if (%null-ptr-p p)
216      (%realpath (car *command-line-argument-list*))
217      (let* ((string (%get-utf-8-cstring p)))
218        #+windows-target (nbackslash-to-forward-slash string)
219        #+darwin-target (precompose-simple-string string)
220        #-(or windows-target darwin-target) string))))
221
222
223(defun open-dumplisp-file (path &key (mode #o666) prepend-kernel)
224  (let* ((prepend-path (if (eq prepend-kernel t)
225                         (kernel-path)
226                         (native-translated-namestring
227                          (pathname prepend-kernel))))
228         (prepend-fd (if prepend-kernel (fd-open prepend-path #$O_RDONLY)))
229         (prepend-len (if (and prepend-fd (>= prepend-fd 0))
230                        (skip-embedded-image prepend-fd)
231                        (signal-file-error prepend-fd prepend-path)))
232         (filename (native-translated-namestring path)))
233    (when (probe-file filename)
234      (%delete-file filename))
235    (when prepend-fd
236      (setq mode (logior #o111 mode)))
237    (let* ((image-fd (fd-open filename (logior #$O_WRONLY #$O_CREAT) mode)))
238      (unless (>= image-fd 0) (signal-file-error image-fd filename))
239      (fd-chmod image-fd mode)
240      (when prepend-fd
241        (%prepend-file image-fd prepend-fd prepend-len))
242      image-fd)))
243
244
245(defun %save-application (fd &optional (flags 1))
246  (let* ((err (%%save-application flags fd)))
247    (unless (eql err 0)
248      (%err-disp err))))
249 
250
251(defun restore-lisp-pointers ()
252  (setq *interactive-streams-initialized* nil)
253  (setq *heap-ivectors* nil)
254  (%revive-system-locks)
255  (refresh-external-entrypoints)
256  (restore-pascal-functions)
257  (initialize-interactive-streams)
258  (let ((system-ptr-fns (reverse *lisp-system-pointer-functions*))
259        (restore-lisp-fns *restore-lisp-functions*)
260        (user-pointer-fns *lisp-user-pointer-functions*)
261        (lisp-startup-fns *lisp-startup-functions*))
262    (unwind-protect
263      (with-simple-restart (abort "Abort (possibly crucial) startup functions.")
264        (let ((call-with-restart
265               #'(lambda (f)
266                   (with-simple-restart 
267                     (continue "Skip (possibly crucial) startup function ~s."
268                               (if (symbolp f) f (function-name f)))
269                     (funcall f)))))
270          (dolist (f system-ptr-fns) (funcall call-with-restart f))
271          (dolist (f restore-lisp-fns) (funcall call-with-restart f))
272          (dolist (f (reverse user-pointer-fns)) (funcall call-with-restart f))
273          (dolist (f (reverse lisp-startup-fns)) (funcall call-with-restart f))))
274      (setf (interrupt-level) 0)))
275  nil)
276
277
278(defun restore-pascal-functions ()
279  (reset-callback-storage)
280  (when (simple-vector-p %pascal-functions%)
281    (dotimes (i (length %pascal-functions%))
282      (let ((pfe (%svref %pascal-functions% i)))
283        (when (vectorp pfe)
284          (let* ((name (pfe.sym pfe))
285                 (descriptor (pfe.routine-descriptor pfe)))
286            (%revive-macptr descriptor)
287            (%setf-macptr descriptor (make-callback-trampoline i (pfe.proc-info pfe)))
288            (when name
289              (set name descriptor))))))))
290
Note: See TracBrowser for help on using the repository browser.