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

Contents of /src/code/save.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.37 - (show annotations)
Thu Aug 24 19:55:29 2000 UTC (13 years, 8 months ago) by dtc
Branch: MAIN
Changes since 1.36: +42 -37 lines
o Based on suggestions from Martin Cracauer, flush commonly used output
  streams during the processing of command line switches and upon exit.
  This is a convenience for typical usage, and not all output streams
  are flushed, so important streams should still be flushed but user code.

o Add a new function finish-standard-output-streams to finish output on
  the commonly used output streams. Called after the processing
  of each command line switch, and before the %end-of-the-world.

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

  ViewVC Help
Powered by ViewVC 1.1.5