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

Contents of /src/code/save.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.53 - (show annotations)
Wed Apr 26 20:49:23 2006 UTC (7 years, 11 months ago) by rtoy
Branch: MAIN
CVS Tags: double-double-array-base, double-double-init-sparc-2, double-double-base, snapshot-2007-05, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, snapshot-2007-01, snapshot-2007-02, release-19d, double-double-init-ppc, double-double-init-%make-sparc, snapshot-2007-03, snapshot-2007-04, snapshot-2007-07, snapshot-2007-06, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, double-double-irrat-end, release-19d-pre2, release-19d-pre1, double-double-init-checkpoint-1, double-double-reader-base, double-double-init-x86, double-double-sparc-checkpoint-1, double-double-irrat-start, snapshot-2006-06, snapshot-2006-07, snapshot-2006-05, snapshot-2006-08, snapshot-2006-09
Branch point for: double-double-reader-branch, double-double-array-branch, release-19d-branch, double-double-branch
Changes since 1.52: +4 -2 lines
src/save.lisp:
o Add new search-list "ld-library-path:" which contains the value of
  the environment variable "LD_LIBRARY_PATH".

src/foreign.lisp:
o Modify LOAD-FOREIGN so that we will try to load a single file as a
  shared library first.  If that fails, we try loading it as an object
  file.  We do not try to see if the library exists (via probe-file or
  anything).  Instead we let dlopen do whatever it would normally do
  to find the file, including searching LD_LIBRARY_PATH.

o REINITIALIZE-GLOBAL-TABLE now has a few restarts to allow the user
  to decide what to do if a shared library cannot be found.  The
  restarts are ignoring the problem, trying to reload the file again,
  or specifying a new path.

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

  ViewVC Help
Powered by ViewVC 1.1.5