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

Contents of /src/code/save.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5