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

Contents of /src/code/save.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (show annotations)
Fri Aug 30 15:40:53 1991 UTC (22 years, 7 months ago) by ram
Branch: MAIN
Changes since 1.7: +64 -22 lines
Added support for the CMUCLLIB/library: search list.  Added load of
library:site-init.  Moved path: initialization here from lispinit.
Only call EVAL:FLUSH-INTERPRETED-FUNCTION-CACHE if it is fbound.
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.8 1991/08/30 15:40:53 ram 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 (def-c-routine "save" (boolean)
51 (file null-terminated-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 "library:") (parse-unix-search-list :cmucllib)))
94
95
96 (defun save-lisp (core-file-name &key
97 (purify t)
98 (root-structures ())
99 (constants nil)
100 (init-function
101 #'(lambda ()
102 (throw 'top-level-catcher nil)))
103 (load-init-file t)
104 (site-init "library:site-init")
105 (enable-gc t)
106 (print-herald t)
107 (process-command-line t))
108 "Saves a CMU Common Lisp core image in the file of the specified name. The
109 following keywords are defined:
110
111 :purify
112 If true, do a purifying GC which moves all dynamically allocated
113 objects into static space so that they stay pure. This takes somewhat
114 longer than the normal GC which is otherwise done, but GC's will done
115 less often and take less time in the resulting core file.
116
117 :root-structures
118 :constants
119 These should be a list of the main entry points in any newly loaded
120 systems and a list of any large data structures that will never again
121 be changed. These need not be supplied, but locality and/or GC performance
122 will be better if they are. They are meaningless if :purify is NIL.
123
124 :init-function
125 This is a function which is called when the created core file is
126 resumed. The default function simply aborts to the top level
127 read-eval-print loop. If the function returns it will be the value
128 of Save-Lisp.
129
130 :load-init-file
131 If true, then look for an init.lisp or init.fasl file when the core
132 file is resumed.
133
134 :site-init
135 If true, then the name of the site init file to load. The default is
136 library:site-init. No error if this does not exist.
137
138 :print-herald
139 If true, print out the lisp system herald when starting.
140
141 :enable-gc
142 If true, turn GC on if it was off."
143
144 (when (fboundp 'eval:flush-interpreted-function-cache)
145 (eval:flush-interpreted-function-cache))
146 (if purify
147 (purify :root-structures root-structures :constants constants)
148 (gc))
149 (unless (save (namestring core-file-name))
150 (dolist (f *before-save-initializations*) (funcall f))
151 (dolist (f *after-save-initializations*) (funcall f))
152 (reinit)
153 (environment-init)
154 (when site-init (load site-init :if-does-not-exist nil))
155 (when process-command-line (ext::process-command-strings))
156 (setf *editor-lisp-p* nil)
157 (macrolet ((find-switch (name)
158 `(find ,name *command-line-switches*
159 :key #'cmd-switch-name
160 :test #'(lambda (x y)
161 (declare (simple-string x y))
162 (string-equal x y)))))
163 (when (and process-command-line (find-switch "edit"))
164 (setf *editor-lisp-p* t))
165 (when (and load-init-file
166 (not (and process-command-line (find-switch "noinit"))))
167 (let* ((cl-switch (find-switch "init"))
168 (name (and cl-switch
169 (or (cmd-switch-value cl-switch)
170 (car (cmd-switch-words cl-switch))))))
171 (if name
172 (load (merge-pathnames name (user-homedir-pathname))
173 :if-does-not-exist nil)
174 (or (load "home:init" :if-does-not-exist nil)
175 (load "home:.cmucl-init" :if-does-not-exist nil))))))
176 (when enable-gc
177 (gc-on))
178 (when print-herald
179 (print-herald))
180 (when process-command-line
181 (ext::invoke-switch-demons *command-line-switches*
182 *command-switch-demons*))
183 (funcall init-function)))
184
185
186 (defun print-herald ()
187 (macrolet ((frob (variable)
188 `(if (boundp ',variable)
189 ,variable
190 "<not loaded>")))
191 (write-string "CMU Common Lisp ")
192 (write-string (lisp-implementation-version))
193 (write-string ", running on ")
194 (write-line (machine-instance))
195 (write-string "Hemlock ")
196 (write-string (frob *hemlock-version*))
197 (write-string ", Python ")
198 (write-string (frob compiler-version))
199 (when (boundp 'c:*backend*)
200 (write-string ", target ")
201 (write-string (c:backend-version c:*backend*)))
202 (terpri)
203 (write-line "Send bug reports and questions to cmucl-bugs@cs.cmu.edu."))
204 (values))
205
206
207 ;;;; Random functions used by worldload.
208
209 (defun assert-user-package ()
210 (unless (eq *package* (find-package "USER"))
211 (error "Change *PACKAGE* to the USER package and try again.")))
212
213 (defun initial-init-function ()
214 (gc-on)
215 (throw 'top-level-catcher nil))

  ViewVC Help
Powered by ViewVC 1.1.5