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

Contents of /src/code/save.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5