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

Contents of /src/code/save.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.58 - (hide annotations)
Wed Dec 10 16:16:10 2008 UTC (5 years, 4 months ago) by rtoy
Branch: MAIN
CVS Tags: release-19f-pre1, snapshot-2008-12, label-2009-03-16, release-19f-base, merge-with-19f, RELEASE_19f, label-2009-03-25, snapshot-2009-02, snapshot-2009-01, snapshot-2009-05, snapshot-2009-04
Branch point for: RELEASE-19F-BRANCH
Changes since 1.57: +5 -4 lines
Change how we put the FPU type into the core file.  We can't use
compile-time options to do this.  The running core file has to tell
us.

lisp/save.c:
o Add extra arg to save function to indicate whether the core we're
  saving supports sse2 or not.  Non-zero means sse2.
o Put the correct indication into the core file.

lisp/save.h:
o Update declaration of save.

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

  ViewVC Help
Powered by ViewVC 1.1.5