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

Contents of /src/code/save.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.65 - (show annotations)
Wed Oct 14 03:42:21 2009 UTC (4 years, 6 months ago) by agoncharov
Branch: MAIN
CVS Tags: amd64-dd-start, intl-2-branch-base, pre-merge-intl-branch, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, snapshot-2009-11, snapshot-2009-12, intl-branch-base
Branch point for: amd64-dd-branch, intl-branch, intl-2-branch
Changes since 1.64: +2 -7 lines
As suggested by Madhu <madhu@cs.unm.edu>, removed the ext:getenv
function that I had introduced a few days ago.  Instead, four foreign
function definitions are introduced, following Madhu's proposal.

The four functions:

   unix-getenv unix-setenv unix-putenv unix-unsetenv

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

  ViewVC Help
Powered by ViewVC 1.1.5