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

Diff of /src/code/save.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by ram, Tue Feb 6 17:26:43 1990 UTC revision 1.1.1.1 by wlott, Sun Jun 17 02:08:50 1990 UTC
# Line 8  Line 8 
8  ;;; Scott Fahlman (FAHLMAN@CMUC).  ;;; Scott Fahlman (FAHLMAN@CMUC).
9  ;;; **********************************************************************  ;;; **********************************************************************
10  ;;;  ;;;
11  ;;; Spice Lisp routines to suspend a process and create a core file.  ;;; $Header$
12  ;;;  ;;;
13  ;;; Written David B. McDonald.  ;;; 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    ;;;
18  ;;;  ;;;
 ;;; To see the format of Spice Lisp core files look at the document  
 ;;; prva:<slisp.docs>core.mss.  
19  (in-package "LISP")  (in-package "LISP")
20    
21  (in-package "EXTENSIONS")  (in-package "EXTENSIONS")
22  (export '(*environment-list*))  (export '(print-herald save-lisp *before-save-initializations*
23  (defvar *environment-list* nil)            *after-save-initializations* *environment-list* *editor-lisp-p*))
24  (in-package "LISP")  (in-package "LISP")
25    
26    (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    
31    (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    
36  (proclaim '(special *task-self*))  (defvar *environment-list* nil
37      "An alist mapping environment variables (as keywords) to either values")
38    
39  (defconstant save-block-size (* 64 1024)  (defvar *editor-lisp-p* nil
40    "Amount to write for each call to write.  This is due to RFS limitations.")    "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  (defvar lisp-environment-list)  (defvar lisp-environment-list)
 (defvar original-lisp-environment)  
46    
 ;;;; Global state:  
47    
48  (defun save (file)  (def-c-routine "save" (boolean)
49    "Save the current lisp core image in a core file.  When it returns in    (file (pointer simple-string)))
50    the current process, the number of bytes written is returned.  
51    When the saved core image is resumed, Nil is returned."  
52    (declare (optimize (speed 3) (safety 0)))  (defun save-lisp (core-file-name &key
53    (format t "~&[Building saved core image: ")                                   (purify t)
54    (finish-output)                                   (root-structures ())
55    (let ((size-to-allocate (* (current-space-usage) 2)))                                   (init-function
56      (declare (fixnum size-to-allocate))                                    #'(lambda ()
57      (let* ((addr (int-sap (gr-call* mach::vm_allocate *task-self*                                        (throw 'top-level-catcher nil)))
58                                      0 size-to-allocate t)))                                   (load-init-file t)
59             (byte-size (%primitive save *current-alien-free-pointer*                                   (print-herald t)
60                                    NIL addr)))                                   (process-command-line t))
61        (cond ((null byte-size)    "Saves a CMU Common Lisp core image in the file of the specified name.  The
62               (mach::vm_deallocate *task-self* addr size-to-allocate)    following keywords are defined:
63               (error "Save failed."))  
64              ((eq byte-size T)    :purify
65               (dolist (f *before-save-initializations*) (funcall f))        If true, do a purifying GC which moves all dynamically allocated
66               (dolist (f *after-save-initializations*) (funcall f))    objects into static space so that they stay pure.  This takes somewhat
67               (reinit)    longer than the normal GC which is otherwise done, but GC's will done
68               (setq original-lisp-environment lisp-environment-list)    less often and take less time in the resulting core file.
69               (let ((result nil))  
70                 (dolist (ele lisp-environment-list    :root-structures
71                              (setf *environment-list* result))        This should be a list of the main entry points in any newly loaded
72                   (let ((=pos (position #\= (the simple-string ele))))    systems.  This need not be supplied, but locality will be better if it
73                     ;;    is.  This is meaningless if :purify is Nil.
74                     ;; This is dubious since all the strings have an =.  
75                     ;; What if one doesn't?  What does that mean?    :init-function
76                     (when =pos        This is a function which is called when the created core file is
77                       (push (cons (intern (string-upcase (subseq ele 0 =pos))    resumed.  The default function simply aborts to the top level
78                                           *keyword-package*)    read-eval-print loop.  If the function returns it will be the value
79                                   (subseq ele (1+ =pos)))    of Save-Lisp.
80                             result)))))  
81               NIL)    :load-init-file
82              (T        If true, then look for an init.lisp or init.fasl file when the core
83               (format t "~D bytes.~%" byte-size)    file is resumed.
84               (format t "Writing to file: ~A~%" file)  
85               (finish-output)    :print-herald
86               (multiple-value-bind (fd err) (mach:unix-creat file #o644)        If true, print out the lisp system herald when starting."
87                 (if (null fd)  
88                     (error "Failed to open file ~A, unix error: ~A"    (declare (ignore purify root-structures))
89                            file (mach:get-unix-error-msg err)))    #+nil
90      (if purify
91                 (do ((left byte-size (- left save-block-size))        (purify :root-structures root-structures)
92                      (index 0 (+ index save-block-size)))        (gc))
93                     ((< left save-block-size)    (unless (save (namestring core-file-name))
94                      (when (> left 0)      (dolist (f *before-save-initializations*) (funcall f))
95                        (multiple-value-bind (res err)      (dolist (f *after-save-initializations*) (funcall f))
96                                             (mach:unix-write fd addr index left)      (reinit)
97                          (if (null res)      (dolist (ele lisp-environment-list)
98                              (error "Failed to write file ~A, unix error: ~A"        (let ((=pos (position #\= (the simple-string ele))))
99                                     file (mach:get-unix-error-msg err))))))          (when =pos
100                   (declare (fixnum left index))            (push (cons (intern (string-upcase (subseq ele 0 =pos))
101                   (multiple-value-bind (res err)                                *keyword-package*)
102                                        (mach:unix-write fd addr index                        (subseq ele (1+ =pos)))
103                                                         save-block-size)                  *environment-list*))))
104                     (if (null res)      (setf (search-list "default:") (list (default-directory)))
105                         (error "Failed to write file ~A, unix error: ~A"      (setf (search-list "path:") (setup-path-search-list))
106                                file (mach:get-unix-error-msg err)))))      (when process-command-line (ext::process-command-strings))
107                 (multiple-value-bind (res err) (mach:unix-close fd)      (setf *editor-lisp-p* nil)
108                   (if (null res)      (macrolet ((find-switch (name)
109                       (error "Failed to close file ~A, unix error: ~A"                   `(find ,name *command-line-switches*
110                              file (mach:get-unix-error-msg err)))))                          :key #'cmd-switch-name
111               (format t "done.]~%")                          :test #'(lambda (x y)
112               (mach::vm_deallocate *task-self* addr size-to-allocate)                                    (declare (simple-string x y))
113               (finish-output)                                    (string-equal x y)))))
114               byte-size)))))        (when (and process-command-line (find-switch "edit"))
115            (setf *editor-lisp-p* t))
116  (defun current-space-usage ()        (when (and load-init-file
117    (declare (optimize (speed 3) (safety 0)))                   (not (and process-command-line (find-switch "noinit"))))
118    (do ((sum 0)          (let* ((cl-switch (find-switch "init"))
119         (type 0 (1+ type)))                 (name (or (and cl-switch
120        ((> type %last-pointer-type) sum)                                (or (cmd-switch-value cl-switch)
121      (declare (fixnum type sum))                                    (car (cmd-switch-words cl-switch))
122      (if (not (or (eq type %short-+-float-type) (eq type %short---float-type)))                                    "init"))
123          (multiple-value-bind (dyn stat ro) (space-usage type)                           "init")))
124            (declare (fixnum dyn stat ro))            (load (merge-pathnames name (user-homedir-pathname))
125            (setq sum (+ sum dyn stat ro))))))                  :if-does-not-exist nil))))
126        (when print-herald
127          (print-herald))
128        (when process-command-line
129          (ext::invoke-switch-demons *command-line-switches*
130                                     *command-switch-demons*))
131        (funcall init-function)))
132    
133    
134    
135    (defun print-herald ()
136      (write-string "CMU Common Lisp ")
137      (write-line (lisp-implementation-version))
138      (write-string "Hemlock ")
139      (write-string *hemlock-version*)
140      (write-string ", Compiler ")
141      (write-line #+nil compiler-version #-nil "What compiler?")
142      (write-line "Send bug reports and questions to Gripe.")
143      (values))

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.1.1.1

  ViewVC Help
Powered by ViewVC 1.1.5