? sbcl-1.0.40-windows-x86 Index: swank-backend.lisp =================================================================== RCS file: /project/slime/cvsroot/slime/swank-backend.lisp,v retrieving revision 1.199 diff -u -r1.199 swank-backend.lisp --- swank-backend.lisp 22 Apr 2010 05:47:35 -0000 1.199 +++ swank-backend.lisp 20 Aug 2010 09:44:31 -0000 @@ -1301,5 +1301,8 @@ "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 +(definterface background-save-image (filename &key restart-function + completion-function) + "Request saving a heap image to the file FILENAME. +RESTART-FUNCTION, if non-nil, should be called when the image is loaded. +COMPLETION-FUNCTION, if non-nil, should be called after saving the image.") Index: swank-sbcl.lisp =================================================================== RCS file: /project/slime/cvsroot/slime/swank-sbcl.lisp,v retrieving revision 1.273 diff -u -r1.273 swank-sbcl.lisp --- swank-sbcl.lisp 12 Aug 2010 12:09:45 -0000 1.273 +++ swank-sbcl.lisp 20 Aug 2010 09:44:32 -0000 @@ -155,12 +155,18 @@ (defimplementation remove-fd-handlers (socket) (sb-sys:invalidate-descriptor (socket-fd socket))) -(defun socket-fd (socket) +(defimplementation socket-fd (socket) (etypecase socket (fixnum socket) (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket)) (file-stream (sb-sys:fd-stream-fd socket)))) +(defimplementation command-line-args () + sb-ext:*posix-argv*) + +(defimplementation dup (fd) + (sb-posix:dup fd)) + (defvar *wait-for-input-called*) (defimplementation wait-for-input (streams &optional timeout) @@ -1549,13 +1555,87 @@ #-win32 (defimplementation save-image (filename &optional restart-function) - (let ((pid (sb-posix:fork))) - (cond ((= pid 0) - (apply #'sb-ext:save-lisp-and-die filename - (when restart-function - (list :toplevel restart-function)))) - (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))))))))) + (flet ((restart-sbcl () + (sb-debug::enable-debugger) + (setf sb-impl::*descriptor-handlers* nil) + (funcall restart-function))) + (let ((pid (sb-posix:fork))) + (cond ((= pid 0) + (sb-debug::disable-debugger) + (apply #'sb-ext:save-lisp-and-die filename + (when restart-function + (list :toplevel #'restart-sbcl)))) + (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)))))))))) + +#+unix +(progn + (sb-alien:define-alien-routine ("execv" sys-execv) sb-alien:int + (program sb-alien:c-string) + (argv (* sb-alien:c-string))) + + (defun execv (program args) + "Replace current executable with another one." + (let ((a-args (sb-alien:make-alien sb-alien:c-string + (+ 1 (length args))))) + (unwind-protect + (progn + (loop for index from 0 by 1 + and item in (append args '(nil)) + do (setf (sb-alien:deref a-args index) + item)) + (when (minusp + (sys-execv program a-args)) + (sb-posix:syscall-error))) + (sb-alien:free-alien a-args)))) + + (defimplementation exec-image (image-file args) + (loop with fd-arg = + (loop for arg in args + and key = "" then arg + when (string-equal key "--swank-fd") + return (parse-integer arg)) + for my-fd from 3 to 1024 + when (/= my-fd fd-arg) + do (ignore-errors (sb-posix:fcntl my-fd sb-posix:f-setfd 1))) + (let* ((self-string (pathname-to-filename sb-ext:*runtime-pathname*))) + (execv + self-string + (apply 'list self-string "--core" image-file args))))) + +(defimplementation make-fd-stream (fd external-format) + (sb-sys:make-fd-stream fd :input t :output t + :element-type 'character + :buffering :full + :dual-channel-p t + :external-format external-format)) + +(defimplementation background-save-image (filename &key restart-function + completion-function) + (flet ((restart-sbcl () + (sb-debug::enable-debugger) + (setf sb-impl::*descriptor-handlers* nil) + (funcall restart-function))) + (multiple-value-bind (pipe-in pipe-out) (sb-posix:pipe) + (let ((pid (sb-posix:fork))) + (cond ((= pid 0) + (sb-posix:close pipe-in) + (sb-debug::disable-debugger) + (apply #'sb-ext:save-lisp-and-die filename + (when restart-function + (list :toplevel #'restart-sbcl)))) + (t + (sb-posix:close pipe-out) + (sb-sys:add-fd-handler + pipe-in :input + (lambda (fd) + (sb-sys:invalidate-descriptor fd) + (sb-posix:close fd) + (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0) + (assert (= pid rpid)) + (assert (sb-posix:wifexited status)) + (funcall completion-function + (zerop (sb-posix:wexitstatus status)))))))))))) Index: contrib/slime-snapshot.el =================================================================== RCS file: /project/slime/cvsroot/slime/contrib/slime-snapshot.el,v retrieving revision 1.5 diff -u -r1.5 slime-snapshot.el --- contrib/slime-snapshot.el 28 May 2010 19:13:17 -0000 1.5 +++ contrib/slime-snapshot.el 20 Aug 2010 09:44:32 -0000 @@ -5,11 +5,15 @@ (:license "Unknown") (:swank-dependencies swank-snapshot)) -(defun slime-snapshot (filename) +(defun slime-snapshot (filename &optional arg) "Save a memory image to the file FILENAME." - (interactive (list (read-file-name "Image file: "))) - (slime-eval-with-transcript - `(swank-snapshot:save-snapshot ,(expand-file-name filename)))) + (interactive (list (read-file-name "Image file: ") + current-prefix-arg)) + (slime-eval-with-transcript + `(,(if arg + 'swank-snapshot:background-save-snapshot + 'swank-snapshot:save-snapshot) + ,(expand-file-name filename)))) (defun slime-restore (filename) "Restore a memory image stored in file FILENAME." Index: contrib/swank-snapshot.lisp =================================================================== RCS file: /project/slime/cvsroot/slime/contrib/swank-snapshot.lisp,v retrieving revision 1.2 diff -u -r1.2 swank-snapshot.lisp --- contrib/swank-snapshot.lisp 13 Aug 2010 07:25:15 -0000 1.2 +++ contrib/swank-snapshot.lisp 20 Aug 2010 09:44:32 -0000 @@ -9,7 +9,7 @@ (swank-backend:save-image image-file (let ((c swank::*emacs-connection*)) (lambda () (resurrect c)))) - t) + (format nil "Dumped lisp to ~A" image-file)) (defslimefun restore-snapshot (image-file) (let* ((conn swank::*emacs-connection*) @@ -37,9 +37,28 @@ (* (format *error-output* "fd=~s style=~s cs=~s~%" fd style coding)) (stream (make-fd-stream fd (find-external-format-or-lose coding))) (connection (make-connection nil stream style coding))) + (let ((*emacs-connection* connection)) + (create-repl nil) + (let ((message #-sbcl "Lisp image restored" + #+sbcl (format nil "Lisp image restored from ~A" + sb-ext:*core-pathname*))) + (background-message "~A" message))) (serve-requests connection) (simple-repl))) +(defslimefun swank-snapshot::background-save-snapshot (image-file) + (let ((connection *emacs-connection*)) + (flet ((complete (success) + (let ((*emacs-connection* connection)) + (background-message + "Dumping lisp image ~A ~:[failed!~;succeeded.~]" image-file success))) + (awaken () + (swank-snapshot::resurrect connection))) + (swank-backend:background-save-image image-file + :restart-function #'awaken + :completion-function #'complete) + (format nil "Started dumping lisp to ~A..." image-file)))) + (defun read-command-line-arg (name) (let* ((args (command-line-args)) (pos (position name args :test #'equal)))