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

Contents of /src/code/save.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.17 - (hide annotations)
Wed Apr 28 01:56:52 1993 UTC (21 years ago) by wlott
Branch: MAIN
Changes since 1.16: +62 -43 lines
Changed core saving to no longer save the stacks.  Instead, when the core
is restored, a (supplied) initial function is invoked which can do whatever
kind of setup it wants.  This makes a saved lisp totally independent of the
location of the C stack.
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     ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7     ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8     ;;;
9     (ext:file-comment
10 wlott 1.17 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/save.lisp,v 1.17 1993/04/28 01:56:52 wlott Exp $")
11 ram 1.5 ;;;
12 ram 1.1 ;;; **********************************************************************
13     ;;;
14 wlott 1.2 ;;; Dump the current lisp image into a core file. All the real work is done
15 ram 1.8 ;;; be C. Also contains various high-level initialization stuff: loading init
16     ;;; files and parsing environment variables.
17 wlott 1.2 ;;;
18     ;;; Written by William Lott.
19 ram 1.1 ;;;
20     ;;;
21     (in-package "LISP")
22    
23     (in-package "EXTENSIONS")
24 ram 1.15 (export '(print-herald *herald-items* save-lisp *before-save-initializations*
25 wlott 1.2 *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     "This is a list of functions which are called before creating a saved core
30     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     "This is a list of functions which are called when a saved core image starts
35     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     "An alist mapping environment variables (as keywords) to either values")
40 ram 1.1
41 wlott 1.2 (defvar *editor-lisp-p* nil
42     "This is true if and only if the lisp was started with the -edit switch.")
43    
44    
45    
46     ;;; Filled in by the startup code.
47 ram 1.1 (defvar lisp-environment-list)
48    
49    
50 ram 1.8 ;;; PARSE-UNIX-SEARCH-LIST -- Internal
51     ;;;
52     ;;; Returns a list of the directories that are in the specified Unix
53     ;;; environment variable. Return NIL if the variable is undefined.
54     ;;;
55     (defun parse-unix-search-list (var)
56     (let ((path (cdr (assoc var ext::*environment-list*))))
57     (when path
58     (do* ((i 0 (1+ p))
59     (p (position #\: path :start i)
60     (position #\: path :start i))
61     (pl ()))
62     ((null p)
63     (let ((s (subseq path i)))
64     (if (string= s "")
65     (push "default:" pl)
66     (push (concatenate 'simple-string s "/") pl)))
67     (nreverse pl))
68     (let ((s (subseq path i p)))
69     (if (string= s "")
70     (push "default:" pl)
71     (push (concatenate 'simple-string s "/") pl)))))))
72    
73    
74     ;;; ENVIRONMENT-INIT -- Internal
75     ;;;
76     ;;; Parse the LISP-ENVIRONMENT-LIST into a keyword alist. Set up default
77     ;;; search lists.
78     ;;;
79     (defun environment-init ()
80 ram 1.16 (setq *environment-list* ())
81 ram 1.8 (dolist (ele lisp-environment-list)
82     (let ((=pos (position #\= (the simple-string ele))))
83     (when =pos
84     (push (cons (intern (string-upcase (subseq ele 0 =pos))
85     *keyword-package*)
86     (subseq ele (1+ =pos)))
87     *environment-list*))))
88     (setf (search-list "default:") (list (default-directory)))
89     (setf (search-list "path:") (parse-unix-search-list :path))
90 ram 1.10 (setf (search-list "home:")
91     (or (parse-unix-search-list :home)
92     (list (default-directory))))
93    
94 ram 1.9 (setf (search-list "library:")
95     (or (parse-unix-search-list :cmucllib)
96     '("/usr/misc/.cmucl/lib/"))))
97 ram 1.8
98 wlott 1.17
99    
100     ;;;; SAVE-LISP itself.
101    
102     (alien:def-alien-routine "save" (alien:boolean)
103     (file c-call:c-string)
104     (initial-function (alien:unsigned #.vm:word-bits)))
105    
106 wlott 1.2 (defun save-lisp (core-file-name &key
107     (purify t)
108     (root-structures ())
109 wlott 1.3 (constants nil)
110 wlott 1.17 (init-function #'%top-level)
111 wlott 1.2 (load-init-file t)
112 ram 1.8 (site-init "library:site-init")
113 wlott 1.2 (print-herald t)
114     (process-command-line t))
115     "Saves a CMU Common Lisp core image in the file of the specified name. The
116     following keywords are defined:
117    
118     :purify
119     If true, do a purifying GC which moves all dynamically allocated
120     objects into static space so that they stay pure. This takes somewhat
121     longer than the normal GC which is otherwise done, but GC's will done
122     less often and take less time in the resulting core file.
123    
124     :root-structures
125 wlott 1.3 :constants
126     These should be a list of the main entry points in any newly loaded
127     systems and a list of any large data structures that will never again
128     be changed. These need not be supplied, but locality and/or GC performance
129     will be better if they are. They are meaningless if :purify is NIL.
130 wlott 1.2
131     :init-function
132     This is a function which is called when the created core file is
133 wlott 1.17 resumed. The default function simply invokes the top level
134     read-eval-print loop. If the function returns the lisp will exit.
135 wlott 1.2
136     :load-init-file
137     If true, then look for an init.lisp or init.fasl file when the core
138     file is resumed.
139 ram 1.8
140     :site-init
141     If true, then the name of the site init file to load. The default is
142     library:site-init. No error if this does not exist.
143    
144 wlott 1.2 :print-herald
145 wlott 1.14 If true, print out the lisp system herald when starting."
146 ram 1.4
147 ram 1.8 (when (fboundp 'eval:flush-interpreted-function-cache)
148     (eval:flush-interpreted-function-cache))
149 wlott 1.2 (if purify
150 wlott 1.3 (purify :root-structures root-structures :constants constants)
151 wlott 1.2 (gc))
152 wlott 1.17 (flet
153     ((restart-lisp ()
154     (catch '%end-of-the-world
155     (with-simple-restart (abort "Skip remaining initializations.")
156     (catch 'top-level-catcher
157     (reinit)
158     (dolist (f *before-save-initializations*) (funcall f))
159     (dolist (f *after-save-initializations*) (funcall f))
160     (environment-init)
161     (when site-init
162     (load site-init :if-does-not-exist nil :verbose nil))
163     (when process-command-line
164     (ext::process-command-strings))
165     (setf *editor-lisp-p* nil)
166     (macrolet ((find-switch (name)
167     `(find ,name *command-line-switches*
168     :key #'cmd-switch-name
169     :test #'(lambda (x y)
170     (declare (simple-string x y))
171     (string-equal x y)))))
172     (when (and process-command-line (find-switch "edit"))
173     (setf *editor-lisp-p* t))
174     (when (and load-init-file
175     (not (and process-command-line
176     (find-switch "noinit"))))
177     (let* ((cl-switch (find-switch "init"))
178     (name (and cl-switch
179     (or (cmd-switch-value cl-switch)
180     (car (cmd-switch-words
181     cl-switch))))))
182     (if name
183     (load (merge-pathnames name #p"home:")
184     :if-does-not-exist nil)
185     (or (load "home:init" :if-does-not-exist nil)
186     (load "home:.cmucl-init"
187     :if-does-not-exist nil))))))
188     (when process-command-line
189     (ext::invoke-switch-demons *command-line-switches*
190     *command-switch-demons*))
191     (when print-herald
192     (print-herald))))
193     (funcall init-function))
194     (unix:unix-exit 0)))
195     (let ((initial-function (get-lisp-obj-address #'restart-lisp)))
196     (without-gcing
197     (save (unix-namestring core-file-name nil) initial-function))))
198     nil)
199 wlott 1.2
200 wlott 1.17
201    
202     ;;;; PRINT-HERALD support.
203 wlott 1.2
204 ram 1.15 (defvar *herald-items* ()
205     "Determines what PRINT-HERALD prints (the system startup banner.) This is a
206     database which can be augmented by each loaded system. The format is a
207     property list which maps from subsystem names to the banner information for
208     that system. This list can be manipulated with GETF -- entries are printed
209     in, reverse order, so the newest entry is printed last. Usually the system
210     feature keyword is used as the system name. A given banner is a list of
211     strings and functions (or function names). Strings are printed, and
212     functions are called with an output stream argument.")
213    
214     (setf (getf *herald-items* :common-lisp)
215     `("CMU Common Lisp "
216     ,#'(lambda (stream)
217     (write-string (lisp-implementation-version) stream))
218     ", running on "
219     ,#'(lambda (stream) (write-string (machine-instance) stream))))
220    
221     (setf (getf *herald-items* :bugs)
222     '("Send bug reports and questions to cmucl-bugs@cs.cmu.edu."
223     terpri
224     "Loaded subsystems:"))
225    
226     ;;; PRINT-HERALD -- Public
227     ;;;
228     (defun print-herald (&optional (stream *standard-output*))
229     "Print some descriptive information about the Lisp system version and
230     configuration."
231     (let ((res ()))
232     (do ((item *herald-items* (cddr item)))
233     ((null item))
234     (push (second item) res))
235    
236     (fresh-line stream)
237     (dolist (item res)
238     (dolist (thing item)
239     (typecase thing
240     (string
241     (write-string thing stream))
242     (function (funcall thing stream))
243     ((or symbol cons)
244     (funcall (fdefinition thing) stream))
245     (t
246     (error "Unrecognized *HERALD-ITEMS* entry: ~S." thing))))
247     (fresh-line stream)))
248    
249 wlott 1.2 (values))
250    
251    
252     ;;;; Random functions used by worldload.
253    
254     (defun assert-user-package ()
255     (unless (eq *package* (find-package "USER"))
256     (error "Change *PACKAGE* to the USER package and try again.")))

  ViewVC Help
Powered by ViewVC 1.1.5