src/runtime/win32-os.c

   1 /*
   2  * the Win32 incarnation of OS-dependent routines.  See also
   3  * $(sbcl_arch)-win32-os.c
   4  *
   5  * This file (along with os.h) exports an OS-independent interface to
   6  * the operating system VM facilities. Surprise surprise, this
   7  * interface looks a lot like the Mach interface (but simpler in some
   8  * places). For some operating systems, a subset of these functions
   9  * will have to be emulated.
  10  */
  11
  12 /*
  13  * This software is part of the SBCL system. See the README file for
  14  * more information.
  15  *
  16  * This software is derived from the CMU CL system, which was
  17  * written at Carnegie Mellon University and released into the
  18  * public domain. The software is in the public domain and is
  19  * provided with absolutely no warranty. See the COPYING and CREDITS
  20  * files for more information.
  21  */
  22
  23 /*
  24  * This file was copied from the Linux version of the same, and
  25  * likely still has some linuxisms in it have haven't been elimiated
  26  * yet.
  27  */
  28
  29 #include <malloc.h>
  30 #include <stdio.h>
  31 #include <stdlib.h>
  32 #include <sys/param.h>
  33 #include <sys/file.h>
  34 #include <io.h>
  35 #include "sbcl.h"
  36 #include "os.h"
  37 #include "arch.h"
  38 #include "globals.h"
  39 #include "sbcl.h"
  40 #include "interrupt.h"
  41 #include "interr.h"
  42 #include "lispregs.h"
  43 #include "runtime.h"
  44 #include "alloc.h"
  45 #include "genesis/primitive-objects.h"
  46 #include "dynbind.h"
  47
  48 #include <sys/types.h>
  49 #include <sys/time.h>
  50 #include <sys/stat.h>
  51 #include <unistd.h>
  52
  53 #include <math.h>
  54 #include <float.h>
  55
  56 #include <excpt.h>
  57
  58 #include "validate.h"
  59 #include "thread.h"
  60 #include "cpputil.h"
  61
  62 #ifndef LISP_FEATURE_SB_THREAD
  63 /* dummy definition to reduce ifdef clutter */
  64 #define WITH_GC_AT_SAFEPOINTS_ONLY() if (0) ; else
  65 #endif
  66
  67 os_vm_size_t os_vm_page_size;
  68
  69 #include "gc.h"
  70 #include "gencgc-internal.h"
  71 #include <winsock2.h>
  72
  73 #if 0
  74 int linux_sparc_siginfo_bug = 0;
  75 int linux_supports_futex=0;
  76 #endif
  77
  78 #include <stdarg.h>
  79 #include <string.h>
  80
  81 /* missing definitions for modern mingws */
  82 #ifndef EH_UNWINDING
  83 #define EH_UNWINDING 0x02
  84 #endif
  85 #ifndef EH_EXIT_UNWIND
  86 #define EH_EXIT_UNWIND 0x04
  87 #endif
  88
  89 /* Tired of writing arch_os_get_current_thread each time. */
  90 #define this_thread (arch_os_get_current_thread())
  91
  92 /* wrappers for winapi calls that must be successful (like SBCL's
  93  * (aver ...) form). */
  94
  95 /* win_aver function: basic building block for miscellaneous
  96  * ..AVER.. macrology (below) */
  97
  98 /* To do: These routines used to be "customizable" with dyndebug_init()
  99  * and variables like dyndebug_survive_aver, dyndebug_skip_averlax based
 100  * on environment variables.  Those features got lost on the way, but
 101  * ought to be reintroduced. */
 102
 103 static inline
 104 intptr_t win_aver(intptr_t value, char* comment, char* file, int line,
 105                   int justwarn)
 106 {
 107     if (!value) {
 108         LPSTR errorMessage = "<FormatMessage failed>";
 109         DWORD errorCode = GetLastError(), allocated=0;
 110         int posixerrno = errno;
 111         const char* posixstrerror = strerror(errno);
 112         char* report_template =
 113             "Expression unexpectedly false: %s:%d\n"
 114             " ... %s\n"
 115             "     ===> returned #X%p, \n"
 116             "     (in thread %p)"
 117             " ... Win32 thinks:\n"
 118             "     ===> code %u, message => %s\n"
 119             " ... CRT thinks:\n"
 120             "     ===> code %u, message => %s\n";
 121
 122         allocated =
 123             FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER|
 124                            FORMAT_MESSAGE_FROM_SYSTEM,
 125                            NULL,
 126                            errorCode,
 127                            MAKELANGID(LANG_ENGLISH,SUBLANG_ENGLISH_US),
 128                            (LPSTR)&errorMessage,
 129                            1024u,
 130                            NULL);
 131
 132         if (justwarn) {
 133             fprintf(stderr, report_template,
 134                     file, line,
 135                     comment, value,
 136                     this_thread,
 137                     (unsigned)errorCode, errorMessage,
 138                     posixerrno, posixstrerror);
 139         } else {
 140             lose(report_template,
 141                     file, line,
 142                     comment, value,
 143                     this_thread,
 144                     (unsigned)errorCode, errorMessage,
 145                     posixerrno, posixstrerror);
 146         }
 147         if (allocated)
 148             LocalFree(errorMessage);
 149     }
 150     return value;
 151 }
 152
 153 /* sys_aver function: really tiny adaptor of win_aver for
 154  * "POSIX-parody" CRT results ("lowio" and similar stuff):
 155  * negative number means something... negative. */
 156 static inline
 157 intptr_t sys_aver(long value, char* comment, char* file, int line,
 158               int justwarn)
 159 {
 160     win_aver((intptr_t)(value>=0),comment,file,line,justwarn);
 161     return value;
 162 }
 163
 164 /* Check for (call) result being boolean true. (call) may be arbitrary
 165  * expression now; massive attack of gccisms ensures transparent type
 166  * conversion back and forth, so the type of AVER(expression) is the
 167  * type of expression. Value is the same _if_ it can be losslessly
 168  * converted to (void*) and back.
 169  *
 170  * Failed AVER() is normally fatal. Well, unless dyndebug_survive_aver
 171  * flag is set. */
 172
 173 #define AVER(call)                                                      \
 174     ({ __typeof__(call) __attribute__((unused)) me =                    \
 175             (__typeof__(call))                                          \
 176             win_aver((intptr_t)(call), #call, __FILE__, __LINE__, 0);      \
 177         me;})
 178
 179 /* AVERLAX(call): do the same check as AVER did, but be mild on
 180  * failure: print an annoying unrequested message to stderr, and
 181  * continue. With dyndebug_skip_averlax flag, AVERLAX stop even to
 182  * check and complain. */
 183
 184 #define AVERLAX(call)                                                   \
 185     ({ __typeof__(call) __attribute__((unused)) me =                    \
 186             (__typeof__(call))                                          \
 187             win_aver((intptr_t)(call), #call, __FILE__, __LINE__, 1);      \
 188         me;})
 189
 190 /* Now, when failed AVER... prints both errno and GetLastError(), two
 191  * variants of "POSIX/lowio" style checks below are almost useless
 192  * (they build on sys_aver like the two above do on win_aver). */
 193
 194 #define CRT_AVER_NONNEGATIVE(call)                              \
 195     ({ __typeof__(call) __attribute__((unused)) me =            \
 196             (__typeof__(call))                                  \
 197             sys_aver((call), #call, __FILE__, __LINE__, 0);     \
 198         me;})
 199
 200 #define CRT_AVERLAX_NONNEGATIVE(call)                           \
 201     ({ __typeof__(call) __attribute__((unused)) me =            \
 202             (__typeof__(call))                                  \
 203             sys_aver((call), #call, __FILE__, __LINE__, 1);     \
 204         me;})
 205
 206 /* to be removed */
 207 #define CRT_AVER(booly)                                         \
 208     ({ __typeof__(booly) __attribute__((unused)) me = (booly);  \
 209         sys_aver((booly)?0:-1, #booly, __FILE__, __LINE__, 0);  \
 210         me;})
 211
 212 const char * t_nil_s(lispobj symbol);
 213
 214 /*
 215  * The following signal-mask-related alien routines are called from Lisp:
 216  */
 217
 218 /* As of win32, deferrables _do_ matter. gc_signal doesn't. */
 219 unsigned long block_deferrables_and_return_mask()
 220 {
 221     sigset_t sset;
 222     block_deferrable_signals(0, &sset);
 223     return (unsigned long)sset;
 224 }
 225
 226 #if defined(LISP_FEATURE_SB_THREAD)
 227 void apply_sigmask(unsigned long sigmask)
 228 {
 229     sigset_t sset = (sigset_t)sigmask;
 230     pthread_sigmask(SIG_SETMASK, &sset, 0);
 231 }
 232 #endif
 233
 234 /* The exception handling function looks like this: */
 235 EXCEPTION_DISPOSITION handle_exception(EXCEPTION_RECORD *,
 236                                        struct lisp_exception_frame *,
 237                                        CONTEXT *,
 238                                        void *);
 239 /* handle_exception is defined further in this file, but since SBCL
 240  * 1.0.1.24, it doesn't get registered as SEH handler directly anymore,
 241  * not even by wos_install_interrupt_handlers. Instead, x86-assem.S
 242  * provides exception_handler_wrapper; we install it here, and each
 243  * exception frame on nested funcall()s also points to it.
 244  */
 245
 246
 247 void *base_seh_frame;
 248
 249 static void *get_seh_frame(void)
 250 {
 251     void* retval;
 252 #ifdef LISP_FEATURE_X86
 253     asm volatile ("mov %%fs:0,%0": "=r" (retval));
 254 #else
 255     asm volatile ("mov %%gs:0,%0": "=r" (retval));
 256 #endif
 257     return retval;
 258 }
 259
 260 static void set_seh_frame(void *frame)
 261 {
 262 #ifdef LISP_FEATURE_X86
 263     asm volatile ("mov %0,%%fs:0": : "r" (frame));
 264 #else
 265     asm volatile ("mov %0,%%gs:0": : "r" (frame));
 266 #endif
 267 }
 268
 269 #if defined(LISP_FEATURE_SB_THREAD)
 270
 271 /* Permit loads from GC_SAFEPOINT_PAGE_ADDR (NB page state change is
 272  * "synchronized" with the memory region content/availability --
 273  * e.g. you won't see other CPU flushing buffered writes after WP --
 274  * but there is some window when other thread _seem_ to trap AFTER
 275  * access is granted. You may think of it something like "OS enters
 276  * SEH handler too slowly" -- what's important is there's no implicit
 277  * synchronization between VirtualProtect caller and other thread's
 278  * SEH handler, hence no ordering of events. VirtualProtect is
 279  * implicitly synchronized with protected memory contents (only).
 280  *
 281  * The last fact may be potentially used with many benefits e.g. for
 282  * foreign call speed, but we don't use it for now: almost the only
 283  * fact relevant to the current signalling protocol is "sooner or
 284  * later everyone will trap [everyone will stop trapping]".
 285  *
 286  * An interesting source on page-protection-based inter-thread
 287  * communication is a well-known paper by Dave Dice, Hui Huang,
 288  * Mingyao Yang: ``Asymmetric Dekker Synchronization''. Last time
 289  * I checked it was available at
 290  * http://home.comcast.net/~pjbishop/Dave/Asymmetric-Dekker-Synchronization.txt
 291  */
 292 void map_gc_page()
 293 {
 294     DWORD oldProt;
 295     AVER(VirtualProtect((void*) GC_SAFEPOINT_PAGE_ADDR, sizeof(lispobj),
 296                         PAGE_READWRITE, &oldProt));
 297 }
 298
 299 void unmap_gc_page()
 300 {
 301     DWORD oldProt;
 302     AVER(VirtualProtect((void*) GC_SAFEPOINT_PAGE_ADDR, sizeof(lispobj),
 303                         PAGE_NOACCESS, &oldProt));
 304 }
 305
 306 #endif
 307
 308 #if defined(LISP_FEATURE_SB_THREAD)
 309 /* We want to get a slot in TIB that (1) is available at constant
 310    offset, (2) is our private property, so libraries wouldn't legally
 311    override it, (3) contains something predefined for threads created
 312    out of our sight.
 313
 314    Low 64 TLS slots are adressable directly, starting with
 315    FS:[#xE10]. When SBCL runtime is initialized, some of the low slots
 316    may be already in use by its prerequisite DLLs, as DllMain()s and
 317    TLS callbacks have been called already. But slot 63 is unlikely to
 318    be reached at this point: one slot per DLL that needs it is the
 319    common practice, and many system DLLs use predefined TIB-based
 320    areas outside conventional TLS storage and don't need TLS slots.
 321    With our current dependencies, even slot 2 is observed to be free
 322    (as of WinXP and wine).
 323
 324    Now we'll call TlsAlloc() repeatedly until slot 63 is officially
 325    assigned to us, then TlsFree() all other slots for normal use. TLS
 326    slot 63, alias FS:[#.(+ #xE10 (* 4 63))], now belongs to us.
 327
 328    To summarize, let's list the assumptions we make:
 329
 330    - TIB, which is FS segment base, contains first 64 TLS slots at the
 331    offset #xE10 (i.e. TIB layout compatibility);
 332    - TLS slots are allocated from lower to higher ones;
 333    - All libraries together with CRT startup have not requested 64
 334    slots yet.
 335
 336    All these assumptions together don't seem to be less warranted than
 337    the availability of TIB arbitrary data slot for our use. There are
 338    some more reasons to prefer slot 63 over TIB arbitrary data: (1) if
 339    our assumptions for slot 63 are violated, it will be detected at
 340    startup instead of causing some system-specific unreproducible
 341    problems afterwards, depending on OS and loaded foreign libraries;
 342    (2) if getting slot 63 reliably with our current approach will
 343    become impossible for some future Windows version, we can add TLS
 344    callback directory to SBCL binary; main image TLS callback is
 345    started before _any_ TLS slot is allocated by libraries, and
 346    some C compiler vendors rely on this fact. */
 347
 348 void os_preinit()
 349 {
 350 #ifdef LISP_FEATURE_X86
 351     DWORD slots[TLS_MINIMUM_AVAILABLE];
 352     DWORD key;
 353     int n_slots = 0, i;
 354     for (i=0; i<TLS_MINIMUM_AVAILABLE; ++i) {
 355         key = TlsAlloc();
 356         if (key == OUR_TLS_INDEX) {
 357             if (TlsGetValue(key)!=NULL)
 358                 lose("TLS slot assertion failed: fresh slot value is not NULL");
 359             TlsSetValue(OUR_TLS_INDEX, (void*)(intptr_t)0xFEEDBAC4);
 360             if ((intptr_t)(void*)arch_os_get_current_thread()!=(intptr_t)0xFEEDBAC4)
 361                 lose("TLS slot assertion failed: TIB layout change detected");
 362             TlsSetValue(OUR_TLS_INDEX, NULL);
 363             break;
 364         }
 365         slots[n_slots++]=key;
 366     }
 367     for (i=0; i<n_slots; ++i) {
 368         TlsFree(slots[i]);
 369     }
 370     if (key!=OUR_TLS_INDEX) {
 371         lose("TLS slot assertion failed: slot 63 is unavailable "
 372              "(last TlsAlloc() returned %u)",key);
 373     }
 374 #endif
 375 }
 376 #endif  /* LISP_FEATURE_SB_THREAD */
 377
 378 int os_number_of_processors = 1;
 379
 380 void os_init(char *argv[], char *envp[])
 381 {
 382     SYSTEM_INFO system_info;
 383     GetSystemInfo(&system_info);
 384     os_vm_page_size = system_info.dwPageSize > BACKEND_PAGE_BYTES?
 385         system_info.dwPageSize : BACKEND_PAGE_BYTES;
 386 #if defined(LISP_FEATURE_X86)
 387     fast_bzero_pointer = fast_bzero_detect;
 388 #endif
 389     os_number_of_processors = system_info.dwNumberOfProcessors;
 390
 391     base_seh_frame = get_seh_frame();
 392 }
 393
 394 static inline boolean local_thread_stack_address_p(os_vm_address_t address)
 395 {
 396     return this_thread &&
 397         (((((u64)address >= (u64)this_thread->os_address) &&
 398            ((u64)address < ((u64)this_thread)-THREAD_CSP_PAGE_SIZE))||
 399           (((u64)address >= (u64)this_thread->control_stack_start)&&
 400            ((u64)address < (u64)this_thread->control_stack_end))));
 401 }
 402
 403 /*
 404  * So we have three fun scenarios here.
 405  *
 406  * First, we could be being called to reserve the memory areas
 407  * during initialization (prior to loading the core file).
 408  *
 409  * Second, we could be being called by the GC to commit a page
 410  * that has just been decommitted (for easy zero-fill).
 411  *
 412  * Third, we could be being called by create_thread_struct()
 413  * in order to create the sundry and various stacks.
 414  *
 415  * The third case is easy to pick out because it passes an
 416  * addr of 0.
 417  *
 418  * The second case is easy to pick out because it will be for
 419  * a range of memory that is MEM_RESERVE rather than MEM_FREE.
 420  *
 421  * The second case is also an easy implement, because we leave
 422  * the memory as reserved (since we do lazy commits).
 423  */
 424
 425 os_vm_address_t
 426 os_validate(os_vm_address_t addr, os_vm_size_t len)
 427 {
 428     MEMORY_BASIC_INFORMATION mem_info;
 429
 430     if (!addr) {
 431         /* the simple case first */
 432         return
 433             AVERLAX(VirtualAlloc(addr, len, MEM_RESERVE|MEM_COMMIT, PAGE_EXECUTE_READWRITE));
 434     }
 435
 436     if (!AVERLAX(VirtualQuery(addr, &mem_info, sizeof mem_info)))
 437         return 0;
 438
 439     if ((mem_info.State == MEM_RESERVE) && (mem_info.RegionSize >=len)) {
 440       /* It would be correct to return here. However, support for Wine
 441        * is beneficial, and Wine has a strange behavior in this
 442        * department. It reports all memory below KERNEL32.DLL as
 443        * reserved, but disallows MEM_COMMIT.
 444        *
 445        * Let's work around it: reserve the region we need for a second
 446        * time. The second reservation is documented to fail on normal NT
 447        * family, but it will succeed on Wine if this region is
 448        * actually free.
 449        */
 450       VirtualAlloc(addr, len, MEM_RESERVE, PAGE_EXECUTE_READWRITE);
 451       /* If it is wine, the second call has succeded, and now the region
 452        * is really reserved. */
 453       return addr;
 454     }
 455
 456     if (mem_info.State == MEM_RESERVE) {
 457         fprintf(stderr, "validation of reserved space too short.\n");
 458         fflush(stderr);
 459         /* Oddly, we do not treat this assertion as fatal; hence also the
 460          * provision for MEM_RESERVE in the following code, I suppose: */
 461     }
 462
 463     if (!AVERLAX(VirtualAlloc(addr, len, (mem_info.State == MEM_RESERVE)?
 464                               MEM_COMMIT: MEM_RESERVE, PAGE_EXECUTE_READWRITE)))
 465         return 0;
 466
 467     return addr;
 468 }
 469
 470 /*
 471  * For os_invalidate(), we merely decommit the memory rather than
 472  * freeing the address space. This loses when freeing per-thread
 473  * data and related memory since it leaks address space.
 474  *
 475  * So far the original comment (author unknown).  It used to continue as
 476  * follows:
 477  *
 478  *   It's not too lossy, however, since the two scenarios I'm aware of
 479  *   are fd-stream buffers, which are pooled rather than torched, and
 480  *   thread information, which I hope to pool (since windows creates
 481  *   threads at its own whim, and we probably want to be able to have
 482  *   them callback without funky magic on the part of the user, and
 483  *   full-on thread allocation is fairly heavyweight).
 484  *
 485  * But: As it turns out, we are no longer content with decommitting
 486  * without freeing, and have now grown a second function
 487  * os_invalidate_free(), sort of a really_os_invalidate().
 488  *
 489  * As discussed on #lisp, this is not a satisfactory solution, and probably
 490  * ought to be rectified in the following way:
 491  *
 492  *  - Any cases currently going through the non-freeing version of
 493  *    os_invalidate() are ultimately meant for zero-filling applications.
 494  *    Replace those use cases with an os_revalidate_bzero() or similarly
 495  *    named function, which explicitly takes care of that aspect of
 496  *    the semantics.
 497  *
 498  *  - The remaining uses of os_invalidate should actually free, and once
 499  *    the above is implemented, we can rename os_invalidate_free back to
 500  *    just os_invalidate().
 501  *
 502  * So far the new plan, as yet unimplemented. -- DFL
 503  */
 504
 505 void
 506 os_invalidate(os_vm_address_t addr, os_vm_size_t len)
 507 {
 508     AVERLAX(VirtualFree(addr, len, MEM_DECOMMIT));
 509 }
 510
 511 void
 512 os_invalidate_free(os_vm_address_t addr, os_vm_size_t len)
 513 {
 514     AVERLAX(VirtualFree(addr, 0, MEM_RELEASE));
 515 }
 516
 517 void
 518 os_invalidate_free_by_any_address(os_vm_address_t addr, os_vm_size_t len)
 519 {
 520     MEMORY_BASIC_INFORMATION minfo;
 521     AVERLAX(VirtualQuery(addr, &minfo, sizeof minfo));
 522     AVERLAX(minfo.AllocationBase);
 523     AVERLAX(VirtualFree(minfo.AllocationBase, 0, MEM_RELEASE));
 524 }
 525
 526 #define maybe_open_osfhandle _open_osfhandle
 527 #define maybe_get_osfhandle _get_osfhandle
 528 #define FDTYPE int
 529
 530 /*
 531  * os_map() is called to map a chunk of the core file into memory.
 532  *
 533  * Unfortunately, Windows semantics completely screws this up, so
 534  * we just add backing store from the swapfile to where the chunk
 535  * goes and read it up like a normal file. We could consider using
 536  * a lazy read (demand page) setup, but that would mean keeping an
 537  * open file pointer for the core indefinately (and be one more
 538  * thing to maintain).
 539  */
 540
 541 os_vm_address_t
 542 os_map(int fd, int offset, os_vm_address_t addr, os_vm_size_t len)
 543 {
 544     os_vm_size_t count;
 545
 546     AVER(VirtualAlloc(addr, len, MEM_COMMIT, PAGE_EXECUTE_READWRITE)||
 547          VirtualAlloc(addr, len, MEM_RESERVE|MEM_COMMIT,
 548                       PAGE_EXECUTE_READWRITE));
 549
 550     CRT_AVER_NONNEGATIVE(lseek(fd, offset, SEEK_SET));
 551
 552     count = read(fd, addr, len);
 553     CRT_AVER( count == len );
 554
 555     return addr;
 556 }
 557
 558 static DWORD os_protect_modes[8] = {
 559     PAGE_NOACCESS,
 560     PAGE_READONLY,
 561     PAGE_READWRITE,
 562     PAGE_READWRITE,
 563     PAGE_EXECUTE,
 564     PAGE_EXECUTE_READ,
 565     PAGE_EXECUTE_READWRITE,
 566     PAGE_EXECUTE_READWRITE,
 567 };
 568
 569 void
 570 os_protect(os_vm_address_t address, os_vm_size_t length, os_vm_prot_t prot)
 571 {
 572     DWORD old_prot;
 573
 574     DWORD new_prot = os_protect_modes[prot];
 575     AVER(VirtualProtect(address, length, new_prot, &old_prot)||
 576          (VirtualAlloc(address, length, MEM_COMMIT, new_prot) &&
 577           VirtualProtect(address, length, new_prot, &old_prot)));
 578     odxprint(misc,"Protecting %p + %p vmaccess %d "
 579              "newprot %08x oldprot %08x",
 580              address,length,prot,new_prot,old_prot);
 581 }
 582
 583 /* FIXME: Now that FOO_END, rather than FOO_SIZE, is the fundamental
 584  * description of a space, we could probably punt this and just do
 585  * (FOO_START <= x && x < FOO_END) everywhere it's called. */
 586 static boolean
 587 in_range_p(os_vm_address_t a, lispobj sbeg, size_t slen)
 588 {
 589     char* beg = (char*)((uword_t)sbeg);
 590     char* end = (char*)((uword_t)sbeg) + slen;
 591     char* adr = (char*)a;
 592     return (adr >= beg && adr < end);
 593 }
 594
 595 boolean
 596 is_linkage_table_addr(os_vm_address_t addr)
 597 {
 598     return in_range_p(addr, LINKAGE_TABLE_SPACE_START, LINKAGE_TABLE_SPACE_END);
 599 }
 600
 601 static boolean is_some_thread_local_addr(os_vm_address_t addr);
 602
 603 boolean
 604 is_valid_lisp_addr(os_vm_address_t addr)
 605 {
 606     if(in_range_p(addr, READ_ONLY_SPACE_START, READ_ONLY_SPACE_SIZE) ||
 607        in_range_p(addr, STATIC_SPACE_START   , STATIC_SPACE_SIZE) ||
 608        in_range_p(addr, DYNAMIC_SPACE_START  , dynamic_space_size) ||
 609        is_some_thread_local_addr(addr))
 610         return 1;
 611     return 0;
 612 }
 613
 614 /* test if an address is within thread-local space */
 615 static boolean
 616 is_thread_local_addr(struct thread* th, os_vm_address_t addr)
 617 {
 618     /* Assuming that this is correct, it would warrant further comment,
 619      * I think.  Based on what our call site is doing, we have been
 620      * tasked to check for the address of a lisp object; not merely any
 621      * foreign address within the thread's area.  Indeed, this used to
 622      * be a check for control and binding stack only, rather than the
 623      * full thread "struct".  So shouldn't the THREAD_STRUCT_SIZE rather
 624      * be (thread_control_stack_size+BINDING_STACK_SIZE) instead?  That
 625      * would also do away with the LISP_FEATURE_SB_THREAD case.  Or does
 626      * it simply not matter?  --DFL */
 627     ptrdiff_t diff = ((char*)th->os_address)-(char*)addr;
 628     return diff > (ptrdiff_t)0 && diff < (ptrdiff_t)THREAD_STRUCT_SIZE
 629 #ifdef LISP_FEATURE_SB_THREAD
 630         && addr != (os_vm_address_t) th->csp_around_foreign_call
 631 #endif
 632         ;
 633 }
 634
 635 static boolean
 636 is_some_thread_local_addr(os_vm_address_t addr)
 637 {
 638     boolean result = 0;
 639 #ifdef LISP_FEATURE_SB_THREAD
 640     struct thread *th;
 641     pthread_mutex_lock(&all_threads_lock);
 642     for_each_thread(th) {
 643         if(is_thread_local_addr(th,addr)) {
 644             result = 1;
 645             break;
 646         }
 647     }
 648     pthread_mutex_unlock(&all_threads_lock);
 649 #endif
 650     return result;
 651 }
 652
 653
 654 /* A tiny bit of interrupt.c state we want our paws on. */
 655 extern boolean internal_errors_enabled;
 656
 657 extern void exception_handler_wrapper();
 658
 659 void
 660 c_level_backtrace(const char* header, int depth)
 661 {
 662     void* frame;
 663     int n = 0;
 664     void** lastseh;
 665
 666     for (lastseh = get_seh_frame(); lastseh && (lastseh!=(void*)-1);
 667          lastseh = *lastseh);
 668
 669     fprintf(stderr, "Backtrace: %s (thread %p)\n", header, this_thread);
 670     for (frame = __builtin_frame_address(0); frame; frame=*(void**)frame)
 671     {
 672         if ((n++)>depth)
 673             return;
 674         fprintf(stderr, "[#%02d]: ebp = 0x%p, ret = 0x%p\n",n,
 675                 frame, ((void**)frame)[1]);
 676     }
 677 }
 678
 679 #ifdef LISP_FEATURE_X86
 680 #define voidreg(ctxptr,name) ((void*)((ctxptr)->E##name))
 681 #else
 682 #define voidreg(ctxptr,name) ((void*)((ctxptr)->R##name))
 683 #endif
 684
 685
 686 #if defined(LISP_FEATURE_X86)
 687 static int
 688 handle_single_step(os_context_t *ctx)
 689 {
 690     if (!single_stepping)
 691         return -1;
 692
 693     /* We are doing a displaced instruction. At least function
 694      * end breakpoints use this. */
 695     WITH_GC_AT_SAFEPOINTS_ONLY () /* Todo: Is it really gc-unsafe? */
 696         restore_breakpoint_from_single_step(ctx);
 697
 698     return 0;
 699 }
 700 #endif
 701
 702 #ifdef LISP_FEATURE_UD2_BREAKPOINTS
 703 #define SBCL_EXCEPTION_BREAKPOINT EXCEPTION_ILLEGAL_INSTRUCTION
 704 #define TRAP_CODE_WIDTH 2
 705 #else
 706 #define SBCL_EXCEPTION_BREAKPOINT EXCEPTION_BREAKPOINT
 707 #define TRAP_CODE_WIDTH 1
 708 #endif
 709
 710 static int
 711 handle_breakpoint_trap(os_context_t *ctx, struct thread* self)
 712 {
 713 #ifdef LISP_FEATURE_UD2_BREAKPOINTS
 714     if (((unsigned short *)((ctx->win32_context)->Eip))[0] != 0x0b0f)
 715         return -1;
 716 #endif
 717
 718     /* Unlike some other operating systems, Win32 leaves EIP
 719      * pointing to the breakpoint instruction. */
 720     (*os_context_pc_addr(ctx)) += TRAP_CODE_WIDTH;
 721
 722     /* Now EIP points just after the INT3 byte and aims at the
 723      * 'kind' value (eg trap_Cerror). */
 724     unsigned trap = *(unsigned char *)(*os_context_pc_addr(ctx));
 725
 726 #ifdef LISP_FEATURE_SB_THREAD
 727     /* Before any other trap handler: gc_safepoint ensures that
 728        inner alloc_sap for passing the context won't trap on
 729        pseudo-atomic. */
 730     if (trap == trap_PendingInterrupt) {
 731         /* Done everything needed for this trap, except EIP
 732            adjustment */
 733         arch_skip_instruction(ctx);
 734         thread_interrupted(ctx);
 735         return 0;
 736     }
 737 #endif
 738
 739     /* This is just for info in case the monitor wants to print an
 740      * approximation. */
 741     access_control_stack_pointer(self) =
 742         (lispobj *)*os_context_sp_addr(ctx);
 743
 744     WITH_GC_AT_SAFEPOINTS_ONLY() {
 745 #if defined(LISP_FEATURE_SB_THREAD)
 746         block_blockable_signals(0,&ctx->sigmask);
 747 #endif
 748         handle_trap(ctx, trap);
 749 #if defined(LISP_FEATURE_SB_THREAD)
 750         thread_sigmask(SIG_SETMASK,&ctx->sigmask,NULL);
 751 #endif
 752     }
 753
 754     /* Done, we're good to go! */
 755     return 0;
 756 }
 757
 758 static int
 759 handle_access_violation(os_context_t *ctx,
 760                         EXCEPTION_RECORD *exception_record,
 761                         void *fault_address,
 762                         struct thread* self)
 763 {
 764     CONTEXT *win32_context = ctx->win32_context;
 765
 766 #if defined(LISP_FEATURE_X86)
 767     odxprint(pagefaults,
 768              "SEGV. ThSap %p, Eip %p, Esp %p, Esi %p, Edi %p, "
 769              "Addr %p Access %d\n",
 770              self,
 771              win32_context->Eip,
 772              win32_context->Esp,
 773              win32_context->Esi,
 774              win32_context->Edi,
 775              fault_address,
 776              exception_record->ExceptionInformation[0]);
 777 #else
 778     odxprint(pagefaults,
 779              "SEGV. ThSap %p, Eip %p, Esp %p, Esi %p, Edi %p, "
 780              "Addr %p Access %d\n",
 781              self,
 782              win32_context->Rip,
 783              win32_context->Rsp,
 784              win32_context->Rsi,
 785              win32_context->Rdi,
 786              fault_address,
 787              exception_record->ExceptionInformation[0]);
 788 #endif
 789
 790     /* Stack: This case takes care of our various stack exhaustion
 791      * protect pages (with the notable exception of the control stack!). */
 792     if (self && local_thread_stack_address_p(fault_address)) {
 793         if (handle_guard_page_triggered(ctx, fault_address))
 794             return 0; /* gc safety? */
 795         goto try_recommit;
 796     }
 797
 798     /* Safepoint pages */
 799 #ifdef LISP_FEATURE_SB_THREAD
 800     if (fault_address == (void *) GC_SAFEPOINT_PAGE_ADDR) {
 801         thread_in_lisp_raised(ctx);
 802         return 0;
 803     }
 804
 805     if ((((u64)fault_address) == ((u64)self->csp_around_foreign_call))){
 806         thread_in_safety_transition(ctx);
 807         return 0;
 808     }
 809 #endif
 810
 811     /* dynamic space */
 812     page_index_t index = find_page_index(fault_address);
 813     if (index != -1) {
 814         /*
 815          * Now, if the page is supposedly write-protected and this
 816          * is a write, tell the gc that it's been hit.
 817          */
 818         if (page_table[index].write_protected) {
 819             gencgc_handle_wp_violation(fault_address);
 820         } else {
 821             AVER(VirtualAlloc(PTR_ALIGN_DOWN(fault_address,os_vm_page_size),
 822                               os_vm_page_size,
 823                               MEM_COMMIT, PAGE_EXECUTE_READWRITE));
 824         }
 825         return 0;
 826     }
 827
 828     if (fault_address == undefined_alien_address)
 829         return -1;
 830
 831     /* linkage table or a "valid_lisp_addr" outside of dynamic space (?) */
 832     if (is_linkage_table_addr(fault_address)
 833         || is_valid_lisp_addr(fault_address))
 834         goto try_recommit;
 835
 836     return -1;
 837
 838 try_recommit:
 839     /* First use of a new page, lets get some memory for it. */
 840
 841 #if defined(LISP_FEATURE_X86)
 842     AVER(VirtualAlloc(PTR_ALIGN_DOWN(fault_address,os_vm_page_size),
 843                       os_vm_page_size,
 844                       MEM_COMMIT, PAGE_EXECUTE_READWRITE)
 845          ||(fprintf(stderr,"Unable to recommit addr %p eip 0x%08lx\n",
 846                     fault_address, win32_context->Eip) &&
 847             (c_level_backtrace("BT",5),
 848              fake_foreign_function_call(ctx),
 849              lose("Lispy backtrace"),
 850              0)));
 851 #else
 852     AVER(VirtualAlloc(PTR_ALIGN_DOWN(fault_address,os_vm_page_size),
 853                       os_vm_page_size,
 854                       MEM_COMMIT, PAGE_EXECUTE_READWRITE)
 855          ||(fprintf(stderr,"Unable to recommit addr %p eip 0x%p\n",
 856                     fault_address, (void*)win32_context->Rip) &&
 857             (c_level_backtrace("BT",5),
 858              fake_foreign_function_call(ctx),
 859              lose("Lispy backtrace"),
 860              0)));
 861 #endif
 862
 863     return 0;
 864 }
 865
 866 static void
 867 signal_internal_error_or_lose(os_context_t *ctx,
 868                               EXCEPTION_RECORD *exception_record,
 869                               void *fault_address)
 870 {
 871     /*
 872      * If we fall through to here then we need to either forward
 873      * the exception to the lisp-side exception handler if it's
 874      * set up, or drop to LDB.
 875      */
 876
 877     if (internal_errors_enabled) {
 878         lispobj context_sap;
 879         lispobj exception_record_sap;
 880
 881         asm("fnclex");
 882         /* We're making the somewhat arbitrary decision that having
 883          * internal errors enabled means that lisp has sufficient
 884          * marbles to be able to handle exceptions, but exceptions
 885          * aren't supposed to happen during cold init or reinit
 886          * anyway. */
 887
 888 #if defined(LISP_FEATURE_SB_THREAD)
 889         block_blockable_signals(0,&ctx->sigmask);
 890 #endif
 891         fake_foreign_function_call(ctx);
 892
 893         WITH_GC_AT_SAFEPOINTS_ONLY() {
 894             /* Allocate the SAP objects while the "interrupts" are still
 895              * disabled. */
 896             context_sap = alloc_sap(ctx);
 897             exception_record_sap = alloc_sap(exception_record);
 898 #if defined(LISP_FEATURE_SB_THREAD)
 899             thread_sigmask(SIG_SETMASK, &ctx->sigmask, NULL);
 900 #endif
 901
 902             /* The exception system doesn't automatically clear pending
 903              * exceptions, so we lose as soon as we execute any FP
 904              * instruction unless we do this first. */
 905             /* Call into lisp to handle things. */
 906             funcall2(StaticSymbolFunction(HANDLE_WIN32_EXCEPTION),
 907                      context_sap,
 908                      exception_record_sap);
 909         }
 910         /* If Lisp doesn't nlx, we need to put things back. */
 911         undo_fake_foreign_function_call(ctx);
 912 #if defined(LISP_FEATURE_SB_THREAD)
 913         thread_sigmask(SIG_SETMASK, &ctx->sigmask, NULL);
 914 #endif
 915         /* FIXME: HANDLE-WIN32-EXCEPTION should be allowed to decline */
 916         return;
 917     }
 918
 919     fprintf(stderr, "Exception Code: 0x%p.\n",
 920             (void*)(intptr_t)exception_record->ExceptionCode);
 921     fprintf(stderr, "Faulting IP: 0x%p.\n",
 922             (void*)(intptr_t)exception_record->ExceptionAddress);
 923     if (exception_record->ExceptionCode == EXCEPTION_ACCESS_VIOLATION) {
 924         MEMORY_BASIC_INFORMATION mem_info;
 925
 926         if (VirtualQuery(fault_address, &mem_info, sizeof mem_info)) {
 927             fprintf(stderr, "page status: 0x%lx.\n", mem_info.State);
 928         }
 929
 930         fprintf(stderr, "Was writing: %p, where: 0x%p.\n",
 931                 (void*)exception_record->ExceptionInformation[0],
 932                 fault_address);
 933     }
 934
 935     fflush(stderr);
 936
 937     fake_foreign_function_call(ctx);
 938     lose("Exception too early in cold init, cannot continue.");
 939 }
 940
 941 /*
 942  * A good explanation of the exception handling semantics is
 943  *   http://win32assembly.online.fr/Exceptionhandling.html (possibly defunct)
 944  * or:
 945  *   http://www.microsoft.com/msj/0197/exception/exception.aspx
 946  */
 947
 948 EXCEPTION_DISPOSITION
 949 handle_exception(EXCEPTION_RECORD *exception_record,
 950                  struct lisp_exception_frame *exception_frame,
 951                  CONTEXT *win32_context,
 952                  void *dispatcher_context)
 953 {
 954     if (!win32_context)
 955         /* Not certain why this should be possible, but let's be safe... */
 956         return ExceptionContinueSearch;
 957
 958     if (exception_record->ExceptionFlags & (EH_UNWINDING | EH_EXIT_UNWIND)) {
 959         /* If we're being unwound, be graceful about it. */
 960
 961         /* Undo any dynamic bindings. */
 962         unbind_to_here(exception_frame->bindstack_pointer,
 963                        arch_os_get_current_thread());
 964         return ExceptionContinueSearch;
 965     }
 966
 967     DWORD lastError = GetLastError();
 968     DWORD lastErrno = errno;
 969     DWORD code = exception_record->ExceptionCode;
 970     struct thread* self = arch_os_get_current_thread();
 971
 972     os_context_t context, *ctx = &context;
 973     context.win32_context = win32_context;
 974 #if defined(LISP_FEATURE_SB_THREAD)
 975     context.sigmask = self ? self->os_thread->blocked_signal_set : 0;
 976 #endif
 977
 978     /* For EXCEPTION_ACCESS_VIOLATION only. */
 979     void *fault_address = (void *)exception_record->ExceptionInformation[1];
 980
 981     odxprint(seh,
 982              "SEH: rec %p, ctxptr %p, rip %p, fault %p\n"
 983              "... code %p, rcx %p, fp-tags %p\n\n",
 984              exception_record,
 985              win32_context,
 986              voidreg(win32_context,ip),
 987              fault_address,
 988              (void*)(intptr_t)code,
 989              voidreg(win32_context,cx),
 990              win32_context->FloatSave.TagWord);
 991
 992     /* This function had become unwieldy.  Let's cut it down into
 993      * pieces based on the different exception codes.  Each exception
 994      * code handler gets the chance to decline by returning non-zero if it
 995      * isn't happy: */
 996
 997     int rc;
 998     switch (code) {
 999     case EXCEPTION_ACCESS_VIOLATION:
1000         rc = handle_access_violation(
1001             ctx, exception_record, fault_address, self);
1002         break;
1003
1004     case SBCL_EXCEPTION_BREAKPOINT:
1005         rc = handle_breakpoint_trap(ctx, self);
1006         break;
1007
1008 #if defined(LISP_FEATURE_X86)
1009     case EXCEPTION_SINGLE_STEP:
1010         rc = handle_single_step(ctx);
1011         break;
1012 #endif
1013
1014     default:
1015         rc = -1;
1016     }
1017
1018     if (rc)
1019         /* All else failed, drop through to the lisp-side exception handler. */
1020         signal_internal_error_or_lose(ctx, exception_record, fault_address);
1021
1022     errno = lastErrno;
1023     SetLastError(lastError);
1024     return ExceptionContinueExecution;
1025 }
1026
1027 void
1028 wos_install_interrupt_handlers(struct lisp_exception_frame *handler)
1029 {
1030 #ifdef LISP_FEATURE_X86
1031     handler->next_frame = get_seh_frame();
1032     handler->handler = (void*)exception_handler_wrapper;
1033     set_seh_frame(handler);
1034 #else
1035     static int once = 0;
1036     if (!once++)
1037         AddVectoredExceptionHandler(1,veh);
1038 #endif
1039 }
1040
1041 /*
1042  * The stubs below are replacements for the windows versions,
1043  * which can -fail- when used in our memory spaces because they
1044  * validate the memory spaces they are passed in a way that
1045  * denies our exception handler a chance to run.
1046  */
1047
1048 void *memmove(void *dest, const void *src, size_t n)
1049 {
1050     if (dest < src) {
1051         int i;
1052         for (i = 0; i < n; i++) *(((char *)dest)+i) = *(((char *)src)+i);
1053     } else {
1054         while (n--) *(((char *)dest)+n) = *(((char *)src)+n);
1055     }
1056     return dest;
1057 }
1058
1059 void *memcpy(void *dest, const void *src, size_t n)
1060 {
1061     while (n--) *(((char *)dest)+n) = *(((char *)src)+n);
1062     return dest;
1063 }
1064
1065 char *dirname(char *path)
1066 {
1067     static char buf[PATH_MAX + 1];
1068     size_t pathlen = strlen(path);
1069     int i;
1070
1071     if (pathlen >= sizeof(buf)) {
1072         lose("Pathname too long in dirname.\n");
1073         return NULL;
1074     }
1075
1076     strcpy(buf, path);
1077     for (i = pathlen; i >= 0; --i) {
1078         if (buf[i] == '/' || buf[i] == '\\') {
1079             buf[i] = '\0';
1080             break;
1081         }
1082     }
1083
1084     return buf;
1085 }
1086
1087 /* Unofficial but widely used property of console handles: they have
1088    #b11 in two minor bits, opposed to other handles, that are
1089    machine-word-aligned. Properly emulated even on wine.
1090
1091    Console handles are special in many aspects, e.g. they aren't NTDLL
1092    system handles: kernel32 redirects console operations to CSRSS
1093    requests. Using the hack below to distinguish console handles is
1094    justified, as it's the only method that won't hang during
1095    outstanding reads, won't try to lock NT kernel object (if there is
1096    one; console isn't), etc. */
1097 int
1098 console_handle_p(HANDLE handle)
1099 {
1100     return (handle != NULL)&&
1101         (handle != INVALID_HANDLE_VALUE)&&
1102         ((((int)(intptr_t)handle)&3)==3);
1103 }
1104
1105 static const LARGE_INTEGER zero_large_offset = {.QuadPart = 0LL};
1106
1107 int
1108 win32_unix_write(FDTYPE fd, void * buf, int count)
1109 {
1110     HANDLE handle;
1111     DWORD written_bytes;
1112     OVERLAPPED overlapped;
1113     struct thread * self = arch_os_get_current_thread();
1114     BOOL waitInGOR;
1115     LARGE_INTEGER file_position;
1116     BOOL seekable;
1117     BOOL ok;
1118
1119     handle =(HANDLE)maybe_get_osfhandle(fd);
1120     if (console_handle_p(handle))
1121         return write(fd, buf, count);
1122
1123     overlapped.hEvent = self->private_events.events[0];
1124     seekable = SetFilePointerEx(handle,
1125                                 zero_large_offset,
1126                                 &file_position,
1127                                 FILE_CURRENT);
1128     if (seekable) {
1129         overlapped.Offset = file_position.LowPart;
1130         overlapped.OffsetHigh = file_position.HighPart;
1131     } else {
1132         overlapped.Offset = 0;
1133         overlapped.OffsetHigh = 0;
1134     }
1135     ok = WriteFile(handle, buf, count, &written_bytes, &overlapped);
1136
1137     if (ok) {
1138         goto done_something;
1139     } else {
1140         if (GetLastError()!=ERROR_IO_PENDING) {
1141             errno = EIO;
1142             return -1;
1143         } else {
1144             if(WaitForMultipleObjects(2,self->private_events.events,
1145                                       FALSE,INFINITE) != WAIT_OBJECT_0) {
1146                 CancelIo(handle);
1147                 waitInGOR = TRUE;
1148             } else {
1149                 waitInGOR = FALSE;
1150             }
1151             if (!GetOverlappedResult(handle,&overlapped,&written_bytes,waitInGOR)) {
1152                 if (GetLastError()==ERROR_OPERATION_ABORTED) {
1153                     errno = EINTR;
1154                 } else {
1155                     errno = EIO;
1156                 }
1157                 return -1;
1158             } else {
1159                 goto done_something;
1160             }
1161         }
1162     }
1163   done_something:
1164     if (seekable) {
1165         file_position.QuadPart += written_bytes;
1166         SetFilePointerEx(handle,file_position,NULL,FILE_BEGIN);
1167     }
1168     return written_bytes;
1169 }
1170
1171 int
1172 win32_unix_read(FDTYPE fd, void * buf, int count)
1173 {
1174     HANDLE handle;
1175     OVERLAPPED overlapped = {.Internal=0};
1176     DWORD read_bytes = 0;
1177     struct thread * self = arch_os_get_current_thread();
1178     DWORD errorCode = 0;
1179     BOOL waitInGOR = FALSE;
1180     BOOL ok = FALSE;
1181     LARGE_INTEGER file_position;
1182     BOOL seekable;
1183
1184     handle = (HANDLE)maybe_get_osfhandle(fd);
1185
1186     if (console_handle_p(handle)) {
1187         /* 1. Console is a singleton.
1188            2. The only way to cancel console handle I/O is to close it.
1189         */
1190     if (console_handle_p(handle))
1191         return read(fd, buf, count);
1192     }
1193     overlapped.hEvent = self->private_events.events[0];
1194     /* If it has a position, we won't try overlapped */
1195     seekable = SetFilePointerEx(handle,
1196                                 zero_large_offset,
1197                                 &file_position,
1198                                 FILE_CURRENT);
1199     if (seekable) {
1200         overlapped.Offset = file_position.LowPart;
1201         overlapped.OffsetHigh = file_position.HighPart;
1202     } else {
1203         overlapped.Offset = 0;
1204         overlapped.OffsetHigh = 0;
1205     }
1206     ok = ReadFile(handle,buf,count,&read_bytes, &overlapped);
1207     if (ok) {
1208         /* immediately */
1209         goto done_something;
1210     } else {
1211         errorCode = GetLastError();
1212         if (errorCode == ERROR_HANDLE_EOF ||
1213             errorCode == ERROR_BROKEN_PIPE ||
1214             errorCode == ERROR_NETNAME_DELETED) {
1215             read_bytes = 0;
1216             goto done_something;
1217         }
1218         if (errorCode!=ERROR_IO_PENDING) {
1219             /* is it some _real_ error? */
1220             errno = EIO;
1221             return -1;
1222         } else {
1223             int ret;
1224             if( (ret = WaitForMultipleObjects(2,self->private_events.events,
1225                                               FALSE,INFINITE)) != WAIT_OBJECT_0) {
1226                 CancelIo(handle);
1227                 waitInGOR = TRUE;
1228                 /* Waiting for IO only */
1229             } else {
1230                 waitInGOR = FALSE;
1231             }
1232             ok = GetOverlappedResult(handle,&overlapped,&read_bytes,waitInGOR);
1233             if (!ok) {
1234                 errorCode = GetLastError();
1235                 if (errorCode == ERROR_HANDLE_EOF ||
1236                     errorCode == ERROR_BROKEN_PIPE ||
1237                     errorCode == ERROR_NETNAME_DELETED) {
1238                     read_bytes = 0;
1239                     goto done_something;
1240                 } else {
1241                     if (errorCode == ERROR_OPERATION_ABORTED)
1242                         errno = EINTR;      /* that's it. */
1243                     else
1244                         errno = EIO;        /* something unspecific */
1245                     return -1;
1246                 }
1247             } else
1248                 goto done_something;
1249         }
1250     }
1251   done_something:
1252     if (seekable) {
1253         file_position.QuadPart += read_bytes;
1254         SetFilePointerEx(handle,file_position,NULL,FILE_BEGIN);
1255     }
1256     return read_bytes;
1257 }
1258
1259 /* This is a manually-maintained version of ldso_stubs.S. */
1260
1261 void __stdcall RtlUnwind(void *, void *, void *, void *); /* I don't have winternl.h */
1262
1263 void scratch(void)
1264 {
1265     LARGE_INTEGER la = {{0}};
1266     closesocket(0);
1267     CloseHandle(0);
1268     shutdown(0, 0);
1269     SetHandleInformation(0, 0, 0);
1270     GetHandleInformation(0, 0);
1271     getsockopt(0, 0, 0, 0, 0);
1272     FlushConsoleInputBuffer(0);
1273     FormatMessageA(0, 0, 0, 0, 0, 0, 0);
1274     FreeLibrary(0);
1275     GetACP();
1276     GetConsoleCP();
1277     GetConsoleOutputCP();
1278     GetCurrentProcess();
1279     GetExitCodeProcess(0, 0);
1280     GetLastError();
1281     GetOEMCP();
1282     GetProcAddress(0, 0);
1283     GetProcessTimes(0, 0, 0, 0, 0);
1284     GetSystemTimeAsFileTime(0);
1285     LoadLibrary(0);
1286     LocalFree(0);
1287     PeekConsoleInput(0, 0, 0, 0);
1288     PeekNamedPipe(0, 0, 0, 0, 0, 0);
1289     ReadFile(0, 0, 0, 0, 0);
1290     Sleep(0);
1291     WriteFile(0, 0, 0, 0, 0);
1292     _get_osfhandle(0);
1293     _open_osfhandle(0, 0);
1294     _rmdir(0);
1295     _pipe(0,0,0);
1296     access(0,0);
1297     close(0);
1298     dup(0);
1299     isatty(0);
1300     strerror(42);
1301     write(0, 0, 0);
1302     RtlUnwind(0, 0, 0, 0);
1303     MapViewOfFile(0,0,0,0,0);
1304     UnmapViewOfFile(0);
1305     FlushViewOfFile(0,0);
1306     SetFilePointerEx(0, la, 0, 0);
1307     #ifndef LISP_FEATURE_SB_UNICODE
1308       CreateDirectoryA(0,0);
1309       CreateFileMappingA(0,0,0,0,0,0);
1310       CreateFileA(0,0,0,0,0,0,0);
1311       GetComputerNameA(0, 0);
1312       GetCurrentDirectoryA(0,0);
1313       GetEnvironmentVariableA(0, 0, 0);
1314       GetFileAttributesA(0);
1315       GetVersionExA(0);
1316       MoveFileA(0,0);
1317       SHGetFolderPathA(0, 0, 0, 0, 0);
1318       SetCurrentDirectoryA(0);
1319       SetEnvironmentVariableA(0, 0);
1320     #else
1321       CreateDirectoryW(0,0);
1322       CreateFileMappingW(0,0,0,0,0,0);
1323       CreateFileW(0,0,0,0,0,0,0);
1324       FormatMessageW(0, 0, 0, 0, 0, 0, 0);
1325       GetComputerNameW(0, 0);
1326       GetCurrentDirectoryW(0,0);
1327       GetEnvironmentVariableW(0, 0, 0);
1328       GetFileAttributesW(0);
1329       GetVersionExW(0);
1330       MoveFileW(0,0);
1331       SHGetFolderPathW(0, 0, 0, 0, 0);
1332       SetCurrentDirectoryW(0);
1333       SetEnvironmentVariableW(0, 0);
1334     #endif
1335     _exit(0);
1336 }
1337
1338 char *
1339 os_get_runtime_executable_path(int external)
1340 {
1341     char path[MAX_PATH + 1];
1342     DWORD bufsize = sizeof(path);
1343     DWORD size;
1344
1345     if ((size = GetModuleFileNameA(NULL, path, bufsize)) == 0)
1346         return NULL;
1347     else if (size == bufsize && GetLastError() == ERROR_INSUFFICIENT_BUFFER)
1348         return NULL;
1349
1350     return copied_string(path);
1351 }
1352
1353 #ifdef LISP_FEATURE_SB_THREAD
1354
1355 int
1356 win32_wait_object_or_signal(HANDLE waitFor)
1357 {
1358     struct thread * self = arch_os_get_current_thread();
1359     HANDLE handles[2];
1360     handles[0] = waitFor;
1361     handles[1] = self->private_events.events[1];
1362     return
1363         WaitForMultipleObjects(2,handles, FALSE,INFINITE);
1364 }
1365
1366 /*
1367  * Portability glue for win32 waitable timers.
1368  *
1369  * One may ask: Why is there a wrapper in C when the calls are so
1370  * obvious that Lisp could do them directly (as it did on Windows)?
1371  *
1372  * But the answer is that on POSIX platforms, we now emulate the win32
1373  * calls and hide that emulation behind this os_* abstraction.
1374  */
1375 HANDLE
1376 os_create_wtimer()
1377 {
1378     return CreateWaitableTimer(0, 0, 0);
1379 }
1380
1381 int
1382 os_wait_for_wtimer(HANDLE handle)
1383 {
1384     return win32_wait_object_or_signal(handle);
1385 }
1386
1387 void
1388 os_close_wtimer(HANDLE handle)
1389 {
1390     CloseHandle(handle);
1391 }
1392
1393 void
1394 os_set_wtimer(HANDLE handle, int sec, int nsec)
1395 {
1396     /* in units of 100ns, i.e. 0.1us. Negative for relative semantics. */
1397     long long dueTime
1398         = -(((long long) sec) * 10000000
1399             + ((long long) nsec + 99) / 100);
1400     SetWaitableTimer(handle, (LARGE_INTEGER*) &dueTime, 0, 0, 0, 0);
1401 }
1402
1403 void
1404 os_cancel_wtimer(HANDLE handle)
1405 {
1406     CancelWaitableTimer(handle);
1407 }
1408 #endif
1409
1410 /* EOF */