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

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

Make CLOSE of shared ioblock-based streams thread-safe:

  • CLOSE (actually, %IOBLOCK-CLOSE) waits for all buffer locks and sets ioblock.device to NIL, does nothing if already NIL.
  • Any other function that waits for ioblock locks checks ioblock.device and signals STREAM-IS-CLOSED error if it's NIL
  • string-streams set ioblock.device to -1 (the default value) when open, follow the same protocol for close. (String-streams are generally implicitly thread-private, but it seems safest to use the same conventions.)
  • Add code to close ioblock-based streams before saving an image, tweak it to observe ioblock.device conventions.
  • Remove a few unused ioblock-lock macros, enforce the check for closed-while-waiting in other macros
  • Since CLOSE now does ownership checks, make stream finalization use CLOSE-FOR-TERMINATION, which (since it's only called when the stream isn't otherwise referenced) can clobber ioblock.owner before doing the CLOSE.

This code (modulo any remaining bugs) should go into 1.2 and other
working branches.

I don't -think- that it's hard to bootstrap, but it's important
to do a full rebuild after svn update.

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