source: branches/working-0711/ccl/lib/dumplisp.lisp @ 12249

Last change on this file since 12249 was 12249, checked in by gz, 11 years ago

r11979 r11983 r12130 r12138 r12167 from trunk

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 11.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                         )
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 prepend-kernel
225                         (if (eq prepend-kernel t)
226                           (kernel-path)
227                           (native-translated-namestring
228                          (pathname prepend-kernel)))))
229         (prepend-fd (if prepend-path (fd-open prepend-path #$O_RDONLY)))
230         (prepend-len (if prepend-kernel
231                        (if (and prepend-fd (>= prepend-fd 0))
232                          (skip-embedded-image prepend-fd)
233                          (signal-file-error prepend-fd prepend-path))))
234         (filename (native-translated-namestring path)))
235    (when (probe-file filename)
236      (%delete-file filename))
237    (when prepend-fd
238      (setq mode (logior #o111 mode)))
239    (let* ((image-fd (fd-open filename (logior #$O_WRONLY #$O_CREAT) mode)))
240      (unless (>= image-fd 0) (signal-file-error image-fd filename))
241      (fd-chmod image-fd mode)
242      (when prepend-fd
243        (%prepend-file image-fd prepend-fd prepend-len))
244      image-fd)))
245
246
247(defun %save-application (fd &optional (flags 1))
248  (let* ((err (%%save-application flags fd)))
249    (unless (eql err 0)
250      (%err-disp err))))
251 
252
253(defun restore-lisp-pointers ()
254  (setq *interactive-streams-initialized* nil)
255  (setq *heap-ivectors* nil)
256  (setq *batch-flag* (not (eql (%get-kernel-global 'batch-flag) 0)))
257  (%revive-system-locks)
258  (refresh-external-entrypoints)
259  (restore-pascal-functions)
260  (initialize-interactive-streams)
261  (let ((system-ptr-fns (reverse *lisp-system-pointer-functions*))
262        (restore-lisp-fns *restore-lisp-functions*)
263        (user-pointer-fns *lisp-user-pointer-functions*)
264        (lisp-startup-fns *lisp-startup-functions*))
265    (unwind-protect
266      (with-simple-restart (abort "Abort (possibly crucial) startup functions.")
267        (let ((call-with-restart
268               #'(lambda (f)
269                   (with-simple-restart 
270                     (continue "Skip (possibly crucial) startup function ~s."
271                               (if (symbolp f) f (function-name f)))
272                     (funcall f)))))
273          (dolist (f system-ptr-fns) (funcall call-with-restart f))
274          (dolist (f restore-lisp-fns) (funcall call-with-restart f))
275          (dolist (f (reverse user-pointer-fns)) (funcall call-with-restart f))
276          (dolist (f (reverse lisp-startup-fns)) (funcall call-with-restart f))))
277      (setf (interrupt-level) 0)))
278  nil)
279
280
281(defun restore-pascal-functions ()
282  (reset-callback-storage)
283  (when (simple-vector-p %pascal-functions%)
284    (dotimes (i (length %pascal-functions%))
285      (let ((pfe (%svref %pascal-functions% i)))
286        (when (vectorp pfe)
287          (let* ((name (pfe.sym pfe))
288                 (descriptor (pfe.routine-descriptor pfe)))
289            (%revive-macptr descriptor)
290            (%setf-macptr descriptor (make-callback-trampoline i (pfe.proc-info pfe)))
291            (when name
292              (set name descriptor))))))))
293
Note: See TracBrowser for help on using the repository browser.