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

Contents of /src/code/save.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.12 - (show annotations)
Fri Feb 14 23:45:28 1992 UTC (22 years, 2 months ago) by wlott
Branch: MAIN
Changes since 1.11: +3 -4 lines
Merged new-alien changes onto trunk.
1 ;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; 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 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/save.lisp,v 1.12 1992/02/14 23:45:28 wlott Exp $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; Dump the current lisp image into a core file. All the real work is done
15 ;;; be C. Also contains various high-level initialization stuff: loading init
16 ;;; files and parsing environment variables.
17 ;;;
18 ;;; Written by William Lott.
19 ;;;
20 ;;;
21 (in-package "LISP")
22
23 (in-package "EXTENSIONS")
24 (export '(print-herald save-lisp *before-save-initializations*
25 *after-save-initializations* *environment-list* *editor-lisp-p*))
26 (in-package "LISP")
27
28 (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
33 (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
38 (defvar *environment-list* nil
39 "An alist mapping environment variables (as keywords) to either values")
40
41 (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 (defvar lisp-environment-list)
48
49
50 (alien:def-alien-routine "save" (alien:boolean)
51 (file c-call:c-string))
52
53
54 ;;; PARSE-UNIX-SEARCH-LIST -- Internal
55 ;;;
56 ;;; Returns a list of the directories that are in the specified Unix
57 ;;; environment variable. Return NIL if the variable is undefined.
58 ;;;
59 (defun parse-unix-search-list (var)
60 (let ((path (cdr (assoc var ext::*environment-list*))))
61 (when path
62 (do* ((i 0 (1+ p))
63 (p (position #\: path :start i)
64 (position #\: path :start i))
65 (pl ()))
66 ((null p)
67 (let ((s (subseq path i)))
68 (if (string= s "")
69 (push "default:" pl)
70 (push (concatenate 'simple-string s "/") pl)))
71 (nreverse pl))
72 (let ((s (subseq path i p)))
73 (if (string= s "")
74 (push "default:" pl)
75 (push (concatenate 'simple-string s "/") pl)))))))
76
77
78 ;;; ENVIRONMENT-INIT -- Internal
79 ;;;
80 ;;; Parse the LISP-ENVIRONMENT-LIST into a keyword alist. Set up default
81 ;;; search lists.
82 ;;;
83 (defun environment-init ()
84 (dolist (ele lisp-environment-list)
85 (let ((=pos (position #\= (the simple-string ele))))
86 (when =pos
87 (push (cons (intern (string-upcase (subseq ele 0 =pos))
88 *keyword-package*)
89 (subseq ele (1+ =pos)))
90 *environment-list*))))
91 (setf (search-list "default:") (list (default-directory)))
92 (setf (search-list "path:") (parse-unix-search-list :path))
93 (setf (search-list "home:")
94 (or (parse-unix-search-list :home)
95 (list (default-directory))))
96
97 (setf (search-list "library:")
98 (or (parse-unix-search-list :cmucllib)
99 '("/usr/misc/.cmucl/lib/"))))
100
101 (defun save-lisp (core-file-name &key
102 (purify t)
103 (root-structures ())
104 (constants nil)
105 (init-function
106 #'(lambda ()
107 (throw 'top-level-catcher nil)))
108 (load-init-file t)
109 (site-init "library:site-init")
110 (enable-gc t)
111 (print-herald t)
112 (process-command-line t))
113 "Saves a CMU Common Lisp core image in the file of the specified name. The
114 following keywords are defined:
115
116 :purify
117 If true, do a purifying GC which moves all dynamically allocated
118 objects into static space so that they stay pure. This takes somewhat
119 longer than the normal GC which is otherwise done, but GC's will done
120 less often and take less time in the resulting core file.
121
122 :root-structures
123 :constants
124 These should be a list of the main entry points in any newly loaded
125 systems and a list of any large data structures that will never again
126 be changed. These need not be supplied, but locality and/or GC performance
127 will be better if they are. They are meaningless if :purify is NIL.
128
129 :init-function
130 This is a function which is called when the created core file is
131 resumed. The default function simply aborts to the top level
132 read-eval-print loop. If the function returns it will be the value
133 of Save-Lisp.
134
135 :load-init-file
136 If true, then look for an init.lisp or init.fasl file when the core
137 file is resumed.
138
139 :site-init
140 If true, then the name of the site init file to load. The default is
141 library:site-init. No error if this does not exist.
142
143 :print-herald
144 If true, print out the lisp system herald when starting.
145
146 :enable-gc
147 If true, turn GC on if it was off."
148
149 (when (fboundp 'eval:flush-interpreted-function-cache)
150 (eval:flush-interpreted-function-cache))
151 (if purify
152 (purify :root-structures root-structures :constants constants)
153 (gc))
154 (unless (save (namestring core-file-name))
155 (dolist (f *before-save-initializations*) (funcall f))
156 (dolist (f *after-save-initializations*) (funcall f))
157 (reinit)
158 (environment-init)
159 (when site-init (load site-init :if-does-not-exist nil))
160 (when process-command-line (ext::process-command-strings))
161 (setf *editor-lisp-p* nil)
162 (macrolet ((find-switch (name)
163 `(find ,name *command-line-switches*
164 :key #'cmd-switch-name
165 :test #'(lambda (x y)
166 (declare (simple-string x y))
167 (string-equal x y)))))
168 (when (and process-command-line (find-switch "edit"))
169 (setf *editor-lisp-p* t))
170 (when (and load-init-file
171 (not (and process-command-line (find-switch "noinit"))))
172 (let* ((cl-switch (find-switch "init"))
173 (name (and cl-switch
174 (or (cmd-switch-value cl-switch)
175 (car (cmd-switch-words cl-switch))))))
176 (if name
177 (load (merge-pathnames name #p"home:") :if-does-not-exist nil)
178 (or (load "home:init" :if-does-not-exist nil)
179 (load "home:.cmucl-init" :if-does-not-exist nil))))))
180 (when enable-gc
181 (gc-on))
182 (when process-command-line
183 (ext::invoke-switch-demons *command-line-switches*
184 *command-switch-demons*))
185 (when print-herald
186 (print-herald))
187 (funcall init-function)))
188
189
190 (defun print-herald ()
191 (macrolet ((frob (variable)
192 `(if (boundp ',variable)
193 ,variable
194 "<not loaded>")))
195 (write-string "CMU Common Lisp ")
196 (write-string (lisp-implementation-version))
197 (write-string ", running on ")
198 (write-line (machine-instance))
199 (write-string "Hemlock ")
200 (write-string (frob *hemlock-version*))
201 (write-string ", Python ")
202 (write-string (frob compiler-version))
203 (when (boundp 'c:*backend*)
204 (write-string ", target ")
205 (write-string (c:backend-version c:*backend*)))
206 (terpri)
207 (write-line "Send bug reports and questions to cmucl-bugs@cs.cmu.edu."))
208 (values))
209
210
211 ;;;; Random functions used by worldload.
212
213 (defun assert-user-package ()
214 (unless (eq *package* (find-package "USER"))
215 (error "Change *PACKAGE* to the USER package and try again.")))
216
217 (defun initial-init-function ()
218 (throw 'top-level-catcher nil))

  ViewVC Help
Powered by ViewVC 1.1.5