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

Contents of /src/code/save.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.65.6.1 - (hide annotations)
Thu Feb 25 20:34:51 2010 UTC (4 years, 1 month ago) by rtoy
Branch: intl-2-branch
Changes since 1.65: +34 -22 lines
Restart internalization work.  This new branch starts with code from
the intl-branch on date 2010-02-12 18:00:00+0500.  This version works
and

LANG=en@piglatin bin/lisp

works (once the piglatin translation is added).
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.6.1 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/save.lisp,v 1.65.6.1 2010/02/25 20:34:51 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.6.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.6.1 _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.6.1 _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.6.1 _N"An alist mapping environment variables (as keywords) to either values")
40    
41     (defvar *environment-list-initialized* nil
42     _N"Non-NIL if environment-init has been called")
43 ram 1.1
44 wlott 1.2 (defvar *editor-lisp-p* nil
45 rtoy 1.65.6.1 _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.6.1 "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.6.1 _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.6.1 :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.6.1 (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 rtoy 1.65.6.1 (intl::setlocale)
238 dtc 1.38 (when process-command-line
239     (ext::process-command-strings))
240     (setf *editor-lisp-p* nil)
241     (macrolet ((find-switch (name)
242     `(find ,name *command-line-switches*
243     :key #'cmd-switch-name
244     :test #'(lambda (x y)
245     (declare (simple-string x y))
246     (string-equal x y)))))
247 pmai 1.52 (when (and process-command-line (find-switch "quiet"))
248     (setq *load-verbose* nil
249     *compile-verbose* nil
250     *compile-print* nil
251     *compile-progress* nil
252     *require-verbose* nil
253     *gc-verbose* nil
254     *herald-items* nil))
255 pmai 1.42 (when (and site-init
256     (not (and process-command-line
257     (find-switch "nositeinit"))))
258 dtc 1.38 (load site-init :if-does-not-exist nil :verbose nil))
259     (when (and process-command-line (find-switch "edit"))
260     (setf *editor-lisp-p* t))
261     (when (and load-init-file
262     (not (and process-command-line
263     (find-switch "noinit"))))
264     (let* ((cl-switch (find-switch "init"))
265     (name (and cl-switch
266     (or (cmd-switch-value cl-switch)
267     (car (cmd-switch-words cl-switch))))))
268     (if name
269     (load (merge-pathnames name #p"home:")
270     :if-does-not-exist nil)
271     (or (load "home:init" :if-does-not-exist nil)
272     (load "home:.cmucl-init"
273     :if-does-not-exist nil))))))
274     (when process-command-line
275     (ext::invoke-switch-demons *command-line-switches*
276     *command-switch-demons*))
277     (when print-herald
278     (print-herald))))
279     (funcall init-function))
280     (restart-lisp ()
281 ram 1.28 (unix:unix-exit
282     (catch '%end-of-the-world
283 dtc 1.37 (unwind-protect
284 dtc 1.38 (if *batch-mode*
285     (handler-case
286     (%restart-lisp)
287     (error (cond)
288 rtoy 1.65.6.1 (format *error-output* _"Error in batch processing:~%~A~%"
289 dtc 1.38 cond)
290     (throw '%end-of-the-world 1)))
291     (%restart-lisp))
292 dtc 1.37 (finish-standard-output-streams))))))
293 ram 1.28
294 pmai 1.48 ;; Record dump time and host
295     (setq *cmucl-core-dump-time* (get-universal-time))
296     (setq *cmucl-core-dump-host* (machine-instance))
297    
298 fgilham 1.54 (let ((initial-function (get-lisp-obj-address #'restart-lisp))
299     (core-name (unix-namestring core-file-name nil)))
300 wlott 1.17 (without-gcing
301 fgilham 1.54 #+:executable
302     (if executable
303     (save-executable core-name initial-function)
304 rtoy 1.58 (save core-name initial-function #+sse2 1 #-sse2 0))
305 fgilham 1.54 #-:executable
306 rtoy 1.58 (save core-name initial-function #+sse2 1 #-sse2 0))))
307 wlott 1.17 nil)
308 wlott 1.2
309 wlott 1.17
310    
311     ;;;; PRINT-HERALD support.
312 wlott 1.2
313 ram 1.15 (defvar *herald-items* ()
314 rtoy 1.65.6.1 _N"Determines what PRINT-HERALD prints (the system startup banner.) This is a
315 ram 1.15 database which can be augmented by each loaded system. The format is a
316     property list which maps from subsystem names to the banner information for
317     that system. This list can be manipulated with GETF -- entries are printed
318     in, reverse order, so the newest entry is printed last. Usually the system
319     feature keyword is used as the system name. A given banner is a list of
320     strings and functions (or function names). Strings are printed, and
321     functions are called with an output stream argument.")
322    
323     (setf (getf *herald-items* :common-lisp)
324     `("CMU Common Lisp "
325     ,#'(lambda (stream)
326     (write-string (lisp-implementation-version) stream))
327 rtoy 1.65.6.1 ,#'(lambda (stream)
328     (write-string _", running on " stream))
329 toy 1.45 ,#'(lambda (stream) (write-string (machine-instance) stream))
330     terpri
331     ,#'(lambda (stream)
332     (let ((core (if (boundp '*cmucl-core-path*)
333     (truename *cmucl-core-path*)
334 pmai 1.48 nil))
335     (dump-time (if (boundp '*cmucl-core-dump-time*)
336     *cmucl-core-dump-time*
337     nil)))
338 toy 1.45 (when core
339 rtoy 1.65.6.1 (write-string _"With core: " stream)
340 pmai 1.48 (write-line (namestring core) stream))
341     (when dump-time
342 rtoy 1.65.6.1 (write-string _"Dumped on: " stream)
343 pmai 1.48 (ext:format-universal-time stream dump-time :style :iso8601)
344 rtoy 1.65.6.1 (write-string _" on " stream)
345 pmai 1.48 (write-line *cmucl-core-dump-host* stream))))
346 toy 1.45 ))
347 ram 1.15
348     (setf (getf *herald-items* :bugs)
349 rtoy 1.65.6.1 `(,#'(lambda (stream)
350     (write-string _"See <http://www.cons.org/cmucl/> for support information." stream))
351 ram 1.15 terpri
352 rtoy 1.65.6.1 ,#'(lambda (stream)
353     (write-string _"Loaded subsystems:" stream))))
354 ram 1.15
355 rtoy 1.60 #+unicode
356     (setf (getf *herald-items* :unicode)
357 rtoy 1.65.6.1 `(,#'(lambda (stream)
358     (write-string _" Unicode " stream))
359 rtoy 1.60 ,(if (and (boundp 'lisp::*unidata-version*)
360     (>= (length lisp::*unidata-version*) 11))
361     (subseq lisp::*unidata-version* 11
362     (1- (length lisp::*unidata-version*)))
363 rtoy 1.61 " ")
364 rtoy 1.65.6.1 ,#'(lambda (stream)
365     (write-string _"with Unicode version " stream))
366 rtoy 1.60 ,#'(lambda (stream)
367     (princ lisp::+unicode-major-version+ stream)
368     (write-char #\. stream)
369     (princ lisp::+unicode-minor-version+ stream)
370     (write-char #\. stream)
371     (princ lisp::+unicode-update-version+ stream))
372     terpri))
373    
374 ram 1.15 ;;; PRINT-HERALD -- Public
375     ;;;
376     (defun print-herald (&optional (stream *standard-output*))
377 rtoy 1.65.6.1 _N"Print some descriptive information about the Lisp system version and
378 ram 1.15 configuration."
379     (let ((res ()))
380     (do ((item *herald-items* (cddr item)))
381     ((null item))
382     (push (second item) res))
383    
384     (fresh-line stream)
385     (dolist (item res)
386     (dolist (thing item)
387     (typecase thing
388     (string
389     (write-string thing stream))
390     (function (funcall thing stream))
391     ((or symbol cons)
392     (funcall (fdefinition thing) stream))
393     (t
394 rtoy 1.65.6.1 (error _"Unrecognized *HERALD-ITEMS* entry: ~S." thing))))
395 ram 1.15 (fresh-line stream)))
396    
397 wlott 1.2 (values))
398    
399    
400     ;;;; Random functions used by worldload.
401    
402     (defun assert-user-package ()
403 gerd 1.51 (unless (eq *package* (find-package "CL-USER"))
404 rtoy 1.65.6.1 (error _"Change *PACKAGE* to the USER package and try again.")))
405 ram 1.20
406     ;;; MAYBE-BYTE-LOAD -- Interface
407     ;;;
408     ;;; If Name has been byte-compiled, and :runtime is a feature, then load the
409     ;;; byte-compiled version, otherwise just do normal load.
410     ;;;
411     (defun maybe-byte-load (name &optional (load-native t))
412     (let ((bname (make-pathname
413     :defaults name
414     :type #.(c:backend-byte-fasl-file-type c:*target-backend*))))
415     (cond ((and (featurep :runtime)
416     (probe-file bname))
417     (load bname))
418     (load-native
419     (load name)))))
420    
421    
422     ;;; BYTE-LOAD-OVER -- Interface
423     ;;;
424     ;;; Replace a cold-loaded native object file with a byte-compiled one, if it
425     ;;; exists.
426     ;;;
427     (defun byte-load-over (name)
428     (load (make-pathname
429     :defaults name
430     :type #.(c:backend-byte-fasl-file-type c:*target-backend*))
431     :if-does-not-exist nil))

  ViewVC Help
Powered by ViewVC 1.1.5