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

Contents of /src/code/save.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5