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

Contents of /src/code/save.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.73 - (show annotations)
Thu Nov 4 14:05:01 2010 UTC (3 years, 5 months ago) by rtoy
Branch: MAIN
CVS Tags: GIT-CONVERSION, cross-sol-x86-merged, cross-sol-x86-base, snapshot-2010-12, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, cross-sol-x86-branch
Changes since 1.72: +5 -4 lines
Correct the docstring for SAVE for the :LOAD-INIT-FILE argument.
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.73 2010/11/04 14:05:01 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 (and (boundp '*cmucl-lib*)
114 #+:executable
115 (not (boundp '*old-cmucl-library-search-list*)))
116 (parse-unix-search-path *cmucl-lib*)
117 (or
118 #+:executable
119 *old-cmucl-library-search-list*
120 '("/usr/local/lib/cmucl/lib/"))))
121 (setf (search-list "modules:")
122 '("library:contrib/" "library:subsystems/" "target:contrib/"))
123 (setf (search-list "ld-library-path:")
124 (parse-unix-search-list :ld_library_path))
125 (setf (search-list "ext-formats:")
126 '("library:ext-formats/"
127 "target:i18n/"
128 "target:pcl/simple-streams/external-formats/"))
129 (setq *environment-list-initialized* t))
130
131
132 ;;;; SAVE-LISP itself.
133
134 (alien:def-alien-routine "save" (alien:boolean)
135 (file c-call:c-string)
136 (initial-function (alien:unsigned #.vm:word-bits))
137 (sse2-mode c-call:int))
138
139 #+:executable
140 (alien:def-alien-routine "save_executable" (alien:boolean)
141 (file c-call:c-string)
142 (initial-function (alien:unsigned #.vm:word-bits)))
143
144 (defun save-lisp (core-file-name &key
145 (purify t)
146 (root-structures ())
147 (environment-name "Auxiliary")
148 (init-function #'%top-level)
149 (load-init-file t)
150 (site-init "library:site-init")
151 (print-herald t)
152 (process-command-line t)
153 #+:executable
154 (executable nil)
155 (batch-mode nil))
156 "Saves a CMU Common Lisp core image in the file of the specified name. The
157 following keywords are defined:
158
159 :purify
160 If true (the default), do a purifying GC which moves all dynamically
161 allocated objects into static space so that they stay pure. This takes
162 somewhat longer than the normal GC which is otherwise done, but GC's will
163 be done less often and take less time in the resulting core file. See
164 EXT:PURIFY.
165
166 :root-structures
167 This should be a list of the main entry points in any newly loaded
168 systems. This need not be supplied, but locality and/or GC performance
169 will be better if they are. Meaningless if :purify is NIL. See EXT:PURIFY.
170
171 :environment-name
172 Also passed to EXT:PURIFY when :PURIFY is T. Rarely used.
173
174 :init-function
175 This is the function that starts running when the created core file is
176 resumed. The default function simply invokes the top level
177 read-eval-print loop. If the function returns the lisp will exit.
178
179 :load-init-file
180 If true, then look for an init file when the core file is resumed.
181 Look for home:init first and then home:.cmucl-init. No error if
182 there is no init file.
183
184 :site-init
185 If true, then the name of the site init file to load. The default is
186 library:site-init. No error if this does not exist.
187
188 :print-herald
189 If true (the default), print out the lisp system herald when starting.
190
191 :process-command-line
192 If true (the default), process command-line switches via the normal
193 mechanisms, otherwise ignore all switches (except those processed by the
194 C startup code).
195
196 :executable
197 If nil (the default), save-lisp will save using the traditional
198 core-file format. If true, save-lisp will create an executable
199 file that contains the lisp image built in.
200 (Not all architectures support this yet.)
201
202 :batch-mode
203 If nil (the default), then the presence of the -batch command-line
204 switch will invoke batch-mode processing. If true, the produced core
205 will always be in batch-mode, regardless of any command-line switches."
206
207 (unless (probe-file (directory-namestring core-file-name))
208 (error 'simple-file-error
209 :format-control (intl:gettext "Directory ~S does not exist")
210 :format-arguments (list (directory-namestring core-file-name))))
211
212 #+mp (mp::shutdown-multi-processing)
213 (when (fboundp 'eval:flush-interpreted-function-cache)
214 (eval:flush-interpreted-function-cache))
215 (when (fboundp 'cancel-finalization)
216 (cancel-finalization sys:*tty*))
217
218 #+:executable
219 (when executable
220 ;; Only do this when dumping an executable Lisp. Otherwise
221 ;; worldload will make us lose because it clears the search lists.
222 ;; If we are dumping an executable lisp image, we want to keep
223 ;; track of the library search list across dumps because the
224 ;; normal way for figuring out the library paths from arg[0] is
225 ;; almost guaranteed to be wrong for executables.
226 (setf *old-cmucl-library-search-list* (search-list "library:")))
227
228 (if purify
229 (purify :root-structures root-structures
230 :environment-name environment-name)
231 #-gencgc (gc) #+gencgc (gc :full t))
232 (dolist (f *before-save-initializations*) (funcall f))
233 (setq ext:*batch-mode* (if batch-mode t nil))
234 (labels
235 ((%restart-lisp ()
236 (with-simple-restart (abort (intl:gettext "Skip remaining initializations."))
237 (catch 'top-level-catcher
238 (reinit)
239 (environment-init)
240 (dolist (f *after-save-initializations*) (funcall f))
241 (intl::setlocale)
242 (when process-command-line
243 (ext::process-command-strings))
244 (setf *editor-lisp-p* nil)
245 (macrolet ((find-switch (name)
246 `(find ,name *command-line-switches*
247 :key #'cmd-switch-name
248 :test #'(lambda (x y)
249 (declare (simple-string x y))
250 (string-equal x y)))))
251 (when (and process-command-line (find-switch "quiet"))
252 (setq *load-verbose* nil
253 *compile-verbose* nil
254 *compile-print* nil
255 *compile-progress* nil
256 *require-verbose* nil
257 *gc-verbose* nil
258 *herald-items* nil))
259 (when (and process-command-line
260 (or (find-switch "help")
261 (find-switch "-help")))
262 ;; Don't load any init files if -help or --help is given
263 (setf site-init nil)
264 (setf load-init-file nil))
265 (when (and site-init
266 (not (and process-command-line
267 (find-switch "nositeinit"))))
268 (load site-init :if-does-not-exist nil :verbose nil))
269 (when (and process-command-line (find-switch "edit"))
270 (setf *editor-lisp-p* t))
271 (when (and load-init-file
272 (not (and process-command-line
273 (find-switch "noinit"))))
274 (let* ((cl-switch (find-switch "init"))
275 (name (and cl-switch
276 (or (cmd-switch-value cl-switch)
277 (car (cmd-switch-words cl-switch))))))
278 (if name
279 (load (merge-pathnames name #p"home:")
280 :if-does-not-exist nil)
281 (or (load "home:init" :if-does-not-exist nil)
282 (load "home:.cmucl-init"
283 :if-does-not-exist nil))))))
284 (when process-command-line
285 (ext::invoke-switch-demons *command-line-switches*
286 *command-switch-demons*))
287 (when print-herald
288 (print-herald))))
289 (funcall init-function))
290 (restart-lisp ()
291 (unix:unix-exit
292 (catch '%end-of-the-world
293 (unwind-protect
294 (if *batch-mode*
295 (handler-case
296 (%restart-lisp)
297 (error (cond)
298 (format *error-output* (intl:gettext "Error in batch processing:~%~A~%")
299 cond)
300 (throw '%end-of-the-world 1)))
301 (%restart-lisp))
302 (finish-standard-output-streams))))))
303
304 ;; Record dump time and host
305 (setq *cmucl-core-dump-time* (get-universal-time))
306 (setq *cmucl-core-dump-host* (machine-instance))
307
308 (let ((initial-function (get-lisp-obj-address #'restart-lisp))
309 (core-name (unix-namestring core-file-name nil)))
310 (without-gcing
311 #+:executable
312 (if executable
313 (save-executable core-name initial-function)
314 (save core-name initial-function #+sse2 1 #-sse2 0))
315 #-:executable
316 (save core-name initial-function #+sse2 1 #-sse2 0))))
317 nil)
318
319
320
321 ;;;; PRINT-HERALD support.
322
323 (defvar *herald-items* ()
324 "Determines what PRINT-HERALD prints (the system startup banner.) This is a
325 database which can be augmented by each loaded system. The format is a
326 property list which maps from subsystem names to the banner information for
327 that system. This list can be manipulated with GETF -- entries are printed
328 in, reverse order, so the newest entry is printed last. Usually the system
329 feature keyword is used as the system name. A given banner is a list of
330 strings and functions (or function names). Strings are printed, and
331 functions are called with an output stream argument.")
332
333 (setf (getf *herald-items* :common-lisp)
334 `("CMU Common Lisp "
335 ,#'(lambda (stream)
336 (write-string (lisp-implementation-version) stream))
337 ,#'(lambda (stream)
338 (write-string (intl:gettext ", running on ") stream))
339 ,#'(lambda (stream) (write-string (machine-instance) stream))
340 terpri
341 ,#'(lambda (stream)
342 (let ((core (if (boundp '*cmucl-core-path*)
343 (truename *cmucl-core-path*)
344 nil))
345 (dump-time (if (boundp '*cmucl-core-dump-time*)
346 *cmucl-core-dump-time*
347 nil)))
348 (when core
349 (write-string (intl:gettext "With core: ") stream)
350 (write-line (namestring core) stream))
351 (when dump-time
352 (write-string (intl:gettext "Dumped on: ") stream)
353 (ext:format-universal-time stream dump-time :style :iso8601)
354 (write-string (intl:gettext " on ") stream)
355 (write-line *cmucl-core-dump-host* stream))))
356 ))
357
358 (setf (getf *herald-items* :bugs)
359 `(,#'(lambda (stream)
360 (write-string (intl:gettext "See <http://www.cons.org/cmucl/> for support information.") stream))
361 terpri
362 ,#'(lambda (stream)
363 (write-string (intl:gettext "Loaded subsystems:") stream))))
364
365 #+unicode
366 (setf (getf *herald-items* :unicode)
367 `(,#'(lambda (stream)
368 (write-string _" Unicode " stream))
369 ,(if (and (boundp 'lisp::*unidata-version*)
370 (>= (length lisp::*unidata-version*) 11))
371 (subseq lisp::*unidata-version* 11
372 (1- (length lisp::*unidata-version*)))
373 " ")
374 ,#'(lambda (stream)
375 (write-string _"with Unicode version " stream))
376 ,#'(lambda (stream)
377 (princ lisp::+unicode-major-version+ stream)
378 (write-char #\. stream)
379 (princ lisp::+unicode-minor-version+ stream)
380 (write-char #\. stream)
381 (princ lisp::+unicode-update-version+ stream))
382 terpri))
383
384 ;;; PRINT-HERALD -- Public
385 ;;;
386 (defun print-herald (&optional (stream *standard-output*))
387 "Print some descriptive information about the Lisp system version and
388 configuration."
389 (let ((res ()))
390 (do ((item *herald-items* (cddr item)))
391 ((null item))
392 (push (second item) res))
393
394 (fresh-line stream)
395 (dolist (item res)
396 (dolist (thing item)
397 (typecase thing
398 (string
399 (write-string thing stream))
400 (function (funcall thing stream))
401 ((or symbol cons)
402 (funcall (fdefinition thing) stream))
403 (t
404 (error (intl:gettext "Unrecognized *HERALD-ITEMS* entry: ~S.") thing))))
405 (fresh-line stream)))
406
407 (values))
408
409
410 ;;;; Random functions used by worldload.
411
412 (defun assert-user-package ()
413 (unless (eq *package* (find-package "CL-USER"))
414 (error (intl:gettext "Change *PACKAGE* to the USER package and try again."))))
415
416 ;;; MAYBE-BYTE-LOAD -- Interface
417 ;;;
418 ;;; If Name has been byte-compiled, and :runtime is a feature, then load the
419 ;;; byte-compiled version, otherwise just do normal load.
420 ;;;
421 (defun maybe-byte-load (name &optional (load-native t))
422 (let ((bname (make-pathname
423 :defaults name
424 :type #.(c:backend-byte-fasl-file-type c:*target-backend*))))
425 (cond ((and (featurep :runtime)
426 (probe-file bname))
427 (load bname))
428 (load-native
429 (load name)))))
430
431
432 ;;; BYTE-LOAD-OVER -- Interface
433 ;;;
434 ;;; Replace a cold-loaded native object file with a byte-compiled one, if it
435 ;;; exists.
436 ;;;
437 (defun byte-load-over (name)
438 (load (make-pathname
439 :defaults name
440 :type #.(c:backend-byte-fasl-file-type c:*target-backend*))
441 :if-does-not-exist nil))

  ViewVC Help
Powered by ViewVC 1.1.5