Skip to content
Snippets Groups Projects
Commit 5bfd87ac authored by wlott's avatar wlott
Browse files

Initial MIPS version.

parent 2b511924
No related branches found
No related tags found
No related merge requests found
...@@ -8,107 +8,136 @@ ...@@ -8,107 +8,136 @@
;;; Scott Fahlman (FAHLMAN@CMUC). ;;; Scott Fahlman (FAHLMAN@CMUC).
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
;;; Spice Lisp routines to suspend a process and create a core file. ;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/save.lisp,v 1.1.1.1 1990/06/17 02:08:50 wlott Exp $
;;; ;;;
;;; Written David B. McDonald. ;;; Dump the current lisp image into a core file. All the real work is done
;;; be C.
;;; ;;;
;;;********************************************************************** ;;; Written by William Lott.
;;;
;;; ;;;
;;; To see the format of Spice Lisp core files look at the document
;;; prva:<slisp.docs>core.mss.
(in-package "LISP") (in-package "LISP")
(in-package "EXTENSIONS") (in-package "EXTENSIONS")
(export '(*environment-list*)) (export '(print-herald save-lisp *before-save-initializations*
(defvar *environment-list* nil) *after-save-initializations* *environment-list* *editor-lisp-p*))
(in-package "LISP") (in-package "LISP")
(defvar *before-save-initializations* nil
"This is a list of functions which are called before creating a saved core
image. These functions are executed in the child process which has no ports,
so they cannot do anything that tries to talk to the outside world.")
(defvar *after-save-initializations* nil
"This is a list of functions which are called when a saved core image starts
up. The system itself should be initialized at this point, but applications
might not be.")
(proclaim '(special *task-self*)) (defvar *environment-list* nil
"An alist mapping environment variables (as keywords) to either values")
(defconstant save-block-size (* 64 1024) (defvar *editor-lisp-p* nil
"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.")
;;; Filled in by the startup code.
(defvar lisp-environment-list) (defvar lisp-environment-list)
(defvar original-lisp-environment)
;;;; Global state: (def-c-routine "save" (boolean)
(file (pointer simple-string)))
(defun save (file)
"Save the current lisp core image in a core file. When it returns in
the current process, the number of bytes written is returned. (defun save-lisp (core-file-name &key
When the saved core image is resumed, Nil is returned." (purify t)
(declare (optimize (speed 3) (safety 0))) (root-structures ())
(format t "~&[Building saved core image: ") (init-function
(finish-output) #'(lambda ()
(let ((size-to-allocate (* (current-space-usage) 2))) (throw 'top-level-catcher nil)))
(declare (fixnum size-to-allocate)) (load-init-file t)
(let* ((addr (int-sap (gr-call* mach::vm_allocate *task-self* (print-herald t)
0 size-to-allocate t))) (process-command-line t))
(byte-size (%primitive save *current-alien-free-pointer* "Saves a CMU Common Lisp core image in the file of the specified name. The
NIL addr))) following keywords are defined:
(cond ((null byte-size)
(mach::vm_deallocate *task-self* addr size-to-allocate) :purify
(error "Save failed.")) If true, do a purifying GC which moves all dynamically allocated
((eq byte-size T) objects into static space so that they stay pure. This takes somewhat
(dolist (f *before-save-initializations*) (funcall f)) longer than the normal GC which is otherwise done, but GC's will done
(dolist (f *after-save-initializations*) (funcall f)) less often and take less time in the resulting core file.
(reinit)
(setq original-lisp-environment lisp-environment-list) :root-structures
(let ((result nil)) This should be a list of the main entry points in any newly loaded
(dolist (ele lisp-environment-list systems. This need not be supplied, but locality will be better if it
(setf *environment-list* result)) is. This is meaningless if :purify is Nil.
(let ((=pos (position #\= (the simple-string ele))))
;; :init-function
;; This is dubious since all the strings have an =. This is a function which is called when the created core file is
;; What if one doesn't? What does that mean? resumed. The default function simply aborts to the top level
(when =pos read-eval-print loop. If the function returns it will be the value
(push (cons (intern (string-upcase (subseq ele 0 =pos)) of Save-Lisp.
*keyword-package*)
(subseq ele (1+ =pos))) :load-init-file
result))))) If true, then look for an init.lisp or init.fasl file when the core
NIL) file is resumed.
(T
(format t "~D bytes.~%" byte-size) :print-herald
(format t "Writing to file: ~A~%" file) If true, print out the lisp system herald when starting."
(finish-output)
(multiple-value-bind (fd err) (mach:unix-creat file #o644) (declare (ignore purify root-structures))
(if (null fd) #+nil
(error "Failed to open file ~A, unix error: ~A" (if purify
file (mach:get-unix-error-msg err))) (purify :root-structures root-structures)
(gc))
(do ((left byte-size (- left save-block-size)) (unless (save (namestring core-file-name))
(index 0 (+ index save-block-size))) (dolist (f *before-save-initializations*) (funcall f))
((< left save-block-size) (dolist (f *after-save-initializations*) (funcall f))
(when (> left 0) (reinit)
(multiple-value-bind (res err) (dolist (ele lisp-environment-list)
(mach:unix-write fd addr index left) (let ((=pos (position #\= (the simple-string ele))))
(if (null res) (when =pos
(error "Failed to write file ~A, unix error: ~A" (push (cons (intern (string-upcase (subseq ele 0 =pos))
file (mach:get-unix-error-msg err)))))) *keyword-package*)
(declare (fixnum left index)) (subseq ele (1+ =pos)))
(multiple-value-bind (res err) *environment-list*))))
(mach:unix-write fd addr index (setf (search-list "default:") (list (default-directory)))
save-block-size) (setf (search-list "path:") (setup-path-search-list))
(if (null res) (when process-command-line (ext::process-command-strings))
(error "Failed to write file ~A, unix error: ~A" (setf *editor-lisp-p* nil)
file (mach:get-unix-error-msg err))))) (macrolet ((find-switch (name)
(multiple-value-bind (res err) (mach:unix-close fd) `(find ,name *command-line-switches*
(if (null res) :key #'cmd-switch-name
(error "Failed to close file ~A, unix error: ~A" :test #'(lambda (x y)
file (mach:get-unix-error-msg err))))) (declare (simple-string x y))
(format t "done.]~%") (string-equal x y)))))
(mach::vm_deallocate *task-self* addr size-to-allocate) (when (and process-command-line (find-switch "edit"))
(finish-output) (setf *editor-lisp-p* t))
byte-size))))) (when (and load-init-file
(not (and process-command-line (find-switch "noinit"))))
(defun current-space-usage () (let* ((cl-switch (find-switch "init"))
(declare (optimize (speed 3) (safety 0))) (name (or (and cl-switch
(do ((sum 0) (or (cmd-switch-value cl-switch)
(type 0 (1+ type))) (car (cmd-switch-words cl-switch))
((> type %last-pointer-type) sum) "init"))
(declare (fixnum type sum)) "init")))
(if (not (or (eq type %short-+-float-type) (eq type %short---float-type))) (load (merge-pathnames name (user-homedir-pathname))
(multiple-value-bind (dyn stat ro) (space-usage type) :if-does-not-exist nil))))
(declare (fixnum dyn stat ro)) (when print-herald
(setq sum (+ sum dyn stat ro)))))) (print-herald))
(when process-command-line
(ext::invoke-switch-demons *command-line-switches*
*command-switch-demons*))
(funcall init-function)))
(defun print-herald ()
(write-string "CMU Common Lisp ")
(write-line (lisp-implementation-version))
(write-string "Hemlock ")
(write-string *hemlock-version*)
(write-string ", Compiler ")
(write-line #+nil compiler-version #-nil "What compiler?")
(write-line "Send bug reports and questions to Gripe.")
(values))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment