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

Contents of /src/code/save.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.15 - (show annotations)
Mon May 25 21:37:20 1992 UTC (21 years, 10 months ago) by ram
Branch: MAIN
Changes since 1.14: +47 -20 lines
Defined new parameterized PRINT-HERALD, exported *HERALD-ITEMS*.
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.15 1992/05/25 21:37:20 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 (alien:def-alien-routine "save" (alien:boolean)
51 (file c-call:c-string))
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-list (var)
60 (let ((path (cdr (assoc var ext::*environment-list*))))
61 (when path
62 (do* ((i 0 (1+ p))
63 (p (position #\: path :start i)
64 (position #\: path :start i))
65 (pl ()))
66 ((null p)
67 (let ((s (subseq path i)))
68 (if (string= s "")
69 (push "default:" pl)
70 (push (concatenate 'simple-string s "/") pl)))
71 (nreverse pl))
72 (let ((s (subseq path i p)))
73 (if (string= s "")
74 (push "default:" pl)
75 (push (concatenate 'simple-string s "/") pl)))))))
76
77
78 ;;; ENVIRONMENT-INIT -- Internal
79 ;;;
80 ;;; Parse the LISP-ENVIRONMENT-LIST into a keyword alist. Set up default
81 ;;; search lists.
82 ;;;
83 (defun environment-init ()
84 (dolist (ele lisp-environment-list)
85 (let ((=pos (position #\= (the simple-string ele))))
86 (when =pos
87 (push (cons (intern (string-upcase (subseq ele 0 =pos))
88 *keyword-package*)
89 (subseq ele (1+ =pos)))
90 *environment-list*))))
91 (setf (search-list "default:") (list (default-directory)))
92 (setf (search-list "path:") (parse-unix-search-list :path))
93 (setf (search-list "home:")
94 (or (parse-unix-search-list :home)
95 (list (default-directory))))
96
97 (setf (search-list "library:")
98 (or (parse-unix-search-list :cmucllib)
99 '("/usr/misc/.cmucl/lib/"))))
100
101 (defun save-lisp (core-file-name &key
102 (purify t)
103 (root-structures ())
104 (constants nil)
105 (init-function
106 #'(lambda ()
107 (throw 'top-level-catcher nil)))
108 (load-init-file t)
109 (site-init "library:site-init")
110 (print-herald t)
111 (process-command-line t))
112 "Saves a CMU Common Lisp core image in the file of the specified name. The
113 following keywords are defined:
114
115 :purify
116 If true, do a purifying GC which moves all dynamically allocated
117 objects into static space so that they stay pure. This takes somewhat
118 longer than the normal GC which is otherwise done, but GC's will done
119 less often and take less time in the resulting core file.
120
121 :root-structures
122 :constants
123 These should be a list of the main entry points in any newly loaded
124 systems and a list of any large data structures that will never again
125 be changed. These need not be supplied, but locality and/or GC performance
126 will be better if they are. They are meaningless if :purify is NIL.
127
128 :init-function
129 This is a function which is called when the created core file is
130 resumed. The default function simply aborts to the top level
131 read-eval-print loop. If the function returns it will be the value
132 of Save-Lisp.
133
134 :load-init-file
135 If true, then look for an init.lisp or init.fasl file when the core
136 file is resumed.
137
138 :site-init
139 If true, then the name of the site init file to load. The default is
140 library:site-init. No error if this does not exist.
141
142 :print-herald
143 If true, print out the lisp system herald when starting."
144
145 (when (fboundp 'eval:flush-interpreted-function-cache)
146 (eval:flush-interpreted-function-cache))
147 (if purify
148 (purify :root-structures root-structures :constants constants)
149 (gc))
150 (unless (save (unix-namestring core-file-name nil))
151 (reinit)
152 (dolist (f *before-save-initializations*) (funcall f))
153 (dolist (f *after-save-initializations*) (funcall f))
154 (environment-init)
155 (when site-init (load site-init :if-does-not-exist nil :verbose nil))
156 (when process-command-line (ext::process-command-strings))
157 (setf *editor-lisp-p* nil)
158 (macrolet ((find-switch (name)
159 `(find ,name *command-line-switches*
160 :key #'cmd-switch-name
161 :test #'(lambda (x y)
162 (declare (simple-string x y))
163 (string-equal x y)))))
164 (when (and process-command-line (find-switch "edit"))
165 (setf *editor-lisp-p* t))
166 (when (and load-init-file
167 (not (and process-command-line (find-switch "noinit"))))
168 (let* ((cl-switch (find-switch "init"))
169 (name (and cl-switch
170 (or (cmd-switch-value cl-switch)
171 (car (cmd-switch-words cl-switch))))))
172 (if name
173 (load (merge-pathnames name #p"home:") :if-does-not-exist nil)
174 (or (load "home:init" :if-does-not-exist nil)
175 (load "home:.cmucl-init" :if-does-not-exist nil))))))
176 (when process-command-line
177 (ext::invoke-switch-demons *command-line-switches*
178 *command-switch-demons*))
179 (when print-herald
180 (print-herald))
181 (funcall init-function)))
182
183
184 (defvar *herald-items* ()
185 "Determines what PRINT-HERALD prints (the system startup banner.) This is a
186 database which can be augmented by each loaded system. The format is a
187 property list which maps from subsystem names to the banner information for
188 that system. This list can be manipulated with GETF -- entries are printed
189 in, reverse order, so the newest entry is printed last. Usually the system
190 feature keyword is used as the system name. A given banner is a list of
191 strings and functions (or function names). Strings are printed, and
192 functions are called with an output stream argument.")
193
194 (setf (getf *herald-items* :common-lisp)
195 `("CMU Common Lisp "
196 ,#'(lambda (stream)
197 (write-string (lisp-implementation-version) stream))
198 ", running on "
199 ,#'(lambda (stream) (write-string (machine-instance) stream))))
200
201 (setf (getf *herald-items* :bugs)
202 '("Send bug reports and questions to cmucl-bugs@cs.cmu.edu."
203 terpri
204 "Loaded subsystems:"))
205
206 ;;; PRINT-HERALD -- Public
207 ;;;
208 (defun print-herald (&optional (stream *standard-output*))
209 "Print some descriptive information about the Lisp system version and
210 configuration."
211 (let ((res ()))
212 (do ((item *herald-items* (cddr item)))
213 ((null item))
214 (push (second item) res))
215
216 (fresh-line stream)
217 (dolist (item res)
218 (dolist (thing item)
219 (typecase thing
220 (string
221 (write-string thing stream))
222 (function (funcall thing stream))
223 ((or symbol cons)
224 (funcall (fdefinition thing) stream))
225 (t
226 (error "Unrecognized *HERALD-ITEMS* entry: ~S." thing))))
227 (fresh-line stream)))
228
229 (values))
230
231
232 ;;;; Random functions used by worldload.
233
234 (defun assert-user-package ()
235 (unless (eq *package* (find-package "USER"))
236 (error "Change *PACKAGE* to the USER package and try again.")))

  ViewVC Help
Powered by ViewVC 1.1.5