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

Contents of /src/code/save.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.17 - (show annotations)
Wed Apr 28 01:56:52 1993 UTC (20 years, 11 months ago) by wlott
Branch: MAIN
Changes since 1.16: +62 -43 lines
Changed core saving to no longer save the stacks.  Instead, when the core
is restored, a (supplied) initial function is invoked which can do whatever
kind of setup it wants.  This makes a saved lisp totally independent of the
location of the C stack.
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.17 1993/04/28 01:56:52 wlott 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 '("/usr/misc/.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 (constants nil)
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, do a purifying GC which moves all dynamically allocated
120 objects into static space so that they stay pure. This takes somewhat
121 longer than the normal GC which is otherwise done, but GC's will done
122 less often and take less time in the resulting core file.
123
124 :root-structures
125 :constants
126 These should be a list of the main entry points in any newly loaded
127 systems and a list of any large data structures that will never again
128 be changed. These need not be supplied, but locality and/or GC performance
129 will be better if they are. They are meaningless if :purify is NIL.
130
131 :init-function
132 This is a function which is called when the created core file is
133 resumed. The default function simply invokes the top level
134 read-eval-print loop. If the function returns the lisp will exit.
135
136 :load-init-file
137 If true, then look for an init.lisp or init.fasl file when the core
138 file is resumed.
139
140 :site-init
141 If true, then the name of the site init file to load. The default is
142 library:site-init. No error if this does not exist.
143
144 :print-herald
145 If true, print out the lisp system herald when starting."
146
147 (when (fboundp 'eval:flush-interpreted-function-cache)
148 (eval:flush-interpreted-function-cache))
149 (if purify
150 (purify :root-structures root-structures :constants constants)
151 (gc))
152 (flet
153 ((restart-lisp ()
154 (catch '%end-of-the-world
155 (with-simple-restart (abort "Skip remaining initializations.")
156 (catch 'top-level-catcher
157 (reinit)
158 (dolist (f *before-save-initializations*) (funcall f))
159 (dolist (f *after-save-initializations*) (funcall f))
160 (environment-init)
161 (when site-init
162 (load site-init :if-does-not-exist nil :verbose nil))
163 (when process-command-line
164 (ext::process-command-strings))
165 (setf *editor-lisp-p* nil)
166 (macrolet ((find-switch (name)
167 `(find ,name *command-line-switches*
168 :key #'cmd-switch-name
169 :test #'(lambda (x y)
170 (declare (simple-string x y))
171 (string-equal x y)))))
172 (when (and process-command-line (find-switch "edit"))
173 (setf *editor-lisp-p* t))
174 (when (and load-init-file
175 (not (and process-command-line
176 (find-switch "noinit"))))
177 (let* ((cl-switch (find-switch "init"))
178 (name (and cl-switch
179 (or (cmd-switch-value cl-switch)
180 (car (cmd-switch-words
181 cl-switch))))))
182 (if name
183 (load (merge-pathnames name #p"home:")
184 :if-does-not-exist nil)
185 (or (load "home:init" :if-does-not-exist nil)
186 (load "home:.cmucl-init"
187 :if-does-not-exist nil))))))
188 (when process-command-line
189 (ext::invoke-switch-demons *command-line-switches*
190 *command-switch-demons*))
191 (when print-herald
192 (print-herald))))
193 (funcall init-function))
194 (unix:unix-exit 0)))
195 (let ((initial-function (get-lisp-obj-address #'restart-lisp)))
196 (without-gcing
197 (save (unix-namestring core-file-name nil) initial-function))))
198 nil)
199
200
201
202 ;;;; PRINT-HERALD support.
203
204 (defvar *herald-items* ()
205 "Determines what PRINT-HERALD prints (the system startup banner.) This is a
206 database which can be augmented by each loaded system. The format is a
207 property list which maps from subsystem names to the banner information for
208 that system. This list can be manipulated with GETF -- entries are printed
209 in, reverse order, so the newest entry is printed last. Usually the system
210 feature keyword is used as the system name. A given banner is a list of
211 strings and functions (or function names). Strings are printed, and
212 functions are called with an output stream argument.")
213
214 (setf (getf *herald-items* :common-lisp)
215 `("CMU Common Lisp "
216 ,#'(lambda (stream)
217 (write-string (lisp-implementation-version) stream))
218 ", running on "
219 ,#'(lambda (stream) (write-string (machine-instance) stream))))
220
221 (setf (getf *herald-items* :bugs)
222 '("Send bug reports and questions to cmucl-bugs@cs.cmu.edu."
223 terpri
224 "Loaded subsystems:"))
225
226 ;;; PRINT-HERALD -- Public
227 ;;;
228 (defun print-herald (&optional (stream *standard-output*))
229 "Print some descriptive information about the Lisp system version and
230 configuration."
231 (let ((res ()))
232 (do ((item *herald-items* (cddr item)))
233 ((null item))
234 (push (second item) res))
235
236 (fresh-line stream)
237 (dolist (item res)
238 (dolist (thing item)
239 (typecase thing
240 (string
241 (write-string thing stream))
242 (function (funcall thing stream))
243 ((or symbol cons)
244 (funcall (fdefinition thing) stream))
245 (t
246 (error "Unrecognized *HERALD-ITEMS* entry: ~S." thing))))
247 (fresh-line stream)))
248
249 (values))
250
251
252 ;;;; Random functions used by worldload.
253
254 (defun assert-user-package ()
255 (unless (eq *package* (find-package "USER"))
256 (error "Change *PACKAGE* to the USER package and try again.")))

  ViewVC Help
Powered by ViewVC 1.1.5