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