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

Last change on this file since 8931 was 8931, checked in by gz, 12 years ago

Fix for bugs #263 and #238:

  • %unix-file-kind takes a native namestring, so don't try to nativize it.
  • file-namestring-from-parts on the other hand takes escaped strings, so don't try to re-escape them.
  • Add a comment in %path-std-quotes explaining the convention.
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 9.5 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
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) (ioblock-device s))
47                      (setf (basic-stream.state o) nil)))
48                  (if (typep o 'buffered-stream-mixin)
49                    (let ((s (slot-value o 'ioblock)))
50                      (when (and (typep s 'ioblock) (ioblock-device s))
51                        (setf (slot-value o 'ioblock) nil))))))))
52
53
54(defun save-application (filename
55                         &rest rest
56                         &key toplevel-function
57                         init-file
58                         error-handler application-class
59                         clear-clos-caches
60                         (purify t)
61                         impurify
62                         (mode #o644)
63                         prepend-kernel
64                         )
65  (declare (ignore toplevel-function error-handler application-class
66                   resources clear-clos-caches init-file impurify
67                   mode prepend-kernel))
68  (unless (probe-file (make-pathname :defaults nil
69                                     :directory (pathname-directory (translate-logical-pathname filename))))
70    (error "Directory containing ~s does not exist." filename))
71  (let* ((kind (%unix-file-kind (native-translated-namestring filename))))
72    (when (and kind (not (eq kind :file )))
73      (error "~S is not a regular file." filename)))
74  (let* ((ip *initial-process*)
75         (cp *current-process*))
76    (when (process-verify-quit ip)
77      (process-interrupt ip
78                         #'(lambda ()
79                             (process-exit-application
80                              *current-process*
81                              #'(lambda ()
82                                  (apply #'%save-application-internal
83                                         filename
84                                         :purify purify
85                                         rest)))))
86      (unless (eq cp ip)
87        (process-kill cp)))))
88
89(defun %save-application-internal (filename &key
90                                            toplevel-function  ;????
91                                            error-handler ; meaningless unless application-class or *application* not lisp-development..
92                                            application-class
93                                            (mode #o644)
94                                            (purify t)
95                                            (impurify nil)
96                                            (init-file nil init-file-p)
97                                            (clear-clos-caches t)
98                                            (prepend-kernel nil))
99  (when (and application-class (neq  (class-of *application*)
100                                     (if (symbolp application-class)
101                                       (find-class application-class)
102                                       application-class)))
103    (setq *application* (make-instance application-class)))
104  (when (not toplevel-function)
105    (setq toplevel-function 
106          #'(lambda ()
107              (toplevel-function *application*
108                                 (if init-file-p
109                                   init-file
110                                   (application-init-file *application*))))))
111  (when error-handler
112    (make-application-error-handler *application* error-handler))
113 
114  (if clear-clos-caches (clear-clos-caches))
115  (save-image (let ((fd (open-dumplisp-file filename
116                                            :mode mode
117                                            :prepend-kernel prepend-kernel)))
118                #'(lambda () (%save-application fd
119                                                (logior (if impurify 2 0)
120                                                        (if purify 1 0)))))
121              toplevel-function))
122
123(defun save-image (save-function toplevel-function)
124  (let ((toplevel #'(lambda () (#_exit -1))))
125      (%set-toplevel #'(lambda ()
126                         (setf (interrupt-level) -1)
127                         (%set-toplevel toplevel)       ; in case *save-exit-functions* error
128                         (dolist (f *save-exit-functions*)
129                           (funcall f))
130                         (kill-lisp-pointers)
131                         (clear-ioblock-streams)
132                         (with-deferred-gc
133                             (let* ((pop *termination-population*))
134                               (with-lock-grabbed (*termination-population-lock*)
135                                 (setf (population.data pop) nil
136                                       (population.termination-list pop) nil))))
137                         (%set-toplevel
138                          #'(lambda ()
139                              (%set-toplevel #'(lambda ()
140                                                 (setf (interrupt-level) 0)
141                                                 (funcall toplevel-function)))
142                              (restore-lisp-pointers)))   ; do startup stuff
143                         (funcall save-function)))
144      (toplevel)))
145
146;;; If file in-fd contains an embedded lisp image, return the file position
147;;; of the start of that image; otherwise, return the file's length.
148(defun skip-embedded-image (in-fd)
149  (let* ((len (fd-lseek in-fd 0 #$SEEK_END)))
150    (if (< len 0)
151      (%errno-disp len)
152      (%stack-block ((trailer 16))
153        (let* ((trailer-pos (fd-lseek in-fd -16 #$SEEK_CUR)))
154          (if (< trailer-pos 0)
155            len
156            (if (not (= 16 (the fixnum (fd-read in-fd trailer 16))))
157              len
158              (if (not (dotimes (i 12 t)
159                         (unless (eql (char-code (schar "OpenMCLImage" i))
160                                      (%get-unsigned-byte trailer i))
161                           (return nil))))
162                len
163                (let* ((header-pos (fd-lseek in-fd
164                                             (%get-signed-long
165                                              trailer
166                                              12)
167                                             #$SEEK_CUR)))
168                  (if (< header-pos 0)
169                    len
170                    header-pos))))))))))
171                 
172 
173(defun %prepend-file (out-fd in-fd len)
174  (declare (fixnum out-fd in-fd len))
175  (fd-lseek in-fd 0 #$SEEK_SET)
176  (let* ((bufsize (ash 1 15)))
177    (%stack-block ((buf bufsize))
178      (loop
179          (when (zerop len) (return))
180          (let* ((nread (fd-read in-fd buf (min len bufsize))))
181            (declare (fixnum nread))
182            (if (< nread 0)
183              (%errno-disp nread))
184            (let* ((nwritten (fd-write out-fd buf nread)))
185              (declare (fixnum nwritten))
186              (unless (= nwritten nread)
187                (error "I/O error writing to fd ~d" out-fd)))
188            (decf len nread))))))
189   
190(defun open-dumplisp-file (path &key (mode #o666) prepend-kernel)
191  (let* ((prepend-fd (if prepend-kernel (fd-open
192                                         (if (eq prepend-kernel t)
193                                           (car *command-line-argument-list*)
194                                           (native-translated-namestring
195                                            (pathname prepend-kernel)))
196                                         #$O_RDONLY)))
197         (prepend-len (if (and prepend-fd (>= prepend-fd 0))
198                        (skip-embedded-image prepend-fd)))
199         (filename (native-translated-namestring path)))
200    (when (probe-file filename)
201      (%delete-file filename))
202    (when prepend-fd
203      (setq mode (logior #o111 mode)))
204    (let* ((image-fd (fd-open filename (logior #$O_WRONLY #$O_CREAT) mode)))
205      (unless (>= image-fd 0) (signal-file-error image-fd filename))
206      (fd-chmod image-fd mode)
207      (when prepend-fd
208        (%prepend-file image-fd prepend-fd prepend-len))
209      image-fd)))
210
211
212(defun %save-application (fd &optional (flags 1))
213  (let* ((err (%%save-application flags fd)))
214    (unless (eql err 0)
215      (%err-disp err))))
216 
217
218(defun restore-lisp-pointers ()
219  (%revive-system-locks)
220  (refresh-external-entrypoints)
221  (restore-pascal-functions)
222  (dolist (f (reverse *lisp-system-pointer-functions*))
223    (funcall f))
224  (let ((restore-lisp-fns *restore-lisp-functions*)
225        (user-pointer-fns *lisp-user-pointer-functions*)
226        (lisp-startup-fns *lisp-startup-functions*))
227    (unwind-protect
228      (with-simple-restart (abort "Abort (possibly crucial) startup functions.")
229        (let ((call-with-restart
230               #'(lambda (f)
231                   (with-simple-restart 
232                     (continue "Skip (possibly crucial) startup function ~s."
233                               (if (symbolp f) f (function-name f)))
234                     (funcall f)))))
235          (dolist (f restore-lisp-fns) (funcall call-with-restart f))
236          (dolist (f (reverse user-pointer-fns)) (funcall call-with-restart f))
237          (dolist (f (reverse lisp-startup-fns)) (funcall call-with-restart f))))
238      (setf (interrupt-level) 0)))
239  nil)
240
241
242(defun restore-pascal-functions ()
243  (reset-callback-storage)
244  (when (simple-vector-p %pascal-functions%)
245    (dotimes (i (length %pascal-functions%))
246      (let ((pfe (%svref %pascal-functions% i)))
247        (when (vectorp pfe)
248          (let* ((name (pfe.sym pfe))
249                 (descriptor (pfe.routine-descriptor pfe)))
250            (%revive-macptr descriptor)
251            (%setf-macptr descriptor (make-callback-trampoline i (pfe.proc-info pfe)))
252            (when name
253              (set name descriptor))))))))
254
Note: See TracBrowser for help on using the repository browser.