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

Contents of /src/code/save.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.12 - (hide 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 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.12 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/save.lisp,v 1.12 1992/02/14 23:45:28 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.12 (alien:def-alien-routine "save" (alien:boolean)
51     (file c-call:c-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     (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 ram 1.8 (environment-init)
159     (when site-init (load site-init :if-does-not-exist nil))
160 wlott 1.2 (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 ram 1.8 (name (and cl-switch
174     (or (cmd-switch-value cl-switch)
175     (car (cmd-switch-words cl-switch))))))
176     (if name
177 ram 1.10 (load (merge-pathnames name #p"home:") :if-does-not-exist nil)
178 ram 1.8 (or (load "home:init" :if-does-not-exist nil)
179     (load "home:.cmucl-init" :if-does-not-exist nil))))))
180 ram 1.4 (when enable-gc
181     (gc-on))
182 wlott 1.2 (when process-command-line
183     (ext::invoke-switch-demons *command-line-switches*
184     *command-switch-demons*))
185 ram 1.11 (when print-herald
186     (print-herald))
187 wlott 1.2 (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 ram 1.7 (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 ram 1.8 (write-line "Send bug reports and questions to cmucl-bugs@cs.cmu.edu."))
208 wlott 1.2 (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