source: branches/qres/ccl/lib/dumplisp.lisp @ 14172

Last change on this file since 14172 was 13235, checked in by gz, 10 years ago

r13225 from trunk (fix for execute permission when prepending symbols)

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