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

Contents of /src/code/save.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.14 - (hide annotations)
Sun Mar 29 21:54:27 1992 UTC (22 years, 1 month ago) by wlott
Branch: MAIN
Changes since 1.13: +4 -13 lines
Removed the :enable-gc option, as it's no longer needed.
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.14 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/save.lisp,v 1.14 1992/03/29 21:54:27 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 wlott 1.2 (print-herald t)
111     (process-command-line t))
112     "Saves a CMU Common Lisp core image in the file of the specified name. The
113     following keywords are defined:
114    
115     :purify
116     If true, do a purifying GC which moves all dynamically allocated
117     objects into static space so that they stay pure. This takes somewhat
118     longer than the normal GC which is otherwise done, but GC's will done
119     less often and take less time in the resulting core file.
120    
121     :root-structures
122 wlott 1.3 :constants
123     These should be a list of the main entry points in any newly loaded
124     systems and a list of any large data structures that will never again
125     be changed. These need not be supplied, but locality and/or GC performance
126     will be better if they are. They are meaningless if :purify is NIL.
127 wlott 1.2
128     :init-function
129     This is a function which is called when the created core file is
130     resumed. The default function simply aborts to the top level
131     read-eval-print loop. If the function returns it will be the value
132     of Save-Lisp.
133    
134     :load-init-file
135     If true, then look for an init.lisp or init.fasl file when the core
136     file is resumed.
137 ram 1.8
138     :site-init
139     If true, then the name of the site init file to load. The default is
140     library:site-init. No error if this does not exist.
141    
142 wlott 1.2 :print-herald
143 wlott 1.14 If true, print out the lisp system herald when starting."
144 ram 1.4
145 ram 1.8 (when (fboundp 'eval:flush-interpreted-function-cache)
146     (eval:flush-interpreted-function-cache))
147 wlott 1.2 (if purify
148 wlott 1.3 (purify :root-structures root-structures :constants constants)
149 wlott 1.2 (gc))
150 wlott 1.14 (unless (save (unix-namestring core-file-name nil))
151     (reinit)
152 wlott 1.2 (dolist (f *before-save-initializations*) (funcall f))
153     (dolist (f *after-save-initializations*) (funcall f))
154 ram 1.8 (environment-init)
155 wlott 1.13 (when site-init (load site-init :if-does-not-exist nil :verbose nil))
156 wlott 1.2 (when process-command-line (ext::process-command-strings))
157     (setf *editor-lisp-p* nil)
158     (macrolet ((find-switch (name)
159     `(find ,name *command-line-switches*
160     :key #'cmd-switch-name
161     :test #'(lambda (x y)
162     (declare (simple-string x y))
163     (string-equal x y)))))
164     (when (and process-command-line (find-switch "edit"))
165     (setf *editor-lisp-p* t))
166     (when (and load-init-file
167     (not (and process-command-line (find-switch "noinit"))))
168     (let* ((cl-switch (find-switch "init"))
169 ram 1.8 (name (and cl-switch
170     (or (cmd-switch-value cl-switch)
171     (car (cmd-switch-words cl-switch))))))
172     (if name
173 ram 1.10 (load (merge-pathnames name #p"home:") :if-does-not-exist nil)
174 ram 1.8 (or (load "home:init" :if-does-not-exist nil)
175     (load "home:.cmucl-init" :if-does-not-exist nil))))))
176 wlott 1.2 (when process-command-line
177     (ext::invoke-switch-demons *command-line-switches*
178     *command-switch-demons*))
179 ram 1.11 (when print-herald
180     (print-herald))
181 wlott 1.2 (funcall init-function)))
182    
183    
184     (defun print-herald ()
185     (macrolet ((frob (variable)
186     `(if (boundp ',variable)
187     ,variable
188     "<not loaded>")))
189     (write-string "CMU Common Lisp ")
190     (write-string (lisp-implementation-version))
191     (write-string ", running on ")
192     (write-line (machine-instance))
193     (write-string "Hemlock ")
194     (write-string (frob *hemlock-version*))
195 ram 1.7 (write-string ", Python ")
196     (write-string (frob compiler-version))
197     (when (boundp 'c:*backend*)
198     (write-string ", target ")
199     (write-string (c:backend-version c:*backend*)))
200     (terpri)
201 ram 1.8 (write-line "Send bug reports and questions to cmucl-bugs@cs.cmu.edu."))
202 wlott 1.2 (values))
203    
204    
205     ;;;; Random functions used by worldload.
206    
207     (defun assert-user-package ()
208     (unless (eq *package* (find-package "USER"))
209     (error "Change *PACKAGE* to the USER package and try again.")))

  ViewVC Help
Powered by ViewVC 1.1.5