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