src/code/warm-mswin.lisp

   1 ;;;; Windows API bindings not needed for cold initialization.
   2 (in-package "SB-WIN32")
   3 \f
   4 ;;;; CreateProcess and surrounding data structures provide a way to implement
   5 ;;;; RUN-PROGRAM while using handles rather than file descriptors.
   6
   7 (define-alien-type process-information
   8     (struct process-information
   9       (process-handle handle)
  10       (thread-handle handle)
  11       (process-id dword)
  12       (thread-id dword)))
  13
  14 (define-alien-type startup-info
  15     (struct startup-info
  16       (cb dword)
  17       (reserved1 system-string)
  18       (desktop system-string)
  19       (title system-string)
  20       (x dword)
  21       (y dword)
  22       (x-size dword)
  23       (y-size dword)
  24       (x-chars dword)
  25       (y-chars dword)
  26       (fill-attribute dword)
  27       (flags dword)
  28       (show-window unsigned-short)
  29       (reserved2 unsigned-short)
  30       (reserved3 (* t))
  31       (stdin handle)
  32       (stdout handle)
  33       (stderr handle)))
  34
  35 (defconstant +startf-use-std-handles+ #x100)
  36
  37 (define-alien-routine ("CreateProcessW" create-process) lispbool
  38   (application-name system-string)
  39   (command-line system-string)
  40   (process-security-attributes (* t))
  41   (thread-security-attributes (* t))
  42   (inherit-handles-p lispbool)
  43   (creation-flags dword)
  44   (environment (* t))
  45   (current-directory system-string)
  46   (startup-info (* t))
  47   (process-information (* t)))
  48
  49 (defun search-path (partial-name)
  50   "Searh executable using the system path"
  51   (with-alien ((pathname-buffer pathname-buffer))
  52     (syscall (("SearchPath" t) dword
  53               system-string
  54               system-string
  55               system-string
  56               dword
  57               (* t)
  58               (* t))
  59              (and (plusp result)
  60                   (values (decode-system-string pathname-buffer) result))
  61              nil partial-name nil
  62              max_path (cast pathname-buffer (* char)) nil)))
  63
  64 (define-alien-routine ("GetExitCodeProcess" get-exit-code-process) int
  65   (handle handle) (exit-code dword :out))
  66
  67 (define-alien-routine ("GetExitCodeThread" get-exit-code-thread) int
  68   (handle handle) (exit-code dword :out))
  69
  70 (defun mswin-spawn (program argv stdin stdout stderr searchp envp waitp
  71                     directory)
  72   (let ((std-handles (multiple-value-list (get-std-handles)))
  73         (inheritp nil))
  74     (flet ((maybe-std-handle (arg)
  75              (let ((default (pop std-handles)))
  76                (case arg (-1 default) (otherwise (setf inheritp t) arg)))))
  77       (with-alien ((process-information process-information)
  78                    (startup-info startup-info))
  79         (sb-kernel:system-area-ub8-fill
  80          0 (alien-sap startup-info)
  81          0 (alien-size startup-info :bytes))
  82         (setf (slot startup-info 'cb) (alien-size startup-info :bytes)
  83               (slot startup-info 'stdin) (maybe-std-handle stdin)
  84               (slot startup-info 'stdout) (maybe-std-handle stdout)
  85               (slot startup-info 'stderr) (maybe-std-handle stderr)
  86               (slot startup-info 'reserved1) nil
  87               (slot startup-info 'reserved2) 0
  88               (slot startup-info 'reserved3) nil
  89               (slot startup-info 'flags) (if inheritp +startf-use-std-handles+ 0))
  90         (without-interrupts
  91           ;; KLUDGE: pass null image file name when searchp is true.
  92           ;; This way, file extension gets resolved by OS if omitted.
  93           (if (create-process (if searchp nil program)
  94                               argv
  95                               nil nil
  96                               inheritp 0 envp directory
  97                               (alien-sap startup-info)
  98                               (alien-sap process-information))
  99               (let ((child (slot process-information 'process-handle)))
 100                 (close-handle (slot process-information 'thread-handle))
 101                 child)
 102               -2))))))
 103
 104 (define-alien-routine ("SetConsoleCtrlHandler" set-console-ctrl-handler) int
 105   (callback (function (:stdcall int) int))
 106   (enable int))
 107
 108 (defun windows-console-control-handler (event-code)
 109   (case event-code
 110     (0
 111      (flet ((interrupt-it ()
 112               (let* ((context
 113                        (sb-di::nth-interrupt-context
 114                         (1- sb-kernel:*free-interrupt-context-index*)))
 115                      (pc (sb-vm:context-pc context)))
 116                 (with-interrupts
 117                   (let ((int (make-condition
 118                               'interactive-interrupt
 119                               :context context
 120                               :address (sb-sys:sap-int pc))))
 121                     ;; First SIGNAL, so that handlers can run.
 122                     (signal int)
 123                     (%break 'sigint int))))))
 124        (sb-thread:interrupt-thread (sb-thread::foreground-thread)
 125                                    #'interrupt-it)
 126        t))))
 127
 128 (defvar *console-control-handler* #'windows-console-control-handler)
 129 (defvar *console-control-enabled* nil)
 130 (defvar *console-control-spec* nil)
 131
 132 (sb-alien::define-alien-callback *alien-console-control-handler* (:stdcall int)
 133     ((event-code int))
 134   (if (ignore-errors (funcall *console-control-handler* event-code)) 1 0))
 135
 136 (defun console-control-handler ()
 137   "Get or set windows console control handler.
 138
 139 Boolean value: use default handler (NIL) or ignore event (T).  Symbol
 140 or function: designator for a function that receives an event code and
 141 returns generalized boolean (false to fall back to other handlers,
 142 true to stop searching)." *console-control-spec*)
 143
 144 (defun (setf console-control-handler) (new-handler)
 145   (etypecase new-handler
 146     (boolean
 147      (aver (plusp (set-console-ctrl-handler
 148                    (sap-alien (int-sap 0)
 149                               (function (:stdcall int) int))
 150                    (if new-handler 1 0))))
 151      (setf *console-control-enabled* nil))
 152     ((or symbol function)
 153      (setf *console-control-handler* new-handler)
 154      (aver (plusp (set-console-ctrl-handler *alien-console-control-handler* 1)))))
 155   (setf *console-control-spec* new-handler))
 156
 157 (defun initialize-console-control-handler (&optional reset-to-default-p)
 158   (setf (console-control-handler)
 159         (if reset-to-default-p
 160             'windows-console-control-handler
 161             (console-control-handler))))
 162
 163 (initialize-console-control-handler t)
 164 (pushnew 'initialize-console-control-handler sb-ext:*init-hooks*)
 165
 166 ;;;; I/O copying for run-program
 167 ;;;; Anonymous pipes do not support overlapped I/O,
 168 ;;;; named pipes are to be used instead.
 169
 170 (define-alien-type overlapped
 171     (struct overlapped
 172             (internal (* ulong))
 173             (internal-high  (* ulong))
 174             (offset dword)
 175             (offset-high dword)
 176             (event handle)))
 177
 178 (define-alien-routine ("CreateNamedPipeW" create-named-pipe) handle
 179   (name system-string)
 180   (open-mode dword)
 181   (pipe-mode dword)
 182   (max-instances dword)
 183   (out-buffer-size dword)
 184   (in-buffer-size dword)
 185   (default-time-out dword)
 186   (security-attributes (* t)))
 187
 188 (define-alien-routine ("WaitForSingleObject" wait-for-single-object) dword
 189   (handle handle)
 190   (timeout dword))
 191
 192 (define-alien-routine ("CreateEventW" create-event) handle
 193   (security-attributes (* t))
 194   (manual-reset lispbool)
 195   (initial-state lispbool)
 196   (name system-string))
 197
 198 (define-alien-routine ("GetOverlappedResult" get-overlapped-result) lispbool
 199   (handle handle)
 200   (overlapped (* t))
 201   (bytes-transferred dword :out)
 202   (wait lispbool))
 203
 204 (defun maybe-win32-error (result)
 205   (when (minusp result)
 206     (win32-error ""))
 207   result)
 208
 209 (defglobal **run-program-pipe-counter** 0)
 210 (declaim (type fixnum **run-program-pipe-counter**))
 211
 212 (defun make-named-pipe ()
 213   (let* ((name (format nil "\\\\.\\pipe\\SBCL-~a-~a"
 214                        (sb-unix:unix-getpid)
 215                        (sb-ext:atomic-incf **run-program-pipe-counter**)))
 216          (pipe (maybe-win32-error
 217                 (create-named-pipe name
 218                                    (logior pipe-access-inbound file-flag-overlapped)
 219                                    pipe-type-byte
 220                                    1 0 0 0 nil))))
 221     (multiple-value-bind (fd error) (sb-unix:unix-open name sb-unix:o_wronly
 222                                                        0 :overlapped nil)
 223       (unless fd
 224         (win32-error "open" error))
 225       (values pipe fd))))
 226
 227 (define-alien-routine ("win32_wait_for_multiple_objects_or_signal"
 228                        wait-for-multiple-objects-or-signal)
 229     dword
 230   (handles (* handle))
 231   (count dword))
 232
 233 (defstruct io-copier
 234   pipe
 235   stream
 236   external-format
 237   buffer
 238   event
 239   overlapped)
 240
 241 (defconstant +copier-buffer+ 256)
 242
 243 (defmacro zero-alien (alien type)
 244   `(sb-kernel:system-area-ub8-fill
 245     0 (alien-sap ,alien)
 246     0 (alien-size ,type :bytes)))
 247
 248 (defun setup-copiers (copiers)
 249   (let ((result (make-array (length copiers))))
 250     (loop for copier in copiers
 251           for i from 0
 252           do
 253           (let ((overlapped (make-alien overlapped))
 254                 (event (create-event nil t nil nil)))
 255            (setf (io-copier-event copier) event
 256                  (io-copier-overlapped copier) overlapped
 257                  (io-copier-buffer copier) (make-alien char +copier-buffer+)
 258                  (svref result i) copier)
 259            (zero-alien overlapped overlapped)
 260            (setf (slot overlapped 'event) event)))
 261     result))
 262
 263 (defun free-copier (copier)
 264   (close-handle (io-copier-pipe copier))
 265   (when (io-copier-event copier)
 266     (close-handle (io-copier-event copier)))
 267   (when (io-copier-overlapped copier)
 268     (free-alien (io-copier-overlapped copier)))
 269   (when (io-copier-buffer copier)
 270     (free-alien (io-copier-buffer copier))))
 271
 272 (defun win32-process-wait (process)
 273   (let ((pid (process-pid process))
 274         (copiers (sb-impl::process-copiers process)))
 275     (cond (copiers
 276            (unwind-protect
 277                 (with-alien ((events
 278                               ;; Should be enough for stdout, stderr, pid,
 279                               ;; and the signal event
 280                               (array handle 4)))
 281                   (let ((copiers (setup-copiers copiers))
 282                         (count (length copiers))
 283                         (lisp-buffer (make-array +copier-buffer+ :element-type '(unsigned-byte 8))))
 284                     (loop for i below count
 285                           do (setf (deref events i)
 286                                    (io-copier-event (svref copiers i))))
 287                     (setf (deref events count) pid)
 288                     (labels ((pending-or-error (operation
 289                                                 &optional (error (get-last-error)))
 290                                (when (/= error error-io-pending)
 291                                  (win32-error operation error)))
 292                              (try-read (copier)
 293                                (cond ((plusp
 294                                        (read-file (io-copier-pipe copier)
 295                                                   (io-copier-buffer copier)
 296                                                   +copier-buffer+
 297                                                   nil
 298                                                   (io-copier-overlapped copier)))
 299                                       (copy copier)
 300                                       (try-read copier))
 301                                      (t
 302                                       (let ((last-error (get-last-error)))
 303                                         (unless (= last-error error-broken-pipe)
 304                                           (pending-or-error "ReadFile" last-error))))))
 305                              (copy (copier)
 306                                (let* ((stream (io-copier-stream copier))
 307                                       (element-type (stream-element-type stream)))
 308                                 (multiple-value-bind (finished count)
 309                                     (get-overlapped-result (io-copier-pipe copier)
 310                                                            (io-copier-overlapped copier) nil)
 311                                   (cond (finished
 312                                          (loop for i below count
 313                                                do (setf (aref lisp-buffer i)
 314                                                         (deref (io-copier-buffer copier) i)))
 315                                          (cond
 316                                            ((member element-type '(base-char character))
 317                                             (write-string
 318                                              (octets-to-string lisp-buffer
 319                                                                :end count
 320                                                                :external-format
 321                                                                (io-copier-external-format copier))
 322                                              stream))
 323                                            (t
 324                                             (handler-bind
 325                                                 ((type-error
 326                                                    (lambda (c)
 327                                                      (error 'simple-type-error
 328                                                             :format-control
 329                                                             "Error using ~s for program output:~@
 330                                                              ~a"
 331                                                             :format-arguments
 332                                                             (list stream c)
 333                                                             :expected-type
 334                                                             (type-error-expected-type c)
 335                                                             :datum
 336                                                             (type-error-datum c)))))
 337                                               (write-sequence lisp-buffer stream :end count)))))
 338                                         (t
 339                                          (let ((last-error (get-last-error)))
 340                                            (unless (= last-error error-broken-pipe)
 341                                              (pending-or-error "ReadFile" last-error)))))))))
 342                       (loop for copier across copiers
 343                             do (try-read copier))
 344                       (loop for event = (wait-for-multiple-objects-or-signal (cast events
 345                                                                                    (* handle))
 346                                                                              (1+ count))
 347                             do
 348                             (cond ((= event wait-timeout))
 349                                   ((< event count)
 350                                    (let ((copier (svref copiers event)))
 351                                      (copy copier)
 352                                      (try-read copier)))
 353                                   ((= event count) ;; PID event
 354                                    (return))
 355                                   ((= event wait-failed)
 356                                    (win32-error "WaitForMultipleObjects")))))))
 357              (mapc #'free-copier copiers)))
 358           (t
 359            (do ()
 360                ((= 0
 361                    (wait-object-or-signal pid))))))
 362     (multiple-value-bind (ok code) (get-exit-code-process pid)
 363       (when (and (plusp ok) (/= code still-active))
 364         (setf (sb-impl::process-%status process) :exited
 365               (sb-impl::process-%exit-code process) code))))
 366   process)
 367