byterun/win32.c

   1 /***********************************************************************/
   2 /*                                                                     */
   3 /*                           Objective Caml                            */
   4 /*                                                                     */
   5 /*           Xavier Leroy, projet Cristal, INRIA Rocquencourt          */
   6 /*                                                                     */
   7 /*  Copyright 1996 Institut National de Recherche en Informatique et   */
   8 /*  en Automatique.  All rights reserved.  This file is distributed    */
   9 /*  under the terms of the GNU Library General Public License, with    */
  10 /*  the special exception on linking described in file ../LICENSE.     */
  11 /*                                                                     */
  12 /***********************************************************************/
  13
  14 /* $Id$ */
  15
  16 /* Win32-specific stuff */
  17
  18 #include <windows.h>
  19 #include <stdlib.h>
  20 #include <stdio.h>
  21 #include <io.h>
  22 #include <fcntl.h>
  23 #include <sys/types.h>
  24 #include <sys/stat.h>
  25 #include <ctype.h>
  26 #include <errno.h>
  27 #include <string.h>
  28 #include <signal.h>
  29 #include "fail.h"
  30 #include "memory.h"
  31 #include "misc.h"
  32 #include "osdeps.h"
  33 #include "signals.h"
  34
  35 #ifndef S_ISREG
  36 #define S_ISREG(mode) (((mode) & S_IFMT) == S_IFREG)
  37 #endif
  38
  39 char * caml_decompose_path(struct ext_table * tbl, char * path)
  40 {
  41   char * p, * q;
  42   int n;
  43
  44   if (path == NULL) return NULL;
  45   p = caml_stat_alloc(strlen(path) + 1);
  46   strcpy(p, path);
  47   q = p;
  48   while (1) {
  49     for (n = 0; q[n] != 0 && q[n] != ';'; n++) /*nothing*/;
  50     caml_ext_table_add(tbl, q);
  51     q = q + n;
  52     if (*q == 0) break;
  53     *q = 0;
  54     q += 1;
  55   }
  56   return p;
  57 }
  58
  59 char * caml_search_in_path(struct ext_table * path, char * name)
  60 {
  61   char * p, * fullname;
  62   int i;
  63   struct stat st;
  64
  65   for (p = name; *p != 0; p++) {
  66     if (*p == '/' || *p == '\\') goto not_found;
  67   }
  68   for (i = 0; i < path->size; i++) {
  69     fullname = caml_stat_alloc(strlen((char *)(path->contents[i])) +
  70                                strlen(name) + 2);
  71     strcpy(fullname, (char *)(path->contents[i]));
  72     strcat(fullname, "\\");
  73     strcat(fullname, name);
  74     caml_gc_message(0x100, "Searching %s\n", (uintnat) fullname);
  75     if (stat(fullname, &st) == 0 && S_ISREG(st.st_mode)) return fullname;
  76     caml_stat_free(fullname);
  77   }
  78  not_found:
  79   caml_gc_message(0x100, "%s not found in search path\n", (uintnat) name);
  80   fullname = caml_stat_alloc(strlen(name) + 1);
  81   strcpy(fullname, name);
  82   return fullname;
  83 }
  84
  85 CAMLexport char * caml_search_exe_in_path(char * name)
  86 {
  87   char * fullname, * filepart;
  88   DWORD pathlen, retcode;
  89
  90   pathlen = strlen(name) + 1;
  91   if (pathlen < 256) pathlen = 256;
  92   while (1) {
  93     fullname = stat_alloc(pathlen);
  94     retcode = SearchPath(NULL,              /* use system search path */
  95                          name,
  96                          ".exe",            /* add .exe extension if needed */
  97                          pathlen,
  98                          fullname,
  99                          &filepart);
 100     if (retcode == 0) {
 101       caml_gc_message(0x100, "%s not found in search path\n",
 102                       (uintnat) name);
 103       strcpy(fullname, name);
 104       break;
 105     }
 106     if (retcode < pathlen) break;
 107     stat_free(fullname);
 108     pathlen = retcode + 1;
 109   }
 110   return fullname;
 111 }
 112
 113 char * caml_search_dll_in_path(struct ext_table * path, char * name)
 114 {
 115   char * dllname = caml_stat_alloc(strlen(name) + 5);
 116   char * res;
 117   strcpy(dllname, name);
 118   strcat(dllname, ".dll");
 119   res = caml_search_in_path(path, dllname);
 120   caml_stat_free(dllname);
 121   return res;
 122 }
 123
 124 void * caml_dlopen(char * libname, int for_execution)
 125 {
 126   HMODULE m;
 127   m = LoadLibraryEx(libname, NULL,
 128                     for_execution ? 0 : DONT_RESOLVE_DLL_REFERENCES);
 129   /* Under Win 95/98/ME, LoadLibraryEx can fail in cases where LoadLibrary
 130      would succeed.  Just try again with LoadLibrary for good measure. */
 131   if (m == NULL) m = LoadLibrary(libname);
 132   return (void *) m;
 133 }
 134
 135 void caml_dlclose(void * handle)
 136 {
 137   FreeLibrary((HMODULE) handle);
 138 }
 139
 140 void * caml_dlsym(void * handle, char * name)
 141 {
 142   return (void *) GetProcAddress((HMODULE) handle, name);
 143 }
 144
 145 char * caml_dlerror(void)
 146 {
 147   static char dlerror_buffer[256];
 148   DWORD msglen =
 149     FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS,
 150                   NULL,         /* message source */
 151                   GetLastError(), /* error number */
 152                   0,            /* default language */
 153                   dlerror_buffer, /* destination */
 154                   sizeof(dlerror_buffer), /* size of destination */
 155                   NULL);         /* no inserts */
 156   if (msglen == 0)
 157     return "unknown error";
 158   else
 159     return dlerror_buffer;
 160 }
 161
 162 /* Proper emulation of signal(), including ctrl-C and ctrl-break */
 163
 164 typedef void (*sighandler)(int sig);
 165 static int ctrl_handler_installed = 0;
 166 static volatile sighandler ctrl_handler_action = SIG_DFL;
 167
 168 static BOOL WINAPI ctrl_handler(DWORD event)
 169 {
 170   int saved_mode;
 171
 172   /* Only ctrl-C and ctrl-Break are handled */
 173   if (event != CTRL_C_EVENT && event != CTRL_BREAK_EVENT) return FALSE;
 174   /* Default behavior is to exit, which we get by not handling the event */
 175   if (ctrl_handler_action == SIG_DFL) return FALSE;
 176   /* Ignore behavior is to do nothing, which we get by claiming that we
 177      have handled the event */
 178   if (ctrl_handler_action == SIG_IGN) return TRUE;
 179   /* Win32 doesn't like it when we do a longjmp() at this point
 180      (it looks like we're running in a different thread than
 181      the main program!).  So, just record the signal. */
 182   caml_record_signal(SIGINT);
 183   /* We have handled the event */
 184   return TRUE;
 185 }
 186
 187 sighandler caml_win32_signal(int sig, sighandler action)
 188 {
 189   sighandler oldaction;
 190
 191   if (sig != SIGINT) return signal(sig, action);
 192   if (! ctrl_handler_installed) {
 193     SetConsoleCtrlHandler(ctrl_handler, TRUE);
 194     ctrl_handler_installed = 1;
 195   }
 196   oldaction = ctrl_handler_action;
 197   ctrl_handler_action = action;
 198   return oldaction;
 199 }
 200
 201 /* Expansion of @responsefile and *? file patterns in the command line */
 202
 203 static int argc;
 204 static char ** argv;
 205 static int argvsize;
 206
 207 static void store_argument(char * arg);
 208 static void expand_argument(char * arg);
 209 static void expand_pattern(char * arg);
 210 static void expand_diversion(char * filename);
 211
 212 static void out_of_memory(void)
 213 {
 214   fprintf(stderr, "Out of memory while expanding command line\n");
 215   exit(2);
 216 }
 217
 218 static void store_argument(char * arg)
 219 {
 220   if (argc + 1 >= argvsize) {
 221     argvsize *= 2;
 222     argv = (char **) realloc(argv, argvsize * sizeof(char *));
 223     if (argv == NULL) out_of_memory();
 224   }
 225   argv[argc++] = arg;
 226 }
 227
 228 static void expand_argument(char * arg)
 229 {
 230   char * p;
 231
 232   if (arg[0] == '@') {
 233     expand_diversion(arg + 1);
 234     return;
 235   }
 236   for (p = arg; *p != 0; p++) {
 237     if (*p == '*' || *p == '?') {
 238       expand_pattern(arg);
 239       return;
 240     }
 241   }
 242   store_argument(arg);
 243 }
 244
 245 static void expand_pattern(char * pat)
 246 {
 247   int handle;
 248   struct _finddata_t ffblk;
 249   int preflen;
 250
 251   handle = _findfirst(pat, &ffblk);
 252   if (handle == -1) {
 253     store_argument(pat); /* a la Bourne shell */
 254     return;
 255   }
 256   for (preflen = strlen(pat); preflen > 0; preflen--) {
 257     char c = pat[preflen - 1];
 258     if (c == '\\' || c == '/' || c == ':') break;
 259   }
 260   do {
 261     char * name = malloc(preflen + strlen(ffblk.name) + 1);
 262     if (name == NULL) out_of_memory();
 263     memcpy(name, pat, preflen);
 264     strcpy(name + preflen, ffblk.name);
 265     store_argument(name);
 266   } while (_findnext(handle, &ffblk) != -1);
 267   _findclose(handle);
 268 }
 269
 270 static void expand_diversion(char * filename)
 271 {
 272   struct _stat stat;
 273   int fd;
 274   char * buf, * endbuf, * p, * q, * s;
 275   int inquote;
 276
 277   if (_stat(filename, &stat) == -1 ||
 278       (fd = _open(filename, O_RDONLY | O_BINARY, 0)) == -1) {
 279     fprintf(stderr, "Cannot open file %s\n", filename);
 280     exit(2);
 281   }
 282   buf = (char *) malloc(stat.st_size + 1);
 283   if (buf == NULL) out_of_memory();
 284   _read(fd, buf, stat.st_size);
 285   endbuf = buf + stat.st_size;
 286   _close(fd);
 287   for (p = buf; p < endbuf; /*nothing*/) {
 288     /* Skip leading blanks */
 289     while (p < endbuf && isspace(*p)) p++;
 290     if (p >= endbuf) break;
 291     s = p;
 292     /* Skip to end of argument, taking quotes into account */
 293     q = s;
 294     inquote = 0;
 295     while (p < endbuf) {
 296       if (! inquote) {
 297         if (isspace(*p)) break;
 298         if (*p == '"') { inquote = 1; p++; continue; }
 299         *q++ = *p++;
 300       } else {
 301         switch (*p) {
 302           case '"':
 303             inquote = 0; p++; continue;
 304           case '\\':
 305             if (p + 4 <= endbuf && strncmp(p, "\\\\\\\"", 4) == 0) {
 306               p += 4; *q++ = '\\'; *q++ = '"'; continue;
 307             }
 308             if (p + 3 <= endbuf && strncmp(p, "\\\\\"", 3) == 0) {
 309               p += 3; *q++ = '\\'; inquote = 0; continue;
 310             }
 311             if (p + 2 <= endbuf && p[1] == '"') {
 312               p += 2; *q++ = '"'; continue;
 313             }
 314             /* fallthrough */
 315         default:
 316           *q++ = *p++;
 317         }
 318       }
 319     }
 320     /* Delimit argument and expand it */
 321     *q++ = 0;
 322     expand_argument(s);
 323     p++;
 324   }
 325 }
 326
 327 CAMLexport void caml_expand_command_line(int * argcp, char *** argvp)
 328 {
 329   int i;
 330   argc = 0;
 331   argvsize = 16;
 332   argv = (char **) malloc(argvsize * sizeof(char *));
 333   if (argv == NULL) out_of_memory();
 334   for (i = 0; i < *argcp; i++) expand_argument((*argvp)[i]);
 335   argv[argc] = NULL;
 336   *argcp = argc;
 337   *argvp = argv;
 338 }
 339
 340 /* Add to [contents] the (short) names of the files contained in
 341    the directory named [dirname].  No entries are added for [.] and [..].
 342    Return 0 on success, -1 on error; set errno in the case of error. */
 343
 344 int caml_read_directory(char * dirname, struct ext_table * contents)
 345 {
 346   int dirnamelen;
 347   char * template;
 348 #if _MSC_VER <= 1200
 349   int h;
 350 #else
 351   intptr_t h;
 352 #endif
 353   struct _finddata_t fileinfo;
 354   char * p;
 355
 356   dirnamelen = strlen(dirname);
 357   template = caml_stat_alloc(dirnamelen + 5);
 358   strcpy(template, dirname);
 359   switch (dirname[dirnamelen - 1]) {
 360   case '/': case '\\': case ':':
 361     strcat(template, "*.*"); break;
 362   default:
 363     strcat(template, "\\*.*");
 364   }
 365   h = _findfirst(template, &fileinfo);
 366   caml_stat_free(template);
 367   if (h == -1) return errno == ENOENT ? 0 : -1;
 368   do {
 369     if (strcmp(fileinfo.name, ".") != 0 && strcmp(fileinfo.name, "..") != 0) {
 370       p = caml_stat_alloc(strlen(fileinfo.name) + 1);
 371       strcpy(p, fileinfo.name);
 372       caml_ext_table_add(contents, p);
 373     }
 374   } while (_findnext(h, &fileinfo) == 0);
 375   _findclose(h);
 376   return 0;
 377 }
 378
 379 #ifndef NATIVE_CODE
 380
 381 /* Set up a new thread for control-C emulation and termination */
 382
 383 void caml_signal_thread(void * lpParam)
 384 {
 385   char *endptr;
 386   HANDLE h;
 387   /* Get an hexa-code raw handle through the environment */
 388   h = (HANDLE) strtol(getenv("CAMLSIGPIPE"), &endptr, 16);
 389   while (1) {
 390     DWORD numread;
 391     BOOL ret;
 392     char iobuf[2];
 393     /* This shall always return a single character */
 394     ret = ReadFile(h, iobuf, 1, &numread, NULL);
 395     if (!ret || numread != 1) caml_sys_exit(Val_int(2));
 396     switch (iobuf[0]) {
 397     case 'C':
 398       caml_record_signal(SIGINT);
 399       break;
 400     case 'T':
 401       raise(SIGTERM);
 402       return;
 403     }
 404   }
 405 }
 406
 407 #endif /* NATIVE_CODE */
 408
 409 #if defined(NATIVE_CODE) && !defined(_WIN64)
 410
 411 /* Handling of system stack overflow.
 412  * Based on code provided by Olivier Andrieu.
 413
 414  * An EXCEPTION_STACK_OVERFLOW is signaled when the guard page at the
 415  * end of the stack has been accessed. Windows clears the PAGE_GUARD
 416  * protection (making it a regular PAGE_READWRITE) and then calls our
 417  * exception handler. This means that although we're handling an "out
 418  * of stack" condition, there is a bit of stack available to call
 419  * functions and allocate temporaries.
 420  *
 421  * PAGE_GUARD is a one-shot access protection mechanism: we need to
 422  * restore the PAGE_GUARD protection on this page otherwise the next
 423  * stack overflow won't be detected and the program will abruptly exit
 424  * with STATUS_ACCESS_VIOLATION.
 425  *
 426  * Visual Studio 2003 and later (_MSC_VER >= 1300) have a
 427  * _resetstkoflw() function that resets this protection.
 428  * Unfortunately, it cannot work when called directly from the
 429  * exception handler because at this point we are using the page that
 430  * is to be protected.
 431  *
 432  * A solution is to used an alternate stack when restoring the
 433  * protection. However it's not possible to use _resetstkoflw() then
 434  * since it determines the stack pointer by calling alloca(): it would
 435  * try to protect the alternate stack.
 436  *
 437  * Finally, we call caml_raise_stack_overflow; it will either call
 438  * caml_raise_exception which switches back to the normal stack, or
 439  * call caml_fatal_uncaught_exception which terminates the program
 440  * quickly.
 441  *
 442  * NB: The PAGE_GUARD protection is only available on WinNT, not
 443  * Win9x. There is an equivalent mechanism on Win9x with
 444  * PAGE_NOACCESS.
 445  *
 446  * Currently, does not work under Win64.
 447  */
 448
 449 static uintnat win32_alt_stack[0x80];
 450
 451 static void caml_reset_stack (void *faulting_address)
 452 {
 453   OSVERSIONINFO osi;
 454   SYSTEM_INFO si;
 455   DWORD page_size;
 456   MEMORY_BASIC_INFORMATION mbi;
 457   DWORD oldprot;
 458
 459   /* get the os version (Win9x or WinNT ?) */
 460   osi.dwOSVersionInfoSize = sizeof osi;
 461   if (! GetVersionEx (&osi))
 462     goto failed;
 463
 464   /* get the system's page size. */
 465   GetSystemInfo (&si);
 466   page_size = si.dwPageSize;
 467
 468   /* get some information on the page the fault occurred */
 469   if (! VirtualQuery (faulting_address, &mbi, sizeof mbi))
 470     goto failed;
 471
 472   /* restore the PAGE_GUARD protection on this page */
 473   switch (osi.dwPlatformId) {
 474   case VER_PLATFORM_WIN32_NT:
 475     VirtualProtect (mbi.BaseAddress, page_size,
 476                     mbi.Protect | PAGE_GUARD, &oldprot);
 477     break;
 478   case VER_PLATFORM_WIN32_WINDOWS:
 479     VirtualProtect (mbi.BaseAddress, page_size,
 480                     PAGE_NOACCESS, &oldprot);
 481     break;
 482   }
 483
 484  failed:
 485   caml_raise_stack_overflow();
 486 }
 487
 488 extern char * caml_code_area_start, * caml_code_area_end;
 489
 490 #define In_code_area(pc) \
 491   ((char *)(pc) >= caml_code_area_start && \
 492    (char *)(pc) <= caml_code_area_end)
 493
 494 static LONG CALLBACK
 495     caml_UnhandledExceptionFilter (EXCEPTION_POINTERS* exn_info)
 496 {
 497   DWORD code   = exn_info->ExceptionRecord->ExceptionCode;
 498   CONTEXT *ctx = exn_info->ContextRecord;
 499   DWORD *ctx_ip = &(ctx->Eip);
 500   DWORD *ctx_sp = &(ctx->Esp);
 501
 502   if (code == EXCEPTION_STACK_OVERFLOW && In_code_area (*ctx_ip))
 503     {
 504       uintnat faulting_address;
 505       uintnat * alt_esp;
 506
 507       /* grab the address that caused the fault */
 508       faulting_address = exn_info->ExceptionRecord->ExceptionInformation[1];
 509
 510       /* call caml_reset_stack(faulting_address) using the alternate stack */
 511       alt_esp  = win32_alt_stack + sizeof(win32_alt_stack) / sizeof(uintnat);
 512       *--alt_esp = faulting_address;
 513       *ctx_sp = (uintnat) (alt_esp - 1);
 514       *ctx_ip = (uintnat) &caml_reset_stack;
 515
 516       return EXCEPTION_CONTINUE_EXECUTION;
 517     }
 518
 519   return EXCEPTION_CONTINUE_SEARCH;
 520 }
 521
 522 void caml_win32_overflow_detection()
 523 {
 524   SetUnhandledExceptionFilter (caml_UnhandledExceptionFilter);
 525 }
 526
 527 #endif
 528
 529 /* Seeding of pseudo-random number generators */
 530
 531 intnat caml_win32_random_seed (void)
 532 {
 533   intnat seed;
 534   SYSTEMTIME t;
 535
 536   GetLocalTime(&t);
 537   seed = t.wMonth;
 538   seed = (seed << 5) ^ t.wDay;
 539   seed = (seed << 4) ^ t.wHour;
 540   seed = (seed << 5) ^ t.wMinute;
 541   seed = (seed << 5) ^ t.wSecond;
 542   seed = (seed << 9) ^ t.wMilliseconds;
 543   seed ^= GetCurrentProcessId();
 544   return seed;
 545 }