49358a14370c9f93a9d61dd353c2f1755a7cd51c
[sbcl.git] / 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 HMODULE runtime_module_handle = 0u;
251
252 static void *get_seh_frame(void)
253 {
254     void* retval;
255 #ifdef LISP_FEATURE_X86
256     asm volatile ("mov %%fs:0,%0": "=r" (retval));
257 #else
258     asm volatile ("mov %%gs:0,%0": "=r" (retval));
259 #endif
260     return retval;
261 }
262
263 static void set_seh_frame(void *frame)
264 {
265 #ifdef LISP_FEATURE_X86
266     asm volatile ("mov %0,%%fs:0": : "r" (frame));
267 #else
268     asm volatile ("mov %0,%%gs:0": : "r" (frame));
269 #endif
270 }
271
272 #if defined(LISP_FEATURE_SB_THREAD)
273
274 void alloc_gc_page()
275 {
276     AVER(VirtualAlloc(GC_SAFEPOINT_PAGE_ADDR, sizeof(lispobj),
277                       MEM_RESERVE|MEM_COMMIT, PAGE_READWRITE));
278 }
279
280 /* Permit loads from GC_SAFEPOINT_PAGE_ADDR (NB page state change is
281  * "synchronized" with the memory region content/availability --
282  * e.g. you won't see other CPU flushing buffered writes after WP --
283  * but there is some window when other thread _seem_ to trap AFTER
284  * access is granted. You may think of it something like "OS enters
285  * SEH handler too slowly" -- what's important is there's no implicit
286  * synchronization between VirtualProtect caller and other thread's
287  * SEH handler, hence no ordering of events. VirtualProtect is
288  * implicitly synchronized with protected memory contents (only).
289  *
290  * The last fact may be potentially used with many benefits e.g. for
291  * foreign call speed, but we don't use it for now: almost the only
292  * fact relevant to the current signalling protocol is "sooner or
293  * later everyone will trap [everyone will stop trapping]".
294  *
295  * An interesting source on page-protection-based inter-thread
296  * communication is a well-known paper by Dave Dice, Hui Huang,
297  * Mingyao Yang: ``Asymmetric Dekker Synchronization''. Last time
298  * I checked it was available at
299  * http://home.comcast.net/~pjbishop/Dave/Asymmetric-Dekker-Synchronization.txt
300  */
301 void map_gc_page()
302 {
303     DWORD oldProt;
304     AVER(VirtualProtect((void*) GC_SAFEPOINT_PAGE_ADDR, sizeof(lispobj),
305                         PAGE_READWRITE, &oldProt));
306 }
307
308 void unmap_gc_page()
309 {
310     DWORD oldProt;
311     AVER(VirtualProtect((void*) GC_SAFEPOINT_PAGE_ADDR, sizeof(lispobj),
312                         PAGE_NOACCESS, &oldProt));
313 }
314
315 #endif
316
317 #if defined(LISP_FEATURE_SB_DYNAMIC_CORE)
318 /* This feature has already saved me more development time than it
319  * took to implement.  In its current state, ``dynamic RT<->core
320  * linking'' is a protocol of initialization of C runtime and Lisp
321  * core, populating SBCL linkage table with entries for runtime
322  * "foreign" symbols that were referenced in cross-compiled code.
323  *
324  * How it works: a sketch
325  *
326  * Last Genesis (resulting in cold-sbcl.core) binds foreign fixups in
327  * x-compiled lisp-objs to sequential addresses from the beginning of
328  * linkage-table space; that's how it ``resolves'' foreign references.
329  * Obviously, this process doesn't require pre-built runtime presence.
330  *
331  * When the runtime loads the core (cold-sbcl.core initially,
332  * sbcl.core later), runtime should do its part of the protocol by (1)
333  * traversing a list of ``runtime symbols'' prepared by Genesis and
334  * dumped as a static symbol value, (2) resolving each name from this
335  * list to an address (stubbing unresolved ones with
336  * undefined_alien_address or undefined_alien_function), (3) adding an
337  * entry for each symbol somewhere near the beginning of linkage table
338  * space (location is provided by the core).
339  *
340  * The implementation of the part described in the last paragraph
341  * follows. C side is currently more ``hackish'' and less clear than
342  * the Lisp code; OTOH, related Lisp changes are scattered, and some
343  * of them play part in complex interrelations -- beautiful but taking
344  * much time to understand --- but my subset of PE-i386 parser below
345  * is in one place (here) and doesn't have _any_ non-trivial coupling
346  * with the rest of the Runtime.
347  *
348  * What do we gain with this feature, after all?
349  *
350  * One things that I have to do rather frequently: recompile and
351  * replace runtime without rebuilding the core. Doubtlessly, slam.sh
352  * was a great time-saver here, but relinking ``cold'' core and bake a
353  * ``warm'' one takes, as it seems, more than 10x times of bare
354  * SBCL.EXE build time -- even if everything is recompiled, which is
355  * now unnecessary. Today, if I have a new idea for the runtime,
356  * getting from C-x C-s M-x ``compile'' to fully loaded SBCL
357  * installation takes 5-15 seconds.
358  *
359  * Another thing (that I'm not currently using, but obviously
360  * possible) is delivering software patches to remote system on
361  * customer site. As you are doing minor additions or corrections in
362  * Lisp code, it doesn't take much effort to prepare a tiny ``FASL
363  * bundle'' that rolls up your patch, redumps and -- presto -- 100MiB
364  * program is fixed by sending and loading a 50KiB thingie.
365  *
366  * However, until LISP_FEATURE_SB_DYNAMIC_CORE, if your bug were fixed
367  * by modifying two lines of _C_ sources, a customer described above
368  * had to be ready to receive and reinstall a new 100MiB
369  * executable. With the aid of code below, deploying such a fix
370  * requires only sending ~300KiB (when stripped) of SBCL.EXE.
371  *
372  * But there is more to it: as the common linkage-table is used for
373  * DLLs and core, its entries may be overridden almost without a look
374  * into SBCL internals. Therefore, ``patching'' C runtime _without_
375  * restarting target systems is also possible in many situations
376  * (it's not as trivial as loading FASLs into a running daemon, but
377  * easy enough to be a viable alternative if any downtime is highly
378  * undesirable).
379  *
380  * During my (rather limited) commercial Lisp development experience
381  * I've already been through a couple of situations where such
382  * ``deployment'' issues were important; from my _total_ programming
383  * experience I know -- _sometimes_ they are a two orders of magnitude
384  * more important than those I observed.
385  *
386  * The possibility of entire runtime ``hot-swapping'' in running
387  * process is not purely theoretical, as it could seem. There are 2-3
388  * problems whose solution is not obvious (call stack patching, for
389  * instance), but it's literally _nothing_ if compared with
390  * e.g. LISP_FEATURE_SB_AUTO_FPU_SWITCH.  By the way, one of the
391  * problems with ``hot-swapping'', that could become a major one in
392  * many other environments, is nonexistent in SBCL: we already have a
393  * ``global quiesce point'' that is generally required for this kind
394  * of worldwide revolution -- around collect_garbage.
395  *
396  * What's almost unnoticeable from the C side (where you are now, dear
397  * reader): using the same style for all linking is beautiful. I tried
398  * to leave old-style linking code in place for the sake of
399  * _non-linkage-table_ platforms (they probably don't have -ldl or its
400  * equivalent, like LL/GPA, at all) -- but i did it usually by moving
401  * the entire `old style' code under #!-sb-dynamic-core and
402  * refactoring the `new style' branch, instead of cutting the tail
403  * piecemeal and increasing #!+-ifdeffery amount & the world enthropy.
404  *
405  * If we look at the majority of the ``new style'' code units, it's a
406  * common thing to observe how #!+-ifdeffery _vanishes_ instead of
407  * multiplying: #!-sb-xc, #!+sb-xc-host and #!-sb-xc-host end up
408  * needing the same code. Runtime checks of static v. dynamic symbol
409  * disappear even faster. STDCALL mangling and leading underscores go
410  * out of scope (and GCed, hopefully) instead of surfacing here and
411  * there as a ``special case for core static symbols''. What I like
412  * the most about CL development in general is a frequency of solving
413  * problems and fixing bugs by simplifying code and dropping special
414  * cases.
415  *
416  * Last important thing about the following code: besides resolving
417  * symbols provided by the core itself, it detects runtime's own
418  * build-time prerequisite DLLs. Any symbol that is unresolved against
419  * the core is looked up in those DLLs (normally kernel32, msvcrt,
420  * ws2_32... I could forget something). This action (1) resembles
421  * implementation of foreign symbol lookup in SBCL itself, (2)
422  * emulates shared library d.l. facilities of OSes that use flat
423  * dynamic symbol namespace (or default to it). Anyone concerned with
424  * portability problems of this PE-i386 stuff below will be glad to
425  * hear that it could be ported to most modern Unices _by deletion_:
426  * raw dlsym() with null handle usually does the same thing that i'm
427  * trying to squeeze out of MS Windows by the brute force.
428  *
429  * My reason for _desiring_ flat symbol namespace, populated from
430  * link-time dependencies, is avoiding any kind of ``requested-by-Lisp
431  * symbol lists to be linked statically'', providing core v. runtime
432  * independence in both directions. Minimizing future maintenance
433  * effort is very important; I had gone for it consistently, starting
434  * by turning "CloseHandle@4" into a simple "CloseHandle", continuing
435  * by adding intermediate Genesis resulting in autogenerated symbol
436  * list (farewell, void scratch(); good riddance), going to take
437  * another great step for core/runtime independence... and _without_
438  * flat namespace emulation, the ghosts and spirits exiled at the
439  * first steps would come and take revenge: well, here are the symbols
440  * that are really in msvcrt.dll.. hmm, let's link statically against
441  * them, so the entry is pulled from the import library.. and those
442  * entry has mangled names that we have to map.. ENOUGH, I though
443  * here: fed up with stuff like that.
444  *
445  * Now here we are, without import libraries, without mangled symbols,
446  * and without nm-generated symbol tables. Every symbol exported by
447  * the runtime is added to SBCL.EXE export directory; every symbol
448  * requested by the core is looked up by GetProcAddress for SBCL.EXE,
449  * falling back to GetProcAddress for MSVCRT.dll, etc etc.. All ties
450  * between SBCL's foreign symbols with object file symbol tables,
451  * import libraries and other pre-linking symbol-resolving entities
452  * _having no representation in SBCL.EXE_ were teared.
453  *
454  * This simplistic approach proved to work well; there is only one
455  * problem introduced by it, and rather minor: in real MSVCRT.dll,
456  * what's used to be available as open() is now called _open();
457  * similar thing happened to many other `lowio' functions, though not
458  * every one, so it's not a kind of name mangling but rather someone's
459  * evil creative mind in action.
460  *
461  * When we look up any of those poor `uglified' functions in CRT
462  * reference on MSDN, we can see a notice resembling this one:
463  *
464  * `unixishname()' is obsolete and provided for backward
465  * compatibility; new standard-compliant function, `_unixishname()',
466  * should be used instead.  Sentences of that kind were there for
467  * several years, probably even for a decade or more (a propos,
468  * MSVCRT.dll, as the name to link against, predates year 2000, so
469  * it's actually possible). Reasoning behing it (what MS people had in
470  * mind) always seemed strange to me: if everyone uses open() and that
471  * `everyone' is important to you, why rename the function?  If no one
472  * uses open(), why provide or retain _open() at all? <kidding>After
473  * all, names like _open() are entirely non-informative and just plain
474  * ugly; compare that with CreateFileW() or InitCommonControlsEx(),
475  * the real examples of beauty and clarity.</kidding>
476  *
477  * Anyway, if the /standard/ name on Windows is _open() (I start to
478  * recall, vaguely, that it's because of _underscore names being
479  * `reserved to system' and all other ones `available for user', per
480  * ANSI/ISO C89) -- well, if the /standard/ name is _open, SBCL should
481  * use it when it uses MSVCRT and not some ``backward-compatible''
482  * stuff. Deciding this way, I added a hack to SBCL's syscall macros,
483  * so "[_]open" as a syscall name is interpreted as a request to link
484  * agains "_open" on win32 and "open" on every other system.
485  *
486  * Of course, this name-parsing trick lacks conceptual clarity; we're
487  * going to get rid of it eventually. */
488
489 u32 os_get_build_time_shared_libraries(u32 excl_maximum,
490                                        void* opt_root,
491                                        void** opt_store_handles,
492                                        const char *opt_store_names[])
493 {
494     void* base = opt_root ? opt_root : (void*)runtime_module_handle;
495     /* base defaults to 0x400000 with GCC/mingw32. If you dereference
496      * that location, you'll see 'MZ' bytes */
497     void* base_magic_location =
498         base + ((IMAGE_DOS_HEADER*)base)->e_lfanew;
499
500     /* dos header provided the offset from `base' to
501      * IMAGE_FILE_HEADER where PE-i386 really starts */
502
503     void* check_duplicates[excl_maximum];
504
505     if ((*(u32*)base_magic_location)!=0x4550) {
506         /* We don't need this DLL thingie _that_ much. If the world
507          * has changed to a degree where PE magic isn't found, let's
508          * silently return `no libraries detected'. */
509         return 0;
510     } else {
511         /* We traverse PE-i386 structures of SBCL.EXE in memory (not
512          * in the file). File and memory layout _surely_ differ in
513          * some places and _may_ differ in some other places, but
514          * fortunately, those places are irrelevant to the task at
515          * hand. */
516
517         IMAGE_FILE_HEADER* image_file_header = (base_magic_location + 4);
518         IMAGE_OPTIONAL_HEADER* image_optional_header =
519             (void*)(image_file_header + 1);
520         IMAGE_DATA_DIRECTORY* image_import_direntry =
521             &image_optional_header->DataDirectory[IMAGE_DIRECTORY_ENTRY_IMPORT];
522         IMAGE_IMPORT_DESCRIPTOR* image_import_descriptor =
523             base + image_import_direntry->VirtualAddress;
524         u32 nlibrary, i,j;
525
526         for (nlibrary=0u; nlibrary < excl_maximum
527                           && image_import_descriptor->FirstThunk;
528              ++image_import_descriptor)
529         {
530             HMODULE hmodule;
531             odxprint(runtime_link, "Now should know DLL: %s",
532                      (char*)(base + image_import_descriptor->Name));
533             /* Code using image thunk data to get its handle was here, with a
534              * number of platform-specific tricks (like using VirtualQuery for
535              * old OSes lacking GetModuleHandleEx).
536              *
537              * It's now replaced with requesting handle by name, which is
538              * theoretically unreliable (with SxS, multiple modules with same
539              * name are quite possible), but good enough to find the
540              * link-time dependencies of our executable or DLL. */
541
542             hmodule = (HMODULE)
543                 GetModuleHandle(base + image_import_descriptor->Name);
544
545             if (hmodule)
546             {
547                 /* We may encouncer some module more than once while
548                    traversing import descriptors (it's usually a
549                    result of non-trivial linking process, like doing
550                    ld -r on some groups of files before linking
551                    everything together.
552
553                    Anyway: using a module handle more than once will
554                    do no harm, but it slows down the startup (even
555                    now, our startup time is not a pleasant topic to
556                    discuss when it comes to :sb-dynamic-core; there is
557                    an obvious direction to go for speed, though --
558                    instead of resolving symbols one-by-one, locate PE
559                    export directories -- they are sorted by symbol
560                    name -- and merge them, at one pass, with sorted
561                    list of required symbols (the best time to sort the
562                    latter list is during Genesis -- that's why I don't
563                    proceed with memory copying, qsort() and merge
564                    right here)). */
565
566                 for (j=0; j<nlibrary; ++j)
567                 {
568                     if(check_duplicates[j] == hmodule)
569                         break;
570                 }
571                 if (j<nlibrary) continue; /* duplicate => skip it in
572                                            * outer loop */
573
574                 check_duplicates[nlibrary] = hmodule;
575                 if (opt_store_handles) {
576                     opt_store_handles[nlibrary] = hmodule;
577                 }
578                 if (opt_store_names) {
579                     opt_store_names[nlibrary] = (const char *)
580                         (base + image_import_descriptor->Name);
581                 }
582                 odxprint(runtime_link, "DLL detection: %u, base %p: %s",
583                          nlibrary, hmodule,
584                          (char*)(base + image_import_descriptor->Name));
585                 ++ nlibrary;
586             }
587         }
588         return nlibrary;
589     }
590 }
591
592 static u32 buildTimeImageCount = 0;
593 static void* buildTimeImages[16];
594
595 /* Resolve symbols against the executable and its build-time dependencies */
596 void* os_dlsym_default(char* name)
597 {
598     unsigned int i;
599     void* result = 0;
600     if (buildTimeImageCount == 0) {
601         buildTimeImageCount =
602             1 + os_get_build_time_shared_libraries(15u,
603             NULL, 1+(void**)buildTimeImages, NULL);
604     }
605     for (i = 0; i<buildTimeImageCount && (!result); ++i) {
606         result = GetProcAddress(buildTimeImages[i], name);
607     }
608     return result;
609 }
610
611 #endif /* SB_DYNAMIC_CORE */
612
613 #if defined(LISP_FEATURE_SB_THREAD)
614 /* We want to get a slot in TIB that (1) is available at constant
615    offset, (2) is our private property, so libraries wouldn't legally
616    override it, (3) contains something predefined for threads created
617    out of our sight.
618
619    Low 64 TLS slots are adressable directly, starting with
620    FS:[#xE10]. When SBCL runtime is initialized, some of the low slots
621    may be already in use by its prerequisite DLLs, as DllMain()s and
622    TLS callbacks have been called already. But slot 63 is unlikely to
623    be reached at this point: one slot per DLL that needs it is the
624    common practice, and many system DLLs use predefined TIB-based
625    areas outside conventional TLS storage and don't need TLS slots.
626    With our current dependencies, even slot 2 is observed to be free
627    (as of WinXP and wine).
628
629    Now we'll call TlsAlloc() repeatedly until slot 63 is officially
630    assigned to us, then TlsFree() all other slots for normal use. TLS
631    slot 63, alias FS:[#.(+ #xE10 (* 4 63))], now belongs to us.
632
633    To summarize, let's list the assumptions we make:
634
635    - TIB, which is FS segment base, contains first 64 TLS slots at the
636    offset #xE10 (i.e. TIB layout compatibility);
637    - TLS slots are allocated from lower to higher ones;
638    - All libraries together with CRT startup have not requested 64
639    slots yet.
640
641    All these assumptions together don't seem to be less warranted than
642    the availability of TIB arbitrary data slot for our use. There are
643    some more reasons to prefer slot 63 over TIB arbitrary data: (1) if
644    our assumptions for slot 63 are violated, it will be detected at
645    startup instead of causing some system-specific unreproducible
646    problems afterwards, depending on OS and loaded foreign libraries;
647    (2) if getting slot 63 reliably with our current approach will
648    become impossible for some future Windows version, we can add TLS
649    callback directory to SBCL binary; main image TLS callback is
650    started before _any_ TLS slot is allocated by libraries, and
651    some C compiler vendors rely on this fact. */
652
653 void os_preinit()
654 {
655 #ifdef LISP_FEATURE_X86
656     DWORD slots[TLS_MINIMUM_AVAILABLE];
657     DWORD key;
658     int n_slots = 0, i;
659     for (i=0; i<TLS_MINIMUM_AVAILABLE; ++i) {
660         key = TlsAlloc();
661         if (key == OUR_TLS_INDEX) {
662             if (TlsGetValue(key)!=NULL)
663                 lose("TLS slot assertion failed: fresh slot value is not NULL");
664             TlsSetValue(OUR_TLS_INDEX, (void*)(intptr_t)0xFEEDBAC4);
665             if ((intptr_t)(void*)arch_os_get_current_thread()!=(intptr_t)0xFEEDBAC4)
666                 lose("TLS slot assertion failed: TIB layout change detected");
667             TlsSetValue(OUR_TLS_INDEX, NULL);
668             break;
669         }
670         slots[n_slots++]=key;
671     }
672     for (i=0; i<n_slots; ++i) {
673         TlsFree(slots[i]);
674     }
675     if (key!=OUR_TLS_INDEX) {
676         lose("TLS slot assertion failed: slot 63 is unavailable "
677              "(last TlsAlloc() returned %u)",key);
678     }
679 #endif
680 }
681 #endif  /* LISP_FEATURE_SB_THREAD */
682
683
684 #ifdef LISP_FEATURE_X86_64
685 /* Windows has 32-bit 'longs', so printf...%lX (and other %l patterns) doesn't
686  * work well with address-sized values, like it's done all over the place in
687  * SBCL. And msvcrt uses I64, not LL, for printing long longs.
688  *
689  * I've already had enough search/replace with longs/words/intptr_t for today,
690  * so I prefer to solve this problem with a format string translator. */
691
692 /* There is (will be) defines for printf and friends. */
693
694 static int translating_vfprintf(FILE*stream, const char *fmt, va_list args)
695 {
696     char translated[1024];
697     int i=0, delta = 0;
698
699     while (fmt[i-delta] && i<sizeof(translated)-1) {
700         if((fmt[i-delta]=='%')&&
701            (fmt[i-delta+1]=='l')) {
702             translated[i++]='%';
703             translated[i++]='I';
704             translated[i++]='6';
705             translated[i++]='4';
706             delta += 2;
707         } else {
708             translated[i]=fmt[i-delta];
709             ++i;
710         }
711     }
712     translated[i++]=0;
713     return vfprintf(stream,translated,args);
714 }
715
716 int printf(const char*fmt,...)
717 {
718     va_list args;
719     va_start(args,fmt);
720     return translating_vfprintf(stdout,fmt,args);
721 }
722 int fprintf(FILE*stream,const char*fmt,...)
723 {
724     va_list args;
725     va_start(args,fmt);
726     return translating_vfprintf(stream,fmt,args);
727 }
728
729 #endif
730
731 int os_number_of_processors = 1;
732
733 BOOL WINAPI CancelIoEx(HANDLE handle, LPOVERLAPPED overlapped);
734 typeof(CancelIoEx) *ptr_CancelIoEx;
735 BOOL WINAPI CancelSynchronousIo(HANDLE threadHandle);
736 typeof(CancelSynchronousIo) *ptr_CancelSynchronousIo;
737
738 #define RESOLVE(hmodule,fn)                     \
739     do {                                        \
740         ptr_##fn = (typeof(ptr_##fn))           \
741             GetProcAddress(hmodule,#fn);        \
742     } while (0)
743
744 static void resolve_optional_imports()
745 {
746     HMODULE kernel32 = GetModuleHandleA("kernel32");
747     if (kernel32) {
748         RESOLVE(kernel32,CancelIoEx);
749         RESOLVE(kernel32,CancelSynchronousIo);
750     }
751 }
752
753 #undef RESOLVE
754
755 intptr_t win32_get_module_handle_by_address(os_vm_address_t addr)
756 {
757     HMODULE result = 0;
758     /* So apparently we could use VirtualQuery instead of
759      * GetModuleHandleEx if we wanted to support pre-XP, pre-2003
760      * versions of Windows (i.e. Windows 2000).  I've opted against such
761      * special-casing. :-).  --DFL */
762     return (intptr_t)(GetModuleHandleEx(
763                           GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS |
764                           GET_MODULE_HANDLE_EX_FLAG_UNCHANGED_REFCOUNT,
765                           (LPCSTR)addr, &result)
766                       ? result : 0);
767 }
768
769 void os_init(char *argv[], char *envp[])
770 {
771     SYSTEM_INFO system_info;
772     GetSystemInfo(&system_info);
773     os_vm_page_size = system_info.dwPageSize > BACKEND_PAGE_BYTES?
774         system_info.dwPageSize : BACKEND_PAGE_BYTES;
775 #if defined(LISP_FEATURE_X86)
776     fast_bzero_pointer = fast_bzero_detect;
777 #endif
778     os_number_of_processors = system_info.dwNumberOfProcessors;
779
780     base_seh_frame = get_seh_frame();
781
782     resolve_optional_imports();
783     runtime_module_handle = (HMODULE)win32_get_module_handle_by_address(&runtime_module_handle);
784 }
785
786 static inline boolean local_thread_stack_address_p(os_vm_address_t address)
787 {
788     return this_thread &&
789         (((((u64)address >= (u64)this_thread->os_address) &&
790            ((u64)address < ((u64)this_thread)-THREAD_CSP_PAGE_SIZE))||
791           (((u64)address >= (u64)this_thread->control_stack_start)&&
792            ((u64)address < (u64)this_thread->control_stack_end))));
793 }
794
795 /*
796  * So we have three fun scenarios here.
797  *
798  * First, we could be being called to reserve the memory areas
799  * during initialization (prior to loading the core file).
800  *
801  * Second, we could be being called by the GC to commit a page
802  * that has just been decommitted (for easy zero-fill).
803  *
804  * Third, we could be being called by create_thread_struct()
805  * in order to create the sundry and various stacks.
806  *
807  * The third case is easy to pick out because it passes an
808  * addr of 0.
809  *
810  * The second case is easy to pick out because it will be for
811  * a range of memory that is MEM_RESERVE rather than MEM_FREE.
812  *
813  * The second case is also an easy implement, because we leave
814  * the memory as reserved (since we do lazy commits).
815  */
816
817 os_vm_address_t
818 os_validate(os_vm_address_t addr, os_vm_size_t len)
819 {
820     MEMORY_BASIC_INFORMATION mem_info;
821
822     if (!addr) {
823         /* the simple case first */
824         return
825             AVERLAX(VirtualAlloc(addr, len, MEM_RESERVE|MEM_COMMIT, PAGE_EXECUTE_READWRITE));
826     }
827
828     if (!AVERLAX(VirtualQuery(addr, &mem_info, sizeof mem_info)))
829         return 0;
830
831     if ((mem_info.State == MEM_RESERVE) && (mem_info.RegionSize >=len)) {
832       /* It would be correct to return here. However, support for Wine
833        * is beneficial, and Wine has a strange behavior in this
834        * department. It reports all memory below KERNEL32.DLL as
835        * reserved, but disallows MEM_COMMIT.
836        *
837        * Let's work around it: reserve the region we need for a second
838        * time. The second reservation is documented to fail on normal NT
839        * family, but it will succeed on Wine if this region is
840        * actually free.
841        */
842       VirtualAlloc(addr, len, MEM_RESERVE, PAGE_EXECUTE_READWRITE);
843       /* If it is wine, the second call has succeded, and now the region
844        * is really reserved. */
845       return addr;
846     }
847
848     if (mem_info.State == MEM_RESERVE) {
849         fprintf(stderr, "validation of reserved space too short.\n");
850         fflush(stderr);
851         /* Oddly, we do not treat this assertion as fatal; hence also the
852          * provision for MEM_RESERVE in the following code, I suppose: */
853     }
854
855     if (!AVERLAX(VirtualAlloc(addr, len, (mem_info.State == MEM_RESERVE)?
856                               MEM_COMMIT: MEM_RESERVE, PAGE_EXECUTE_READWRITE)))
857         return 0;
858
859     return addr;
860 }
861
862 /*
863  * For os_invalidate(), we merely decommit the memory rather than
864  * freeing the address space. This loses when freeing per-thread
865  * data and related memory since it leaks address space.
866  *
867  * So far the original comment (author unknown).  It used to continue as
868  * follows:
869  *
870  *   It's not too lossy, however, since the two scenarios I'm aware of
871  *   are fd-stream buffers, which are pooled rather than torched, and
872  *   thread information, which I hope to pool (since windows creates
873  *   threads at its own whim, and we probably want to be able to have
874  *   them callback without funky magic on the part of the user, and
875  *   full-on thread allocation is fairly heavyweight).
876  *
877  * But: As it turns out, we are no longer content with decommitting
878  * without freeing, and have now grown a second function
879  * os_invalidate_free(), sort of a really_os_invalidate().
880  *
881  * As discussed on #lisp, this is not a satisfactory solution, and probably
882  * ought to be rectified in the following way:
883  *
884  *  - Any cases currently going through the non-freeing version of
885  *    os_invalidate() are ultimately meant for zero-filling applications.
886  *    Replace those use cases with an os_revalidate_bzero() or similarly
887  *    named function, which explicitly takes care of that aspect of
888  *    the semantics.
889  *
890  *  - The remaining uses of os_invalidate should actually free, and once
891  *    the above is implemented, we can rename os_invalidate_free back to
892  *    just os_invalidate().
893  *
894  * So far the new plan, as yet unimplemented. -- DFL
895  */
896
897 void
898 os_invalidate(os_vm_address_t addr, os_vm_size_t len)
899 {
900     AVERLAX(VirtualFree(addr, len, MEM_DECOMMIT));
901 }
902
903 void
904 os_invalidate_free(os_vm_address_t addr, os_vm_size_t len)
905 {
906     AVERLAX(VirtualFree(addr, 0, MEM_RELEASE));
907 }
908
909 void
910 os_invalidate_free_by_any_address(os_vm_address_t addr, os_vm_size_t len)
911 {
912     MEMORY_BASIC_INFORMATION minfo;
913     AVERLAX(VirtualQuery(addr, &minfo, sizeof minfo));
914     AVERLAX(minfo.AllocationBase);
915     AVERLAX(VirtualFree(minfo.AllocationBase, 0, MEM_RELEASE));
916 }
917
918 /* os_validate doesn't commit, i.e. doesn't actually "validate" in the
919  * sense that we could start using the space afterwards.  Usually it's
920  * os_map or Lisp code that will run into that, in which case we recommit
921  * elsewhere in this file.  For cases where C wants to write into newly
922  * os_validate()d memory, it needs to commit it explicitly first:
923  */
924 os_vm_address_t
925 os_validate_recommit(os_vm_address_t addr, os_vm_size_t len)
926 {
927     return
928         AVERLAX(VirtualAlloc(addr, len, MEM_COMMIT, PAGE_EXECUTE_READWRITE));
929 }
930
931 /*
932  * os_map() is called to map a chunk of the core file into memory.
933  *
934  * Unfortunately, Windows semantics completely screws this up, so
935  * we just add backing store from the swapfile to where the chunk
936  * goes and read it up like a normal file. We could consider using
937  * a lazy read (demand page) setup, but that would mean keeping an
938  * open file pointer for the core indefinately (and be one more
939  * thing to maintain).
940  */
941
942 os_vm_address_t
943 os_map(int fd, int offset, os_vm_address_t addr, os_vm_size_t len)
944 {
945     os_vm_size_t count;
946
947     AVER(VirtualAlloc(addr, len, MEM_COMMIT, PAGE_EXECUTE_READWRITE)||
948          VirtualAlloc(addr, len, MEM_RESERVE|MEM_COMMIT,
949                       PAGE_EXECUTE_READWRITE));
950
951     CRT_AVER_NONNEGATIVE(lseek(fd, offset, SEEK_SET));
952
953     count = read(fd, addr, len);
954     CRT_AVER( count == len );
955
956     return addr;
957 }
958
959 static DWORD os_protect_modes[8] = {
960     PAGE_NOACCESS,
961     PAGE_READONLY,
962     PAGE_READWRITE,
963     PAGE_READWRITE,
964     PAGE_EXECUTE,
965     PAGE_EXECUTE_READ,
966     PAGE_EXECUTE_READWRITE,
967     PAGE_EXECUTE_READWRITE,
968 };
969
970 void
971 os_protect(os_vm_address_t address, os_vm_size_t length, os_vm_prot_t prot)
972 {
973     DWORD old_prot;
974
975     DWORD new_prot = os_protect_modes[prot];
976     AVER(VirtualProtect(address, length, new_prot, &old_prot)||
977          (VirtualAlloc(address, length, MEM_COMMIT, new_prot) &&
978           VirtualProtect(address, length, new_prot, &old_prot)));
979     odxprint(misc,"Protecting %p + %p vmaccess %d "
980              "newprot %08x oldprot %08x",
981              address,length,prot,new_prot,old_prot);
982 }
983
984 /* FIXME: Now that FOO_END, rather than FOO_SIZE, is the fundamental
985  * description of a space, we could probably punt this and just do
986  * (FOO_START <= x && x < FOO_END) everywhere it's called. */
987 static boolean
988 in_range_p(os_vm_address_t a, lispobj sbeg, size_t slen)
989 {
990     char* beg = (char*)((uword_t)sbeg);
991     char* end = (char*)((uword_t)sbeg) + slen;
992     char* adr = (char*)a;
993     return (adr >= beg && adr < end);
994 }
995
996 boolean
997 is_linkage_table_addr(os_vm_address_t addr)
998 {
999     return in_range_p(addr, LINKAGE_TABLE_SPACE_START, LINKAGE_TABLE_SPACE_END);
1000 }
1001
1002 static boolean is_some_thread_local_addr(os_vm_address_t addr);
1003
1004 boolean
1005 is_valid_lisp_addr(os_vm_address_t addr)
1006 {
1007     if(in_range_p(addr, READ_ONLY_SPACE_START, READ_ONLY_SPACE_SIZE) ||
1008        in_range_p(addr, STATIC_SPACE_START   , STATIC_SPACE_SIZE) ||
1009        in_range_p(addr, DYNAMIC_SPACE_START  , dynamic_space_size) ||
1010        is_some_thread_local_addr(addr))
1011         return 1;
1012     return 0;
1013 }
1014
1015 /* test if an address is within thread-local space */
1016 static boolean
1017 is_thread_local_addr(struct thread* th, os_vm_address_t addr)
1018 {
1019     /* Assuming that this is correct, it would warrant further comment,
1020      * I think.  Based on what our call site is doing, we have been
1021      * tasked to check for the address of a lisp object; not merely any
1022      * foreign address within the thread's area.  Indeed, this used to
1023      * be a check for control and binding stack only, rather than the
1024      * full thread "struct".  So shouldn't the THREAD_STRUCT_SIZE rather
1025      * be (thread_control_stack_size+BINDING_STACK_SIZE) instead?  That
1026      * would also do away with the LISP_FEATURE_SB_THREAD case.  Or does
1027      * it simply not matter?  --DFL */
1028     ptrdiff_t diff = ((char*)th->os_address)-(char*)addr;
1029     return diff > (ptrdiff_t)0 && diff < (ptrdiff_t)THREAD_STRUCT_SIZE
1030 #ifdef LISP_FEATURE_SB_THREAD
1031         && addr != (os_vm_address_t) th->csp_around_foreign_call
1032 #endif
1033         ;
1034 }
1035
1036 static boolean
1037 is_some_thread_local_addr(os_vm_address_t addr)
1038 {
1039     boolean result = 0;
1040 #ifdef LISP_FEATURE_SB_THREAD
1041     struct thread *th;
1042     pthread_mutex_lock(&all_threads_lock);
1043     for_each_thread(th) {
1044         if(is_thread_local_addr(th,addr)) {
1045             result = 1;
1046             break;
1047         }
1048     }
1049     pthread_mutex_unlock(&all_threads_lock);
1050 #endif
1051     return result;
1052 }
1053
1054
1055 /* A tiny bit of interrupt.c state we want our paws on. */
1056 extern boolean internal_errors_enabled;
1057
1058 extern void exception_handler_wrapper();
1059
1060 void
1061 c_level_backtrace(const char* header, int depth)
1062 {
1063     void* frame;
1064     int n = 0;
1065     void** lastseh;
1066
1067     for (lastseh = get_seh_frame(); lastseh && (lastseh!=(void*)-1);
1068          lastseh = *lastseh);
1069
1070     fprintf(stderr, "Backtrace: %s (thread %p)\n", header, this_thread);
1071     for (frame = __builtin_frame_address(0); frame; frame=*(void**)frame)
1072     {
1073         if ((n++)>depth)
1074             return;
1075         fprintf(stderr, "[#%02d]: ebp = 0x%p, ret = 0x%p\n",n,
1076                 frame, ((void**)frame)[1]);
1077     }
1078 }
1079
1080 #ifdef LISP_FEATURE_X86
1081 #define voidreg(ctxptr,name) ((void*)((ctxptr)->E##name))
1082 #else
1083 #define voidreg(ctxptr,name) ((void*)((ctxptr)->R##name))
1084 #endif
1085
1086
1087 static int
1088 handle_single_step(os_context_t *ctx)
1089 {
1090     if (!single_stepping)
1091         return -1;
1092
1093     /* We are doing a displaced instruction. At least function
1094      * end breakpoints use this. */
1095     restore_breakpoint_from_single_step(ctx);
1096
1097     return 0;
1098 }
1099
1100 #ifdef LISP_FEATURE_UD2_BREAKPOINTS
1101 #define SBCL_EXCEPTION_BREAKPOINT EXCEPTION_ILLEGAL_INSTRUCTION
1102 #define TRAP_CODE_WIDTH 2
1103 #else
1104 #define SBCL_EXCEPTION_BREAKPOINT EXCEPTION_BREAKPOINT
1105 #define TRAP_CODE_WIDTH 1
1106 #endif
1107
1108 static int
1109 handle_breakpoint_trap(os_context_t *ctx, struct thread* self)
1110 {
1111 #ifdef LISP_FEATURE_UD2_BREAKPOINTS
1112     if (((unsigned short *)*os_context_pc_addr(ctx))[0] != 0x0b0f)
1113         return -1;
1114 #endif
1115
1116     /* Unlike some other operating systems, Win32 leaves EIP
1117      * pointing to the breakpoint instruction. */
1118     (*os_context_pc_addr(ctx)) += TRAP_CODE_WIDTH;
1119
1120     /* Now EIP points just after the INT3 byte and aims at the
1121      * 'kind' value (eg trap_Cerror). */
1122     unsigned trap = *(unsigned char *)(*os_context_pc_addr(ctx));
1123
1124 #ifdef LISP_FEATURE_SB_THREAD
1125     /* Before any other trap handler: gc_safepoint ensures that
1126        inner alloc_sap for passing the context won't trap on
1127        pseudo-atomic. */
1128     if (trap == trap_PendingInterrupt) {
1129         /* Done everything needed for this trap, except EIP
1130            adjustment */
1131         arch_skip_instruction(ctx);
1132         thread_interrupted(ctx);
1133         return 0;
1134     }
1135 #endif
1136
1137     /* This is just for info in case the monitor wants to print an
1138      * approximation. */
1139     access_control_stack_pointer(self) =
1140         (lispobj *)*os_context_sp_addr(ctx);
1141
1142     WITH_GC_AT_SAFEPOINTS_ONLY() {
1143 #if defined(LISP_FEATURE_SB_THREAD)
1144         block_blockable_signals(0,&ctx->sigmask);
1145 #endif
1146         handle_trap(ctx, trap);
1147 #if defined(LISP_FEATURE_SB_THREAD)
1148         thread_sigmask(SIG_SETMASK,&ctx->sigmask,NULL);
1149 #endif
1150     }
1151
1152     /* Done, we're good to go! */
1153     return 0;
1154 }
1155
1156 static int
1157 handle_access_violation(os_context_t *ctx,
1158                         EXCEPTION_RECORD *exception_record,
1159                         void *fault_address,
1160                         struct thread* self)
1161 {
1162     CONTEXT *win32_context = ctx->win32_context;
1163
1164 #if defined(LISP_FEATURE_X86)
1165     odxprint(pagefaults,
1166              "SEGV. ThSap %p, Eip %p, Esp %p, Esi %p, Edi %p, "
1167              "Addr %p Access %d\n",
1168              self,
1169              win32_context->Eip,
1170              win32_context->Esp,
1171              win32_context->Esi,
1172              win32_context->Edi,
1173              fault_address,
1174              exception_record->ExceptionInformation[0]);
1175 #else
1176     odxprint(pagefaults,
1177              "SEGV. ThSap %p, Eip %p, Esp %p, Esi %p, Edi %p, "
1178              "Addr %p Access %d\n",
1179              self,
1180              win32_context->Rip,
1181              win32_context->Rsp,
1182              win32_context->Rsi,
1183              win32_context->Rdi,
1184              fault_address,
1185              exception_record->ExceptionInformation[0]);
1186 #endif
1187
1188     /* Stack: This case takes care of our various stack exhaustion
1189      * protect pages (with the notable exception of the control stack!). */
1190     if (self && local_thread_stack_address_p(fault_address)) {
1191         if (handle_guard_page_triggered(ctx, fault_address))
1192             return 0; /* gc safety? */
1193         goto try_recommit;
1194     }
1195
1196     /* Safepoint pages */
1197 #ifdef LISP_FEATURE_SB_THREAD
1198     if (fault_address == (void *) GC_SAFEPOINT_PAGE_ADDR) {
1199         thread_in_lisp_raised(ctx);
1200         return 0;
1201     }
1202
1203     if ((((u64)fault_address) == ((u64)self->csp_around_foreign_call))){
1204         thread_in_safety_transition(ctx);
1205         return 0;
1206     }
1207 #endif
1208
1209     /* dynamic space */
1210     page_index_t index = find_page_index(fault_address);
1211     if (index != -1) {
1212         /*
1213          * Now, if the page is supposedly write-protected and this
1214          * is a write, tell the gc that it's been hit.
1215          */
1216         if (page_table[index].write_protected) {
1217             gencgc_handle_wp_violation(fault_address);
1218         } else {
1219             AVER(VirtualAlloc(PTR_ALIGN_DOWN(fault_address,os_vm_page_size),
1220                               os_vm_page_size,
1221                               MEM_COMMIT, PAGE_EXECUTE_READWRITE));
1222         }
1223         return 0;
1224     }
1225
1226     if (fault_address == undefined_alien_address)
1227         return -1;
1228
1229     /* linkage table or a "valid_lisp_addr" outside of dynamic space (?) */
1230     if (is_linkage_table_addr(fault_address)
1231         || is_valid_lisp_addr(fault_address))
1232         goto try_recommit;
1233
1234     return -1;
1235
1236 try_recommit:
1237     /* First use of a new page, lets get some memory for it. */
1238
1239 #if defined(LISP_FEATURE_X86)
1240     AVER(VirtualAlloc(PTR_ALIGN_DOWN(fault_address,os_vm_page_size),
1241                       os_vm_page_size,
1242                       MEM_COMMIT, PAGE_EXECUTE_READWRITE)
1243          ||(fprintf(stderr,"Unable to recommit addr %p eip 0x%08lx\n",
1244                     fault_address, win32_context->Eip) &&
1245             (c_level_backtrace("BT",5),
1246              fake_foreign_function_call(ctx),
1247              lose("Lispy backtrace"),
1248              0)));
1249 #else
1250     AVER(VirtualAlloc(PTR_ALIGN_DOWN(fault_address,os_vm_page_size),
1251                       os_vm_page_size,
1252                       MEM_COMMIT, PAGE_EXECUTE_READWRITE)
1253          ||(fprintf(stderr,"Unable to recommit addr %p eip 0x%p\n",
1254                     fault_address, (void*)win32_context->Rip) &&
1255             (c_level_backtrace("BT",5),
1256              fake_foreign_function_call(ctx),
1257              lose("Lispy backtrace"),
1258              0)));
1259 #endif
1260
1261     return 0;
1262 }
1263
1264 static void
1265 signal_internal_error_or_lose(os_context_t *ctx,
1266                               EXCEPTION_RECORD *exception_record,
1267                               void *fault_address)
1268 {
1269     /*
1270      * If we fall through to here then we need to either forward
1271      * the exception to the lisp-side exception handler if it's
1272      * set up, or drop to LDB.
1273      */
1274
1275     if (internal_errors_enabled) {
1276         lispobj context_sap;
1277         lispobj exception_record_sap;
1278
1279         asm("fnclex");
1280         /* We're making the somewhat arbitrary decision that having
1281          * internal errors enabled means that lisp has sufficient
1282          * marbles to be able to handle exceptions, but exceptions
1283          * aren't supposed to happen during cold init or reinit
1284          * anyway. */
1285
1286 #if defined(LISP_FEATURE_SB_THREAD)
1287         block_blockable_signals(0,&ctx->sigmask);
1288 #endif
1289         fake_foreign_function_call(ctx);
1290
1291         WITH_GC_AT_SAFEPOINTS_ONLY() {
1292             /* Allocate the SAP objects while the "interrupts" are still
1293              * disabled. */
1294             context_sap = alloc_sap(ctx);
1295             exception_record_sap = alloc_sap(exception_record);
1296 #if defined(LISP_FEATURE_SB_THREAD)
1297             thread_sigmask(SIG_SETMASK, &ctx->sigmask, NULL);
1298 #endif
1299
1300             /* The exception system doesn't automatically clear pending
1301              * exceptions, so we lose as soon as we execute any FP
1302              * instruction unless we do this first. */
1303             /* Call into lisp to handle things. */
1304             funcall2(StaticSymbolFunction(HANDLE_WIN32_EXCEPTION),
1305                      context_sap,
1306                      exception_record_sap);
1307         }
1308         /* If Lisp doesn't nlx, we need to put things back. */
1309         undo_fake_foreign_function_call(ctx);
1310 #if defined(LISP_FEATURE_SB_THREAD)
1311         thread_sigmask(SIG_SETMASK, &ctx->sigmask, NULL);
1312 #endif
1313         /* FIXME: HANDLE-WIN32-EXCEPTION should be allowed to decline */
1314         return;
1315     }
1316
1317     fprintf(stderr, "Exception Code: 0x%p.\n",
1318             (void*)(intptr_t)exception_record->ExceptionCode);
1319     fprintf(stderr, "Faulting IP: 0x%p.\n",
1320             (void*)(intptr_t)exception_record->ExceptionAddress);
1321     if (exception_record->ExceptionCode == EXCEPTION_ACCESS_VIOLATION) {
1322         MEMORY_BASIC_INFORMATION mem_info;
1323
1324         if (VirtualQuery(fault_address, &mem_info, sizeof mem_info)) {
1325             fprintf(stderr, "page status: 0x%lx.\n", mem_info.State);
1326         }
1327
1328         fprintf(stderr, "Was writing: %p, where: 0x%p.\n",
1329                 (void*)exception_record->ExceptionInformation[0],
1330                 fault_address);
1331     }
1332
1333     fflush(stderr);
1334
1335     fake_foreign_function_call(ctx);
1336     lose("Exception too early in cold init, cannot continue.");
1337 }
1338
1339 /*
1340  * A good explanation of the exception handling semantics is
1341  *   http://win32assembly.online.fr/Exceptionhandling.html (possibly defunct)
1342  * or:
1343  *   http://www.microsoft.com/msj/0197/exception/exception.aspx
1344  */
1345
1346 EXCEPTION_DISPOSITION
1347 handle_exception(EXCEPTION_RECORD *exception_record,
1348                  struct lisp_exception_frame *exception_frame,
1349                  CONTEXT *win32_context,
1350                  void *dispatcher_context)
1351 {
1352     if (!win32_context)
1353         /* Not certain why this should be possible, but let's be safe... */
1354         return ExceptionContinueSearch;
1355
1356     if (exception_record->ExceptionFlags & (EH_UNWINDING | EH_EXIT_UNWIND)) {
1357         /* If we're being unwound, be graceful about it. */
1358
1359         /* Undo any dynamic bindings. */
1360         unbind_to_here(exception_frame->bindstack_pointer,
1361                        arch_os_get_current_thread());
1362         return ExceptionContinueSearch;
1363     }
1364
1365     DWORD lastError = GetLastError();
1366     DWORD lastErrno = errno;
1367     DWORD code = exception_record->ExceptionCode;
1368     struct thread* self = arch_os_get_current_thread();
1369
1370     os_context_t context, *ctx = &context;
1371     context.win32_context = win32_context;
1372 #if defined(LISP_FEATURE_SB_THREAD)
1373     context.sigmask = self ? self->os_thread->blocked_signal_set : 0;
1374 #endif
1375
1376     os_context_register_t oldbp = NULL;
1377     if (self) {
1378         oldbp = self ? self->carried_base_pointer : 0;
1379         self->carried_base_pointer
1380             = (os_context_register_t) voidreg(win32_context, bp);
1381     }
1382
1383     /* For EXCEPTION_ACCESS_VIOLATION only. */
1384     void *fault_address = (void *)exception_record->ExceptionInformation[1];
1385
1386     odxprint(seh,
1387              "SEH: rec %p, ctxptr %p, rip %p, fault %p\n"
1388              "... code %p, rcx %p, fp-tags %p\n\n",
1389              exception_record,
1390              win32_context,
1391              voidreg(win32_context,ip),
1392              fault_address,
1393              (void*)(intptr_t)code,
1394              voidreg(win32_context,cx),
1395              win32_context->FloatSave.TagWord);
1396
1397     /* This function had become unwieldy.  Let's cut it down into
1398      * pieces based on the different exception codes.  Each exception
1399      * code handler gets the chance to decline by returning non-zero if it
1400      * isn't happy: */
1401
1402     int rc;
1403     switch (code) {
1404     case EXCEPTION_ACCESS_VIOLATION:
1405         rc = handle_access_violation(
1406             ctx, exception_record, fault_address, self);
1407         break;
1408
1409     case SBCL_EXCEPTION_BREAKPOINT:
1410         rc = handle_breakpoint_trap(ctx, self);
1411         break;
1412
1413     case EXCEPTION_SINGLE_STEP:
1414         rc = handle_single_step(ctx);
1415         break;
1416
1417     default:
1418         rc = -1;
1419     }
1420
1421     if (rc)
1422         /* All else failed, drop through to the lisp-side exception handler. */
1423         signal_internal_error_or_lose(ctx, exception_record, fault_address);
1424
1425     if (self)
1426         self->carried_base_pointer = oldbp;
1427
1428     errno = lastErrno;
1429     SetLastError(lastError);
1430     return ExceptionContinueExecution;
1431 }
1432
1433 #ifdef LISP_FEATURE_X86_64
1434
1435 #define RESTORING_ERRNO()                                       \
1436     int sbcl__lastErrno = errno;                                \
1437     RUN_BODY_ONCE(restoring_errno, errno = sbcl__lastErrno)
1438
1439 LONG
1440 veh(EXCEPTION_POINTERS *ep)
1441 {
1442     EXCEPTION_DISPOSITION disp;
1443
1444     RESTORING_ERRNO() {
1445         if (!pthread_self())
1446             return EXCEPTION_CONTINUE_SEARCH;
1447     }
1448
1449     disp = handle_exception(ep->ExceptionRecord,0,ep->ContextRecord,0);
1450
1451     switch (disp)
1452     {
1453     case ExceptionContinueExecution:
1454         return EXCEPTION_CONTINUE_EXECUTION;
1455     case ExceptionContinueSearch:
1456         return EXCEPTION_CONTINUE_SEARCH;
1457     default:
1458         fprintf(stderr,"Exception handler is mad\n");
1459         ExitProcess(0);
1460     }
1461 }
1462 #endif
1463
1464 os_context_register_t
1465 carry_frame_pointer(os_context_register_t default_value)
1466 {
1467     struct thread* self = arch_os_get_current_thread();
1468     os_context_register_t bp = self->carried_base_pointer;
1469     return bp ? bp : default_value;
1470 }
1471
1472 void
1473 wos_install_interrupt_handlers(struct lisp_exception_frame *handler)
1474 {
1475 #ifdef LISP_FEATURE_X86
1476     handler->next_frame = get_seh_frame();
1477     handler->handler = (void*)exception_handler_wrapper;
1478     set_seh_frame(handler);
1479 #else
1480     static int once = 0;
1481     if (!once++)
1482         AddVectoredExceptionHandler(1,veh);
1483 #endif
1484 }
1485
1486 /*
1487  * The stubs below are replacements for the windows versions,
1488  * which can -fail- when used in our memory spaces because they
1489  * validate the memory spaces they are passed in a way that
1490  * denies our exception handler a chance to run.
1491  */
1492
1493 void *memmove(void *dest, const void *src, size_t n)
1494 {
1495     if (dest < src) {
1496         int i;
1497         for (i = 0; i < n; i++) *(((char *)dest)+i) = *(((char *)src)+i);
1498     } else {
1499         while (n--) *(((char *)dest)+n) = *(((char *)src)+n);
1500     }
1501     return dest;
1502 }
1503
1504 void *memcpy(void *dest, const void *src, size_t n)
1505 {
1506     while (n--) *(((char *)dest)+n) = *(((char *)src)+n);
1507     return dest;
1508 }
1509
1510 char *dirname(char *path)
1511 {
1512     static char buf[PATH_MAX + 1];
1513     size_t pathlen = strlen(path);
1514     int i;
1515
1516     if (pathlen >= sizeof(buf)) {
1517         lose("Pathname too long in dirname.\n");
1518         return NULL;
1519     }
1520
1521     strcpy(buf, path);
1522     for (i = pathlen; i >= 0; --i) {
1523         if (buf[i] == '/' || buf[i] == '\\') {
1524             buf[i] = '\0';
1525             break;
1526         }
1527     }
1528
1529     return buf;
1530 }
1531
1532 // 0 - not a socket or other error, 1 - has input, 2 - has no input
1533 int
1534 socket_input_available(HANDLE socket)
1535 {
1536     unsigned long count = 0, count_size = 0;
1537     int wsaErrno = GetLastError();
1538     int err = WSAIoctl((SOCKET)socket, FIONREAD, NULL, 0,
1539                        &count, sizeof(count), &count_size, NULL, NULL);
1540
1541     int ret;
1542
1543     if (err == 0) {
1544         ret = (count > 0) ? 1 : 2;
1545     } else
1546         ret = 0;
1547     SetLastError(wsaErrno);
1548     return ret;
1549 }
1550
1551 /* Unofficial but widely used property of console handles: they have
1552    #b11 in two minor bits, opposed to other handles, that are
1553    machine-word-aligned. Properly emulated even on wine.
1554
1555    Console handles are special in many aspects, e.g. they aren't NTDLL
1556    system handles: kernel32 redirects console operations to CSRSS
1557    requests. Using the hack below to distinguish console handles is
1558    justified, as it's the only method that won't hang during
1559    outstanding reads, won't try to lock NT kernel object (if there is
1560    one; console isn't), etc. */
1561 int
1562 console_handle_p(HANDLE handle)
1563 {
1564     return (handle != NULL)&&
1565         (handle != INVALID_HANDLE_VALUE)&&
1566         ((((int)(intptr_t)handle)&3)==3);
1567 }
1568
1569 /* Atomically mark current thread as (probably) doing synchronous I/O
1570  * on handle, if no cancellation is requested yet (and return TRUE),
1571  * otherwise clear thread's I/O cancellation flag and return false.
1572  */
1573 static
1574 boolean io_begin_interruptible(HANDLE handle)
1575 {
1576     /* No point in doing it unless OS supports cancellation from other
1577      * threads */
1578     if (!ptr_CancelIoEx)
1579         return 1;
1580
1581     if (!__sync_bool_compare_and_swap(&this_thread->synchronous_io_handle_and_flag,
1582                                       0, handle)) {
1583         ResetEvent(this_thread->private_events.events[0]);
1584         this_thread->synchronous_io_handle_and_flag = 0;
1585         return 0;
1586     }
1587     return 1;
1588 }
1589
1590 static pthread_mutex_t interrupt_io_lock = PTHREAD_MUTEX_INITIALIZER;
1591
1592 /* Unmark current thread as (probably) doing synchronous I/O; if an
1593  * I/O cancellation was requested, postpone it until next
1594  * io_begin_interruptible */
1595 static void
1596 io_end_interruptible(HANDLE handle)
1597 {
1598     if (!ptr_CancelIoEx)
1599         return;
1600     pthread_mutex_lock(&interrupt_io_lock);
1601     __sync_bool_compare_and_swap(&this_thread->synchronous_io_handle_and_flag,
1602                                  handle, 0);
1603     pthread_mutex_unlock(&interrupt_io_lock);
1604 }
1605
1606 /* Documented limit for ReadConsole/WriteConsole is 64K bytes.
1607    Real limit observed on W2K-SP3 is somewhere in between 32KiB and 64Kib...
1608 */
1609 #define MAX_CONSOLE_TCHARS 16384
1610
1611 int
1612 win32_write_unicode_console(HANDLE handle, void * buf, int count)
1613 {
1614     DWORD written = 0;
1615     DWORD nchars;
1616     BOOL result;
1617     nchars = count>>1;
1618     if (nchars>MAX_CONSOLE_TCHARS) nchars = MAX_CONSOLE_TCHARS;
1619
1620     if (!io_begin_interruptible(handle)) {
1621         errno = EINTR;
1622         return -1;
1623     }
1624     result = WriteConsoleW(handle,buf,nchars,&written,NULL);
1625     io_end_interruptible(handle);
1626
1627     if (result) {
1628         if (!written) {
1629             errno = EINTR;
1630             return -1;
1631         } else {
1632             return 2*written;
1633         }
1634     } else {
1635         DWORD err = GetLastError();
1636         odxprint(io,"WriteConsole fails => %u\n", err);
1637         errno = (err==ERROR_OPERATION_ABORTED ? EINTR : EIO);
1638         return -1;
1639     }
1640 }
1641
1642 /*
1643  * (AK writes:)
1644  *
1645  * It may be unobvious, but (probably) the most straightforward way of
1646  * providing some sane CL:LISTEN semantics for line-mode console
1647  * channel requires _dedicated input thread_.
1648  *
1649  * LISTEN should return true iff the next (READ-CHAR) won't have to
1650  * wait. As our console may be shared with another process, entirely
1651  * out of our control, looking at the events in PeekConsoleEvent
1652  * result (and searching for #\Return) doesn't cut it.
1653  *
1654  * We decided that console input thread must do something smarter than
1655  * a bare loop of continuous ReadConsoleW(). On Unix, user experience
1656  * with the terminal is entirely unaffected by the fact that some
1657  * process does (or doesn't) call read(); the situation on MS Windows
1658  * is different.
1659  *
1660  * Echo output and line editing present on MS Windows while some
1661  * process is waiting in ReadConsole(); otherwise all input events are
1662  * buffered. If our thread were calling ReadConsole() all the time, it
1663  * would feel like Unix cooked mode.
1664  *
1665  * But we don't write a Unix emulator here, even if it sometimes feels
1666  * like that; therefore preserving this aspect of console I/O seems a
1667  * good thing to us.
1668  *
1669  * LISTEN itself becomes trivial with dedicated input thread, but the
1670  * goal stated above -- provide `native' user experience with blocked
1671  * console -- don't play well with this trivial implementation.
1672  *
1673  * What's currently implemented is a compromise, looking as something
1674  * in between Unix cooked mode and Win32 line mode.
1675  *
1676  * 1. As long as no console I/O function is called (incl. CL:LISTEN),
1677  * console looks `blocked': no echo, no line editing.
1678  *
1679  * 2. (READ-CHAR), (READ-SEQUENCE) and other functions doing real
1680  * input result in the ReadConsole request (in a dedicated thread);
1681  *
1682  * 3. Once ReadConsole is called, it is not cancelled in the
1683  * middle. In line mode, it returns when <Enter> key is hit (or
1684  * something like that happens). Therefore, if line editing and echo
1685  * output had a chance to happen, console won't look `blocked' until
1686  * the line is entered (even if line input was triggered by
1687  * (READ-CHAR)).
1688  *
1689  * 4. LISTEN may request ReadConsole too (if no other thread is
1690  * reading the console and no data are queued). It's the only case
1691  * when the console becomes `unblocked' without any actual input
1692  * requested by Lisp code.  LISTEN check if there is at least one
1693  * input event in PeekConsole queue; unless there is such an event,
1694  * ReadConsole is not triggered by LISTEN.
1695  *
1696  * 5. Console-reading Lisp thread now may be interrupted immediately;
1697  * ReadConsole call itself, however, continues until the line is
1698  * entered.
1699  */
1700
1701 struct {
1702     WCHAR buffer[MAX_CONSOLE_TCHARS];
1703     DWORD head, tail;
1704     pthread_mutex_t lock;
1705     pthread_cond_t cond_has_data;
1706     pthread_cond_t cond_has_client;
1707     pthread_t thread;
1708     boolean initialized;
1709     HANDLE handle;
1710     boolean in_progress;
1711 } ttyinput = {.lock = PTHREAD_MUTEX_INITIALIZER};
1712
1713 static void*
1714 tty_read_line_server()
1715 {
1716     pthread_mutex_lock(&ttyinput.lock);
1717     while (ttyinput.handle) {
1718         DWORD nchars;
1719         BOOL ok;
1720
1721         while (!ttyinput.in_progress)
1722             pthread_cond_wait(&ttyinput.cond_has_client,&ttyinput.lock);
1723
1724         pthread_mutex_unlock(&ttyinput.lock);
1725
1726         ok = ReadConsoleW(ttyinput.handle,
1727                           &ttyinput.buffer[ttyinput.tail],
1728                           MAX_CONSOLE_TCHARS-ttyinput.tail,
1729                           &nchars,NULL);
1730
1731         pthread_mutex_lock(&ttyinput.lock);
1732
1733         if (ok) {
1734             ttyinput.tail += nchars;
1735             pthread_cond_broadcast(&ttyinput.cond_has_data);
1736         }
1737         ttyinput.in_progress = 0;
1738     }
1739     pthread_mutex_unlock(&ttyinput.lock);
1740     return NULL;
1741 }
1742
1743 static boolean
1744 tty_maybe_initialize_unlocked(HANDLE handle)
1745 {
1746     if (!ttyinput.initialized) {
1747         if (!DuplicateHandle(GetCurrentProcess(),handle,
1748                              GetCurrentProcess(),&ttyinput.handle,
1749                              0,FALSE,DUPLICATE_SAME_ACCESS)) {
1750             return 0;
1751         }
1752         pthread_cond_init(&ttyinput.cond_has_data,NULL);
1753         pthread_cond_init(&ttyinput.cond_has_client,NULL);
1754         pthread_create(&ttyinput.thread,NULL,tty_read_line_server,NULL);
1755         ttyinput.initialized = 1;
1756     }
1757     return 1;
1758 }
1759
1760 boolean
1761 win32_tty_listen(HANDLE handle)
1762 {
1763     boolean result = 0;
1764     INPUT_RECORD ir;
1765     DWORD nevents;
1766     pthread_mutex_lock(&ttyinput.lock);
1767     if (!tty_maybe_initialize_unlocked(handle))
1768         result = 0;
1769
1770     if (ttyinput.in_progress) {
1771         result = 0;
1772     } else {
1773         if (ttyinput.head != ttyinput.tail) {
1774             result = 1;
1775         } else {
1776             if (PeekConsoleInput(ttyinput.handle,&ir,1,&nevents) && nevents) {
1777                 ttyinput.in_progress = 1;
1778                 pthread_cond_broadcast(&ttyinput.cond_has_client);
1779             }
1780         }
1781     }
1782     pthread_mutex_unlock(&ttyinput.lock);
1783     return result;
1784 }
1785
1786 static int
1787 tty_read_line_client(HANDLE handle, void* buf, int count)
1788 {
1789     int result = 0;
1790     int nchars = count / sizeof(WCHAR);
1791     sigset_t pendset;
1792
1793     if (!nchars)
1794         return 0;
1795     if (nchars>MAX_CONSOLE_TCHARS)
1796         nchars=MAX_CONSOLE_TCHARS;
1797
1798     count = nchars*sizeof(WCHAR);
1799
1800     pthread_mutex_lock(&ttyinput.lock);
1801
1802     if (!tty_maybe_initialize_unlocked(handle)) {
1803         result = -1;
1804         errno = EIO;
1805         goto unlock;
1806     }
1807
1808     while (!result) {
1809         while (ttyinput.head == ttyinput.tail) {
1810             if (!io_begin_interruptible(ttyinput.handle)) {
1811                 ttyinput.in_progress = 0;
1812                 result = -1;
1813                 errno = EINTR;
1814                 goto unlock;
1815             } else {
1816                 if (!ttyinput.in_progress) {
1817                     /* We are to wait */
1818                     ttyinput.in_progress=1;
1819                     /* wake console reader */
1820                     pthread_cond_broadcast(&ttyinput.cond_has_client);
1821                 }
1822                 pthread_cond_wait(&ttyinput.cond_has_data, &ttyinput.lock);
1823                 io_end_interruptible(ttyinput.handle);
1824             }
1825         }
1826         result = sizeof(WCHAR)*(ttyinput.tail-ttyinput.head);
1827         if (result > count) {
1828             result = count;
1829         }
1830         if (result) {
1831             if (result > 0) {
1832                 DWORD nch,offset = 0;
1833                 LPWSTR ubuf = buf;
1834
1835                 memcpy(buf,&ttyinput.buffer[ttyinput.head],count);
1836                 ttyinput.head += (result / sizeof(WCHAR));
1837                 if (ttyinput.head == ttyinput.tail)
1838                     ttyinput.head = ttyinput.tail = 0;
1839
1840                 for (nch=0;nch<result/sizeof(WCHAR);++nch) {
1841                     if (ubuf[nch]==13) {
1842                         ++offset;
1843                     } else {
1844                         ubuf[nch-offset]=ubuf[nch];
1845                     }
1846                 }
1847                 result-=offset*sizeof(WCHAR);
1848
1849             }
1850         } else {
1851             result = -1;
1852             ttyinput.head = ttyinput.tail = 0;
1853             errno = EIO;
1854         }
1855     }
1856 unlock:
1857     pthread_mutex_unlock(&ttyinput.lock);
1858     return result;
1859 }
1860
1861 int
1862 win32_read_unicode_console(HANDLE handle, void* buf, int count)
1863 {
1864
1865     int result;
1866     result = tty_read_line_client(handle,buf,count);
1867     return result;
1868 }
1869
1870 boolean
1871 win32_maybe_interrupt_io(void* thread)
1872 {
1873     struct thread *th = thread;
1874     boolean done = 0;
1875     if (ptr_CancelIoEx) {
1876         pthread_mutex_lock(&interrupt_io_lock);
1877         HANDLE h = (HANDLE)
1878             InterlockedExchangePointer((volatile LPVOID *)
1879                                        &th->synchronous_io_handle_and_flag,
1880                                        (LPVOID)INVALID_HANDLE_VALUE);
1881         if (h && (h!=INVALID_HANDLE_VALUE)) {
1882             if (console_handle_p(h)) {
1883                 pthread_mutex_lock(&ttyinput.lock);
1884                 pthread_cond_broadcast(&ttyinput.cond_has_data);
1885                 pthread_mutex_unlock(&ttyinput.lock);
1886             }
1887             if (ptr_CancelSynchronousIo) {
1888                 pthread_mutex_lock(&th->os_thread->fiber_lock);
1889                 done = !!ptr_CancelSynchronousIo(th->os_thread->fiber_group->handle);
1890                 pthread_mutex_unlock(&th->os_thread->fiber_lock);
1891             }
1892             done |= !!ptr_CancelIoEx(h,NULL);
1893         }
1894         pthread_mutex_unlock(&interrupt_io_lock);
1895     }
1896     return done;
1897 }
1898
1899 static const LARGE_INTEGER zero_large_offset = {.QuadPart = 0LL};
1900
1901 int
1902 win32_unix_write(HANDLE handle, void * buf, int count)
1903 {
1904     DWORD written_bytes;
1905     OVERLAPPED overlapped;
1906     struct thread * self = arch_os_get_current_thread();
1907     BOOL waitInGOR;
1908     LARGE_INTEGER file_position;
1909     BOOL seekable;
1910     BOOL ok;
1911
1912     if (console_handle_p(handle))
1913         return win32_write_unicode_console(handle,buf,count);
1914
1915     overlapped.hEvent = self->private_events.events[0];
1916     seekable = SetFilePointerEx(handle,
1917                                 zero_large_offset,
1918                                 &file_position,
1919                                 FILE_CURRENT);
1920     if (seekable) {
1921         overlapped.Offset = file_position.LowPart;
1922         overlapped.OffsetHigh = file_position.HighPart;
1923     } else {
1924         overlapped.Offset = 0;
1925         overlapped.OffsetHigh = 0;
1926     }
1927     if (!io_begin_interruptible(handle)) {
1928         errno = EINTR;
1929         return -1;
1930     }
1931     ok = WriteFile(handle, buf, count, &written_bytes, &overlapped);
1932     io_end_interruptible(handle);
1933
1934     if (ok) {
1935         goto done_something;
1936     } else {
1937         DWORD errorCode = GetLastError();
1938         if (errorCode==ERROR_OPERATION_ABORTED) {
1939             GetOverlappedResult(handle,&overlapped,&written_bytes,FALSE);
1940             errno = EINTR;
1941             return -1;
1942         }
1943         if (errorCode!=ERROR_IO_PENDING) {
1944             errno = EIO;
1945             return -1;
1946         } else {
1947             if(WaitForMultipleObjects(2,self->private_events.events,
1948                                       FALSE,INFINITE) != WAIT_OBJECT_0) {
1949                 CancelIo(handle);
1950                 waitInGOR = TRUE;
1951             } else {
1952                 waitInGOR = FALSE;
1953             }
1954             if (!GetOverlappedResult(handle,&overlapped,&written_bytes,waitInGOR)) {
1955                 if (GetLastError()==ERROR_OPERATION_ABORTED) {
1956                     errno = EINTR;
1957                 } else {
1958                     errno = EIO;
1959                 }
1960                 return -1;
1961             } else {
1962                 goto done_something;
1963             }
1964         }
1965     }
1966   done_something:
1967     if (seekable) {
1968         file_position.QuadPart += written_bytes;
1969         SetFilePointerEx(handle,file_position,NULL,FILE_BEGIN);
1970     }
1971     return written_bytes;
1972 }
1973
1974 int
1975 win32_unix_read(HANDLE handle, void * buf, int count)
1976 {
1977     OVERLAPPED overlapped = {.Internal=0};
1978     DWORD read_bytes = 0;
1979     struct thread * self = arch_os_get_current_thread();
1980     DWORD errorCode = 0;
1981     BOOL waitInGOR = FALSE;
1982     BOOL ok = FALSE;
1983     LARGE_INTEGER file_position;
1984     BOOL seekable;
1985
1986     if (console_handle_p(handle))
1987         return win32_read_unicode_console(handle,buf,count);
1988
1989     overlapped.hEvent = self->private_events.events[0];
1990     /* If it has a position, we won't try overlapped */
1991     seekable = SetFilePointerEx(handle,
1992                                 zero_large_offset,
1993                                 &file_position,
1994                                 FILE_CURRENT);
1995     if (seekable) {
1996         overlapped.Offset = file_position.LowPart;
1997         overlapped.OffsetHigh = file_position.HighPart;
1998     } else {
1999         overlapped.Offset = 0;
2000         overlapped.OffsetHigh = 0;
2001     }
2002     if (!io_begin_interruptible(handle)) {
2003         errno = EINTR;
2004         return -1;
2005     }
2006     ok = ReadFile(handle,buf,count,&read_bytes, &overlapped);
2007     io_end_interruptible(handle);
2008     if (ok) {
2009         /* immediately */
2010         goto done_something;
2011     } else {
2012         errorCode = GetLastError();
2013         if (errorCode == ERROR_HANDLE_EOF ||
2014             errorCode == ERROR_BROKEN_PIPE ||
2015             errorCode == ERROR_NETNAME_DELETED) {
2016             read_bytes = 0;
2017             goto done_something;
2018         }
2019         if (errorCode==ERROR_OPERATION_ABORTED) {
2020             GetOverlappedResult(handle,&overlapped,&read_bytes,FALSE);
2021             errno = EINTR;
2022             return -1;
2023         }
2024         if (errorCode!=ERROR_IO_PENDING) {
2025             /* is it some _real_ error? */
2026             errno = EIO;
2027             return -1;
2028         } else {
2029             int ret;
2030             if( (ret = WaitForMultipleObjects(2,self->private_events.events,
2031                                               FALSE,INFINITE)) != WAIT_OBJECT_0) {
2032                 CancelIo(handle);
2033                 waitInGOR = TRUE;
2034                 /* Waiting for IO only */
2035             } else {
2036                 waitInGOR = FALSE;
2037             }
2038             ok = GetOverlappedResult(handle,&overlapped,&read_bytes,waitInGOR);
2039             if (!ok) {
2040                 errorCode = GetLastError();
2041                 if (errorCode == ERROR_HANDLE_EOF ||
2042                     errorCode == ERROR_BROKEN_PIPE ||
2043                     errorCode == ERROR_NETNAME_DELETED) {
2044                     read_bytes = 0;
2045                     goto done_something;
2046                 } else {
2047                     if (errorCode == ERROR_OPERATION_ABORTED)
2048                         errno = EINTR;      /* that's it. */
2049                     else
2050                         errno = EIO;        /* something unspecific */
2051                     return -1;
2052                 }
2053             } else
2054                 goto done_something;
2055         }
2056     }
2057   done_something:
2058     if (seekable) {
2059         file_position.QuadPart += read_bytes;
2060         SetFilePointerEx(handle,file_position,NULL,FILE_BEGIN);
2061     }
2062     return read_bytes;
2063 }
2064
2065 /* We used to have a scratch() function listing all symbols needed by
2066  * Lisp.  Much rejoicing commenced upon its removal.  However, I would
2067  * like cold init to fail aggressively when encountering unused symbols.
2068  * That poses a problem, however, since our C code no longer includes
2069  * any references to symbols in ws2_32.dll, and hence the linker
2070  * completely ignores our request to reference it (--no-as-needed does
2071  * not work).  Warm init would later load the DLLs explicitly, but then
2072  * it's too late for an early sanity check.  In the unfortunate spirit
2073  * of scratch(), continue to reference some required DLLs explicitly by
2074  * means of one scratch symbol per DLL.
2075  */
2076 void scratch(void)
2077 {
2078     /* a function from ws2_32.dll */
2079     shutdown(0, 0);
2080
2081     /* a function from shell32.dll */
2082     SHGetFolderPathA(0, 0, 0, 0, 0);
2083 }
2084
2085 char *
2086 os_get_runtime_executable_path(int external)
2087 {
2088     char path[MAX_PATH + 1];
2089     DWORD bufsize = sizeof(path);
2090     DWORD size;
2091
2092     if ((size = GetModuleFileNameA(NULL, path, bufsize)) == 0)
2093         return NULL;
2094     else if (size == bufsize && GetLastError() == ERROR_INSUFFICIENT_BUFFER)
2095         return NULL;
2096
2097     return copied_string(path);
2098 }
2099
2100 #ifdef LISP_FEATURE_SB_THREAD
2101
2102 int
2103 win32_wait_object_or_signal(HANDLE waitFor)
2104 {
2105     struct thread * self = arch_os_get_current_thread();
2106     HANDLE handles[2];
2107     handles[0] = waitFor;
2108     handles[1] = self->private_events.events[1];
2109     return
2110         WaitForMultipleObjects(2,handles, FALSE,INFINITE);
2111 }
2112
2113 /*
2114  * Portability glue for win32 waitable timers.
2115  *
2116  * One may ask: Why is there a wrapper in C when the calls are so
2117  * obvious that Lisp could do them directly (as it did on Windows)?
2118  *
2119  * But the answer is that on POSIX platforms, we now emulate the win32
2120  * calls and hide that emulation behind this os_* abstraction.
2121  */
2122 HANDLE
2123 os_create_wtimer()
2124 {
2125     return CreateWaitableTimer(0, 0, 0);
2126 }
2127
2128 int
2129 os_wait_for_wtimer(HANDLE handle)
2130 {
2131     return win32_wait_object_or_signal(handle);
2132 }
2133
2134 void
2135 os_close_wtimer(HANDLE handle)
2136 {
2137     CloseHandle(handle);
2138 }
2139
2140 void
2141 os_set_wtimer(HANDLE handle, int sec, int nsec)
2142 {
2143     /* in units of 100ns, i.e. 0.1us. Negative for relative semantics. */
2144     long long dueTime
2145         = -(((long long) sec) * 10000000
2146             + ((long long) nsec + 99) / 100);
2147     SetWaitableTimer(handle, (LARGE_INTEGER*) &dueTime, 0, 0, 0, 0);
2148 }
2149
2150 void
2151 os_cancel_wtimer(HANDLE handle)
2152 {
2153     CancelWaitableTimer(handle);
2154 }
2155 #endif
2156
2157 /* EOF */