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                 (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))))))
 107
 108 (define-alien-routine ("SetConsoleCtrlHandler" set-console-ctrl-handler) int
 109   (callback (function (:stdcall int) int))
 110   (enable int))
 111
 112 (defun windows-console-control-handler (event-code)
 113   (case event-code
 114     (0
 115      (flet ((interrupt-it ()
 116               (let* ((context
 117                        (sb-di::nth-interrupt-context
 118                         (1- sb-kernel:*free-interrupt-context-index*)))
 119                      (pc (sb-vm:context-pc context)))
 120                 (with-interrupts
 121                   (let ((int (make-condition
 122                               'interactive-interrupt
 123                               :context context
 124                               :address (sb-sys:sap-int pc))))
 125                     ;; First SIGNAL, so that handlers can run.
 126                     (signal int)
 127                     (%break 'sigint int))))))
 128        (sb-thread:interrupt-thread (sb-thread::foreground-thread)
 129                                    #'interrupt-it)
 130        t))))
 131
 132 (defvar *console-control-handler* #'windows-console-control-handler)
 133 (defvar *console-control-enabled* nil)
 134 (defvar *console-control-spec* nil)
 135
 136 (sb-alien::define-alien-callback *alien-console-control-handler* (:stdcall int)
 137     ((event-code int))
 138   (if (ignore-errors (funcall *console-control-handler* event-code)) 1 0))
 139
 140 (defun console-control-handler ()
 141   "Get or set windows console control handler.
 142
 143 Boolean value: use default handler (NIL) or ignore event (T).  Symbol
 144 or function: designator for a function that receives an event code and
 145 returns generalized boolean (false to fall back to other handlers,
 146 true to stop searching)." *console-control-spec*)
 147
 148 (defun (setf console-control-handler) (new-handler)
 149   (etypecase new-handler
 150     (boolean
 151      (aver (plusp (set-console-ctrl-handler
 152                    (sap-alien (int-sap 0)
 153                               (function (:stdcall int) int))
 154                    (if new-handler 1 0))))
 155      (setf *console-control-enabled* nil))
 156     ((or symbol function)
 157      (setf *console-control-handler* new-handler)
 158      (aver (plusp (set-console-ctrl-handler *alien-console-control-handler* 1)))))
 159   (setf *console-control-spec* new-handler))
 160
 161 (defun initialize-console-control-handler (&optional reset-to-default-p)
 162   (setf (console-control-handler)
 163         (if reset-to-default-p
 164             'windows-console-control-handler
 165             (console-control-handler))))
 166
 167 (initialize-console-control-handler t)
 168 (pushnew 'initialize-console-control-handler sb-ext:*init-hooks*)