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   (declare (ignorable envp))
  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 nil nil
  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                 (if waitp
 102                     (do () ((/= 1 (with-local-interrupts (wait-object-or-signal child)))
 103                             (multiple-value-bind (got code) (get-exit-code-process child)
 104                               (if got code -1))))
 105                     child))
 106               -2))))))