[slime-cvs] CVS slime
heller
heller at common-lisp.net
Tue Aug 12 17:54:44 UTC 2008
Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv21320
Modified Files:
ChangeLog swank-backend.lisp swank-clisp.lisp swank-cmucl.lisp
swank-loader.lisp swank-sbcl.lisp
Log Message:
Add a dump-image function to the loader.
* swank-loader.lisp (dump-image): New.
* swank-backend.lisp (save-image): New interface.
* swank-cmucl.lisp, swank-clisp.lisp, swank-sbcl.lisp
(save-image): Implemented.
--- /project/slime/cvsroot/slime/ChangeLog 2008/08/12 17:54:35 1.1448
+++ /project/slime/cvsroot/slime/ChangeLog 2008/08/12 17:54:43 1.1449
@@ -1,5 +1,16 @@
2008-08-12 Helmut Eller <heller at common-lisp.net>
+ Add a dump-image function to the loader.
+
+ * swank-loader.lisp (dump-image): New.
+
+ * swank-backend.lisp (save-image): New interface.
+
+ * swank-cmucl.lisp, swank-clisp.lisp, swank-sbcl.lisp
+ (save-image): Implemented.
+
+2008-08-12 Helmut Eller <heller at common-lisp.net>
+
* slime.el (slime-repl-send-input): Disable modification hooks
when marking old input.
(slime-check-version): Use y-or-n-p.
--- /project/slime/cvsroot/slime/swank-backend.lisp 2008/08/11 17:41:55 1.144
+++ /project/slime/cvsroot/slime/swank-backend.lisp 2008/08/12 17:54:43 1.145
@@ -1097,3 +1097,12 @@
(values . (&rest typespecs))
(vector . (&optional element-type size))
))
+
+;;; Heap dumps
+
+(definterface save-image (filename &optional restart-function)
+ "Save a heap image to the file FILENAME.
+RESTART-FUNCTION, if non-nil, should be called when the image is loaded.")
+
+
+
\ No newline at end of file
--- /project/slime/cvsroot/slime/swank-clisp.lisp 2008/08/11 17:41:55 1.73
+++ /project/slime/cvsroot/slime/swank-clisp.lisp 2008/08/12 17:54:43 1.74
@@ -691,6 +691,12 @@
(defimplementation make-weak-value-hash-table (&rest args)
(apply #'make-hash-table :weak :value args))
+(defimplementation save-image (filename &optional restart-function)
+ (let ((args `(,filename
+ ,@(if restart-function
+ `((:init-function ,restart-function))))))
+ (apply #'ext:saveinitmem args)))
+
;;; Local Variables:
;;; eval: (put 'compile-file-frobbing-notes 'lisp-indent-function 1)
;;; eval: (put 'dynamic-flet 'common-lisp-indent-function 1)
--- /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/08/11 17:41:55 1.186
+++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/08/12 17:54:44 1.187
@@ -2267,6 +2267,98 @@
(defimplementation make-weak-key-hash-table (&rest args)
(apply #'make-hash-table :weak-p t args))
+
+;;; Save image
+
+(defimplementation save-image (filename &optional restart-function)
+ (multiple-value-bind (pid error) (unix:unix-fork)
+ (when (not pid) (error "fork: ~A" (unix:get-unix-error-msg error)))
+ (cond ((= pid 0)
+ (let ((args `(,filename
+ ,@(if restart-function
+ `((:init-function ,restart-function))))))
+ (apply #'ext:save-lisp args)))
+ (t
+ (let ((status (waitpid pid)))
+ (destructuring-bind (&key exited? status &allow-other-keys) status
+ (assert (and exited? (equal status 0)) ()
+ "Invalid exit status: ~a" status)))))))
+
+(defun waitpid (pid)
+ (alien:with-alien ((status c-call:int))
+ (let ((code (alien:alien-funcall
+ (alien:extern-alien
+ waitpid (alien:function unix::pid-t
+ unix::pid-t
+ (* c-call:int) c-call:int))
+ pid (alien:addr status) 0)))
+ (cond ((= code -1) (error "waitpid: ~A" (unix:get-unix-error-msg)))
+ (t (assert (= code pid))
+ (decode-wait-status status))))))
+
+(defun decode-wait-status (status)
+ (let ((output (with-output-to-string (s)
+ (call-program (list (process-status-program)
+ (format nil "~d" status))
+ :output s))))
+ (read-from-string output)))
+
+(defun call-program (args &key output)
+ (destructuring-bind (program &rest args) args
+ (let ((process (ext:run-program program args :output output)))
+ (when (not program) (error "fork failed"))
+ (unless (and (eq (ext:process-status process) :exited)
+ (= (ext:process-exit-code process) 0))
+ (error "Non-zero exit status")))))
+
+(defvar *process-status-program* nil)
+
+(defun process-status-program ()
+ (or *process-status-program*
+ (setq *process-status-program*
+ (compile-process-status-program))))
+
+(defun compile-process-status-program ()
+ (let ((infile (system::pick-temporary-file-name
+ "/tmp/process-status~d~c.c")))
+ (with-open-file (stream infile :direction :output :if-exists :supersede)
+ (format stream "
+#include <stdio.h>
+#include <stdlib.h>
+#include <sys/types.h>
+#include <sys/wait.h>
+#include <assert.h>
+
+#define FLAG(value) (value ? \"t\" : \"nil\")
+
+int main (int argc, char** argv) {
+ assert (argc == 2);
+ {
+ char* endptr = NULL;
+ char* arg = argv[1];
+ long int status = strtol (arg, &endptr, 10);
+ assert (endptr != arg && *endptr == '\\0');
+ printf (\"(:exited? %s :status %d :signal? %s :signal %d :coredump? %s\"
+ \" :stopped? %s :stopsig %d)\\n\",
+ FLAG(WIFEXITED(status)), WEXITSTATUS(status),
+ FLAG(WIFSIGNALED(status)), WTERMSIG(status),
+ FLAG(WCOREDUMP(status)),
+ FLAG(WIFSTOPPED(status)), WSTOPSIG(status));
+ fflush (NULL);
+ return 0;
+ }
+}
+")
+ (finish-output stream))
+ (let* ((outfile (system::pick-temporary-file-name))
+ (args (list "cc" "-o" outfile infile)))
+ (warn "Running cc: ~{~a ~}~%" args)
+ (call-program args :output t)
+ (delete-file infile)
+ outfile)))
+
+;; (save-image "/tmp/x.core")
+
;; Local Variables:
;; pbook-heading-regexp: "^;;;\\(;+\\)"
;; pbook-commentary-regexp: "^;;;\\($\\|[^;]\\)"
--- /project/slime/cvsroot/slime/swank-loader.lisp 2008/07/23 14:29:10 1.86
+++ /project/slime/cvsroot/slime/swank-loader.lisp 2008/08/12 17:54:44 1.87
@@ -21,6 +21,7 @@
(cl:defpackage :swank-loader
(:use :cl)
(:export :init
+ :dump-image
:*source-directory*
:*fasl-directory*))
@@ -225,6 +226,10 @@
(eval `(pushnew 'compile-contribs ,(q "swank::*after-init-hook*")))
(funcall (q "swank::init")))
+(defun dump-image (filename)
+ (init :setup nil)
+ (funcall (q "swank-backend:save-image") filename))
+
(defun init (&key delete reload load-contribs (setup t))
(when (and delete (find-package :swank))
(mapc #'delete-package '(:swank :swank-io-package :swank-backend)))
--- /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/08/11 17:41:55 1.213
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/08/12 17:54:44 1.214
@@ -112,6 +112,7 @@
(or external-format :iso-latin-1-unix)
(or buffering :full)))
+#-win32
(defimplementation install-sigint-handler (function)
(sb-sys:enable-interrupt sb-unix:sigint
(lambda (&rest args)
@@ -1402,3 +1403,17 @@
(defimplementation hash-table-weakness (hashtable)
#+#.(swank-backend::sbcl-with-weak-hash-tables)
(sb-ext:hash-table-weakness hashtable))
+
+#-win32
+(defimplementation save-image (filename &optional restart-function)
+ (let ((pid (sb-posix:fork)))
+ (cond ((= pid 0)
+ (let ((args `(,filename
+ ,@(if restart-function
+ `((:toplevel ,restart-function))))))
+ (apply #'sb-ext:save-lisp-and-die args)))
+ (t
+ (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
+ (assert (= pid rpid))
+ (assert (and (sb-posix:wifexited status)
+ (zerop (sb-posix:wexitstatus status)))))))))
\ No newline at end of file
More information about the slime-cvs
mailing list