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

Contents of /src/code/save.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5