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

Contents of /src/code/save.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.45 - (hide annotations)
Wed Jan 29 19:47:47 2003 UTC (11 years, 2 months ago) by toy
Branch: MAIN
Changes since 1.44: +34 -18 lines
o Adds support for searching for the lisp.core file based on the
  location of the lisp C binary, when CMUCLLIB is not given, and the
  core file is not specified.
o Add support for a CMUCLCORE envvar, and a -lib option for setting
  the path for the library: search-list.
o Added some spare static symbols for the sparc port so we don't have
  to cross-compile again for a while.

See cmucl-imp archives for some more details.
1 ram 1.1 ;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.5 ;;; 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 toy 1.45 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/save.lisp,v 1.45 2003/01/29 19:47:47 toy Exp $")
9 ram 1.5 ;;;
10 ram 1.1 ;;; **********************************************************************
11     ;;;
12 wlott 1.2 ;;; Dump the current lisp image into a core file. All the real work is done
13 ram 1.8 ;;; be C. Also contains various high-level initialization stuff: loading init
14     ;;; files and parsing environment variables.
15 wlott 1.2 ;;;
16     ;;; Written by William Lott.
17 ram 1.1 ;;;
18     ;;;
19     (in-package "LISP")
20    
21     (in-package "EXTENSIONS")
22 ram 1.15 (export '(print-herald *herald-items* save-lisp *before-save-initializations*
23 wlott 1.2 *after-save-initializations* *environment-list* *editor-lisp-p*))
24 ram 1.1 (in-package "LISP")
25    
26 wlott 1.2 (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 ram 1.1
31 wlott 1.2 (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 ram 1.1
36 wlott 1.2 (defvar *environment-list* nil
37     "An alist mapping environment variables (as keywords) to either values")
38 ram 1.1
39 wlott 1.2 (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 ram 1.1 (defvar lisp-environment-list)
46 toy 1.45 (defvar *cmucl-lib*) ; Essentially the envvar CMUCLLIB, where available
47     (defvar *cmucl-core-path*) ; Path to where the Lisp core file was found.
48 ram 1.1
49    
50 ram 1.8 ;;; 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 toy 1.45 (defun parse-unix-search-path (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 ram 1.8 (defun parse-unix-search-list (var)
72     (let ((path (cdr (assoc var ext::*environment-list*))))
73     (when path
74 toy 1.45 (parse-unix-search-path path))))
75 ram 1.8
76    
77     ;;; ENVIRONMENT-INIT -- Internal
78     ;;;
79     ;;; Parse the LISP-ENVIRONMENT-LIST into a keyword alist. Set up default
80     ;;; search lists.
81     ;;;
82     (defun environment-init ()
83 ram 1.16 (setq *environment-list* ())
84 ram 1.8 (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 ram 1.10 (setf (search-list "home:")
94     (or (parse-unix-search-list :home)
95     (list (default-directory))))
96    
97 ram 1.9 (setf (search-list "library:")
98 toy 1.45 (if (boundp '*cmucl-lib*)
99     (parse-unix-search-path *cmucl-lib*)
100 pmai 1.41 '("/usr/local/lib/cmucl/lib/")))
101 toy 1.44 (setf (search-list "modules:") '("library:subsystems/")))
102 ram 1.8
103 wlott 1.17
104    
105     ;;;; SAVE-LISP itself.
106    
107     (alien:def-alien-routine "save" (alien:boolean)
108     (file c-call:c-string)
109     (initial-function (alien:unsigned #.vm:word-bits)))
110    
111 wlott 1.2 (defun save-lisp (core-file-name &key
112     (purify t)
113     (root-structures ())
114 ram 1.21 (environment-name "Auxiliary")
115 ram 1.28 (init-function #'%top-level)
116 wlott 1.2 (load-init-file t)
117 ram 1.8 (site-init "library:site-init")
118 wlott 1.2 (print-herald t)
119 pmai 1.43 (process-command-line t)
120     (batch-mode nil))
121 wlott 1.2 "Saves a CMU Common Lisp core image in the file of the specified name. The
122     following keywords are defined:
123    
124     :purify
125 ram 1.18 If true (the default), do a purifying GC which moves all dynamically
126     allocated objects into static space so that they stay pure. This takes
127     somewhat longer than the normal GC which is otherwise done, but GC's will
128 toy 1.45 be done less often and take less time in the resulting core file. See
129 ram 1.21 EXT:PURIFY.
130 wlott 1.2
131     :root-structures
132 ram 1.21 This should be a list of the main entry points in any newly loaded
133     systems. This need not be supplied, but locality and/or GC performance
134     will be better if they are. Meaningless if :purify is NIL. See EXT:PURIFY.
135    
136     :environment-name
137     Also passed to EXT:PURIFY when :PURIFY is T. Rarely used.
138 wlott 1.2
139     :init-function
140 ram 1.18 This is the function that starts running when the created core file is
141 wlott 1.17 resumed. The default function simply invokes the top level
142     read-eval-print loop. If the function returns the lisp will exit.
143 wlott 1.2
144     :load-init-file
145     If true, then look for an init.lisp or init.fasl file when the core
146     file is resumed.
147 ram 1.8
148     :site-init
149     If true, then the name of the site init file to load. The default is
150     library:site-init. No error if this does not exist.
151    
152 wlott 1.2 :print-herald
153 pmai 1.43 If true (the default), print out the lisp system herald when starting.
154    
155     :process-command-line
156     If true (the default), process command-line switches via the normal
157     mechanisms, otherwise ignore all switches (except those processed by the
158     C startup code).
159    
160     :batch-mode
161     If nil (the default), then the presence of the -batch command-line
162     switch will invoke batch-mode processing. If true, the produced core
163     will always be in batch-mode, regardless of any command-line switches."
164 ram 1.4
165 dtc 1.33 #+mp (mp::shutdown-multi-processing)
166 ram 1.8 (when (fboundp 'eval:flush-interpreted-function-cache)
167     (eval:flush-interpreted-function-cache))
168 dtc 1.31 (when (fboundp 'cancel-finalization)
169     (cancel-finalization sys:*tty*))
170 wlott 1.2 (if purify
171 ram 1.21 (purify :root-structures root-structures
172     :environment-name environment-name)
173 dtc 1.32 #-gencgc (gc) #+gencgc (gc :full t))
174 ram 1.23 (dolist (f *before-save-initializations*) (funcall f))
175 pmai 1.43 (setq ext:*batch-mode* (if batch-mode t nil))
176 dtc 1.38 (labels
177     ((%restart-lisp ()
178     (with-simple-restart (abort "Skip remaining initializations.")
179     (catch 'top-level-catcher
180     (reinit)
181     (environment-init)
182     (dolist (f *after-save-initializations*) (funcall f))
183     (when process-command-line
184     (ext::process-command-strings))
185     (setf *editor-lisp-p* nil)
186     (macrolet ((find-switch (name)
187     `(find ,name *command-line-switches*
188     :key #'cmd-switch-name
189     :test #'(lambda (x y)
190     (declare (simple-string x y))
191     (string-equal x y)))))
192 pmai 1.42 (when (and site-init
193     (not (and process-command-line
194     (find-switch "nositeinit"))))
195 dtc 1.38 (load site-init :if-does-not-exist nil :verbose nil))
196     (when (and process-command-line (find-switch "edit"))
197     (setf *editor-lisp-p* t))
198     (when (and load-init-file
199     (not (and process-command-line
200     (find-switch "noinit"))))
201     (let* ((cl-switch (find-switch "init"))
202     (name (and cl-switch
203     (or (cmd-switch-value cl-switch)
204     (car (cmd-switch-words cl-switch))))))
205     (if name
206     (load (merge-pathnames name #p"home:")
207     :if-does-not-exist nil)
208     (or (load "home:init" :if-does-not-exist nil)
209     (load "home:.cmucl-init"
210     :if-does-not-exist nil))))))
211     (when process-command-line
212     (ext::invoke-switch-demons *command-line-switches*
213     *command-switch-demons*))
214     (when print-herald
215     (print-herald))))
216     (funcall init-function))
217     (restart-lisp ()
218 ram 1.28 (unix:unix-exit
219     (catch '%end-of-the-world
220 dtc 1.37 (unwind-protect
221 dtc 1.38 (if *batch-mode*
222     (handler-case
223     (%restart-lisp)
224     (error (cond)
225 dtc 1.39 (format *error-output* "Error in batch processing:~%~A~%"
226 dtc 1.38 cond)
227     (throw '%end-of-the-world 1)))
228     (%restart-lisp))
229 dtc 1.37 (finish-standard-output-streams))))))
230 ram 1.28
231 wlott 1.17 (let ((initial-function (get-lisp-obj-address #'restart-lisp)))
232     (without-gcing
233     (save (unix-namestring core-file-name nil) initial-function))))
234     nil)
235 wlott 1.2
236 wlott 1.17
237    
238     ;;;; PRINT-HERALD support.
239 wlott 1.2
240 ram 1.15 (defvar *herald-items* ()
241     "Determines what PRINT-HERALD prints (the system startup banner.) This is a
242     database which can be augmented by each loaded system. The format is a
243     property list which maps from subsystem names to the banner information for
244     that system. This list can be manipulated with GETF -- entries are printed
245     in, reverse order, so the newest entry is printed last. Usually the system
246     feature keyword is used as the system name. A given banner is a list of
247     strings and functions (or function names). Strings are printed, and
248     functions are called with an output stream argument.")
249    
250     (setf (getf *herald-items* :common-lisp)
251     `("CMU Common Lisp "
252     ,#'(lambda (stream)
253     (write-string (lisp-implementation-version) stream))
254     ", running on "
255 toy 1.45 ,#'(lambda (stream) (write-string (machine-instance) stream))
256     terpri
257     ,#'(lambda (stream)
258     (let ((core (if (boundp '*cmucl-core-path*)
259     (truename *cmucl-core-path*)
260     nil)))
261     (when core
262     (write-string "With core: " stream)
263     (write-string (namestring core) stream))))
264     terpri
265     ))
266 ram 1.15
267     (setf (getf *herald-items* :bugs)
268 dtc 1.35 '("Send questions to cmucl-help@cons.org. and bug reports to cmucl-imp@cons.org."
269 ram 1.15 terpri
270     "Loaded subsystems:"))
271    
272     ;;; PRINT-HERALD -- Public
273     ;;;
274     (defun print-herald (&optional (stream *standard-output*))
275     "Print some descriptive information about the Lisp system version and
276     configuration."
277     (let ((res ()))
278     (do ((item *herald-items* (cddr item)))
279     ((null item))
280     (push (second item) res))
281    
282     (fresh-line stream)
283     (dolist (item res)
284     (dolist (thing item)
285     (typecase thing
286     (string
287     (write-string thing stream))
288     (function (funcall thing stream))
289     ((or symbol cons)
290     (funcall (fdefinition thing) stream))
291     (t
292     (error "Unrecognized *HERALD-ITEMS* entry: ~S." thing))))
293     (fresh-line stream)))
294    
295 wlott 1.2 (values))
296    
297    
298     ;;;; Random functions used by worldload.
299    
300     (defun assert-user-package ()
301     (unless (eq *package* (find-package "USER"))
302     (error "Change *PACKAGE* to the USER package and try again.")))
303 ram 1.20
304     ;;; MAYBE-BYTE-LOAD -- Interface
305     ;;;
306     ;;; If Name has been byte-compiled, and :runtime is a feature, then load the
307     ;;; byte-compiled version, otherwise just do normal load.
308     ;;;
309     (defun maybe-byte-load (name &optional (load-native t))
310     (let ((bname (make-pathname
311     :defaults name
312     :type #.(c:backend-byte-fasl-file-type c:*target-backend*))))
313     (cond ((and (featurep :runtime)
314     (probe-file bname))
315     (load bname))
316     (load-native
317     (load name)))))
318    
319    
320     ;;; BYTE-LOAD-OVER -- Interface
321     ;;;
322     ;;; Replace a cold-loaded native object file with a byte-compiled one, if it
323     ;;; exists.
324     ;;;
325     (defun byte-load-over (name)
326     (load (make-pathname
327     :defaults name
328     :type #.(c:backend-byte-fasl-file-type c:*target-backend*))
329     :if-does-not-exist nil))

  ViewVC Help
Powered by ViewVC 1.1.5