/[cmucl]/src/code/save.lisp
ViewVC logotype

Contents of /src/code/save.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.56.4.1.2.1 - (show annotations)
Fri Dec 19 01:31:32 2008 UTC (5 years, 4 months ago) by rtoy
Branch: unicode-utf16-extfmt-branch
CVS Tags: unicode-utf16-extfmts-sync-2008-12
Changes since 1.56.4.1: +5 -4 lines
Merge changes from utf16 branch to update to snapshot 2008-12.
1 ;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/save.lisp,v 1.56.4.1.2.1 2008/12/19 01:31:32 rtoy Exp $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Dump the current lisp image into a core file. All the real work is done
13 ;;; be C. Also contains various high-level initialization stuff: loading init
14 ;;; files and parsing environment variables.
15 ;;;
16 ;;; Written by William Lott.
17 ;;;
18 ;;;
19 (in-package "LISP")
20
21 (in-package "EXTENSIONS")
22 (export '(print-herald *herald-items* save-lisp *before-save-initializations*
23 *after-save-initializations* *environment-list* *editor-lisp-p*))
24 (in-package "LISP")
25
26 (defvar *before-save-initializations* nil
27 "This is a list of functions which are called before creating a saved core
28 image. These functions are executed in the child process which has no ports,
29 so they cannot do anything that tries to talk to the outside world.")
30
31 (defvar *after-save-initializations* nil
32 "This is a list of functions which are called when a saved core image starts
33 up. The system itself should be initialized at this point, but applications
34 might not be.")
35
36 (defvar *environment-list* nil
37 "An alist mapping environment variables (as keywords) to either values")
38
39 (defvar *editor-lisp-p* nil
40 "This is true if and only if the lisp was started with the -edit switch.")
41
42
43
44 ;;; Filled in by the startup code.
45 (defvar lisp-environment-list)
46 (defvar *cmucl-lib*) ; Essentially the envvar CMUCLLIB, if available
47
48 #+:executable
49 ;; A dumped executable image won't have any reasonable default
50 ;; library: search list. Save the one from when it was dumped.
51 (defvar *old-cmucl-library-search-list*)
52
53 (defvar *cmucl-core-path*) ; Path to where the Lisp core file was found.
54
55 ;;; Filled in by the save code.
56 (defvar *cmucl-core-dump-time*) ; Time the core was dumped
57 (defvar *cmucl-core-dump-host*) ; machine-instance the core was dumped on
58
59
60 ;;; PARSE-UNIX-SEARCH-LIST -- Internal
61 ;;;
62 ;;; Returns a list of the directories that are in the specified Unix
63 ;;; environment variable. Return NIL if the variable is undefined.
64 ;;;
65 (defun parse-unix-search-path (path)
66 (do* ((i 0 (1+ p))
67 (p (position #\: path :start i)
68 (position #\: path :start i))
69 (pl ()))
70 ((null p)
71 (let ((s (subseq path i)))
72 (if (string= s "")
73 (push "default:" pl)
74 (push (concatenate 'simple-string s "/") pl)))
75 (nreverse pl))
76 (let ((s (subseq path i p)))
77 (if (string= s "")
78 (push "default:" pl)
79 (push (concatenate 'simple-string s "/") pl)))))
80
81 (defun parse-unix-search-list (var)
82 (let ((path (cdr (assoc var ext::*environment-list*))))
83 (when path
84 (parse-unix-search-path path))))
85
86
87 ;;; ENVIRONMENT-INIT -- Internal
88 ;;;
89 ;;; Parse the LISP-ENVIRONMENT-LIST into a keyword alist. Set up default
90 ;;; search lists.
91 ;;;
92 (defun environment-init ()
93 (setq *environment-list* ())
94 (dolist (ele lisp-environment-list)
95 (let ((=pos (position #\= (the simple-string ele))))
96 (when =pos
97 (push (cons (intern (subseq ele 0 =pos)
98 *keyword-package*)
99 (subseq ele (1+ =pos)))
100 *environment-list*))))
101 (setf (search-list "default:") (list (default-directory)))
102 (setf (search-list "path:") (parse-unix-search-list :path))
103 (setf (search-list "home:")
104 (or (parse-unix-search-list :home)
105 (list (default-directory))))
106
107 (setf (search-list "library:")
108 (if (boundp '*cmucl-lib*)
109 (parse-unix-search-path *cmucl-lib*)
110 (or
111 #+:executable
112 *old-cmucl-library-search-list*
113 '("/usr/local/lib/cmucl/lib/"))))
114 (setf (search-list "modules:") '("library:subsystems/"))
115 (setf (search-list "ld-library-path:")
116 (parse-unix-search-list :ld_library_path))
117 (setf (search-list "ext-formats:")
118 '("library:ext-formats/")))
119
120
121
122 ;;;; SAVE-LISP itself.
123
124 (alien:def-alien-routine "save" (alien:boolean)
125 (file c-call:c-string)
126 (initial-function (alien:unsigned #.vm:word-bits))
127 (sse2-mode c-call:int))
128
129 #+:executable
130 (alien:def-alien-routine "save_executable" (alien:boolean)
131 (file c-call:c-string)
132 (initial-function (alien:unsigned #.vm:word-bits)))
133
134 (defun save-lisp (core-file-name &key
135 (purify t)
136 (root-structures ())
137 (environment-name "Auxiliary")
138 (init-function #'%top-level)
139 (load-init-file t)
140 (site-init "library:site-init")
141 (print-herald t)
142 (process-command-line t)
143 #+:executable
144 (executable nil)
145 (batch-mode nil))
146 "Saves a CMU Common Lisp core image in the file of the specified name. The
147 following keywords are defined:
148
149 :purify
150 If true (the default), do a purifying GC which moves all dynamically
151 allocated objects into static space so that they stay pure. This takes
152 somewhat longer than the normal GC which is otherwise done, but GC's will
153 be done less often and take less time in the resulting core file. See
154 EXT:PURIFY.
155
156 :root-structures
157 This should be a list of the main entry points in any newly loaded
158 systems. This need not be supplied, but locality and/or GC performance
159 will be better if they are. Meaningless if :purify is NIL. See EXT:PURIFY.
160
161 :environment-name
162 Also passed to EXT:PURIFY when :PURIFY is T. Rarely used.
163
164 :init-function
165 This is the function that starts running when the created core file is
166 resumed. The default function simply invokes the top level
167 read-eval-print loop. If the function returns the lisp will exit.
168
169 :load-init-file
170 If true, then look for an init.lisp or init.fasl file when the core
171 file is resumed.
172
173 :site-init
174 If true, then the name of the site init file to load. The default is
175 library:site-init. No error if this does not exist.
176
177 :print-herald
178 If true (the default), print out the lisp system herald when starting.
179
180 :process-command-line
181 If true (the default), process command-line switches via the normal
182 mechanisms, otherwise ignore all switches (except those processed by the
183 C startup code).
184
185 :executable
186 If nil (the default), save-lisp will save using the traditional
187 core-file format. If true, save-lisp will create an executable
188 file that contains the lisp image built in.
189 (Not all architectures support this yet.)
190
191 :batch-mode
192 If nil (the default), then the presence of the -batch command-line
193 switch will invoke batch-mode processing. If true, the produced core
194 will always be in batch-mode, regardless of any command-line switches."
195
196 (unless (probe-file (directory-namestring core-file-name))
197 (error 'simple-file-error
198 :format-control "Directory ~S does not exist"
199 :format-arguments (list (directory-namestring core-file-name))))
200
201 #+mp (mp::shutdown-multi-processing)
202 (when (fboundp 'eval:flush-interpreted-function-cache)
203 (eval:flush-interpreted-function-cache))
204 (when (fboundp 'cancel-finalization)
205 (cancel-finalization sys:*tty*))
206
207 #+:executable
208 (when executable
209 ;; Only do this when dumping an executable Lisp. Otherwise
210 ;; worldload will make us lose because it clears the search lists.
211 ;; If we are dumping an executable lisp image, we want to keep
212 ;; track of the library search list across dumps because the
213 ;; normal way for figuring out the library paths from arg[0] is
214 ;; almost guaranteed to be wrong for executables.
215 (setf *old-cmucl-library-search-list* (search-list "library:")))
216
217 (if purify
218 (purify :root-structures root-structures
219 :environment-name environment-name)
220 #-gencgc (gc) #+gencgc (gc :full t))
221 (dolist (f *before-save-initializations*) (funcall f))
222 (setq ext:*batch-mode* (if batch-mode t nil))
223 (labels
224 ((%restart-lisp ()
225 (with-simple-restart (abort "Skip remaining initializations.")
226 (catch 'top-level-catcher
227 (reinit)
228 (environment-init)
229 (dolist (f *after-save-initializations*) (funcall f))
230 (when process-command-line
231 (ext::process-command-strings))
232 (setf *editor-lisp-p* nil)
233 (macrolet ((find-switch (name)
234 `(find ,name *command-line-switches*
235 :key #'cmd-switch-name
236 :test #'(lambda (x y)
237 (declare (simple-string x y))
238 (string-equal x y)))))
239 (when (and process-command-line (find-switch "quiet"))
240 (setq *load-verbose* nil
241 *compile-verbose* nil
242 *compile-print* nil
243 *compile-progress* nil
244 *require-verbose* nil
245 *gc-verbose* nil
246 *herald-items* nil))
247 (when (and site-init
248 (not (and process-command-line
249 (find-switch "nositeinit"))))
250 (load site-init :if-does-not-exist nil :verbose nil))
251 (when (and process-command-line (find-switch "edit"))
252 (setf *editor-lisp-p* t))
253 (when (and load-init-file
254 (not (and process-command-line
255 (find-switch "noinit"))))
256 (let* ((cl-switch (find-switch "init"))
257 (name (and cl-switch
258 (or (cmd-switch-value cl-switch)
259 (car (cmd-switch-words cl-switch))))))
260 (if name
261 (load (merge-pathnames name #p"home:")
262 :if-does-not-exist nil)
263 (or (load "home:init" :if-does-not-exist nil)
264 (load "home:.cmucl-init"
265 :if-does-not-exist nil))))))
266 (when process-command-line
267 (ext::invoke-switch-demons *command-line-switches*
268 *command-switch-demons*))
269 (when print-herald
270 (print-herald))))
271 (funcall init-function))
272 (restart-lisp ()
273 (unix:unix-exit
274 (catch '%end-of-the-world
275 (unwind-protect
276 (if *batch-mode*
277 (handler-case
278 (%restart-lisp)
279 (error (cond)
280 (format *error-output* "Error in batch processing:~%~A~%"
281 cond)
282 (throw '%end-of-the-world 1)))
283 (%restart-lisp))
284 (finish-standard-output-streams))))))
285
286 ;; Record dump time and host
287 (setq *cmucl-core-dump-time* (get-universal-time))
288 (setq *cmucl-core-dump-host* (machine-instance))
289
290 (let ((initial-function (get-lisp-obj-address #'restart-lisp))
291 (core-name (unix-namestring core-file-name nil)))
292 (without-gcing
293 #+:executable
294 (if executable
295 (save-executable core-name initial-function)
296 (save core-name initial-function #+sse2 1 #-sse2 0))
297 #-:executable
298 (save core-name initial-function #+sse2 1 #-sse2 0))))
299 nil)
300
301
302
303 ;;;; PRINT-HERALD support.
304
305 (defvar *herald-items* ()
306 "Determines what PRINT-HERALD prints (the system startup banner.) This is a
307 database which can be augmented by each loaded system. The format is a
308 property list which maps from subsystem names to the banner information for
309 that system. This list can be manipulated with GETF -- entries are printed
310 in, reverse order, so the newest entry is printed last. Usually the system
311 feature keyword is used as the system name. A given banner is a list of
312 strings and functions (or function names). Strings are printed, and
313 functions are called with an output stream argument.")
314
315 (setf (getf *herald-items* :common-lisp)
316 `("CMU Common Lisp "
317 ,#'(lambda (stream)
318 (write-string (lisp-implementation-version) stream))
319 ", running on "
320 ,#'(lambda (stream) (write-string (machine-instance) stream))
321 terpri
322 ,#'(lambda (stream)
323 (let ((core (if (boundp '*cmucl-core-path*)
324 (truename *cmucl-core-path*)
325 nil))
326 (dump-time (if (boundp '*cmucl-core-dump-time*)
327 *cmucl-core-dump-time*
328 nil)))
329 (when core
330 (write-string "With core: " stream)
331 (write-line (namestring core) stream))
332 (when dump-time
333 (write-string "Dumped on: " stream)
334 (ext:format-universal-time stream dump-time :style :iso8601)
335 (write-string " on " stream)
336 (write-line *cmucl-core-dump-host* stream))))
337 ))
338
339 (setf (getf *herald-items* :bugs)
340 '("See <http://www.cons.org/cmucl/> for support information."
341 terpri
342 "Loaded subsystems:"))
343
344 ;;; PRINT-HERALD -- Public
345 ;;;
346 (defun print-herald (&optional (stream *standard-output*))
347 "Print some descriptive information about the Lisp system version and
348 configuration."
349 (let ((res ()))
350 (do ((item *herald-items* (cddr item)))
351 ((null item))
352 (push (second item) res))
353
354 (fresh-line stream)
355 (dolist (item res)
356 (dolist (thing item)
357 (typecase thing
358 (string
359 (write-string thing stream))
360 (function (funcall thing stream))
361 ((or symbol cons)
362 (funcall (fdefinition thing) stream))
363 (t
364 (error "Unrecognized *HERALD-ITEMS* entry: ~S." thing))))
365 (fresh-line stream)))
366
367 (values))
368
369
370 ;;;; Random functions used by worldload.
371
372 (defun assert-user-package ()
373 (unless (eq *package* (find-package "CL-USER"))
374 (error "Change *PACKAGE* to the USER package and try again.")))
375
376 ;;; MAYBE-BYTE-LOAD -- Interface
377 ;;;
378 ;;; If Name has been byte-compiled, and :runtime is a feature, then load the
379 ;;; byte-compiled version, otherwise just do normal load.
380 ;;;
381 (defun maybe-byte-load (name &optional (load-native t))
382 (let ((bname (make-pathname
383 :defaults name
384 :type #.(c:backend-byte-fasl-file-type c:*target-backend*))))
385 (cond ((and (featurep :runtime)
386 (probe-file bname))
387 (load bname))
388 (load-native
389 (load name)))))
390
391
392 ;;; BYTE-LOAD-OVER -- Interface
393 ;;;
394 ;;; Replace a cold-loaded native object file with a byte-compiled one, if it
395 ;;; exists.
396 ;;;
397 (defun byte-load-over (name)
398 (load (make-pathname
399 :defaults name
400 :type #.(c:backend-byte-fasl-file-type c:*target-backend*))
401 :if-does-not-exist nil))

  ViewVC Help
Powered by ViewVC 1.1.5