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

Contents of /src/code/save.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5