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

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

I thought that I'd checked this in already: in %PREPEND-FILE, change
PEF to PE (and add a comment explaining why.) Try to use the FFI to
generate some magic constants (structure sizes, field offsets) for us.
(I'd been concerned that this code might be broken on Win64, but the
relevant sizes/offsets that're used here happened to be OK.)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 13.9 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                         #+windows-target (application-type :console))
76  (declare (ignore toplevel-function error-handler application-class
77                   clear-clos-caches init-file impurify))
78  #+windows-target (check-type application-type (member :console :gui))
79  (unless (probe-file (make-pathname :defaults nil
80                                     :directory (pathname-directory (translate-logical-pathname filename))))
81    (error "Directory containing ~s does not exist." filename))
82  (let* ((kind (%unix-file-kind (native-translated-namestring filename))))
83    (when (and kind (not (eq kind :file )))
84      (error "~S is not a regular file." filename)))
85  (let* ((ip *initial-process*)
86         (cp *current-process*))
87    (when (process-verify-quit ip)
88      (let* ((fd (open-dumplisp-file filename
89                                     :mode mode
90                                     :prepend-kernel prepend-kernel
91                                     #+windows-target  #+windows-target 
92                                     :application-type application-type)))
93        (process-interrupt ip
94                           #'(lambda ()
95                               (process-exit-application
96                                *current-process*
97                                #'(lambda ()
98                                    (apply #'%save-application-internal
99                                           fd
100                                           :purify purify
101                                           rest))))))
102      (unless (eq cp ip)
103        (process-kill cp)))))
104
105(defun %save-application-internal (fd &key
106                                      toplevel-function ;????
107                                      error-handler ; meaningless unless application-class or *application* not lisp-development..
108                                      application-class
109                                      mode
110                                      (purify t)
111                                      (impurify nil)
112                                      (init-file nil init-file-p)
113                                      (clear-clos-caches t)
114                                      prepend-kernel
115                                      #+windows-target application-type)
116  (declare (ignore mode prepend-kernel #+windows-target application-type))
117  (when (and application-class (neq  (class-of *application*)
118                                     (if (symbolp application-class)
119                                       (find-class application-class)
120                                       application-class)))
121    (setq *application* (make-instance application-class)))
122  (if (not toplevel-function)
123    (setq toplevel-function 
124          #'(lambda ()
125              (toplevel-function *application*
126                                 (if init-file-p
127                                   init-file
128                                   (application-init-file *application*)))))
129    (let* ((user-toplevel-function (coerce-to-function toplevel-function)))
130      (setq toplevel-function
131            (lambda ()
132              (process-run-function "toplevel" (lambda ()
133                                                 (funcall user-toplevel-function)
134                                                 (quit)))
135              (%set-toplevel #'housekeeping-loop)
136              (toplevel)))))
137  (when error-handler
138    (make-application-error-handler *application* error-handler))
139 
140  (if clear-clos-caches (clear-clos-caches))
141  (save-image #'(lambda () (%save-application fd
142                                              (logior (if impurify 2 0)
143                                                      (if purify 1 0))))
144              toplevel-function))
145
146(defun save-image (save-function toplevel-function)
147  (let ((toplevel #'(lambda () (#_exit -1))))
148      (%set-toplevel #'(lambda ()
149                         (setf (interrupt-level) -1)
150                         (%set-toplevel toplevel)       ; in case *save-exit-functions* error
151                         (dolist (f *save-exit-functions*)
152                           (funcall f))
153                         (kill-lisp-pointers)
154                         (clear-ioblock-streams)
155                         (with-deferred-gc
156                             (let* ((pop *termination-population*))
157                               (with-lock-grabbed (*termination-population-lock*)
158                                 (setf (population.data pop) nil
159                                       (population.termination-list pop) nil))))
160                         (%set-toplevel
161                          #'(lambda ()
162                              (%set-toplevel #'(lambda ()
163                                                 (setf (interrupt-level) 0)
164                                                 (funcall toplevel-function)))
165                              (restore-lisp-pointers)))   ; do startup stuff
166                         (funcall save-function)))
167      (toplevel)))
168
169;;; If file in-fd contains an embedded lisp image, return the file position
170;;; of the start of that image; otherwise, return the file's length.
171(defun skip-embedded-image (in-fd)
172  (let* ((len (fd-lseek in-fd 0 #$SEEK_END)))
173    (if (< len 0)
174      (%errno-disp len)
175      (%stack-block ((trailer 16))
176        (let* ((trailer-pos (fd-lseek in-fd -16 #$SEEK_CUR)))
177          (if (< trailer-pos 0)
178            len
179            (if (not (= 16 (the fixnum (fd-read in-fd trailer 16))))
180              len
181              (if (not (dotimes (i 12 t)
182                         (unless (eql (char-code (schar "OpenMCLImage" i))
183                                      (%get-unsigned-byte trailer i))
184                           (return nil))))
185                len
186                (let* ((header-pos (fd-lseek in-fd
187                                             (%get-signed-long
188                                              trailer
189                                              12)
190                                             #$SEEK_CUR)))
191                  (if (< header-pos 0)
192                    len
193                    header-pos))))))))))
194                 
195;;; Note that Windows executable files are in what they call "PE"
196;;; (= "Portable Executable") format, not to be confused with the "PEF"
197;;; (= "PowerPC Executable Format" or "Preferred Executable Format")
198;;; executable format that Apple used on Classic MacOS.
199(defun %prepend-file (out-fd in-fd len #+windows-target application-type)
200  (declare (fixnum out-fd in-fd len))
201  (fd-lseek in-fd 0 #$SEEK_SET)
202  (let* ((bufsize (ash 1 15))
203         #+windows-target (first-buf t))
204    (%stack-block ((buf bufsize))
205      (loop
206          (when (zerop len) (return))
207          (let* ((nread (fd-read in-fd buf (min len bufsize))))
208            (declare (fixnum nread))
209            (if (< nread 0)
210              (%errno-disp nread))
211            #+windows-target
212            (when (shiftf first-buf nil)
213              (let* ((application-byte (ecase application-type
214                                         (:console #$IMAGE_SUBSYSTEM_WINDOWS_CUI)
215                                         (:gui #$IMAGE_SUBSYSTEM_WINDOWS_GUI)))
216                     (offset (%get-long buf (get-field-offset #>IMAGE_DOS_HEADER.lfanew))))
217                (assert (< offset bufsize) () "PE header not within first ~D bytes" bufsize)
218                (assert (= (%get-byte buf (+ offset 0)) (char-code #\P)) ()
219                        "File does not appear to be a PE file")
220                (assert (= (%get-byte buf (+ offset 1)) (char-code #\E)) ()
221                        "File does not appear to be a PE file")
222                (assert (= (%get-byte buf (+ offset 2)) 0) ()
223                        "File does not appear to be a PE file")
224                (assert (= (%get-byte buf (+ offset 3)) 0) ()
225                        "File does not appear to be a PE file")
226                ;; File is a PE file -- Windows subsystem byte goes at offset 68 in the
227                ;;  "optional header" which appears right after the standard header (20 bytes)
228                ;;  and the PE cookie (4 bytes)
229                (setf (%get-byte buf (+ offset 4 20 68)) application-byte)))
230            (let* ((nwritten (fd-write out-fd buf nread)))
231              (declare (fixnum nwritten))
232              (unless (= nwritten nread)
233                (error "I/O error writing to fd ~d" out-fd)))
234            (decf len nread))))))
235
236
237
238(defun kernel-path ()
239  (let* ((p (%null-ptr)))
240    (declare (dynamic-extent p))
241    (%get-kernel-global-ptr 'kernel-path p)
242    (if (%null-ptr-p p)
243      (%realpath (car *command-line-argument-list*))
244      (let* ((string (%get-utf-8-cstring p)))
245        #+windows-target (nbackslash-to-forward-slash string)
246        #+darwin-target (precompose-simple-string string)
247        #-(or windows-target darwin-target) string))))
248
249
250(defun open-dumplisp-file (path &key (mode #o666) prepend-kernel
251                           #+windows-target application-type)
252  (let* ((prepend-path (if prepend-kernel
253                         (if (eq prepend-kernel t)
254                           (kernel-path)
255                           (native-translated-namestring
256                          (pathname prepend-kernel)))))
257         (prepend-fd (if prepend-path (fd-open prepend-path #$O_RDONLY)))
258         (prepend-len (if prepend-kernel
259                        (if (and prepend-fd (>= prepend-fd 0))
260                          (skip-embedded-image prepend-fd)
261                          (signal-file-error prepend-fd prepend-path))))
262         (filename (native-translated-namestring path)))
263    (when (probe-file filename)
264      (%delete-file filename))
265    (when prepend-fd
266      (setq mode (logior #o111 mode)))
267    (let* ((image-fd (fd-open filename (logior #$O_WRONLY #$O_CREAT) mode)))
268      (unless (>= image-fd 0) (signal-file-error image-fd filename))
269      (when prepend-fd
270        (%prepend-file image-fd prepend-fd prepend-len #+windows-target application-type))
271      (fd-chmod image-fd mode)
272      image-fd)))
273
274
275(defun %save-application (fd &optional (flags 1))
276  (let* ((err (%%save-application flags fd)))
277    (unless (eql err 0)
278      (%err-disp err))))
279 
280
281(defun restore-lisp-pointers ()
282  (setq *interactive-streams-initialized* nil)
283  (setq *heap-ivectors* nil)
284  (setq *batch-flag* (not (eql (%get-kernel-global 'batch-flag) 0)))
285  (%revive-system-locks)
286  (refresh-external-entrypoints)
287  (restore-pascal-functions)
288  (initialize-interactive-streams)
289  (let ((system-ptr-fns (reverse *lisp-system-pointer-functions*))
290        (restore-lisp-fns *restore-lisp-functions*)
291        (user-pointer-fns *lisp-user-pointer-functions*)
292        (lisp-startup-fns *lisp-startup-functions*))
293    (unwind-protect
294      (with-simple-restart (abort "Abort (possibly crucial) startup functions.")
295        (let ((call-with-restart
296               #'(lambda (f)
297                   (with-simple-restart 
298                     (continue "Skip (possibly crucial) startup function ~s."
299                               (if (symbolp f) f (function-name f)))
300                     (funcall f)))))
301          (dolist (f system-ptr-fns) (funcall call-with-restart f))
302          (dolist (f restore-lisp-fns) (funcall call-with-restart f))
303          (dolist (f (reverse user-pointer-fns)) (funcall call-with-restart f))
304          (dolist (f (reverse lisp-startup-fns)) (funcall call-with-restart f))))
305      (setf (interrupt-level) 0)))
306  nil)
307
308
309(defun restore-pascal-functions ()
310  (reset-callback-storage)
311  (when (simple-vector-p %pascal-functions%)
312    (dotimes (i (length %pascal-functions%))
313      (let ((pfe (%svref %pascal-functions% i)))
314        (when (vectorp pfe)
315          (let* ((name (pfe.sym pfe))
316                 (descriptor (pfe.routine-descriptor pfe)))
317            (%revive-macptr descriptor)
318            (%setf-macptr descriptor (make-callback-trampoline i (pfe.proc-info pfe)))
319            (when name
320              (set name descriptor))))))))
321
Note: See TracBrowser for help on using the repository browser.