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

Contents of /src/code/save.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.28 - (show annotations)
Wed May 8 02:02:37 1996 UTC (17 years, 11 months ago) by ram
Branch: MAIN
Changes since 1.27: +45 -44 lines
Fixed batch-mode stuff to have a chance of working.
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.28 1996/05/08 02:02:37 ram 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 #-mach "/usr/local/lib/cmucl/lib/"))))
96
97
98
99 ;;;; SAVE-LISP itself.
100
101 (alien:def-alien-routine "save" (alien:boolean)
102 (file c-call:c-string)
103 (initial-function (alien:unsigned #.vm:word-bits)))
104
105 (defun save-lisp (core-file-name &key
106 (purify t)
107 (root-structures ())
108 (environment-name "Auxiliary")
109 (init-function #'%top-level)
110 (load-init-file t)
111 (site-init "library:site-init")
112 (print-herald t)
113 (process-command-line t))
114 "Saves a CMU Common Lisp core image in the file of the specified name. The
115 following keywords are defined:
116
117 :purify
118 If true (the default), do a purifying GC which moves all dynamically
119 allocated objects into static space so that they stay pure. This takes
120 somewhat longer than the normal GC which is otherwise done, but GC's will
121 done less often and take less time in the resulting core file. See
122 EXT:PURIFY.
123
124 :root-structures
125 This should be a list of the main entry points in any newly loaded
126 systems. This need not be supplied, but locality and/or GC performance
127 will be better if they are. Meaningless if :purify is NIL. See EXT:PURIFY.
128
129 :environment-name
130 Also passed to EXT:PURIFY when :PURIFY is T. Rarely used.
131
132 :init-function
133 This is the function that starts running when the created core file is
134 resumed. The default function simply invokes the top level
135 read-eval-print loop. If the function returns the lisp will exit.
136
137 :load-init-file
138 If true, then look for an init.lisp or init.fasl file when the core
139 file is resumed.
140
141 :site-init
142 If true, then the name of the site init file to load. The default is
143 library:site-init. No error if this does not exist.
144
145 :print-herald
146 If true (the default), print out the lisp system herald when starting."
147
148 (when (fboundp 'eval:flush-interpreted-function-cache)
149 (eval:flush-interpreted-function-cache))
150 (if purify
151 (purify :root-structures root-structures
152 :environment-name environment-name)
153 (gc))
154 (dolist (f *before-save-initializations*) (funcall f))
155 (flet
156 ((restart-lisp ()
157 (unix:unix-exit
158 (catch '%end-of-the-world
159 (with-simple-restart (abort "Skip remaining initializations.")
160 (catch 'top-level-catcher
161 (reinit)
162 (dolist (f *after-save-initializations*) (funcall f))
163 (environment-init)
164 (when site-init
165 (load site-init :if-does-not-exist nil :verbose nil))
166 (when process-command-line
167 (ext::process-command-strings))
168 (setf *editor-lisp-p* nil)
169 (macrolet ((find-switch (name)
170 `(find ,name *command-line-switches*
171 :key #'cmd-switch-name
172 :test #'(lambda (x y)
173 (declare (simple-string x y))
174 (string-equal x y)))))
175 (when (and process-command-line (find-switch "edit"))
176 (setf *editor-lisp-p* t))
177 (when (and load-init-file
178 (not (and process-command-line
179 (find-switch "noinit"))))
180 (let* ((cl-switch (find-switch "init"))
181 (name (and cl-switch
182 (or (cmd-switch-value cl-switch)
183 (car (cmd-switch-words
184 cl-switch))))))
185 (if name
186 (load (merge-pathnames name #p"home:")
187 :if-does-not-exist nil)
188 (or (load "home:init" :if-does-not-exist nil)
189 (load "home:.cmucl-init"
190 :if-does-not-exist nil))))))
191 (when process-command-line
192 (ext::invoke-switch-demons *command-line-switches*
193 *command-switch-demons*))
194 (when print-herald
195 (print-herald))))
196 (funcall (if (and *batch-mode* (eq init-function #'%top-level))
197 #'%handled-top-level
198 init-function))))))
199
200 (let ((initial-function (get-lisp-obj-address #'restart-lisp)))
201 (without-gcing
202 (save (unix-namestring core-file-name nil) initial-function))))
203 nil)
204
205
206
207 ;;;; PRINT-HERALD support.
208
209 (defvar *herald-items* ()
210 "Determines what PRINT-HERALD prints (the system startup banner.) This is a
211 database which can be augmented by each loaded system. The format is a
212 property list which maps from subsystem names to the banner information for
213 that system. This list can be manipulated with GETF -- entries are printed
214 in, reverse order, so the newest entry is printed last. Usually the system
215 feature keyword is used as the system name. A given banner is a list of
216 strings and functions (or function names). Strings are printed, and
217 functions are called with an output stream argument.")
218
219 (setf (getf *herald-items* :common-lisp)
220 `("CMU Common Lisp "
221 ,#'(lambda (stream)
222 (write-string (lisp-implementation-version) stream))
223 ", running on "
224 ,#'(lambda (stream) (write-string (machine-instance) stream))))
225
226 (setf (getf *herald-items* :bugs)
227 '("Send bug reports and questions to cmucl-bugs@cs.cmu.edu."
228 terpri
229 "Loaded subsystems:"))
230
231 ;;; PRINT-HERALD -- Public
232 ;;;
233 (defun print-herald (&optional (stream *standard-output*))
234 "Print some descriptive information about the Lisp system version and
235 configuration."
236 (let ((res ()))
237 (do ((item *herald-items* (cddr item)))
238 ((null item))
239 (push (second item) res))
240
241 (fresh-line stream)
242 (dolist (item res)
243 (dolist (thing item)
244 (typecase thing
245 (string
246 (write-string thing stream))
247 (function (funcall thing stream))
248 ((or symbol cons)
249 (funcall (fdefinition thing) stream))
250 (t
251 (error "Unrecognized *HERALD-ITEMS* entry: ~S." thing))))
252 (fresh-line stream)))
253
254 (values))
255
256
257 ;;;; Random functions used by worldload.
258
259 (defun assert-user-package ()
260 (unless (eq *package* (find-package "USER"))
261 (error "Change *PACKAGE* to the USER package and try again.")))
262
263 ;;; MAYBE-BYTE-LOAD -- Interface
264 ;;;
265 ;;; If Name has been byte-compiled, and :runtime is a feature, then load the
266 ;;; byte-compiled version, otherwise just do normal load.
267 ;;;
268 (defun maybe-byte-load (name &optional (load-native t))
269 (let ((bname (make-pathname
270 :defaults name
271 :type #.(c:backend-byte-fasl-file-type c:*target-backend*))))
272 (cond ((and (featurep :runtime)
273 (probe-file bname))
274 (load bname))
275 (load-native
276 (load name)))))
277
278
279 ;;; BYTE-LOAD-OVER -- Interface
280 ;;;
281 ;;; Replace a cold-loaded native object file with a byte-compiled one, if it
282 ;;; exists.
283 ;;;
284 (defun byte-load-over (name)
285 (load (make-pathname
286 :defaults name
287 :type #.(c:backend-byte-fasl-file-type c:*target-backend*))
288 :if-does-not-exist nil))

  ViewVC Help
Powered by ViewVC 1.1.5