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

Contents of /src/code/save.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5