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