From 5bfd87ac3ef7f6f0f0ede55eca68fef297c3609b Mon Sep 17 00:00:00 2001 From: wlott <wlott> Date: Sun, 17 Jun 1990 02:08:50 +0000 Subject: [PATCH] Initial MIPS version. --- code/save.lisp | 215 ++++++++++++++++++++++++++++--------------------- 1 file changed, 122 insertions(+), 93 deletions(-) diff --git a/code/save.lisp b/code/save.lisp index bc6926cb2..7969c9c0a 100644 --- a/code/save.lisp +++ b/code/save.lisp @@ -8,107 +8,136 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; Spice Lisp routines to suspend a process and create a core file. -;;; -;;; Written David B. McDonald. +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/save.lisp,v 1.1.1.1 1990/06/17 02:08:50 wlott Exp $ +;;; +;;; 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 "EXTENSIONS") -(export '(*environment-list*)) -(defvar *environment-list* nil) +(export '(print-herald save-lisp *before-save-initializations* + *after-save-initializations* *environment-list* *editor-lisp-p*)) (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) - "Amount to write for each call to write. This is due to RFS limitations.") +(defvar *editor-lisp-p* nil + "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 original-lisp-environment) - -;;;; Global state: - -(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. - When the saved core image is resumed, Nil is returned." - (declare (optimize (speed 3) (safety 0))) - (format t "~&[Building saved core image: ") - (finish-output) - (let ((size-to-allocate (* (current-space-usage) 2))) - (declare (fixnum size-to-allocate)) - (let* ((addr (int-sap (gr-call* mach::vm_allocate *task-self* - 0 size-to-allocate t))) - (byte-size (%primitive save *current-alien-free-pointer* - NIL addr))) - (cond ((null byte-size) - (mach::vm_deallocate *task-self* addr size-to-allocate) - (error "Save failed.")) - ((eq byte-size T) - (dolist (f *before-save-initializations*) (funcall f)) - (dolist (f *after-save-initializations*) (funcall f)) - (reinit) - (setq original-lisp-environment lisp-environment-list) - (let ((result nil)) - (dolist (ele lisp-environment-list - (setf *environment-list* result)) - (let ((=pos (position #\= (the simple-string ele)))) - ;; - ;; This is dubious since all the strings have an =. - ;; What if one doesn't? What does that mean? - (when =pos - (push (cons (intern (string-upcase (subseq ele 0 =pos)) - *keyword-package*) - (subseq ele (1+ =pos))) - result))))) - NIL) - (T - (format t "~D bytes.~%" byte-size) - (format t "Writing to file: ~A~%" file) - (finish-output) - (multiple-value-bind (fd err) (mach:unix-creat file #o644) - (if (null fd) - (error "Failed to open file ~A, unix error: ~A" - file (mach:get-unix-error-msg err))) - - (do ((left byte-size (- left save-block-size)) - (index 0 (+ index save-block-size))) - ((< left save-block-size) - (when (> left 0) - (multiple-value-bind (res err) - (mach:unix-write fd addr index left) - (if (null res) - (error "Failed to write file ~A, unix error: ~A" - file (mach:get-unix-error-msg err)))))) - (declare (fixnum left index)) - (multiple-value-bind (res err) - (mach:unix-write fd addr index - save-block-size) - (if (null res) - (error "Failed to write file ~A, unix error: ~A" - file (mach:get-unix-error-msg err))))) - (multiple-value-bind (res err) (mach:unix-close fd) - (if (null res) - (error "Failed to close file ~A, unix error: ~A" - file (mach:get-unix-error-msg err))))) - (format t "done.]~%") - (mach::vm_deallocate *task-self* addr size-to-allocate) - (finish-output) - byte-size))))) - -(defun current-space-usage () - (declare (optimize (speed 3) (safety 0))) - (do ((sum 0) - (type 0 (1+ type))) - ((> type %last-pointer-type) sum) - (declare (fixnum type sum)) - (if (not (or (eq type %short-+-float-type) (eq type %short---float-type))) - (multiple-value-bind (dyn stat ro) (space-usage type) - (declare (fixnum dyn stat ro)) - (setq sum (+ sum dyn stat ro)))))) + + +(def-c-routine "save" (boolean) + (file (pointer simple-string))) + + +(defun save-lisp (core-file-name &key + (purify t) + (root-structures ()) + (init-function + #'(lambda () + (throw 'top-level-catcher nil))) + (load-init-file t) + (print-herald t) + (process-command-line t)) + "Saves a CMU Common Lisp core image in the file of the specified name. The + following keywords are defined: + + :purify + If true, do a purifying GC which moves all dynamically allocated + objects into static space so that they stay pure. This takes somewhat + longer than the normal GC which is otherwise done, but GC's will done + less often and take less time in the resulting core file. + + :root-structures + This should be a list of the main entry points in any newly loaded + systems. This need not be supplied, but locality will be better if it + is. This is meaningless if :purify is Nil. + + :init-function + This is a function which is called when the created core file is + resumed. The default function simply aborts to the top level + read-eval-print loop. If the function returns it will be the value + of Save-Lisp. + + :load-init-file + If true, then look for an init.lisp or init.fasl file when the core + file is resumed. + + :print-herald + If true, print out the lisp system herald when starting." + + (declare (ignore purify root-structures)) + #+nil + (if purify + (purify :root-structures root-structures) + (gc)) + (unless (save (namestring core-file-name)) + (dolist (f *before-save-initializations*) (funcall f)) + (dolist (f *after-save-initializations*) (funcall f)) + (reinit) + (dolist (ele lisp-environment-list) + (let ((=pos (position #\= (the simple-string ele)))) + (when =pos + (push (cons (intern (string-upcase (subseq ele 0 =pos)) + *keyword-package*) + (subseq ele (1+ =pos))) + *environment-list*)))) + (setf (search-list "default:") (list (default-directory))) + (setf (search-list "path:") (setup-path-search-list)) + (when process-command-line (ext::process-command-strings)) + (setf *editor-lisp-p* nil) + (macrolet ((find-switch (name) + `(find ,name *command-line-switches* + :key #'cmd-switch-name + :test #'(lambda (x y) + (declare (simple-string x y)) + (string-equal x y))))) + (when (and process-command-line (find-switch "edit")) + (setf *editor-lisp-p* t)) + (when (and load-init-file + (not (and process-command-line (find-switch "noinit")))) + (let* ((cl-switch (find-switch "init")) + (name (or (and cl-switch + (or (cmd-switch-value cl-switch) + (car (cmd-switch-words cl-switch)) + "init")) + "init"))) + (load (merge-pathnames name (user-homedir-pathname)) + :if-does-not-exist nil)))) + (when print-herald + (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)) -- GitLab