Index: swank-backend.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank-backend.lisp,v
retrieving revision 1.224
diff -u -b -r1.224 swank-backend.lisp
--- swank-backend.lisp	2 Feb 2013 10:11:16 -0000	1.224
+++ swank-backend.lisp	10 Jun 2013 20:14:08 -0000
@@ -43,7 +43,10 @@
            #:emacs-inspect
            #:label-value-line
            #:label-value-line*
-           #:with-symbol))
+           #:with-symbol
+           ;; thread stopper
+           #:call-with-only-initial-thread
+           #:register-thread-stopper))
 
 (defpackage :swank-mop
   (:use)
@@ -535,8 +538,8 @@
 (definterface socket-fd (socket-stream)
   "Return the file descriptor for SOCKET-STREAM.")
 
-(definterface make-fd-stream (fd external-format)
-  "Create a character stream for the file descriptor FD.")
+(definterface make-fd-stream (fd &key external-format element-type)
+  "Create a stream for the file descriptor FD.")
 
 (definterface dup (fd)
   "Duplicate a file descriptor.
@@ -1375,6 +1378,15 @@
   (declare (ignore name))
   nil)
 
+(definterface find-initial-thread ()
+  "Return the initial thread that image was started with."
+  nil)
+
+(definterface join-thread (thread)
+  "Wait for the thread to finish. May throw error if thread is already dead"
+  (declare (ignore thread))
+  nil)
+
 (definterface set-default-initial-binding (var form)
   "Initialize special variable VAR by default with FORM.
 
@@ -1502,12 +1514,158 @@
 RESTART-FUNCTION, if non-nil, should be called when the image is loaded.")
 
 (definterface background-save-image (filename &key restart-function
-                                              completion-function)
+                                              completion-function
+                                              communication-style)
   "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.")
+COMPLETION-FUNCTION, if non-nil, should be called after saving the image.
+COMMUNICATION-STYLE is the style of the calling connection")
 
 (defun deinit-log-output ()
   ;; Can't hang on to an fd-stream from a previous session.
   (setf (symbol-value (find-symbol "*LOG-OUTPUT*" 'swank))
         nil))
+
+
+;;; Thread stopper protocol, used for heap dumps
+
+;; Provides CALL-WITH-INITIAL-THREAD utility, which can be used by
+;; implementations that can't do some operations when there are
+;; multiple threads running.
+;; 
+;; Maintains a list of thread stoppers, which are callbacks that
+;; are called to stop and then resume threads.
+
+
+(defvar *thread-stopper-data*)
+(defvar *thread-stopper-alist* nil)
+
+(defun call-with-only-initial-thread (cont)
+  (declare (type (or symbol function) cont))
+  (if (> (length (all-threads)) 1) 
+      (spawn
+       (lambda ()
+         (let ((caller (current-thread))) 
+           (ignore-errors 
+            (interrupt-thread (find-initial-thread)
+                              (lambda ()
+                                (ensure-kill-thread caller)
+                                (stop-and-resume-threads cont))))))
+       :name "killer")
+      (stop-and-resume-threads cont)))
+
+(defun ensure-kill-thread (thread)
+  (when (thread-alive-p thread)
+    (ignore-errors (kill-thread thread))
+    (when (thread-alive-p thread)
+      (ignore-errors (join-thread thread)) 
+      (assert (not (thread-alive-p thread))))))
+
+(defun register-thread-stopper (name stopper)
+  "Allows libraries to register a thread stopper,
+which will be called around calls to fork().
+
+NAME :: coercible to string, used as unique id. If stopper already
+exist under that name, it will be replaced.
+
+STOPPER :: Must be a funcallable object
+
+Protocol:
+
+1. STOP PHASE.
+
+   Before attempting to fork, each stopper will be called with two
+   arguments, first being keyword :STOP and second being a
+   COLLECTOR, a function of zero or more arguments.
+
+   The stopper must stop all threads.
+
+   It may call the COLLECTOR zero or more times, passing arbitrary
+   arguments, which will all be remembered.
+
+   Usually the stopper will stop each thread, and call COLLECTOR with
+   enough information, that it can use to restart that thread, in the
+   same state as before.
+
+   Stoppers are called from the \"main\" thread.
+
+2. START PHASE
+
+   After the fork been done, each stopper that had called COLLECTOR
+   at least once doing the start phase, will be called again with
+   the first argument being :START, and rest of the arguments being
+   the remembered arguments from call to COLLECTOR.
+
+   Stopper must now restart the threads it had previously stopped
+
+Any errors doing the STOP phase, will result in entire operation being
+abandoned, with those stoppers that had successfully run before that
+point, being invoked called with :START.
+
+How to use this from your library.
+
+In case this patch does not make it to slime, you can can use the
+following method to register a stopper without causing any errors if
+service is not available when available
+
+  #+(and sbcl thread-stopper)
+  (progn
+    (defun my-library-stopper (cmd arg)
+      (ecase cmd (:stop
+                     (dolist (thread (my-library-thread-list))
+                       ;; remember it
+                       (funcall arg (thread-name thread))
+                       (ignore-errors (kill-thread thread))
+                       (ignore-errors (join-thread thread))
+                       (assert (not (thread-live-p thread)))))
+                 (:start (let ((thread-name arg))
+                           ... dispatch on thread-name, and start appropriate-thread ...))))
+                       
+     (swank-backend:register-thread-stopper 'my-library-stopper)      
+
+Also see the SLIME-CONNECTION-STOPPER function, which implement
+stop/start of threads used by Slime connection.
+
+"
+  (declare (type (or symbol string) name)
+           (type (or symbol function) stopper))
+  (setq name (string name))
+  (when (find name *thread-stopper-alist* :key #'car :test #'string=)
+    (setq *thread-stopper-alist* (remove name *thread-stopper-alist* :key #'car :test #'string=)))
+  (push (cons name stopper) *thread-stopper-alist*))
+
+(defun call-stoppers-to-stop ()
+  (loop for (name . stopper)
+        in *thread-stopper-alist*
+        for stopper-data = nil
+        do (progn
+             (funcall stopper :stop
+                      (lambda (&rest args)
+                        (push args stopper-data)))
+             (when stopper-data
+               (push (cons stopper stopper-data) *thread-stopper-data*)))))
+
+(defun call-stoppers-to-start ()
+  (loop for (stopper . stopper-data)
+        in *thread-stopper-data*
+        do (dolist (args stopper-data)
+             (handler-case
+                 (progn
+                   (apply stopper :start args))
+               (error (c)
+                 (format *error-output* "~@<Caught ~S ~A ~
+                 while calling ~S~:@>" (type-of c) c stopper))))))
+
+(defun stop-and-resume-threads (cont)
+  (let ((*thread-stopper-data* nil)) 
+    (unwind-protect
+         (progn 
+           ;; give REPL time to send response from our initial thread
+           (sleep 0.15)
+           (call-stoppers-to-stop)
+           (if (<= (length (all-threads)) 1)
+               (funcall cont)
+               (format *error-output* "Unable to get rid of all threads. Thread list:~% ~S~%"
+                       (all-threads))))
+      (call-stoppers-to-start))))
+
Index: swank-cmucl.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank-cmucl.lisp,v
retrieving revision 1.245
diff -u -b -r1.245 swank-cmucl.lisp
--- swank-cmucl.lisp	30 Oct 2012 18:38:33 -0000	1.245
+++ swank-cmucl.lisp	10 Jun 2013 20:14:09 -0000
@@ -159,7 +159,8 @@
                              :element-type '(unsigned-byte 8)
                              :buffering buffering))))
 
-(defimplementation make-fd-stream (fd external-format)
+(defimplementation make-fd-stream (fd &key external-format element-type)
+  (declare (ignore element-type))
   (make-socket-io-stream fd :full external-format))
 
 (defimplementation dup (fd)
Index: swank-sbcl.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank-sbcl.lisp,v
retrieving revision 1.328
diff -u -b -r1.328 swank-sbcl.lisp
--- swank-sbcl.lisp	2 Feb 2013 10:11:16 -0000	1.328
+++ swank-sbcl.lisp	10 Jun 2013 20:14:09 -0000
@@ -662,9 +662,7 @@
 (sb-alien:define-alien-routine (#-win32 "tempnam" #+win32 "_tempnam" tempnam)
     sb-alien:c-string
   (dir sb-alien:c-string)
-  (prefix sb-alien:c-string))
-
-)
+  (prefix sb-alien:c-string)))
 
 (defun temp-file-name ()
   "Return a temporary file name to compile strings into."
@@ -1622,6 +1620,12 @@
   (defimplementation thread-alive-p (thread)
     (sb-thread:thread-alive-p thread))
 
+  (defimplementation join-thread (thread)
+    (sb-thread:join-thread thread))
+
+  (defimplementation find-initial-thread ()
+    (first (last (all-threads))))
+
   (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
   (defvar *mailboxes* (list))
   (declaim (type list *mailboxes*))
@@ -1788,10 +1792,11 @@
 
 #-win32
 (defimplementation save-image (filename &optional restart-function)
-  (flet ((restart-sbcl ()
+  (labels ((restart-sbcl ()
            (sb-debug::enable-debugger)
            (setf sb-impl::*descriptor-handlers* nil)
-           (funcall restart-function)))
+           (funcall restart-function))
+         (forker () 
     (let ((pid (sb-posix:fork)))
       (cond ((= pid 0)
              (sb-debug::disable-debugger)
@@ -1803,6 +1808,7 @@
                (assert (= pid rpid))
                (assert (and (sb-posix:wifexited status)
                             (zerop (sb-posix:wexitstatus status))))))))))
+    (call-with-only-initial-thread #'forker)))
 
 #+unix
 (progn
@@ -1834,52 +1840,91 @@
     (car sb-ext:*posix-argv*))
 
   (defimplementation exec-image (image-file args)
-    (loop with fd-arg =
-          (loop for arg in args
+    (let ((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)))
+                        return (parse-integer arg)))
+          (dedicated-fd (loop for arg in args
+                              and key = "" then arg
+                              when (string-equal key "--dedicated-fd")
+                              return (parse-integer arg)))) 
+      (loop for my-fd from 3 to 1024
+            when (not (or (= my-fd fd-arg)
+                          (eql my-fd dedicated-fd)))
+            do (ignore-errors (sb-posix:fcntl my-fd sb-posix:f-setfd 1))))
     (let* ((self-string (pathname-to-filename (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
+(defimplementation make-fd-stream (fd &key external-format element-type)
+  (let ((args `(:input t :output t
+                :element-type ,(if external-format
+                                   'character 
+                                   (or element-type '(unsigned-byte 8)))
                          :buffering :full
                          :dual-channel-p t                         
-                         :external-format external-format))
+                ,@(cond ((and external-format (sb-int:featurep :sb-unicode))
+                         `(:external-format ,external-format))
+                        (t '()))))) 
+    (apply #'sb-sys:make-fd-stream fd args)))
 
 #-win32
 (defimplementation background-save-image (filename &key restart-function
-                                                   completion-function)
-  (flet ((restart-sbcl ()
+                                                   completion-function
+                                                   communication-style)
+  (let (pid) 
+    (labels ((restart-sbcl ()
            (sb-debug::enable-debugger)
            (setf sb-impl::*descriptor-handlers* nil)
-           (funcall restart-function)))
+               (funcall restart-function))
+             (logg (&rest args)
+               (ignore-errors 
+                (apply #'format sb-sys:*tty* args)
+                (terpri sb-sys:*tty*)
+                (finish-output sb-sys:*tty*)))
+             (waiter (&optional fd)
+               (logg "FD-HANDLER for pid ~d fd ~d" pid fd)
+               (when fd 
+                 (logg "before invalidate ~d" fd) 
+                 (sb-sys:invalidate-descriptor fd) 
+                 (logg "before close ~d" fd)
+                 (sb-posix:close fd))
+               (logg "before waitpid")
+               (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
+                 (logg "waitpid returned")
+                 (assert (= pid rpid))
+                 (assert (sb-posix:wifexited status))
+                 (funcall completion-function
+                          (zerop (sb-posix:wexitstatus status))))
+               (logg "After waitpid"))
+             (forker () 
+               (if (eq communication-style :spawn) 
+                   (cond ((= (setq pid (sb-posix:fork)) 0)
+                          (sb-debug::disable-debugger)
+                          (logg "I'm a child in forker()")
+                          (apply #'sb-ext:save-lisp-and-die filename
+                                 (when restart-function
+                                   (list :toplevel #'restart-sbcl))))
+                         (t
+                          (logg "I'm a parent of ~d, will use thread to wait" pid)
+                          (spawn #'waiter :name "background-save-image")))
     (multiple-value-bind (pipe-in pipe-out) (sb-posix:pipe)
-      (let ((pid (sb-posix:fork)))
-        (cond ((= pid 0)
+                     (cond ((= (setq pid (sb-posix:fork)) 0)
                (sb-posix:close pipe-in)
                (sb-debug::disable-debugger)
+                            (logg "I'm a child in forker()")
                (apply #'sb-ext:save-lisp-and-die filename
                       (when restart-function
                         (list :toplevel #'restart-sbcl))))
               (t
+                            (logg "I'm a parent of ~d, will use fd-handler to wait" pid)
                (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))))))))))))
+                            (sb-sys:add-fd-handler pipe-in :input #'waiter)
+                            (logg "Added fd handler to ~d~% handlers are now ~s" pipe-in
+                                  sb-impl::*descriptor-handlers*)))))))
+      (call-with-only-initial-thread #'forker))))
+
+
 
 (pushnew 'deinit-log-output sb-ext:*save-hooks*)
Index: swank.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank.lisp,v
retrieving revision 1.803
diff -u -b -r1.803 swank.lisp
--- swank.lisp	11 Jan 2013 09:00:30 -0000	1.803
+++ swank.lisp	10 Jun 2013 20:14:09 -0000
@@ -649,6 +649,62 @@
     (throw 'exit-sentinel nil)))
 
 
+;;; Thread stopper, for image dumping
+
+(defun slime-connection-stopper (cmd arg)
+  (ecase cmd
+    (:stop 
+     (dolist (c *connections*)
+       (etypecase c
+         (multithreaded-connection
+          (let ((threads
+                  (append 
+                   (remove nil (list (mconn.repl-thread c)
+                                     (mconn.reader-thread c)
+                                     (mconn.control-thread c)
+                                     (mconn.auto-flush-thread c)
+                                     (mconn.indentation-cache-thread c)))
+                   (mconn.active-threads c))))
+            (dolist (thread threads)
+              (ignore-errors (kill-thread thread)))
+            (dolist (thread threads)
+              (ignore-errors (join-thread thread)))
+            (assert (notany #'thread-alive-p threads))
+            ;; mark for restoration
+            (funcall arg c)))
+         (singlethreaded-connection)))
+     (let ((sentinel (find-registered 'sentinel)))
+       (when sentinel
+         (ignore-errors 
+          (interrupt-thread
+           sentinel
+           (lambda ()
+             (throw 'exit-sentinel nil))))
+         (ignore-errors (join-thread sentinel))
+         (assert (not (thread-alive-p sentinel)))
+         ;; mark for restoration
+         (funcall arg 'sentinel)
+         ;; make slime forget it had one
+         (register-thread 'sentinel nil))))
+    (:start
+     (cond ((connection-p arg) 
+            (etypecase arg
+              (multithreaded-connection
+               (serve-requests arg)
+               ;; when we had a flush thread, restart it
+               (when (mconn.auto-flush-thread arg) 
+                 (setf (mconn.auto-flush-thread arg)
+                       (spawn (lambda ()
+                                       (auto-flush-loop
+                                        (connection.user-output arg)))
+                         :name "auto-flush-thread"))))
+              (singlethreaded-connection)))
+           ((eq arg 'sentinel)
+            (start-sentinel))))))
+
+(register-thread-stopper :swank #'slime-connection-stopper)
+
+
 ;;;;; Misc
 
 (defun use-threads-p ()
@@ -968,7 +1024,7 @@
               (loop for (i f) in backtrace collect 
                     (ignore-errors 
                       (format nil "~d: ~a" i (escape-non-ascii f))))
-              (escape-non-ascii (safe-condition-message condition) )
+              (escape-non-ascii (safe-condition-message condition))
               (type-of condition)
               (connection.communication-style c)))
     (finish-output *log-output*)
Index: contrib/slime-snapshot.el
===================================================================
RCS file: /project/slime/cvsroot/slime/contrib/slime-snapshot.el,v
retrieving revision 1.7
diff -u -b -r1.7 slime-snapshot.el
--- contrib/slime-snapshot.el	21 May 2011 17:01:48 -0000	1.7
+++ contrib/slime-snapshot.el	10 Jun 2013 20:14:09 -0000
@@ -24,9 +24,18 @@
   "Restore a memory image stored in file FILENAME."
   (interactive (list (read-file-name "Image file: ")))
   ;; bypass event dispatcher because we don't expect a reply. FIXME.
-  (slime-net-send `(:emacs-rex (swank-snapshot:restore-snapshot 
-				,(expand-file-name filename))
+  (let* ((have-repl-p
+          (when (and (fboundp
+                      'slime-connection-output-buffer) 
+                     (slime-connection-output-buffer))
+            t))
+         (cs (when have-repl-p (slime-repl-choose-coding-system))))
+    (slime-net-send
+     `(:emacs-rex (swank-snapshot:restore-snapshot 
+                   ,(expand-file-name filename)
+                   :have-repl-p ,have-repl-p
+                   ,@(when have-repl-p `(:coding-system ,cs)))
 			       nil t nil)
-		  (slime-connection)))
+     (slime-connection))))
 
 (provide 'slime-snapshot)
Index: contrib/swank-repl.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/contrib/swank-repl.lisp,v
retrieving revision 1.7
diff -u -b -r1.7 swank-repl.lisp
--- contrib/swank-repl.lisp	16 Dec 2012 13:38:21 -0000	1.7
+++ contrib/swank-repl.lisp	10 Jun 2013 20:14:09 -0000
@@ -25,10 +25,18 @@
               (with-simple-restart (abort-read
                                     "Abort reading input from Emacs.")
                 (read-user-input-from-emacs)))))
-         (dedicated-output (if *use-dedicated-output-stream*
+         (ds (getf properties :dedicated-stream))
+         (dedicated-output
+           (if ds (prog1 ds
+                    ;; When restoring a snapshot without dedicated output
+                    ;; in the image that has one, make setting match
+                    ;; the calling image
+                    (unless *use-dedicated-output-stream* 
+                      (setq *use-dedicated-output-stream* t)))
+               (if *use-dedicated-output-stream*
                                (open-dedicated-output-stream
                                 connection
-                                (getf properties :coding-system))))
+                    (getf properties :coding-system)))))
          (in (make-input-stream input-fn))
          (out (or dedicated-output
                   (make-output-stream (make-output-function connection))))
@@ -73,6 +81,7 @@
            (encode-message `(:open-dedicated-output-stream ,port
                                                            ,coding-system)
                            (connection.socket-io connection))
+
            (let ((dedicated (accept-connection
                              socket
                              :external-format ef
@@ -119,10 +128,13 @@
 ;;; We always redirect the standard streams to Emacs while evaluating
 ;;; an RPC. This is done with simple dynamic bindings.
 
-(defslimefun create-repl (target &key coding-system)
+(defslimefun create-repl (target &key coding-system dedicated-stream)
   (assert (eq target nil))
   (let ((conn *emacs-connection*))
-    (initialize-streams-for-connection conn `(:coding-system ,coding-system))
+    (initialize-streams-for-connection
+     ;; dedicated stream will be non-NIL when restoring snapshot
+     conn `(:coding-system ,coding-system
+            :dedicated-stream ,dedicated-stream))
     (with-struct* (connection. @ conn)
       (setf (@ env)
             `((*standard-output* . ,(@ user-output))
Index: contrib/swank-snapshot.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/contrib/swank-snapshot.lisp,v
retrieving revision 1.4
diff -u -b -r1.4 swank-snapshot.lisp
--- contrib/swank-snapshot.lisp	6 Mar 2012 20:55:13 -0000	1.4
+++ contrib/swank-snapshot.lisp	10 Jun 2013 20:14:09 -0000
@@ -11,22 +11,35 @@
 			      (lambda () (resurrect c))))
   (format nil "Dumped lisp to ~A" image-file))
 
-(defslimefun restore-snapshot (image-file)
+(defslimefun restore-snapshot (image-file &key have-repl-p coding-system)
+  (handler-case 
   (let* ((conn swank::*emacs-connection*)
 	 (stream (swank::connection.socket-io conn))
-	 (clone (swank-backend:dup (swank-backend:socket-fd stream)))
+             (dedicated-output (swank::connection.dedicated-output conn)))
+        (let* ((clone (swank-backend:dup (swank-backend:socket-fd stream)))
+               (output-clone (when dedicated-output
+                               (swank-backend:dup (swank-backend:socket-fd dedicated-output))))
 	 (style (swank::connection.communication-style conn))
-	 (repl (if (swank::connection.user-io conn) t))
-	 (args (list "--swank-fd" (format nil "~d" clone)
+               (args
+                 (append
+                  (list "--swank-fd" (format nil "~d" clone)
 		     "--swank-style" (format nil "~s" style)
-		     "--swank-repl" (format nil "~s" repl))))
-    (swank::close-connection conn nil nil)
-    (swank-backend:exec-image image-file args)))
+                        "--swank-repl" (format nil "~s" (when have-repl-p t)))
+                  (when output-clone
+                    (list "--dedicated-fd" (format nil "~d" output-clone)))
+                  (when have-repl-p
+                    (list "--coding-system" (format nil "~a" coding-system)))))) 
+          ;; (swank::close-connection conn nil nil)
+          (swank-backend:exec-image image-file args))
+        (error "~s unexpectedly returned" 'swank-backend:exec-image))
+    (condition (c)
+      (list nil (format nil "~A" c)))))
 
 (defslimefun background-save-snapshot (image-file)
-  (let ((connection swank::*emacs-connection*))
+  (let* ((connection swank::*emacs-connection*)
+         (style (swank::connection.communication-style connection)))
     (flet ((complete (success)
-	     (let ((swank::*emacs-connection* connection))
+	     (swank::with-connection (connection)
 	       (swank::background-message
 		"Dumping lisp image ~A ~:[failed!~;succeeded.~]" 
 		image-file success)))
@@ -34,33 +47,64 @@
 	     (resurrect connection)))
       (swank-backend:background-save-image image-file
 					   :restart-function #'awaken
-					   :completion-function #'complete)
+					   :completion-function #'complete
+                                           :communication-style style)
       (format nil "Started dumping lisp to ~A..." image-file))))
 
 (in-package :swank)
 
 (defun swank-snapshot::resurrect (old-connection)
+  (sb-ext:enable-debugger)
   (setq *log-output* nil)
   (init-log-output)
   (clear-event-history)
   (setq *connections* (delete old-connection *connections*))
   (format *error-output* "args: ~s~%" (command-line-args))
   (let* ((fd (read-command-line-arg "--swank-fd"))
+         (dedicated-fd (read-command-line-arg "--dedicated-fd"))
 	 (style (read-command-line-arg "--swank-style"))
 	 (repl (read-command-line-arg "--swank-repl"))
 	 (* (format *error-output* "fd=~s style=~s~%" fd style))
-	 (stream (make-fd-stream fd nil))
+         (stream (make-fd-stream fd :element-type '(unsigned-byte 8)))
+         (coding-system (read-command-line-arg "--coding-system" nil))
 	 (connection (make-connection nil stream style)))
-    (let ((*emacs-connection* connection))
-      (when repl (swank::create-repl nil))
-      (background-message "~A" "Lisp image restored"))
+    ;; top level one should be null
+    (setq *emacs-connection* nil)
+    (when (eq style :spawn)
+      (start-sentinel))
+    (with-connection (connection)
+      (when repl (swank::create-repl
+                  nil
+                  :coding-system coding-system
+                  :dedicated-stream
+                  (when dedicated-fd
+                    (make-fd-stream dedicated-fd
+                                    :external-format
+                                    (find-external-format-or-lose coding-system))))))
+    ;; Aha! serve-requests, has to be outside of *emacs-connection*
+    ;; binding, because handle-requests uses (with-connection), which
+    ;; short-circuits if *emacs-connection* is the same, and does not
+    ;; setup io redirection
+    (assert (null *emacs-connection*))
     (serve-requests connection)
-    (simple-repl)))
+    ;; But to send message back, we need with-connection-again
+    (with-connection (connection) (background-message "~A" "Lisp image restored")) 
+    (tagbody toplevel
+       (restart-case
+           (let ((*sldb-quit-restart* (find-restart 'abort)))
+             (simple-repl))
+         (abort (&optional v)
+           :report "Return to top level."
+           (declare (ignore v))
+           (go toplevel))))))
 
-(defun read-command-line-arg (name)
+(defun read-command-line-arg (name &optional (use-read-p t))
   (let* ((args (command-line-args))
 	 (pos (position name args :test #'equal)))
-    (read-from-string (elt args (1+ pos)))))
+    (when pos 
+      (if use-read-p 
+          (read-from-string (elt args (1+ pos)))
+          (elt args (1+ pos))))))
 
 (in-package :swank-snapshot)
 
