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

Contents of /src/code/save.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (hide annotations)
Wed Oct 3 15:55:58 1990 UTC (23 years, 6 months ago) by ram
Branch: MAIN
Changes since 1.3: +8 -2 lines
Added the :ENABLE-GC option to SAVE-LISP so that GC can be turned on
before switch demons are run (such as -edit.)
1 ram 1.1 ;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
2     ;;;
3     ;;; **********************************************************************
4     ;;; This code was written as part of the Spice Lisp project at
5     ;;; Carnegie-Mellon University, and has been placed in the public domain.
6     ;;; Spice Lisp is currently incomplete and under active development.
7     ;;; If you want to use this code or any part of Spice Lisp, please contact
8     ;;; Scott Fahlman (FAHLMAN@CMUC).
9     ;;; **********************************************************************
10     ;;;
11 ram 1.4 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/code/save.lisp,v 1.4 1990/10/03 15:55:58 ram Exp $
12 wlott 1.2 ;;;
13     ;;; Dump the current lisp image into a core file. All the real work is done
14     ;;; be C.
15     ;;;
16     ;;; Written by William Lott.
17 ram 1.1 ;;;
18     ;;;
19     (in-package "LISP")
20    
21     (in-package "EXTENSIONS")
22 wlott 1.2 (export '(print-herald save-lisp *before-save-initializations*
23     *after-save-initializations* *environment-list* *editor-lisp-p*))
24 ram 1.1 (in-package "LISP")
25    
26 wlott 1.2 (defvar *before-save-initializations* nil
27     "This is a list of functions which are called before creating a saved core
28     image. These functions are executed in the child process which has no ports,
29     so they cannot do anything that tries to talk to the outside world.")
30 ram 1.1
31 wlott 1.2 (defvar *after-save-initializations* nil
32     "This is a list of functions which are called when a saved core image starts
33     up. The system itself should be initialized at this point, but applications
34     might not be.")
35 ram 1.1
36 wlott 1.2 (defvar *environment-list* nil
37     "An alist mapping environment variables (as keywords) to either values")
38 ram 1.1
39 wlott 1.2 (defvar *editor-lisp-p* nil
40     "This is true if and only if the lisp was started with the -edit switch.")
41    
42    
43    
44     ;;; Filled in by the startup code.
45 ram 1.1 (defvar lisp-environment-list)
46    
47    
48 wlott 1.2 (def-c-routine "save" (boolean)
49     (file null-terminated-string))
50 ram 1.1
51 wlott 1.2
52     (defun save-lisp (core-file-name &key
53     (purify t)
54     (root-structures ())
55 wlott 1.3 (constants nil)
56 wlott 1.2 (init-function
57     #'(lambda ()
58     (throw 'top-level-catcher nil)))
59     (load-init-file t)
60 ram 1.4 (enable-gc t)
61 wlott 1.2 (print-herald t)
62     (process-command-line t))
63     "Saves a CMU Common Lisp core image in the file of the specified name. The
64     following keywords are defined:
65    
66     :purify
67     If true, do a purifying GC which moves all dynamically allocated
68     objects into static space so that they stay pure. This takes somewhat
69     longer than the normal GC which is otherwise done, but GC's will done
70     less often and take less time in the resulting core file.
71    
72     :root-structures
73 wlott 1.3 :constants
74     These should be a list of the main entry points in any newly loaded
75     systems and a list of any large data structures that will never again
76     be changed. These need not be supplied, but locality and/or GC performance
77     will be better if they are. They are meaningless if :purify is NIL.
78 wlott 1.2
79     :init-function
80     This is a function which is called when the created core file is
81     resumed. The default function simply aborts to the top level
82     read-eval-print loop. If the function returns it will be the value
83     of Save-Lisp.
84    
85     :load-init-file
86     If true, then look for an init.lisp or init.fasl file when the core
87     file is resumed.
88    
89     :print-herald
90 ram 1.4 If true, print out the lisp system herald when starting.
91    
92     :enable-gc
93     If true, turn GC on if it was off."
94 wlott 1.2
95     (if purify
96 wlott 1.3 (purify :root-structures root-structures :constants constants)
97 wlott 1.2 (gc))
98     (unless (save (namestring core-file-name))
99     (dolist (f *before-save-initializations*) (funcall f))
100     (dolist (f *after-save-initializations*) (funcall f))
101     (reinit)
102     (dolist (ele lisp-environment-list)
103     (let ((=pos (position #\= (the simple-string ele))))
104     (when =pos
105     (push (cons (intern (string-upcase (subseq ele 0 =pos))
106     *keyword-package*)
107     (subseq ele (1+ =pos)))
108     *environment-list*))))
109     (setf (search-list "default:") (list (default-directory)))
110     (setf (search-list "path:") (setup-path-search-list))
111     (when process-command-line (ext::process-command-strings))
112     (setf *editor-lisp-p* nil)
113     (macrolet ((find-switch (name)
114     `(find ,name *command-line-switches*
115     :key #'cmd-switch-name
116     :test #'(lambda (x y)
117     (declare (simple-string x y))
118     (string-equal x y)))))
119     (when (and process-command-line (find-switch "edit"))
120     (setf *editor-lisp-p* t))
121     (when (and load-init-file
122     (not (and process-command-line (find-switch "noinit"))))
123     (let* ((cl-switch (find-switch "init"))
124     (name (or (and cl-switch
125     (or (cmd-switch-value cl-switch)
126     (car (cmd-switch-words cl-switch))
127     "init"))
128     "init")))
129     (load (merge-pathnames name (user-homedir-pathname))
130     :if-does-not-exist nil))))
131 ram 1.4 (when enable-gc
132     (gc-on))
133 wlott 1.2 (when print-herald
134     (print-herald))
135     (when process-command-line
136     (ext::invoke-switch-demons *command-line-switches*
137     *command-switch-demons*))
138     (funcall init-function)))
139    
140    
141     (defun print-herald ()
142     (macrolet ((frob (variable)
143     `(if (boundp ',variable)
144     ,variable
145     "<not loaded>")))
146     (write-string "CMU Common Lisp ")
147     (write-string (lisp-implementation-version))
148     (write-string ", running on ")
149     (write-line (machine-instance))
150     (write-string "Hemlock ")
151     (write-string (frob *hemlock-version*))
152     (write-string ", Compiler ")
153     (write-line (frob compiler-version))
154     (write-line "Send bug reports and questions to Gripe."))
155     (values))
156    
157    
158     ;;;; Random functions used by worldload.
159    
160     (defun assert-user-package ()
161     (unless (eq *package* (find-package "USER"))
162     (error "Change *PACKAGE* to the USER package and try again.")))
163    
164     (defun initial-init-function ()
165     (gc-on)
166     (throw 'top-level-catcher nil))
167    

  ViewVC Help
Powered by ViewVC 1.1.5