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

Contents of /src/code/save.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (hide annotations)
Tue Feb 6 17:26:43 1990 UTC (24 years, 2 months ago) by ram
Branch: MAIN
Initial revision
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     ;;; Spice Lisp routines to suspend a process and create a core file.
12     ;;;
13     ;;; Written David B. McDonald.
14     ;;;
15     ;;;**********************************************************************
16     ;;;
17     ;;; To see the format of Spice Lisp core files look at the document
18     ;;; prva:<slisp.docs>core.mss.
19     (in-package "LISP")
20    
21     (in-package "EXTENSIONS")
22     (export '(*environment-list*))
23     (defvar *environment-list* nil)
24     (in-package "LISP")
25    
26    
27     (proclaim '(special *task-self*))
28    
29     (defconstant save-block-size (* 64 1024)
30     "Amount to write for each call to write. This is due to RFS limitations.")
31    
32     (defvar lisp-environment-list)
33     (defvar original-lisp-environment)
34    
35     ;;;; Global state:
36    
37     (defun save (file)
38     "Save the current lisp core image in a core file. When it returns in
39     the current process, the number of bytes written is returned.
40     When the saved core image is resumed, Nil is returned."
41     (declare (optimize (speed 3) (safety 0)))
42     (format t "~&[Building saved core image: ")
43     (finish-output)
44     (let ((size-to-allocate (* (current-space-usage) 2)))
45     (declare (fixnum size-to-allocate))
46     (let* ((addr (int-sap (gr-call* mach::vm_allocate *task-self*
47     0 size-to-allocate t)))
48     (byte-size (%primitive save *current-alien-free-pointer*
49     NIL addr)))
50     (cond ((null byte-size)
51     (mach::vm_deallocate *task-self* addr size-to-allocate)
52     (error "Save failed."))
53     ((eq byte-size T)
54     (dolist (f *before-save-initializations*) (funcall f))
55     (dolist (f *after-save-initializations*) (funcall f))
56     (reinit)
57     (setq original-lisp-environment lisp-environment-list)
58     (let ((result nil))
59     (dolist (ele lisp-environment-list
60     (setf *environment-list* result))
61     (let ((=pos (position #\= (the simple-string ele))))
62     ;;
63     ;; This is dubious since all the strings have an =.
64     ;; What if one doesn't? What does that mean?
65     (when =pos
66     (push (cons (intern (string-upcase (subseq ele 0 =pos))
67     *keyword-package*)
68     (subseq ele (1+ =pos)))
69     result)))))
70     NIL)
71     (T
72     (format t "~D bytes.~%" byte-size)
73     (format t "Writing to file: ~A~%" file)
74     (finish-output)
75     (multiple-value-bind (fd err) (mach:unix-creat file #o644)
76     (if (null fd)
77     (error "Failed to open file ~A, unix error: ~A"
78     file (mach:get-unix-error-msg err)))
79    
80     (do ((left byte-size (- left save-block-size))
81     (index 0 (+ index save-block-size)))
82     ((< left save-block-size)
83     (when (> left 0)
84     (multiple-value-bind (res err)
85     (mach:unix-write fd addr index left)
86     (if (null res)
87     (error "Failed to write file ~A, unix error: ~A"
88     file (mach:get-unix-error-msg err))))))
89     (declare (fixnum left index))
90     (multiple-value-bind (res err)
91     (mach:unix-write fd addr index
92     save-block-size)
93     (if (null res)
94     (error "Failed to write file ~A, unix error: ~A"
95     file (mach:get-unix-error-msg err)))))
96     (multiple-value-bind (res err) (mach:unix-close fd)
97     (if (null res)
98     (error "Failed to close file ~A, unix error: ~A"
99     file (mach:get-unix-error-msg err)))))
100     (format t "done.]~%")
101     (mach::vm_deallocate *task-self* addr size-to-allocate)
102     (finish-output)
103     byte-size)))))
104    
105     (defun current-space-usage ()
106     (declare (optimize (speed 3) (safety 0)))
107     (do ((sum 0)
108     (type 0 (1+ type)))
109     ((> type %last-pointer-type) sum)
110     (declare (fixnum type sum))
111     (if (not (or (eq type %short-+-float-type) (eq type %short---float-type)))
112     (multiple-value-bind (dyn stat ro) (space-usage type)
113     (declare (fixnum dyn stat ro))
114     (setq sum (+ sum dyn stat ro))))))

  ViewVC Help
Powered by ViewVC 1.1.5