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

Contents of /src/code/save.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.43 - (hide annotations)
Fri Jan 18 17:58:15 2002 UTC (12 years, 3 months ago) by pmai
Branch: MAIN
Changes since 1.42: +15 -3 lines
This change causes the *batch-mode* flag to be reset when saving a
core.  If the newly introduced :batch-mode argument to save-lisp is
supplied and is true, then the *batch-mode* flag is set to true,
otherwise it is set to false, before saving the core.  This should
prevent ugly surprises by newbies using -batch when dumping cores.
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.43 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/save.lisp,v 1.43 2002/01/18 17:58:15 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 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    
47    
48 ram 1.8 ;;; 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 ram 1.16 (setq *environment-list* ())
79 ram 1.8 (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 ram 1.10 (setf (search-list "home:")
89     (or (parse-unix-search-list :home)
90     (list (default-directory))))
91    
92 ram 1.9 (setf (search-list "library:")
93     (or (parse-unix-search-list :cmucllib)
94 pmai 1.41 '("/usr/local/lib/cmucl/lib/")))
95 pw 1.40 (setf (search-list "modules:") (ext:unix-namestring "library:subsystems/")))
96 ram 1.8
97 wlott 1.17
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 wlott 1.2 (defun save-lisp (core-file-name &key
106     (purify t)
107     (root-structures ())
108 ram 1.21 (environment-name "Auxiliary")
109 ram 1.28 (init-function #'%top-level)
110 wlott 1.2 (load-init-file t)
111 ram 1.8 (site-init "library:site-init")
112 wlott 1.2 (print-herald t)
113 pmai 1.43 (process-command-line t)
114     (batch-mode nil))
115 wlott 1.2 "Saves a CMU Common Lisp core image in the file of the specified name. The
116     following keywords are defined:
117    
118     :purify
119 ram 1.18 If true (the default), do a purifying GC which moves all dynamically
120     allocated objects into static space so that they stay pure. This takes
121     somewhat longer than the normal GC which is otherwise done, but GC's will
122 ram 1.21 done less often and take less time in the resulting core file. See
123     EXT:PURIFY.
124 wlott 1.2
125     :root-structures
126 ram 1.21 This should be a list of the main entry points in any newly loaded
127     systems. This need not be supplied, but locality and/or GC performance
128     will be better if they are. Meaningless if :purify is NIL. See EXT:PURIFY.
129    
130     :environment-name
131     Also passed to EXT:PURIFY when :PURIFY is T. Rarely used.
132 wlott 1.2
133     :init-function
134 ram 1.18 This is the function that starts running when the created core file is
135 wlott 1.17 resumed. The default function simply invokes the top level
136     read-eval-print loop. If the function returns the lisp will exit.
137 wlott 1.2
138     :load-init-file
139     If true, then look for an init.lisp or init.fasl file when the core
140     file is resumed.
141 ram 1.8
142     :site-init
143     If true, then the name of the site init file to load. The default is
144     library:site-init. No error if this does not exist.
145    
146 wlott 1.2 :print-herald
147 pmai 1.43 If true (the default), print out the lisp system herald when starting.
148    
149     :process-command-line
150     If true (the default), process command-line switches via the normal
151     mechanisms, otherwise ignore all switches (except those processed by the
152     C startup code).
153    
154     :batch-mode
155     If nil (the default), then the presence of the -batch command-line
156     switch will invoke batch-mode processing. If true, the produced core
157     will always be in batch-mode, regardless of any command-line switches."
158 ram 1.4
159 dtc 1.33 #+mp (mp::shutdown-multi-processing)
160 ram 1.8 (when (fboundp 'eval:flush-interpreted-function-cache)
161     (eval:flush-interpreted-function-cache))
162 dtc 1.31 (when (fboundp 'cancel-finalization)
163     (cancel-finalization sys:*tty*))
164 wlott 1.2 (if purify
165 ram 1.21 (purify :root-structures root-structures
166     :environment-name environment-name)
167 dtc 1.32 #-gencgc (gc) #+gencgc (gc :full t))
168 ram 1.23 (dolist (f *before-save-initializations*) (funcall f))
169 pmai 1.43 (setq ext:*batch-mode* (if batch-mode t nil))
170 dtc 1.38 (labels
171     ((%restart-lisp ()
172     (with-simple-restart (abort "Skip remaining initializations.")
173     (catch 'top-level-catcher
174     (reinit)
175     (environment-init)
176     (dolist (f *after-save-initializations*) (funcall f))
177     (when process-command-line
178     (ext::process-command-strings))
179     (setf *editor-lisp-p* nil)
180     (macrolet ((find-switch (name)
181     `(find ,name *command-line-switches*
182     :key #'cmd-switch-name
183     :test #'(lambda (x y)
184     (declare (simple-string x y))
185     (string-equal x y)))))
186 pmai 1.42 (when (and site-init
187     (not (and process-command-line
188     (find-switch "nositeinit"))))
189 dtc 1.38 (load site-init :if-does-not-exist nil :verbose nil))
190     (when (and process-command-line (find-switch "edit"))
191     (setf *editor-lisp-p* t))
192     (when (and load-init-file
193     (not (and process-command-line
194     (find-switch "noinit"))))
195     (let* ((cl-switch (find-switch "init"))
196     (name (and cl-switch
197     (or (cmd-switch-value cl-switch)
198     (car (cmd-switch-words cl-switch))))))
199     (if name
200     (load (merge-pathnames name #p"home:")
201     :if-does-not-exist nil)
202     (or (load "home:init" :if-does-not-exist nil)
203     (load "home:.cmucl-init"
204     :if-does-not-exist nil))))))
205     (when process-command-line
206     (ext::invoke-switch-demons *command-line-switches*
207     *command-switch-demons*))
208     (when print-herald
209     (print-herald))))
210     (funcall init-function))
211     (restart-lisp ()
212 ram 1.28 (unix:unix-exit
213     (catch '%end-of-the-world
214 dtc 1.37 (unwind-protect
215 dtc 1.38 (if *batch-mode*
216     (handler-case
217     (%restart-lisp)
218     (error (cond)
219 dtc 1.39 (format *error-output* "Error in batch processing:~%~A~%"
220 dtc 1.38 cond)
221     (throw '%end-of-the-world 1)))
222     (%restart-lisp))
223 dtc 1.37 (finish-standard-output-streams))))))
224 ram 1.28
225 wlott 1.17 (let ((initial-function (get-lisp-obj-address #'restart-lisp)))
226     (without-gcing
227     (save (unix-namestring core-file-name nil) initial-function))))
228     nil)
229 wlott 1.2
230 wlott 1.17
231    
232     ;;;; PRINT-HERALD support.
233 wlott 1.2
234 ram 1.15 (defvar *herald-items* ()
235     "Determines what PRINT-HERALD prints (the system startup banner.) This is a
236     database which can be augmented by each loaded system. The format is a
237     property list which maps from subsystem names to the banner information for
238     that system. This list can be manipulated with GETF -- entries are printed
239     in, reverse order, so the newest entry is printed last. Usually the system
240     feature keyword is used as the system name. A given banner is a list of
241     strings and functions (or function names). Strings are printed, and
242     functions are called with an output stream argument.")
243    
244     (setf (getf *herald-items* :common-lisp)
245     `("CMU Common Lisp "
246     ,#'(lambda (stream)
247     (write-string (lisp-implementation-version) stream))
248     ", running on "
249     ,#'(lambda (stream) (write-string (machine-instance) stream))))
250    
251     (setf (getf *herald-items* :bugs)
252 dtc 1.35 '("Send questions to cmucl-help@cons.org. and bug reports to cmucl-imp@cons.org."
253 ram 1.15 terpri
254     "Loaded subsystems:"))
255    
256     ;;; PRINT-HERALD -- Public
257     ;;;
258     (defun print-herald (&optional (stream *standard-output*))
259     "Print some descriptive information about the Lisp system version and
260     configuration."
261     (let ((res ()))
262     (do ((item *herald-items* (cddr item)))
263     ((null item))
264     (push (second item) res))
265    
266     (fresh-line stream)
267     (dolist (item res)
268     (dolist (thing item)
269     (typecase thing
270     (string
271     (write-string thing stream))
272     (function (funcall thing stream))
273     ((or symbol cons)
274     (funcall (fdefinition thing) stream))
275     (t
276     (error "Unrecognized *HERALD-ITEMS* entry: ~S." thing))))
277     (fresh-line stream)))
278    
279 wlott 1.2 (values))
280    
281    
282     ;;;; Random functions used by worldload.
283    
284     (defun assert-user-package ()
285     (unless (eq *package* (find-package "USER"))
286     (error "Change *PACKAGE* to the USER package and try again.")))
287 ram 1.20
288     ;;; MAYBE-BYTE-LOAD -- Interface
289     ;;;
290     ;;; If Name has been byte-compiled, and :runtime is a feature, then load the
291     ;;; byte-compiled version, otherwise just do normal load.
292     ;;;
293     (defun maybe-byte-load (name &optional (load-native t))
294     (let ((bname (make-pathname
295     :defaults name
296     :type #.(c:backend-byte-fasl-file-type c:*target-backend*))))
297     (cond ((and (featurep :runtime)
298     (probe-file bname))
299     (load bname))
300     (load-native
301     (load name)))))
302    
303    
304     ;;; BYTE-LOAD-OVER -- Interface
305     ;;;
306     ;;; Replace a cold-loaded native object file with a byte-compiled one, if it
307     ;;; exists.
308     ;;;
309     (defun byte-load-over (name)
310     (load (make-pathname
311     :defaults name
312     :type #.(c:backend-byte-fasl-file-type c:*target-backend*))
313     :if-does-not-exist nil))

  ViewVC Help
Powered by ViewVC 1.1.5