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

Last change on this file since 10277 was 10277, checked in by gb, 12 years ago

In RESTORE-LISP-POINTERS: clear *INTERACTIVE-STREAMS-INITIALIZED*
early, then call INITIALIZE-INTERACTIVE-STREAMS* and set the variable
ASAP (after locks revived and FFI reinitialized.)

Guard calls to *LISP-SYSTEM-POINTER-FUNCTIONS* with a restart (like
for the other kinds of reinitialization functions.) Errors in any
of the "system" functions might be even more critical, but it's
better to try to let the user know that something allegedly useful
failed than to just report an even more mysterious error.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 10.1 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                   mode prepend-kernel))
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      (process-interrupt ip
89                         #'(lambda ()
90                             (process-exit-application
91                              *current-process*
92                              #'(lambda ()
93                                  (apply #'%save-application-internal
94                                         filename
95                                         :purify purify
96                                         rest)))))
97      (unless (eq cp ip)
98        (process-kill cp)))))
99
100(defun %save-application-internal (filename &key
101                                            toplevel-function  ;????
102                                            error-handler ; meaningless unless application-class or *application* not lisp-development..
103                                            application-class
104                                            (mode #o644)
105                                            (purify t)
106                                            (impurify nil)
107                                            (init-file nil init-file-p)
108                                            (clear-clos-caches t)
109                                            (prepend-kernel nil))
110  (when (and application-class (neq  (class-of *application*)
111                                     (if (symbolp application-class)
112                                       (find-class application-class)
113                                       application-class)))
114    (setq *application* (make-instance application-class)))
115  (when (not toplevel-function)
116    (setq toplevel-function 
117          #'(lambda ()
118              (toplevel-function *application*
119                                 (if init-file-p
120                                   init-file
121                                   (application-init-file *application*))))))
122  (when error-handler
123    (make-application-error-handler *application* error-handler))
124 
125  (if clear-clos-caches (clear-clos-caches))
126  (save-image (let ((fd (open-dumplisp-file filename
127                                            :mode mode
128                                            :prepend-kernel prepend-kernel)))
129                #'(lambda () (%save-application fd
130                                                (logior (if impurify 2 0)
131                                                        (if purify 1 0)))))
132              toplevel-function))
133
134(defun save-image (save-function toplevel-function)
135  (let ((toplevel #'(lambda () (#_exit -1))))
136      (%set-toplevel #'(lambda ()
137                         (setf (interrupt-level) -1)
138                         (%set-toplevel toplevel)       ; in case *save-exit-functions* error
139                         (dolist (f *save-exit-functions*)
140                           (funcall f))
141                         (kill-lisp-pointers)
142                         (clear-ioblock-streams)
143                         (%set-toplevel
144                          #'(lambda ()
145                              (%set-toplevel #'(lambda ()
146                                                 (setf (interrupt-level) 0)
147                                                 (funcall toplevel-function)))
148                              (restore-lisp-pointers)))   ; do startup stuff
149                         (funcall save-function)))
150      (toplevel)))
151
152;;; If file in-fd contains an embedded lisp image, return the file position
153;;; of the start of that image; otherwise, return the file's length.
154(defun skip-embedded-image (in-fd)
155  (let* ((len (fd-lseek in-fd 0 #$SEEK_END)))
156    (if (< len 0)
157      (%errno-disp len)
158      (%stack-block ((trailer 16))
159        (let* ((trailer-pos (fd-lseek in-fd -16 #$SEEK_CUR)))
160          (if (< trailer-pos 0)
161            len
162            (if (not (= 16 (the fixnum (fd-read in-fd trailer 16))))
163              len
164              (if (not (dotimes (i 12 t)
165                         (unless (eql (char-code (schar "OpenMCLImage" i))
166                                      (%get-unsigned-byte trailer i))
167                           (return nil))))
168                len
169                (let* ((header-pos (fd-lseek in-fd
170                                             (%get-signed-long
171                                              trailer
172                                              12)
173                                             #$SEEK_CUR)))
174                  (if (< header-pos 0)
175                    len
176                    header-pos))))))))))
177                 
178 
179(defun %prepend-file (out-fd in-fd len)
180  (declare (fixnum out-fd in-fd len))
181  (fd-lseek in-fd 0 #$SEEK_SET)
182  (let* ((bufsize (ash 1 15)))
183    (%stack-block ((buf bufsize))
184      (loop
185          (when (zerop len) (return))
186          (let* ((nread (fd-read in-fd buf (min len bufsize))))
187            (declare (fixnum nread))
188            (if (< nread 0)
189              (%errno-disp nread))
190            (let* ((nwritten (fd-write out-fd buf nread)))
191              (declare (fixnum nwritten))
192              (unless (= nwritten nread)
193                (error "I/O error writing to fd ~d" out-fd)))
194            (decf len nread))))))
195   
196(defun open-dumplisp-file (path &key (mode #o666) prepend-kernel)
197  (let* ((prepend-fd (if prepend-kernel (fd-open
198                                         (if (eq prepend-kernel t)
199                                           (car *command-line-argument-list*)
200                                           (native-translated-namestring
201                                            (pathname prepend-kernel)))
202                                         #$O_RDONLY)))
203         (prepend-len (if (and prepend-fd (>= prepend-fd 0))
204                        (skip-embedded-image prepend-fd)))
205         (filename (native-translated-namestring path)))
206    (when (probe-file filename)
207      (%delete-file filename))
208    (when prepend-fd
209      (setq mode (logior #o111 mode)))
210    (let* ((image-fd (fd-open filename (logior #$O_WRONLY #$O_CREAT) mode)))
211      (unless (>= image-fd 0) (signal-file-error image-fd filename))
212      (fd-chmod image-fd mode)
213      (when prepend-fd
214        (%prepend-file image-fd prepend-fd prepend-len))
215      image-fd)))
216
217
218(defun %save-application (fd &optional (flags 1))
219  (let* ((err (%%save-application flags fd)))
220    (unless (eql err 0)
221      (%err-disp err))))
222 
223
224(defun restore-lisp-pointers ()
225  (setq *interactive-streams-initialized* nil)
226  (%revive-system-locks)
227  (refresh-external-entrypoints)
228  (restore-pascal-functions)
229  (initialize-interactive-streams)
230  (let ((system-ptr-fns (reverse *lisp-system-pointer-functions*))
231        (restore-lisp-fns *restore-lisp-functions*)
232        (user-pointer-fns *lisp-user-pointer-functions*)
233        (lisp-startup-fns *lisp-startup-functions*))
234    (unwind-protect
235      (with-simple-restart (abort "Abort (possibly crucial) startup functions.")
236        (let ((call-with-restart
237               #'(lambda (f)
238                   (with-simple-restart 
239                     (continue "Skip (possibly crucial) startup function ~s."
240                               (if (symbolp f) f (function-name f)))
241                     (funcall f)))))
242          (dolist (f system-ptr-fns) (funcall call-with-restart f))
243          (dolist (f restore-lisp-fns) (funcall call-with-restart f))
244          (dolist (f (reverse user-pointer-fns)) (funcall call-with-restart f))
245          (dolist (f (reverse lisp-startup-fns)) (funcall call-with-restart f))))
246      (setf (interrupt-level) 0)))
247  nil)
248
249
250(defun restore-pascal-functions ()
251  (reset-callback-storage)
252  (when (simple-vector-p %pascal-functions%)
253    (dotimes (i (length %pascal-functions%))
254      (let ((pfe (%svref %pascal-functions% i)))
255        (when (vectorp pfe)
256          (let* ((name (pfe.sym pfe))
257                 (descriptor (pfe.routine-descriptor pfe)))
258            (%revive-macptr descriptor)
259            (%setf-macptr descriptor (make-callback-trampoline i (pfe.proc-info pfe)))
260            (when name
261              (set name descriptor))))))))
262
Note: See TracBrowser for help on using the repository browser.