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

Contents of /src/code/save.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5