MinGW open-process, take N

MinGW open-process, take N

[Andy Wingo]

[-- Attachment #1: Type: text/plain, Size: 381 bytes --]

Hi Eli,

I have reworked Guile a bit in anticipation of your patch and in the end
reworked your patch a bit too.  Please fetch git and see how things are
working for you, first -- it could be I introduced a MinGW bug.  Then
here attached is your patch, reworked.  Let me know how it looks to
you.  If it looks good I'll apply and release in 2.0.12 tomorrow or so.

Regards,

Andy


[-- Attachment #2: 0001-Add-POSIX-shims-for-MinGW.patch --]
[-- Type: text/plain, Size: 26282 bytes --]

From 0ffd406b582dea54ff080f1785eea25a1199c5df Mon Sep 17 00:00:00 2001
From: Eli Zaretskii <eliz@gnu.org>
Date: Mon, 11 Jul 2016 22:52:17 +0200
Subject: [PATCH] Add POSIX shims for MinGW

* libguile/posix-w32.h:
* libguile/posix-w32.c (kill, waitpid, getpriority, setpriority)
  (sched_getaffinity, sched_setaffinity): Add MinGW implementations.
  Also, provides macros that on Posix hosts are in sys/wait.h, like
  WIFEXITED and WTERMSIG.
  (start_child): Add implementation.
---
 libguile/posix-w32.c | 864 ++++++++++++++++++++++++++++++++++++++++++++++++++-
 libguile/posix-w32.h |  48 ++-
 libguile/posix.c     |   3 +-
 3 files changed, 912 insertions(+), 3 deletions(-)

diff --git a/libguile/posix-w32.c b/libguile/posix-w32.c
index f1251b2..f7df180 100644
--- a/libguile/posix-w32.c
+++ b/libguile/posix-w32.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2006, 2008, 2016 Free Software Foundation, Inc.
  * 
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -22,8 +22,12 @@
 
 #include "libguile/__scm.h"
 
+# define WIN32_LEAN_AND_MEAN
 #include <windows.h>
+#include <c-strcase.h>
+#include <process.h>
 #include <stdio.h>
+#include <stdlib.h>
 #include <string.h>
 
 #include "posix-w32.h"
@@ -144,3 +148,861 @@ uname (struct utsname *uts)
   GetComputerName (uts->nodename, &sLength);
   return 0;
 }
+
+/* Run a child process with redirected standard handles, without
+   redirecting standard handles of the parent.  This is required in
+   multithreaded programs, where redirecting a standard handle affects
+   all threads.  */
+
+/* Prepare a possibly redirected file handle to be passed to a child
+   process.  The handle is for the file/device open on file descriptor
+   FD; if FD is invalid, use the null device instead.
+
+   USE_STD non-zero means we have been passed the descriptor used by
+   the parent.
+
+   ACCESS is the Windows access mode for opening the null device.
+
+   Returns the Win32 handle to be passed to CreateProcess.  */
+static HANDLE
+prepare_child_handle (int fd, int use_std, DWORD access)
+{
+  HANDLE htem, hret;
+  DWORD err = 0;
+
+  /* Start with the descriptor, if specified by the caller and valid,
+     otherwise open the null device.  */
+  if (fd < 0)
+    htem = INVALID_HANDLE_VALUE;
+  else
+    htem = (HANDLE)_get_osfhandle (fd);
+
+  /* Duplicate the handle and make it inheritable.  */
+  if (DuplicateHandle (GetCurrentProcess (),
+		       htem,
+		       GetCurrentProcess (),
+		       &hret,
+		       0,
+		       TRUE,
+		       DUPLICATE_SAME_ACCESS) == FALSE)
+    {
+      /* If the original standard handle was invalid (happens, e.g.,
+	 in GUI programs), open the null device instead.  */
+      if ((err = GetLastError ()) == ERROR_INVALID_HANDLE
+	  && use_std)
+	{
+	  htem = CreateFile ("NUL", access,
+			     FILE_SHARE_READ | FILE_SHARE_WRITE, NULL,
+			     OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);
+	  if (htem != INVALID_HANDLE_VALUE
+	      && DuplicateHandle (GetCurrentProcess (),
+				  htem,
+				  GetCurrentProcess (),
+				  &hret,
+				  0,
+				  TRUE,
+				  DUPLICATE_SAME_ACCESS) == FALSE)
+	    {
+	      err = GetLastError ();
+	      CloseHandle (htem);
+	      hret = INVALID_HANDLE_VALUE;
+	    }
+	}
+    }
+
+  if (hret == INVALID_HANDLE_VALUE)
+    {
+      switch (err)
+	{
+	  case ERROR_NO_MORE_FILES:
+	    errno = EMFILE;
+	    break;
+	  case ERROR_INVALID_HANDLE:
+	  default:
+	    errno = EBADF;
+	    break;
+	}
+    }
+
+  return hret;
+}
+
+/* A comparison function for sorting the environment.  */
+static int
+compenv (const void *a1, const void *a2)
+{
+  return stricmp (*((char**)a1), *((char**)a2));
+}
+
+/* Convert the program's 'environ' array to a block of environment
+   variables suitable to be passed to CreateProcess.  This is needed
+   to ensure the child process inherits the up-to-date environment of
+   the parent, including any variables inserted by the parent.  */
+static void
+prepare_envblk (char **envp, char **envblk)
+{
+  char **tmp;
+  int size_needed;
+  int envcnt;
+  char *ptr;
+
+  for (envcnt = 0; envp[envcnt]; envcnt++)
+    ;
+
+  tmp = scm_calloc ((envcnt + 1) * sizeof (*tmp));
+
+  for (envcnt = size_needed = 0; envp[envcnt]; envcnt++)
+    {
+      tmp[envcnt] = envp[envcnt];
+      size_needed += strlen (envp[envcnt]) + 1;
+    }
+  size_needed++;
+
+  /* Windows likes its environment variables sorted.  */
+  qsort ((void *) tmp, (size_t) envcnt, sizeof (char *), compenv);
+
+  /* CreateProcess needs the environment block as a linear array,
+     where each variable is terminated by a null character, and the
+     last one is terminated by 2 null characters.  */
+  ptr = *envblk = scm_calloc (size_needed);
+
+  for (envcnt = 0; tmp[envcnt]; envcnt++)
+    {
+      strcpy (ptr, tmp[envcnt]);
+      ptr += strlen (tmp[envcnt]) + 1;
+    }
+
+  free (tmp);
+}
+
+/* Find an executable PROGRAM on PATH, return result in malloc'ed
+   storage.  If PROGRAM is /bin/sh, and no sh.exe was found on PATH,
+   fall back on the Windows shell and set BIN_SH_REPLACED to non-zero.  */
+static char *
+lookup_cmd (const char *program, int *bin_sh_replaced)
+{
+  static const char *extensions[] = {
+    ".exe", ".cmd", ".bat", "", ".com", NULL
+  };
+  int bin_sh_requested = 0;
+  char *path, *dir, *sep;
+  char abs_name[MAX_PATH];
+  DWORD abs_namelen = 0;
+
+  /* If they ask for the Unix system shell, try to find it on PATH.  */
+  if (c_strcasecmp (program, "/bin/sh") == 0)
+    {
+      bin_sh_requested = 1;
+      program = "sh.exe";
+    }
+
+  /* If PROGRAM includes leading directories, the caller already did
+     our job.  */
+  if (strchr (program, '/') != NULL
+      || strchr (program, '\\') != NULL)
+    return scm_strdup (program);
+
+  /* Note: It is OK for getenv below to return NULL -- in that case,
+     SearchPath will search in the directories whose list is specified
+     by the system Registry.  */
+  path = getenv ("PATH");
+  if (!path)	/* shouldn't happen, really */
+    path = ".";
+  dir = sep = path = strdup (path);
+  for ( ; sep && *sep; dir = sep + 1)
+    {
+      int i;
+
+      sep = strpbrk (dir, ";");
+      if (sep == dir)	/* two or more ;'s in a row */
+	continue;
+      if (sep)
+	*sep = '\0';
+      for (i = 0; extensions[i]; i++)
+	{
+	  abs_namelen = SearchPath (dir, program, extensions[i],
+				    MAX_PATH, abs_name, NULL);
+	  if (0 < abs_namelen && abs_namelen <= MAX_PATH)	/* found! */
+	    break;
+	}
+      if (extensions[i])	/* found! */
+	break;
+      if (sep)
+	*sep = ';';
+    }
+
+  free (path);
+
+  /* If they asked for /bin/sh and we didn't find it, fall back on the
+     default Windows shell.  */
+  if (abs_namelen <= 0 && bin_sh_requested)
+    {
+      const char *shell = getenv ("ComSpec");
+
+      if (!shell)
+	shell = "C:\\Windows\\system32\\cmd.exe";
+
+      *bin_sh_replaced = 1;
+      strcpy (abs_name, shell);
+      abs_namelen = strlen (abs_name);
+    }
+
+  /* If not found, return the original PROGRAM name.  */
+  if (abs_namelen <= 0 || abs_namelen > MAX_PATH)
+    return scm_strdup (program);
+
+  return scm_strndup (abs_name, abs_namelen);
+}
+
+/* Concatenate command-line arguments in argv[] into a single
+   command-line string, while quoting arguments as needed.  The result
+   is malloc'ed.  */
+static char *
+prepare_cmdline (const char *cmd, const char * const *argv, int bin_sh_replaced)
+{
+  /* These characters should include anything that is special to _any_
+     program, including both Windows and Unixy shells, and the
+     widlcard expansion in startup code of a typical Windows app.  */
+  const char need_quotes[] = " \t#;\"\'*?[]&|<>(){}$`^";
+  size_t cmdlen = 1;	/* for terminating null */
+  char *cmdline = scm_malloc (cmdlen);
+  char *dst = cmdline;
+  int cmd_exe_quoting = 0;
+  int i;
+  const char *p;
+
+  /* Are we constructing a command line for cmd.exe?  */
+  if (bin_sh_replaced)
+    cmd_exe_quoting = 1;
+  else
+    {
+      for (p = cmd + strlen (cmd);
+	   p > cmd && p[-1] != '/' && p[-1] != '\\' && p[-1] != ':';
+	   p--)
+	;
+      if (c_strcasecmp (p, "cmd.exe") == 0
+	  || c_strcasecmp (p, "cmd") == 0)
+	cmd_exe_quoting = 1;
+    }
+
+  /* Initialize the command line to empty.  */
+  *dst = '\0';
+
+  /* Append arguments, if any, from argv[]. */
+  for (i = 0; argv[i]; i++)
+    {
+      const char *src = argv[i];
+      size_t len;
+      int quote_this = 0, n_backslashes = 0;
+      int j;
+
+      /* Append the blank separator.  We don't do that for argv[0]
+	 because that is the command name (will end up in child's
+	 argv[0]), and is only recognized as such if there're no
+	 blanks before it.  */
+      if (i > 0)
+	*dst++ = ' ';
+      len = dst - cmdline;
+
+      /* How much space is required for this argument?  */
+      cmdlen += strlen (argv[i]) + 1; /* 1 for a blank separator */
+      /* cmd.exe needs a different style of quoting: all the arguments
+	 beyond the /c switch are enclosed in an extra pair of quotes,
+	 and not otherwise quoted/escaped. */
+      if (cmd_exe_quoting)
+	{
+	  if (i == 2)
+	    cmdlen += 2;
+	}
+      else if (strpbrk (argv[i], need_quotes))
+	{
+	  quote_this = 1;
+	  cmdlen += 2;
+	  for ( ; *src; src++)
+	    {
+	      /* An embedded quote needs to be escaped by a backslash.
+		 Any backslashes immediately preceding that quote need
+		 each one to be escaped by another backslash.  */
+	      if (*src == '\"')
+		cmdlen += n_backslashes + 1;
+	      if (*src == '\\')
+		n_backslashes++;
+	      else
+		n_backslashes = 0;
+	    }
+	  /* If the closing quote we will add is preceded by
+	     backslashes, those backslashes need to be escaped.  */
+	  cmdlen += n_backslashes;
+	}
+
+      /* Enlarge the command-line string as needed.  */
+      cmdline = scm_realloc (cmdline, cmdlen);
+      dst = cmdline + len;
+
+      if (i == 0
+	  && c_strcasecmp (argv[0], "/bin/sh") == 0
+	  && bin_sh_replaced)
+	{
+	  strcpy (dst, "cmd.exe");
+	  dst += sizeof ("cmd.exe") - 1;
+	  continue;
+	}
+      if (i == 1 && bin_sh_replaced && strcmp (argv[1], "-c") == 0)
+	{
+	  *dst++ = '/';
+	  *dst++ = 'c';
+	  *dst = '\0';
+	  continue;
+	}
+
+      /* Add this argument, possibly quoted, to the command line.  */
+      if (quote_this || (i == 2 && cmd_exe_quoting))
+	*dst++ = '\"';
+      for (src = argv[i]; *src; src++)
+	{
+	  if (quote_this)
+	    {
+	      if (*src == '\"')
+		for (j = n_backslashes + 1; j > 0; j--)
+		  *dst++ = '\\';
+	      if (*src == '\\')
+		n_backslashes++;
+	      else
+		n_backslashes = 0;
+	    }
+	  *dst++ = *src;
+	}
+      if (quote_this)
+	{
+	  for (j = n_backslashes; j > 0; j--)
+	    *dst++ = '\\';
+	  *dst++ = '\"';
+	}
+      *dst = '\0';
+    }
+
+  if (cmd_exe_quoting && i > 2)
+    {
+      /* One extra slot was already reserved when we enlarged cmdlen
+	 by 2 in the "if (cmd_exe_quoting)" clause above.  So we can
+	 safely append a closing quote.  */
+      *dst++ = '\"';
+      *dst = '\0';
+    }
+
+  return cmdline;
+}
+
+/* Start a child process running the program in EXEC_FILE with its
+   standard input and output optionally redirected to a pipe.  ARGV is
+   the array of command-line arguments to pass to the child.  P2C and
+   C2P are 2 pipes for communicating with the child, and ERRFD is the
+   standard error file descriptor to be inherited by the child.
+   READING and WRITING, if non-zero, mean that the corresponding pipe
+   will be used.
+
+   Return the PID of the child process, or -1 if couldn't start a
+   process.  */
+int
+start_child (const char *exec_file, char **argv,
+	     int reading, int c2p[2], int writing, int p2c[2],
+             int infd, int outfd, int errfd)
+{
+  HANDLE hin = INVALID_HANDLE_VALUE, hout = INVALID_HANDLE_VALUE;
+  HANDLE herr = INVALID_HANDLE_VALUE;
+  STARTUPINFO si;
+  char *env_block = NULL;
+  char *cmdline = NULL;
+  PROCESS_INFORMATION pi;
+  char *progfile, *p;
+  int errno_save;
+  intptr_t pid;
+  int bin_sh_replaced = 0;
+
+  if (!reading)
+    c2p[1] = outfd;
+  if (!writing)
+    p2c[0] = infd;
+
+  /* Prepare standard handles to be passed to the child process.  */
+  hin = prepare_child_handle (p2c[0], !writing, GENERIC_READ);
+  if (hin == INVALID_HANDLE_VALUE)
+    return -1;
+  hout = prepare_child_handle (c2p[1], !reading, GENERIC_WRITE);
+  if (hout == INVALID_HANDLE_VALUE)
+    return -1;
+  herr = prepare_child_handle (errfd, 1, GENERIC_WRITE);
+  if (herr == INVALID_HANDLE_VALUE)
+    return -1;
+
+  /* Make sure the parent side of both pipes is not inherited.  This
+     is required because gnulib's 'pipe' creates pipes whose both ends
+     are inheritable, which is traditional on Posix (where pipe
+     descriptors are implicitly duplicated by 'fork'), but wrong on
+     Windows (where pipe handles need to be explicitly
+     duplicated).  */
+  if (writing)
+    SetHandleInformation ((HANDLE)_get_osfhandle (p2c[1]),
+			  HANDLE_FLAG_INHERIT, 0);
+  if (reading)
+    {
+      SetHandleInformation ((HANDLE)_get_osfhandle (c2p[0]),
+			    HANDLE_FLAG_INHERIT, 0);
+      /* Gnulib's 'pipe' opens the pipe in binary mode, but we don't
+	 want to read text-mode input of subprocesses in binary more,
+	 because then we will get the ^M (a.k.a. "CR") characters we
+	 don't expect.  */
+      _setmode (c2p[0], _O_TEXT);
+    }
+
+  /* Set up the startup info for the child, using the parent's as the
+     starting point, and specify in it the redirected handles.  */
+  GetStartupInfo (&si);
+  si.dwFlags = STARTF_USESTDHANDLES;
+  si.lpReserved = 0;
+  si.cbReserved2 = 0;
+  si.lpReserved2 = 0;
+  si.hStdInput = hin;
+  si.hStdOutput = hout;
+  si.hStdError = herr;
+
+  /* Create the environment block for the child.  This is needed
+     because the environment we have in 'environ' is not in the format
+     expected by CreateProcess.  */
+  prepare_envblk (environ, &env_block);
+
+  /* CreateProcess doesn't search PATH, so we must do that for it.  */
+  progfile = lookup_cmd (exec_file, &bin_sh_replaced);
+
+  /* CreateProcess doesn't like forward slashes in the application
+     file name.  */
+  for (p = progfile; *p; p++)
+    if (*p == '/')
+      *p = '\\';
+
+  /* Construct the command line.  */
+  cmdline = prepare_cmdline (exec_file, (const char * const *)argv,
+			     bin_sh_replaced);
+
+  /* All set and ready to fly.  Launch the child process.  */
+  if (!CreateProcess (progfile, cmdline, NULL, NULL, TRUE, 0, env_block, NULL,
+		      &si, &pi))
+    {
+      pid = -1;
+
+      /* Since we use Win32 APIs directly, we need to translate their
+	 errors to errno values by hand.  */
+      switch (GetLastError ())
+	{
+	  case ERROR_FILE_NOT_FOUND:
+	  case ERROR_PATH_NOT_FOUND:
+	  case ERROR_INVALID_DRIVE:
+	  case ERROR_BAD_PATHNAME:
+	    errno = ENOENT;
+	    break;
+	  case ERROR_ACCESS_DENIED:
+	    errno = EACCES;
+	    break;
+	  case ERROR_BAD_ENVIRONMENT:
+	    errno = E2BIG;
+	    break;
+	  case ERROR_BROKEN_PIPE:
+	    errno = EPIPE;
+	    break;
+	  case ERROR_INVALID_HANDLE:
+	    errno = EBADF;
+	    break;
+	  case ERROR_MAX_THRDS_REACHED:
+	    errno = EAGAIN;
+	    break;
+	  case ERROR_BAD_EXE_FORMAT:
+	  case ERROR_BAD_FORMAT:
+	  default:
+	    errno = ENOEXEC;
+	    break;
+	}
+    }
+  else
+    pid = (intptr_t)pi.hProcess;
+
+  errno_save = errno;
+
+  /* Free resources.  */
+  free (progfile);
+  free (cmdline);
+  free (env_block);
+  CloseHandle (hin);
+  CloseHandle (hout);
+  CloseHandle (herr);
+  CloseHandle (pi.hThread);
+
+  /* Posix requires to call the shell if execvp fails to invoke EXEC_FILE.  */
+  if (errno_save == ENOEXEC || errno_save == ENOENT)
+    {
+      const char *shell = getenv ("ComSpec");
+
+      if (!shell)
+	shell = "cmd.exe";
+
+      if (c_strcasecmp (exec_file, shell) != 0)
+	{
+	  argv[0] = (char *)exec_file;
+	  return start_child (shell, argv, reading, c2p, writing, p2c, errfd);
+	}
+    }
+
+  errno = errno_save;
+  return pid;
+}
+
+\f
+/* Emulation of waitpid which only supports WNOHANG, since _cwait doesn't.  */
+int
+waitpid (intptr_t pid, int *status, int options)
+{
+  if ((options & WNOHANG) != 0)
+    {
+      DWORD st;
+
+      if (!GetExitCodeProcess ((HANDLE)pid, &st))
+	{
+	  errno = ECHILD;
+	  return -1;
+	}
+      if (st == STILL_ACTIVE)
+	return 0;
+      if (status)
+	*status = st;
+      return (int)pid;
+    }
+
+  return (int)_cwait (status, pid, WAIT_CHILD);
+}
+
+\f
+/* Translate abnormal exit status of Windows programs into the signal
+   that terminated the program.  This is required to support scm_kill
+   and WTERMSIG.  */
+
+struct signal_and_status {
+  int sig;
+  DWORD status;
+};
+
+static const struct signal_and_status sigtbl[] = {
+  {SIGSEGV, 0xC0000005},	/* access to invalid address */
+  {SIGSEGV, 0xC0000008},	/* invalid handle */
+  {SIGILL,  0xC000001D},	/* illegal instruction */
+  {SIGILL,  0xC0000025},	/* non-continuable instruction */
+  {SIGSEGV, 0xC000008C},	/* array bounds exceeded */
+  {SIGFPE,  0xC000008D},	/* float denormal */
+  {SIGFPE,  0xC000008E},	/* float divide by zero */
+  {SIGFPE,  0xC000008F},	/* float inexact */
+  {SIGFPE,  0xC0000090},	/* float invalid operation */
+  {SIGFPE,  0xC0000091},	/* float overflow */
+  {SIGFPE,  0xC0000092},	/* float stack check */
+  {SIGFPE,  0xC0000093},	/* float underflow */
+  {SIGFPE,  0xC0000094},	/* integer divide by zero */
+  {SIGFPE,  0xC0000095},	/* integer overflow */
+  {SIGILL,  0xC0000096},	/* privileged instruction */
+  {SIGSEGV, 0xC00000FD},	/* stack overflow */
+  {SIGTERM, 0xC000013A},	/* Ctrl-C exit */
+  {SIGINT,  0xC000013A}
+};
+
+static int
+w32_signal_to_status (int sig)
+{
+  int i;
+
+  for (i = 0; i < sizeof (sigtbl) / sizeof (sigtbl[0]); i++)
+    if (sig == sigtbl[i].sig)
+      return sigtbl[i].status;
+
+  return (int)0xC000013A;
+}
+
+int
+w32_status_to_termsig (DWORD status)
+{
+  int i;
+
+  for (i = 0; i < sizeof (sigtbl) / sizeof (sigtbl[0]); i++)
+    if (status == sigtbl[i].status)
+      return sigtbl[i].sig;
+
+  return SIGTERM;
+}
+
+/* Support for scm_kill.  */
+int
+kill (int pid, int sig)
+{
+  HANDLE ph = OpenProcess (PROCESS_TERMINATE, 0, pid);
+
+  if (!ph)
+    {
+      errno = EPERM;
+      return -1;
+    }
+  if (!TerminateProcess (ph, w32_signal_to_status (sig)))
+    {
+      errno = EINVAL;
+      return -1;
+    }
+  CloseHandle (ph);
+
+  return 0;
+}
+
+/* Emulation of getpriority and setpriority.  */
+#define NZERO        8
+
+int
+getpriority (int which, int who)
+{
+  HANDLE hp;
+  int nice_value = -1;
+  int error = 0;
+
+  /* We don't support process groups and users.  */
+  if (which != PRIO_PROCESS)
+    {
+      errno = ENOSYS;
+      return -1;
+    }
+
+  if (who == 0)
+    hp = GetCurrentProcess ();
+  else
+    hp = OpenProcess (PROCESS_QUERY_INFORMATION, FALSE, who);
+
+  if (hp)
+    {
+      DWORD pri_class = GetPriorityClass (hp);
+
+      if (pri_class > 0)
+	{
+	  switch (pri_class)
+	    {
+	    case IDLE_PRIORITY_CLASS:
+	      nice_value = 4;
+	      break;
+	    case BELOW_NORMAL_PRIORITY_CLASS:
+	      nice_value = 6;
+	      break;
+	    case NORMAL_PRIORITY_CLASS:
+	      nice_value = 8;
+	      break;
+	    case ABOVE_NORMAL_PRIORITY_CLASS:
+	      nice_value = 10;
+	      break;
+	    case HIGH_PRIORITY_CLASS:
+	      nice_value = 13;
+	      break;
+	    case REALTIME_PRIORITY_CLASS:
+	      nice_value = 24;
+	      break;
+	    }
+	  /* If WHO is us, we can provide a more fine-grained value by
+	     looking at the current thread's priority value.  (For
+	     other processes, it is not clear which thread to use.)  */
+	  if (who == 0 || who == GetCurrentProcessId ())
+	    {
+	      HANDLE ht = GetCurrentThread ();
+	      int tprio = GetThreadPriority (ht);
+
+	      switch (tprio)
+		{
+		case THREAD_PRIORITY_IDLE:
+		  if (pri_class == REALTIME_PRIORITY_CLASS)
+		    nice_value = 16;
+		  else
+		    nice_value = 1;
+		  break;
+		case THREAD_PRIORITY_TIME_CRITICAL:
+		  if (pri_class == REALTIME_PRIORITY_CLASS)
+		    nice_value = 31;
+		  else
+		    nice_value = 15;
+		case THREAD_PRIORITY_ERROR_RETURN:
+		  nice_value = -1;
+		  error = 1;
+		  break;
+		default:
+		  nice_value += tprio;
+		  break;
+		}
+	    }
+	  /* Map to "nice values" similar to what one would see on
+	     Posix platforms.  */
+	  if (!error)
+	    nice_value = - (nice_value - NZERO);
+	}
+      else
+	error = 1;
+    }
+  else
+    error = 1;
+
+  if (error)
+    {
+      DWORD err = GetLastError ();
+
+      switch (err)
+	{
+	case ERROR_INVALID_PARAMETER:
+	case ERROR_INVALID_THREAD_ID:
+	  errno = ESRCH;
+	  break;
+	default:
+	  errno = EPERM;
+	  break;
+	}
+    }
+
+  return nice_value;
+}
+
+int
+setpriority (int which, int who, int nice_val)
+{
+  HANDLE hp;
+  DWORD err;
+
+  if (which != PRIO_PROCESS)
+    {
+      errno = ENOSYS;
+      return -1;
+    }
+
+  if (who == 0)
+    hp = GetCurrentProcess ();
+  else
+    hp = OpenProcess (PROCESS_SET_INFORMATION, FALSE, who);
+
+  if (hp)
+    {
+      DWORD pri_class;
+
+      /* Map "nice values" back to process priority classes.  */
+      nice_val = -nice_val + NZERO;
+      if (nice_val < 6)
+	pri_class = IDLE_PRIORITY_CLASS;
+      else if (nice_val < 8)
+	pri_class = BELOW_NORMAL_PRIORITY_CLASS;
+      else if (nice_val < 10)
+	pri_class = NORMAL_PRIORITY_CLASS;
+      else if (nice_val < 13)
+	pri_class = ABOVE_NORMAL_PRIORITY_CLASS;
+      else if (nice_val < 16)
+	pri_class = HIGH_PRIORITY_CLASS;
+      else
+	pri_class = REALTIME_PRIORITY_CLASS;
+
+      if (SetPriorityClass (hp, pri_class))
+	return 0;
+    }
+
+  err = GetLastError ();
+
+  switch (err)
+    {
+    case ERROR_INVALID_PARAMETER:
+      errno = ESRCH;
+      break;
+    default:
+      errno = EPERM;
+      break;
+    }
+
+  return -1;
+}
+
+/* Emulation of sched_getaffinity and sched_setaffinity.  */
+int
+sched_getaffinity (int pid, size_t mask_size, cpu_set_t *mask)
+{
+  HANDLE hp;
+  DWORD err;
+
+  if (mask == NULL)
+    {
+      errno = EFAULT;
+      return -1;
+    }
+
+  if (pid == 0)
+    hp = GetCurrentProcess ();
+  else
+    hp = OpenProcess (PROCESS_QUERY_INFORMATION, FALSE, pid);
+
+  if (hp)
+    {
+      DWORD_PTR ignored;
+      BOOL result = GetProcessAffinityMask (hp, (DWORD_PTR *)mask, &ignored);
+
+      if (pid != 0)
+	CloseHandle (hp);
+      if (result)
+	return 0;
+    }
+
+  err = GetLastError ();
+
+  switch (err)
+    {
+    case ERROR_INVALID_PARAMETER:
+      errno = ESRCH;
+      break;
+    case ERROR_ACCESS_DENIED:
+    default:
+      errno = EPERM;
+      break;
+    }
+
+  return -1;
+}
+
+int
+sched_setaffinity (int pid, size_t mask_size, cpu_set_t *mask)
+{
+  HANDLE hp;
+  DWORD err;
+
+  if (mask == NULL)
+    {
+      errno = EFAULT;
+      return -1;
+    }
+
+  if (pid == 0)
+    hp = GetCurrentProcess ();
+  else
+    hp = OpenProcess (PROCESS_SET_INFORMATION, FALSE, pid);
+
+  if (hp)
+    {
+      BOOL result = SetProcessAffinityMask (hp, *(DWORD_PTR *)mask);
+
+      if (pid != 0)
+	CloseHandle (hp);
+      if (result)
+	return 0;
+    }
+
+  err = GetLastError ();
+
+  switch (err)
+    {
+    case ERROR_INVALID_PARAMETER:
+      errno = ESRCH;
+      break;
+    case ERROR_ACCESS_DENIED:
+    default:
+      errno = EPERM;
+      break;
+    }
+
+  return -1;
+}
diff --git a/libguile/posix-w32.h b/libguile/posix-w32.h
index b4c6510..f11a25e 100644
--- a/libguile/posix-w32.h
+++ b/libguile/posix-w32.h
@@ -21,6 +21,8 @@
  * 02110-1301 USA
  */
 
+#include <string.h>
+
 #define _UTSNAME_LENGTH 65
 #define _UTSNAME_NODENAME_LENGTH _UTSNAME_LENGTH
 #define _UTSNAME_DOMAIN_LENGTH _UTSNAME_LENGTH
@@ -47,6 +49,50 @@ struct utsname
   char domainname[_UTSNAME_DOMAIN_LENGTH];
 };
 
-int uname (struct utsname * uts);
+#define WNOHANG               1
+
+#define WEXITSTATUS(stat_val) ((stat_val) & 255)
+/* MS-Windows programs that crash due to a fatal exception exit with
+   an exit code whose 2 MSB bits are set.  */
+#define WIFEXITED(stat_val)   (((stat_val) & 0xC0000000) == 0)
+#define WIFSIGNALED(stat_val) (((stat_val) & 0xC0000000) == 0xC0000000)
+#define WTERMSIG(stat_val)    w32_status_to_termsig (stat_val)
+/* The funny conditional avoids a compiler warning in status:stop_sig.  */
+#define WIFSTOPPED(stat_val)  ((stat_val) == (stat_val) ? 0 : 0)
+#define WSTOPSIG(stat_var)    (0)
+
+#define CPU_ZERO(s)     memset(s,0,sizeof(*s))
+#define CPU_ISSET(b,s)  ((*s) & (1U << (b))) != 0
+#define CPU_SET(b,s)    (*s) |= (1U << (b))
+#define CPU_SETSIZE     (8*sizeof(DWORD_PTR))
+typedef DWORD_PTR cpu_set_t;
+
+#define PRIO_PROCESS 1
+#define PRIO_PGRP    2
+#define PRIO_USER    3
+
+SCM_INTERNAL int uname (struct utsname * uts);
+SCM_INTERNAL int waitpid (intptr_t, int *, int);
+SCM_INTERNAL int w32_status_to_termsig (DWORD status);
+
+SCM_INTERNAL int start_child (const char *exec_file, char **argv,
+                              int reading, int c2p[2], int writing, int p2c[2],
+                              int infd, int outfd, int errfd);
+
+SCM_INTERNAL int kill (int pid, int sig);
+
+SCM_INTERNAL int getpriority (int which, int who);
+SCM_INTERNAL int setpriority (int which, int who, int nice_val);
+SCM_INTERNAL int sched_getaffinity (int pid, size_t mask_size, cpu_set_t *mask);
+SCM_INTERNAL int sched_setaffinity (int pid, size_t mask_size, cpu_set_t *mask);
+
+#define HAVE_UNAME 1
+#define HAVE_WAITPID 1
+#define HAVE_START_CHILD 1
+#define HAVE_KILL 1
+#define HAVE_GETPRIORITY 1
+#define HAVE_SETPRIORITY 1
+#define HAVE_SCHED_GETAFFINITY 1
+#define HAVE_SCHED_SETAFFINITY 1
 
 #endif /* SCM_POSIX_W32_H */
diff --git a/libguile/posix.c b/libguile/posix.c
index 6b4e72e..8f627c3 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -88,6 +88,7 @@
 #if HAVE_SYS_WAIT_H
 # include <sys/wait.h>
 #endif
+
 #ifndef WEXITSTATUS
 # define WEXITSTATUS(stat_val) ((unsigned)(stat_val) >> 8)
 #endif
@@ -1430,7 +1431,7 @@ scm_open_process (SCM mode, SCM prog, SCM args)
 #undef FUNC_NAME
 #endif /* HAVE_START_CHILD */
 
-#if defined (HAVE_UNAME) || defined (__MINGW32__)
+#ifdef HAVE_UNAME
 SCM_DEFINE (scm_uname, "uname", 0, 0, 0,
             (),
 	    "Return an object with some information about the computer\n"
-- 
2.8.3

Re: MinGW open-process, take N

[Eli Zaretskii]

> From: Andy Wingo <wingo@pobox.com>
> Cc: guile-devel@gnu.org, ludo@gnu.org, mhw@netris.org
> Date: Mon, 11 Jul 2016 23:51:17 +0200
> 
> I have reworked Guile a bit in anticipation of your patch and in the end
> reworked your patch a bit too.  Please fetch git and see how things are
> working for you, first -- it could be I introduced a MinGW bug.  Then
> here attached is your patch, reworked.  Let me know how it looks to
> you.  If it looks good I'll apply and release in 2.0.12 tomorrow or so.

Thanks.

It's hard for me to build Guile from Git, due to the additional
prerequisites that needs.

Instead, I reviewed the changes, comparing them with my original
patch.

First, I see that you also removed getuid and getgid; I believe we
only talked about removing setuid and setgid.  As I said, getuid is
needed to build Guile.

The only other issue I see is the type of the value returned by
start_child, and as result by scm_open_process.  On Windows, the value
returned has the type HANDLE, which is actually a pointer in disguise.
I used intptr_t for that, but you changed it to just int.  This will
not work in 64-bit MinGW builds, where a pointer is a 64-bit type.  I
think we should go back to intptr_t, and also change the conversion to
the value returned by scm_open_process, since scm_from_int will AFAIK
not support 64-bit integer types.  Note that the MinGW waitpid
implementation also expects to get a valu that is interpreted as a
handle.

Other than that, the changes look good, and I will certainly try to
build Guile 2.0.12 when it is released.

Thanks.

Re: MinGW open-process, take N

[Andy Wingo]

Greets,

On Tue 12 Jul 2016 15:02, Eli Zaretskii <eliz@gnu.org> writes:

> It's hard for me to build Guile from Git, due to the additional
> prerequisites that needs.

Understood, in that case please note that there is also an automatic
build service that runs "make" and "make dist" to make tarballs:

  https://hydra.nixos.org/job/gnu/guile-2-0/tarball

Just click through and you can download a tarball.  For example:

  https://hydra.nixos.org/build/37557639/download/3/guile-2.0.11.238-e1cb7.tar.gz

There is .xz too.  This service exists for Guile master too:

  https://hydra.nixos.org/job/gnu/guile-master/tarball

> First, I see that you also removed getuid and getgid; I believe we
> only talked about removing setuid and setgid.  As I said, getuid is
> needed to build Guile.

Hmm, I don't think getuid is needed to build Guile.  Your message from
Tuesday said:

  getuid is used in boot-9.scm, so if it's unavailable, we cannot build
  Guile without making changes in the Scheme code.  I don't know if that
  convinces you, and I have no practical way of counting their uses in
  Guile programs outside Guile itself.

But in reality the getuid is of this form:

  (define (load-user-init)
    (let* ((home (or (getenv "HOME")
                     (false-if-exception (passwd:dir (getpwuid (getuid))))
                     file-name-separator-string))  ;; fallback for cygwin etc.
           (init-file (in-vicinity home ".guile")))
      (if (file-exists? init-file)
          (primitive-load init-file))))

So, no problem.

I would be happy to look at another patch that adds them if it turns out
that you need them (and sets HAVE_GETUID etc).  But, I don't think that
leaving them out will hurt anything.

> The only other issue I see is the type of the value returned by
> start_child, and as result by scm_open_process.  On Windows, the value
> returned has the type HANDLE, which is actually a pointer in disguise.
> I used intptr_t for that, but you changed it to just int.  This will
> not work in 64-bit MinGW builds, where a pointer is a 64-bit type.  I
> think we should go back to intptr_t, and also change the conversion to
> the value returned by scm_open_process, since scm_from_int will AFAIK
> not support 64-bit integer types.  Note that the MinGW waitpid
> implementation also expects to get a valu that is interpreted as a
> handle.

Hummmm, I don't know, there are a number of other things in that file
which treat PIDs as ints (scm_waitpid, scm_getppid, etc etc etc).  I
think that would need to be another patch that adds scm_from_pid_t and
scm_to_pid_t and so on.  And then what is this?

  http://permalink.gmane.org/gmane.comp.gnu.mingw.w64.general/12235

We also have some unrelated problems on MinGW64 due to the 32-bit longs
there.

I will apply your patch though and I look forward to hearing if it works
for you :)

Andy

Re: MinGW open-process, take N

[Eli Zaretskii]

> From: Andy Wingo <wingo@pobox.com>
> Cc: guile-devel@gnu.org,  ludo@gnu.org,  mhw@netris.org
> Date: Tue, 12 Jul 2016 16:05:35 +0200
> 
> > It's hard for me to build Guile from Git, due to the additional
> > prerequisites that needs.
> 
> Understood, in that case please note that there is also an automatic
> build service that runs "make" and "make dist" to make tarballs:
> 
>   https://hydra.nixos.org/job/gnu/guile-2-0/tarball
> 
> Just click through and you can download a tarball.  For example:
> 
>   https://hydra.nixos.org/build/37557639/download/3/guile-2.0.11.238-e1cb7.tar.gz
> 
> There is .xz too.  This service exists for Guile master too:
> 
>   https://hydra.nixos.org/job/gnu/guile-master/tarball

Thanks, I will try that when I have time, if Guile is not released
before that.

>   getuid is used in boot-9.scm, so if it's unavailable, we cannot build
>   Guile without making changes in the Scheme code.  I don't know if that
>   convinces you, and I have no practical way of counting their uses in
>   Guile programs outside Guile itself.
> 
> But in reality the getuid is of this form:
> 
>   (define (load-user-init)
>     (let* ((home (or (getenv "HOME")
>                      (false-if-exception (passwd:dir (getpwuid (getuid))))
>                      file-name-separator-string))  ;; fallback for cygwin etc.
>            (init-file (in-vicinity home ".guile")))
>       (if (file-exists? init-file)
>           (primitive-load init-file))))
> 
> So, no problem.

Won't this fail to compile during boot, or at least produce a warning?

> > The only other issue I see is the type of the value returned by
> > start_child, and as result by scm_open_process.  On Windows, the value
> > returned has the type HANDLE, which is actually a pointer in disguise.
> > I used intptr_t for that, but you changed it to just int.  This will
> > not work in 64-bit MinGW builds, where a pointer is a 64-bit type.  I
> > think we should go back to intptr_t, and also change the conversion to
> > the value returned by scm_open_process, since scm_from_int will AFAIK
> > not support 64-bit integer types.  Note that the MinGW waitpid
> > implementation also expects to get a valu that is interpreted as a
> > handle.
> 
> Hummmm, I don't know, there are a number of other things in that file
> which treat PIDs as ints (scm_waitpid, scm_getppid, etc etc etc).  I
> think that would need to be another patch that adds scm_from_pid_t and
> scm_to_pid_t and so on.  And then what is this?
> 
>   http://permalink.gmane.org/gmane.comp.gnu.mingw.w64.general/12235

The process ID is indeed an int, but my code hides a process handle
inside it.

> I will apply your patch though and I look forward to hearing if it works
> for you :)

The above is not a problem for me, since I use the 32-bit MinGW, where
a handle is a 32-bit type.  This is only a potential problem in 64-bit
builds.

Thanks.

Re: MinGW open-process, take N

[Andy Wingo]

On Tue 12 Jul 2016 16:46, Eli Zaretskii <eliz@gnu.org> writes:

>> But in reality the getuid is of this form:
>> 
>>   (define (load-user-init)
>>     (let* ((home (or (getenv "HOME")
>>                      (false-if-exception (passwd:dir (getpwuid (getuid))))
>>                      file-name-separator-string))  ;; fallback for cygwin etc.
>>            (init-file (in-vicinity home ".guile")))
>>       (if (file-exists? init-file)
>>           (primitive-load init-file))))
>> 
>> So, no problem.
>
> Won't this fail to compile during boot, or at least produce a warning?

It will produce a warning at compile-time, yes, but no problem at
run-time because of the false-if-exception block.

>> Hummmm, I don't know, there are a number of other things in that file
>> which treat PIDs as ints (scm_waitpid, scm_getppid, etc etc etc).  I
>> think that would need to be another patch that adds scm_from_pid_t and
>> scm_to_pid_t and so on.  And then what is this?
>> 
>>   http://permalink.gmane.org/gmane.comp.gnu.mingw.w64.general/12235
>
> The process ID is indeed an int, but my code hides a process handle
> inside it.

If you don't mind my asking: why? :)  The caller effectively just
returns the PID to Scheme, at which point it has a not-quite-PID
floating around.  Sounds like trouble to me.

Andy

Re: MinGW open-process, take N

[Eli Zaretskii]

> From: Andy Wingo <wingo@pobox.com>
> Cc: mhw@netris.org,  ludo@gnu.org,  guile-devel@gnu.org
> Date: Thu, 14 Jul 2016 12:20:09 +0200
> 
> On Tue 12 Jul 2016 16:46, Eli Zaretskii <eliz@gnu.org> writes:
> 
> >> But in reality the getuid is of this form:
> >> 
> >>   (define (load-user-init)
> >>     (let* ((home (or (getenv "HOME")
> >>                      (false-if-exception (passwd:dir (getpwuid (getuid))))
> >>                      file-name-separator-string))  ;; fallback for cygwin etc.
> >>            (init-file (in-vicinity home ".guile")))
> >>       (if (file-exists? init-file)
> >>           (primitive-load init-file))))
> >> 
> >> So, no problem.
> >
> > Won't this fail to compile during boot, or at least produce a warning?
> 
> It will produce a warning at compile-time, yes, but no problem at
> run-time because of the false-if-exception block.

Sigh.

> > The process ID is indeed an int, but my code hides a process handle
> > inside it.
> 
> If you don't mind my asking: why? :)

Because that's the only way on Windows to make sure the process object
is kept around by the kernel.  Integer PIDs are reused very quickly on
Windows, so by the time you get to scm_waitpid or some other function
that wants to query the process, that PID might not exist, or even
name a different process.  Having a handle open on the process
prevents the process object from being recycled.  Also, _cwait, used
by the Windows emulation of waitpid, needs a handle.

> The caller effectively just returns the PID to Scheme, at which
> point it has a not-quite-PID floating around.  Sounds like trouble
> to me.

Not sure why you think it's trouble.  Can you explain?

Re: MinGW open-process, take N

[Andy Wingo]

On Thu 14 Jul 2016 17:34, Eli Zaretskii <eliz@gnu.org> writes:

>> > The process ID is indeed an int, but my code hides a process handle
>> > inside it.
>> 
>> If you don't mind my asking: why? :)
>
> Because that's the only way on Windows to make sure the process object
> is kept around by the kernel.  Integer PIDs are reused very quickly on
> Windows, so by the time you get to scm_waitpid or some other function
> that wants to query the process, that PID might not exist, or even
> name a different process.  Having a handle open on the process
> prevents the process object from being recycled.  Also, _cwait, used
> by the Windows emulation of waitpid, needs a handle.

Are you saying that Windows doesn't wait until you waitpid() on a PID to
reap it?

>> The caller effectively just returns the PID to Scheme, at which
>> point it has a not-quite-PID floating around.  Sounds like trouble
>> to me.
>
> Not sure why you think it's trouble.  Can you explain?

Just that spawn_child isn't the only way to get a PID.  getpid would be
the most obvious one, but reading a PID value over a socket or whatever
is also possible.  But then your code is now introducing not-quite-PIDs
as well.  What if an interface expects one but gets the other?

Andy

Re: MinGW open-process, take N

[Eli Zaretskii]

> From: Andy Wingo <wingo@pobox.com>
> Cc: mhw@netris.org,  ludo@gnu.org,  guile-devel@gnu.org
> Date: Thu, 14 Jul 2016 20:11:28 +0200
> 
> On Thu 14 Jul 2016 17:34, Eli Zaretskii <eliz@gnu.org> writes:
> 
> >> > The process ID is indeed an int, but my code hides a process handle
> >> > inside it.
> >> 
> >> If you don't mind my asking: why? :)
> >
> > Because that's the only way on Windows to make sure the process object
> > is kept around by the kernel.  Integer PIDs are reused very quickly on
> > Windows, so by the time you get to scm_waitpid or some other function
> > that wants to query the process, that PID might not exist, or even
> > name a different process.  Having a handle open on the process
> > prevents the process object from being recycled.  Also, _cwait, used
> > by the Windows emulation of waitpid, needs a handle.
> 
> Are you saying that Windows doesn't wait until you waitpid() on a PID to
> reap it?

If there's no handle open on a process, then when it exits, its object
is recycled and its PID can easily be reused (on a busy system), yes.

> >> The caller effectively just returns the PID to Scheme, at which
> >> point it has a not-quite-PID floating around.  Sounds like trouble
> >> to me.
> >
> > Not sure why you think it's trouble.  Can you explain?
> 
> Just that spawn_child isn't the only way to get a PID.  getpid would be
> the most obvious one, but reading a PID value over a socket or whatever
> is also possible.  But then your code is now introducing not-quite-PIDs
> as well.  What if an interface expects one but gets the other?

I see your point, and I think I can fix this, together with the pid_t
width issue in 64-bit build, if I introduce an array private to
posix-w32.c that will hold the PIDs of all processes known to Guile
for which waitpid did not yet return an exit code, and their
corresponding process handles.  Then we can return an int to Scheme,
and the w32 functions will get hold of the handle by looking up the
PID in that array.

How's that sound?  If you agree, I can work on this tomorrow.

Re: MinGW open-process, take N

[Andy Wingo]

Greets :)

On Thu 14 Jul 2016 20:41, Eli Zaretskii <eliz@gnu.org> writes:

>> Just that spawn_child isn't the only way to get a PID.  getpid would be
>> the most obvious one, but reading a PID value over a socket or whatever
>> is also possible.  But then your code is now introducing not-quite-PIDs
>> as well.  What if an interface expects one but gets the other?
>
> I see your point, and I think I can fix this, together with the pid_t
> width issue in 64-bit build, if I introduce an array private to
> posix-w32.c that will hold the PIDs of all processes known to Guile
> for which waitpid did not yet return an exit code, and their
> corresponding process handles.  Then we can return an int to Scheme,
> and the w32 functions will get hold of the handle by looking up the
> PID in that array.
>
> How's that sound?  If you agree, I can work on this tomorrow.

That actually sounds really nice!  That way the PID-using functions will
all see proper PIDS and we also get the waitpid() behavior.

I would be happy to apply such a patch.  Thank you :-)

Andy

Re: MinGW open-process, take N

[Eli Zaretskii]

> From: Andy Wingo <wingo@pobox.com>
> Cc: mhw@netris.org,  ludo@gnu.org,  guile-devel@gnu.org
> Date: Thu, 14 Jul 2016 23:31:31 +0200
> 
> > I see your point, and I think I can fix this, together with the pid_t
> > width issue in 64-bit build, if I introduce an array private to
> > posix-w32.c that will hold the PIDs of all processes known to Guile
> > for which waitpid did not yet return an exit code, and their
> > corresponding process handles.  Then we can return an int to Scheme,
> > and the w32 functions will get hold of the handle by looking up the
> > PID in that array.
> >
> > How's that sound?  If you agree, I can work on this tomorrow.
> 
> That actually sounds really nice!  That way the PID-using functions will
> all see proper PIDS and we also get the waitpid() behavior.
> 
> I would be happy to apply such a patch.  Thank you :-)

Here's the first cut.  (I will rework it into git-format-patch form,
or commit and push myself, whatever is more convenient for you, as
soon as it is okayed for upstream.)

There are two more issues which I need help/guidance to resolve:

 . Access to the procs[] array should be synchronized between
   threads.  (Currently, MinGW builds of Guile don't work at all
   unless built with --disable-threads, but AFAIR Mark wanted to have
   the code thread-safe anyway.)  I guess this entails taking some
   mutex before accessing the array, but I never wrote any such code
   in Guile, so I'd appreciate to be pointed to some example, or to
   have some boilerplate for that.

 . Once a subprocess is launched, its record sits in the procs[] array
   until deleted by waitpid, if it finds that the process has exited,
   or by kill.  If neither waitpid nor kill are called, the process's
   record will not be deleted, even though the process might be long
   dead.  This means that we leak handles, and the system gets process
   objects accumulated that it cannot recycle.  (This problem was
   already present in the previous version of the code, it is not new
   with the modified version.)  Can we be sure that a well-behaving
   Guile program will always call one of these 2 functions?  If not,
   how to prevent that in a well-behaving Guile program?  I guess at
   least close-port should try killing the process (if it doesn't
   already)?  Any other ideas?

Thanks.

Here's the patch:

2016-07-16  Eli Zaretskii  <eliz@gnu.org>

	* libguile/posix-w32.c (uname): Update to modern processors (ia64
	and x86_64) and OS versions (Vista to Windows 10).  Delete
	trailing whitespace.
	(proc_record): New structure tag.
	<procs, proc_size>: New static variables.
	(find_proc, proc_handle, record_proc, delete_proc): New utility
	functions.
	(start_child): Return value is now pid_t, as it is on Posix
	platforms.  Record the new process and returns its PID, instead of
	returning a handle.
	(waitpid, kill, getpriority, setpriority, sched_getaffinity)
	(sched_setaffinity): Look up the PID in the recorded subprocesses
	before trying to open a process that is not our subprocess.  Make
	sure any open handle is closed before returning, unless it's our
	subprocess.

--- libguile/posix-w32.c~2	2016-07-16 10:22:08.273250000 +0300
+++ libguile/posix-w32.c	2016-07-16 13:18:51.163875000 +0300
@@ -173,6 +173,80 @@ uname (struct utsname *uts)
   return 0;
 }
 
+/* Utility functions for maintaining the list of subprocesses launched
+   by Guile.  */
+
+struct proc_record {
+  DWORD pid;
+  HANDLE handle;
+};
+
+static struct proc_record *procs;
+static ptrdiff_t proc_size;
+
+/* Find the process slot that corresponds to PID.  Return the index of
+   the slot, or -1 if not found.  */
+static ptrdiff_t
+find_proc (pid_t pid)
+{
+  ptrdiff_t found = -1, i;
+
+  for (i = 0; i < proc_size; i++)
+    {
+      if (procs[i].pid == pid && procs[i].handle != INVALID_HANDLE_VALUE)
+	found = i;
+    }
+
+  return found;
+}
+
+/* Return the process handle corresponding to its PID.  If not found,
+   return invalid handle value.  */
+static HANDLE
+proc_handle (pid_t pid)
+{
+  ptrdiff_t idx = find_proc (pid);
+
+  if (idx < 0)
+    return INVALID_HANDLE_VALUE;
+  return procs[idx].handle;
+}
+
+/* Store a process record in the procs[] array.  */
+static void
+record_proc (pid_t proc_pid, HANDLE proc_handle)
+{
+  ptrdiff_t i;
+
+  /* Find a vacant slot.  */
+  for (i = 0; i < proc_size; i++)
+    {
+      if (procs[i].handle == INVALID_HANDLE_VALUE)
+	break;
+    }
+
+  /* If no vacant slot, enlarge the array.  */
+  if (i == proc_size)
+    {
+      proc_size++;
+      procs = scm_realloc (procs, proc_size * sizeof(procs[0]));
+    }
+
+  /* Store the process data.  */
+  procs[i].pid = proc_pid;
+  procs[i].handle = proc_handle;
+}
+
+/* Delete a process record for process PID.  */
+static void
+delete_proc (pid_t pid)
+{
+  ptrdiff_t idx = find_proc (pid);
+
+  if (0 <= idx && idx < proc_size)
+    procs[idx].handle = INVALID_HANDLE_VALUE;
+}
+
 /* Run a child process with redirected standard handles, without
    redirecting standard handles of the parent.  This is required in
    multithreaded programs, where redirecting a standard handle affects
@@ -527,7 +601,7 @@ prepare_cmdline (const char *cmd, const 
 
    Return the PID of the child process, or -1 if couldn't start a
    process.  */
-int
+pid_t
 start_child (const char *exec_file, char **argv,
 	     int reading, int c2p[2], int writing, int p2c[2],
              int infd, int outfd, int errfd)
@@ -647,7 +721,10 @@ start_child (const char *exec_file, char
 	}
     }
   else
-    pid = (intptr_t)pi.hProcess;
+    {
+      record_proc (pi.dwProcessId, pi.hProcess);
+      pid = pi.dwProcessId;
+    }
 
   errno_save = errno;
 
@@ -683,13 +760,31 @@ start_child (const char *exec_file, char
 \f
 /* Emulation of waitpid which only supports WNOHANG, since _cwait doesn't.  */
 int
-waitpid (intptr_t pid, int *status, int options)
+waitpid (pid_t pid, int *status, int options)
 {
+  HANDLE ph;
+
+  /* Not supported on MS-Windows.  */
+  if (pid <= 0)
+    {
+      errno = ENOSYS;
+      return -1;
+    }
+
+  ph = proc_handle (pid);
+  /* Since scm_waitpid is documented to work only on child processes,
+     being unable to find a process in our records means failure.  */
+  if (ph == INVALID_HANDLE_VALUE)
+    {
+      errno = ECHILD;
+      return -1;
+    }
+
   if ((options & WNOHANG) != 0)
     {
       DWORD st;
 
-      if (!GetExitCodeProcess ((HANDLE)pid, &st))
+      if (!GetExitCodeProcess (ph, &st))
 	{
 	  errno = ECHILD;
 	  return -1;
@@ -698,10 +793,14 @@ waitpid (intptr_t pid, int *status, int 
 	return 0;
       if (status)
 	*status = st;
-      return (int)pid;
+      CloseHandle (ph);
     }
+  else
+    _cwait (status, (intptr_t)ph, WAIT_CHILD);
+
+  delete_proc (pid);
 
-  return (int)_cwait (status, pid, WAIT_CHILD);
+  return pid;
 }
 
 \f
@@ -763,8 +862,23 @@ w32_status_to_termsig (DWORD status)
 int
 kill (int pid, int sig)
 {
-  HANDLE ph = OpenProcess (PROCESS_TERMINATE, 0, pid);
+  HANDLE ph;
+  int child_proc = 0;
 
+  if (pid == getpid ())
+    {
+      if (raise (sig) == 0)
+	errno = ENOSYS;
+      return -1;
+    }
+
+  ph = proc_handle (pid);
+  /* If not found among our subprocesses, look elsewhere in the
+     system.  */
+  if (ph == INVALID_HANDLE_VALUE)
+    ph = OpenProcess (PROCESS_TERMINATE, 0, pid);
+  else
+    child_proc = 1;
   if (!ph)
     {
       errno = EPERM;
@@ -772,10 +886,19 @@ kill (int pid, int sig)
     }
   if (!TerminateProcess (ph, w32_signal_to_status (sig)))
     {
-      errno = EINVAL;
+      /* If it's our subprocess, it could have already exited.  In
+	 that case, waitpid will handily delete the process from our
+	 records, and we should return a more meaningful ESRCH to the
+	 caller.  */
+      if (child_proc && waitpid (pid, NULL, WNOHANG) == pid)
+	errno = ESRCH;
+      else
+	errno = EINVAL;
       return -1;
     }
   CloseHandle (ph);
+  if (child_proc)
+    delete_proc (pid);
 
   return 0;
 }
@@ -789,6 +912,7 @@ getpriority (int which, int who)
   HANDLE hp;
   int nice_value = -1;
   int error = 0;
+  int child_proc = 0;
 
   /* We don't support process groups and users.  */
   if (which != PRIO_PROCESS)
@@ -800,12 +924,25 @@ getpriority (int which, int who)
   if (who == 0)
     hp = GetCurrentProcess ();
   else
-    hp = OpenProcess (PROCESS_QUERY_INFORMATION, FALSE, who);
+    {
+      hp = proc_handle (who);
+      /* If not found among our subprocesses, look elsewhere in the
+	 system.  */
+      if (hp == INVALID_HANDLE_VALUE)
+	hp = OpenProcess (PROCESS_QUERY_INFORMATION, FALSE, who);
+      else
+	child_proc = 1;
+    }
 
   if (hp)
     {
       DWORD pri_class = GetPriorityClass (hp);
 
+      /* The pseudo-handle returned by GetCurrentProcess doesn't need
+	 to be closed.  */
+      if (who > 0 && !child_proc)
+	CloseHandle (hp);
+
       if (pri_class > 0)
 	{
 	  switch (pri_class)
@@ -894,6 +1031,7 @@ setpriority (int which, int who, int nic
 {
   HANDLE hp;
   DWORD err;
+  int child_proc = 0, retval = -1;
 
   if (which != PRIO_PROCESS)
     {
@@ -904,7 +1042,15 @@ setpriority (int which, int who, int nic
   if (who == 0)
     hp = GetCurrentProcess ();
   else
-    hp = OpenProcess (PROCESS_SET_INFORMATION, FALSE, who);
+    {
+      hp = proc_handle (who);
+      /* If not found among our subprocesses, look elsewhere in the
+	 system.  */
+      if (hp == INVALID_HANDLE_VALUE)
+	hp = OpenProcess (PROCESS_SET_INFORMATION, FALSE, who);
+      else
+	child_proc = 1;
+    }
 
   if (hp)
     {
@@ -926,7 +1072,7 @@ setpriority (int which, int who, int nic
 	pri_class = REALTIME_PRIORITY_CLASS;
 
       if (SetPriorityClass (hp, pri_class))
-	return 0;
+	retval = 0;
     }
 
   err = GetLastError ();
@@ -940,8 +1086,12 @@ setpriority (int which, int who, int nic
       errno = EPERM;
       break;
     }
+  /* The pseudo-handle returned by GetCurrentProcess doesn't
+     need to be closed.  */
+  if (hp && who > 0 && !child_proc)
+    CloseHandle (hp);
 
-  return -1;
+  return retval;
 }
 
 /* Emulation of sched_getaffinity and sched_setaffinity.  */
@@ -950,6 +1100,7 @@ sched_getaffinity (int pid, size_t mask_
 {
   HANDLE hp;
   DWORD err;
+  int child_proc = 0;
 
   if (mask == NULL)
     {
@@ -960,14 +1111,24 @@ sched_getaffinity (int pid, size_t mask_
   if (pid == 0)
     hp = GetCurrentProcess ();
   else
-    hp = OpenProcess (PROCESS_QUERY_INFORMATION, FALSE, pid);
+    {
+      hp = proc_handle (pid);
+      /* If not found among our subprocesses, look elsewhere in the
+	 system.  */
+      if (hp == INVALID_HANDLE_VALUE)
+	hp = OpenProcess (PROCESS_QUERY_INFORMATION, FALSE, pid);
+      else
+	child_proc = 1;
+    }
 
   if (hp)
     {
       DWORD_PTR ignored;
       BOOL result = GetProcessAffinityMask (hp, (DWORD_PTR *)mask, &ignored);
 
-      if (pid != 0)
+      /* The pseudo-handle returned by GetCurrentProcess doesn't
+	 need to be closed.  */
+      if (pid > 0 && !child_proc)
 	CloseHandle (hp);
       if (result)
 	return 0;
@@ -994,6 +1155,7 @@ sched_setaffinity (int pid, size_t mask_
 {
   HANDLE hp;
   DWORD err;
+  int child_proc = 0;
 
   if (mask == NULL)
     {
@@ -1004,13 +1166,23 @@ sched_setaffinity (int pid, size_t mask_
   if (pid == 0)
     hp = GetCurrentProcess ();
   else
-    hp = OpenProcess (PROCESS_SET_INFORMATION, FALSE, pid);
+    {
+      hp = proc_handle (pid);
+      /* If not found among our subprocesses, look elsewhere in the
+	 system.  */
+      if (hp == INVALID_HANDLE_VALUE)
+	hp = OpenProcess (PROCESS_SET_INFORMATION, FALSE, pid);
+      else
+	child_proc = 1;
+    }
 
   if (hp)
     {
       BOOL result = SetProcessAffinityMask (hp, *(DWORD_PTR *)mask);
 
-      if (pid != 0)
+      /* The pseudo-handle returned by GetCurrentProcess doesn't
+	 need to be closed.  */
+      if (pid > 0 && !child_proc)
 	CloseHandle (hp);
       if (result)
 	return 0;

Re: MinGW open-process, take N

[Andy Wingo]

On Sat 16 Jul 2016 12:54, Eli Zaretskii <eliz@gnu.org> writes:

> Here's the first cut.  (I will rework it into git-format-patch form,
> or commit and push myself, whatever is more convenient for you, as
> soon as it is okayed for upstream.)

Looks good to me.  Please configure your editor to not introduce tabs
though, and remove tabs introduced in this patch.

>  . Access to the procs[] array should be synchronized between
>    threads.  (Currently, MinGW builds of Guile don't work at all
>    unless built with --disable-threads, but AFAIR Mark wanted to have
>    the code thread-safe anyway.)  I guess this entails taking some
>    mutex before accessing the array, but I never wrote any such code
>    in Guile, so I'd appreciate to be pointed to some example, or to
>    have some boilerplate for that.

You can either use the scm_i_misc_mutex, or define your own.  If you
define your own you do:

  static scm_i_pthread_mutex_t process_table_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;

I would just use scm_i_misc_mutex in this case though.

  scm_i_scm_pthread_mutex_lock (&scm_i_misc_mutex);

  /* do your thing */

  scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);

>  . Once a subprocess is launched, its record sits in the procs[] array
>    until deleted by waitpid, if it finds that the process has exited,
>    or by kill.  If neither waitpid nor kill are called, the process's
>    record will not be deleted, even though the process might be long
>    dead.  This means that we leak handles, and the system gets process
>    objects accumulated that it cannot recycle.  (This problem was
>    already present in the previous version of the code, it is not new
>    with the modified version.)  Can we be sure that a well-behaving
>    Guile program will always call one of these 2 functions?  If not,
>    how to prevent that in a well-behaving Guile program?  I guess at
>    least close-port should try killing the process (if it doesn't
>    already)?  Any other ideas?

This mirrors how POSIX works AFAIU.  Until you waitpid() on a child
process, the PID isn't recycled, and the process exists in a "zombie"
state.  So portable Guile programs will always waitpid() on processes
they spawn.

Patch looks good to me, feel free to push after fixing tab problems and
adding the mutex.

Andy

Re: MinGW open-process, take N

[Eli Zaretskii]

> From: Andy Wingo <wingo@pobox.com>
> Cc: mhw@netris.org,  ludo@gnu.org,  guile-devel@gnu.org
> Date: Sat, 16 Jul 2016 13:32:04 +0200
> 
> On Sat 16 Jul 2016 12:54, Eli Zaretskii <eliz@gnu.org> writes:
> 
> > Here's the first cut.  (I will rework it into git-format-patch form,
> > or commit and push myself, whatever is more convenient for you, as
> > soon as it is okayed for upstream.)
> 
> Looks good to me.

Thanks.

> Please configure your editor to not introduce tabs though

Sorry, not going to happen.  That's the default GNU indentation style.

> and remove tabs introduced in this patch.

The file had an enormous amount of tabs before my changes and my
changes added maybe 2 or 3.  Does it make sense to remove only those
few?

> I would just use scm_i_misc_mutex in this case though.
> 
>   scm_i_scm_pthread_mutex_lock (&scm_i_misc_mutex);
> 
>   /* do your thing */
> 
>   scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);

OK, will do.

> >  . Once a subprocess is launched, its record sits in the procs[] array
> >    until deleted by waitpid, if it finds that the process has exited,
> >    or by kill.  If neither waitpid nor kill are called, the process's
> >    record will not be deleted, even though the process might be long
> >    dead.  This means that we leak handles, and the system gets process
> >    objects accumulated that it cannot recycle.  (This problem was
> >    already present in the previous version of the code, it is not new
> >    with the modified version.)  Can we be sure that a well-behaving
> >    Guile program will always call one of these 2 functions?  If not,
> >    how to prevent that in a well-behaving Guile program?  I guess at
> >    least close-port should try killing the process (if it doesn't
> >    already)?  Any other ideas?
> 
> This mirrors how POSIX works AFAIU.  Until you waitpid() on a child
> process, the PID isn't recycled, and the process exists in a "zombie"
> state.  So portable Guile programs will always waitpid() on processes
> they spawn.

Ah, good to know.

> Patch looks good to me, feel free to push after fixing tab problems and
> adding the mutex.

Will do, after we figure out the tricky tabs issue ;-)

Re: MinGW open-process, take N

[Eli Zaretskii]

> From: Andy Wingo <wingo@pobox.com>
> Cc: mhw@netris.org,  ludo@gnu.org,  guile-devel@gnu.org
> Date: Sat, 16 Jul 2016 13:32:04 +0200
> 
> Patch looks good to me, feel free to push after fixing tab problems and
> adding the mutex.

I added the mutex.

Is it okay to push what I have now, and remove all the tabs from
posix-w32.c (not just those I added) in a follow-up commit?

Re: MinGW open-process, take N

[Eli Zaretskii]

> Date: Sat, 16 Jul 2016 16:24:46 +0300
> From: Eli Zaretskii <eliz@gnu.org>
> Cc: mhw@netris.org, ludo@gnu.org, guile-devel@gnu.org
> 
> Is it okay to push what I have now, and remove all the tabs from
> posix-w32.c (not just those I added) in a follow-up commit?

Never mind, I just did that.

Thanks.

Re: MinGW open-process, take N

[Andy Wingo]

On Sat 16 Jul 2016 19:02, Eli Zaretskii <eliz@gnu.org> writes:

>> Date: Sat, 16 Jul 2016 16:24:46 +0300
>> From: Eli Zaretskii <eliz@gnu.org>
>> Cc: mhw@netris.org, ludo@gnu.org, guile-devel@gnu.org
>> 
>> Is it okay to push what I have now, and remove all the tabs from
>> posix-w32.c (not just those I added) in a follow-up commit?
>
> Never mind, I just did that.

Great, thank you.

Cheers,

Andy