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

Contents of /src/code/save.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5