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

Contents of /src/code/save.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.10.1.1 - (hide annotations) (vendor branch)
Sun Oct 6 12:57:00 1991 UTC (22 years, 6 months ago) by wlott
Changes since 1.10: +41 -36 lines
Fixed for gengc system.
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.10.1.1 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/save.lisp,v 1.10.1.1 1991/10/06 12:57:00 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 wlott 1.2 (export '(print-herald save-lisp *before-save-initializations*
25     *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 wlott 1.10.1.1 (def-c-routine "core_Save" (int)
51 wlott 1.2 (file null-terminated-string))
52 ram 1.1
53 wlott 1.2
54 ram 1.8 ;;; 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 ram 1.10 (setf (search-list "home:")
94     (or (parse-unix-search-list :home)
95     (list (default-directory))))
96    
97 ram 1.9 (setf (search-list "library:")
98     (or (parse-unix-search-list :cmucllib)
99     '("/usr/misc/.cmucl/lib/"))))
100 ram 1.8
101 wlott 1.2 (defun save-lisp (core-file-name &key
102     (purify t)
103     (root-structures ())
104 wlott 1.3 (constants nil)
105 wlott 1.2 (init-function
106     #'(lambda ()
107     (throw 'top-level-catcher nil)))
108     (load-init-file t)
109 ram 1.8 (site-init "library:site-init")
110 ram 1.4 (enable-gc t)
111 wlott 1.2 (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 wlott 1.3 :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 wlott 1.2
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 ram 1.8
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 wlott 1.2 :print-herald
144 ram 1.4 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 ram 1.6
149 ram 1.8 (when (fboundp 'eval:flush-interpreted-function-cache)
150     (eval:flush-interpreted-function-cache))
151 wlott 1.2 (if purify
152 wlott 1.3 (purify :root-structures root-structures :constants constants)
153 wlott 1.2 (gc))
154 wlott 1.10.1.1 (let ((result (core_save (namestring core-file-name))))
155     (cond
156     ((zerop result))
157     ((minusp result)
158     (dolist (f *before-save-initializations*) (funcall f))
159     (dolist (f *after-save-initializations*) (funcall f))
160     (reinit)
161     (environment-init)
162     (when site-init (load site-init :if-does-not-exist nil))
163     (when process-command-line (ext::process-command-strings))
164     (setf *editor-lisp-p* nil)
165     (macrolet ((find-switch (name)
166     `(find ,name *command-line-switches*
167     :key #'cmd-switch-name
168     :test #'(lambda (x y)
169     (declare (simple-string x y))
170     (string-equal x y)))))
171     (when (and process-command-line (find-switch "edit"))
172     (setf *editor-lisp-p* t))
173     (when (and load-init-file
174     (not (and process-command-line (find-switch "noinit"))))
175     (let* ((cl-switch (find-switch "init"))
176     (name (and cl-switch
177     (or (cmd-switch-value cl-switch)
178     (car (cmd-switch-words cl-switch))))))
179     (if name
180     (load (merge-pathnames name #p"home:") :if-does-not-exist nil)
181     (or (load "home:init" :if-does-not-exist nil)
182     (load "home:.cmucl-init" :if-does-not-exist nil))))))
183     (when enable-gc
184     (gc-on))
185     (when print-herald
186     (print-herald))
187     (when process-command-line
188     (ext::invoke-switch-demons *command-line-switches*
189     *command-switch-demons*))
190     (funcall init-function))
191     (t
192     (error "Save didn't work: ~A" (mach:get-unix-error-msg result))))))
193 wlott 1.2
194    
195     (defun print-herald ()
196     (macrolet ((frob (variable)
197     `(if (boundp ',variable)
198     ,variable
199     "<not loaded>")))
200     (write-string "CMU Common Lisp ")
201     (write-string (lisp-implementation-version))
202     (write-string ", running on ")
203     (write-line (machine-instance))
204     (write-string "Hemlock ")
205     (write-string (frob *hemlock-version*))
206 ram 1.7 (write-string ", Python ")
207     (write-string (frob compiler-version))
208     (when (boundp 'c:*backend*)
209     (write-string ", target ")
210     (write-string (c:backend-version c:*backend*)))
211     (terpri)
212 ram 1.8 (write-line "Send bug reports and questions to cmucl-bugs@cs.cmu.edu."))
213 wlott 1.2 (values))
214    
215    
216     ;;;; Random functions used by worldload.
217    
218     (defun assert-user-package ()
219     (unless (eq *package* (find-package "USER"))
220     (error "Change *PACKAGE* to the USER package and try again.")))
221    
222     (defun initial-init-function ()
223     (gc-on)
224     (throw 'top-level-catcher nil))

  ViewVC Help
Powered by ViewVC 1.1.5