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

  ViewVC Help
Powered by ViewVC 1.1.5