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

Contents of /src/code/save.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5