2 * the Win32 incarnation of OS-dependent routines. See also
3 * $(sbcl_arch)-win32-os.c
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.
13 * This software is part of the SBCL system. See the README file for
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.
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
32 #include <sys/param.h>
40 #include "interrupt.h"
45 #include "genesis/primitive-objects.h"
48 #include <sys/types.h>
63 #ifndef LISP_FEATURE_SB_THREAD
64 /* dummy definition to reduce ifdef clutter */
65 #define WITH_GC_AT_SAFEPOINTS_ONLY() if (0) ; else
68 os_vm_size_t os_vm_page_size;
71 #include "gencgc-internal.h"
75 int linux_sparc_siginfo_bug = 0;
76 int linux_supports_futex=0;
82 /* missing definitions for modern mingws */
84 #define EH_UNWINDING 0x02
86 #ifndef EH_EXIT_UNWIND
87 #define EH_EXIT_UNWIND 0x04
90 /* Tired of writing arch_os_get_current_thread each time. */
91 #define this_thread (arch_os_get_current_thread())
93 /* wrappers for winapi calls that must be successful (like SBCL's
94 * (aver ...) form). */
96 /* win_aver function: basic building block for miscellaneous
97 * ..AVER.. macrology (below) */
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. */
105 intptr_t win_aver(intptr_t value, char* comment, char* file, int line,
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"
116 " ===> returned #X%p, \n"
118 " ... Win32 thinks:\n"
119 " ===> code %u, message => %s\n"
121 " ===> code %u, message => %s\n";
124 FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER|
125 FORMAT_MESSAGE_FROM_SYSTEM,
128 MAKELANGID(LANG_ENGLISH,SUBLANG_ENGLISH_US),
129 (LPSTR)&errorMessage,
134 fprintf(stderr, report_template,
138 (unsigned)errorCode, errorMessage,
139 posixerrno, posixstrerror);
141 lose(report_template,
145 (unsigned)errorCode, errorMessage,
146 posixerrno, posixstrerror);
149 LocalFree(errorMessage);
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. */
158 intptr_t sys_aver(long value, char* comment, char* file, int line,
161 win_aver((intptr_t)(value>=0),comment,file,line,justwarn);
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.
171 * Failed AVER() is normally fatal. Well, unless dyndebug_survive_aver
175 ({ __typeof__(call) __attribute__((unused)) me = \
177 win_aver((intptr_t)(call), #call, __FILE__, __LINE__, 0); \
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. */
185 #define AVERLAX(call) \
186 ({ __typeof__(call) __attribute__((unused)) me = \
188 win_aver((intptr_t)(call), #call, __FILE__, __LINE__, 1); \
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). */
195 #define CRT_AVER_NONNEGATIVE(call) \
196 ({ __typeof__(call) __attribute__((unused)) me = \
198 sys_aver((call), #call, __FILE__, __LINE__, 0); \
201 #define CRT_AVERLAX_NONNEGATIVE(call) \
202 ({ __typeof__(call) __attribute__((unused)) me = \
204 sys_aver((call), #call, __FILE__, __LINE__, 1); \
208 #define CRT_AVER(booly) \
209 ({ __typeof__(booly) __attribute__((unused)) me = (booly); \
210 sys_aver((booly)?0:-1, #booly, __FILE__, __LINE__, 0); \
213 const char * t_nil_s(lispobj symbol);
216 * The following signal-mask-related alien routines are called from Lisp:
219 /* As of win32, deferrables _do_ matter. gc_signal doesn't. */
220 unsigned long block_deferrables_and_return_mask()
223 block_deferrable_signals(0, &sset);
224 return (unsigned long)sset;
227 #if defined(LISP_FEATURE_SB_THREAD)
228 void apply_sigmask(unsigned long sigmask)
230 sigset_t sset = (sigset_t)sigmask;
231 pthread_sigmask(SIG_SETMASK, &sset, 0);
235 /* The exception handling function looks like this: */
236 EXCEPTION_DISPOSITION handle_exception(EXCEPTION_RECORD *,
237 struct lisp_exception_frame *,
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.
248 void *base_seh_frame;
250 HMODULE runtime_module_handle = 0u;
252 static void *get_seh_frame(void)
255 #ifdef LISP_FEATURE_X86
256 asm volatile ("mov %%fs:0,%0": "=r" (retval));
258 asm volatile ("mov %%gs:0,%0": "=r" (retval));
263 static void set_seh_frame(void *frame)
265 #ifdef LISP_FEATURE_X86
266 asm volatile ("mov %0,%%fs:0": : "r" (frame));
268 asm volatile ("mov %0,%%gs:0": : "r" (frame));
272 #if defined(LISP_FEATURE_SB_THREAD)
276 AVER(VirtualAlloc(GC_SAFEPOINT_PAGE_ADDR, sizeof(lispobj),
277 MEM_RESERVE|MEM_COMMIT, PAGE_READWRITE));
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).
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]".
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
304 AVER(VirtualProtect((void*) GC_SAFEPOINT_PAGE_ADDR, sizeof(lispobj),
305 PAGE_READWRITE, &oldProt));
311 AVER(VirtualProtect((void*) GC_SAFEPOINT_PAGE_ADDR, sizeof(lispobj),
312 PAGE_NOACCESS, &oldProt));
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.
324 * How it works: a sketch
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.
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).
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.
348 * What do we gain with this feature, after all?
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.
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.
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.
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
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.
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.
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.
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
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.
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.
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.
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.
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:
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>
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.
486 * Of course, this name-parsing trick lacks conceptual clarity; we're
487 * going to get rid of it eventually. */
489 u32 os_get_build_time_shared_libraries(u32 excl_maximum,
491 void** opt_store_handles,
492 const char *opt_store_names[])
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;
500 /* dos header provided the offset from `base' to
501 * IMAGE_FILE_HEADER where PE-i386 really starts */
503 void* check_duplicates[excl_maximum];
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'. */
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
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;
526 for (nlibrary=0u; nlibrary < excl_maximum
527 && image_import_descriptor->FirstThunk;
528 ++image_import_descriptor)
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).
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. */
543 GetModuleHandle(base + image_import_descriptor->Name);
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
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
566 for (j=0; j<nlibrary; ++j)
568 if(check_duplicates[j] == hmodule)
571 if (j<nlibrary) continue; /* duplicate => skip it in
574 check_duplicates[nlibrary] = hmodule;
575 if (opt_store_handles) {
576 opt_store_handles[nlibrary] = hmodule;
578 if (opt_store_names) {
579 opt_store_names[nlibrary] = (const char *)
580 (base + image_import_descriptor->Name);
582 odxprint(runtime_link, "DLL detection: %u, base %p: %s",
584 (char*)(base + image_import_descriptor->Name));
592 static u32 buildTimeImageCount = 0;
593 static void* buildTimeImages[16];
595 /* Resolve symbols against the executable and its build-time dependencies */
596 void* os_dlsym_default(char* name)
600 if (buildTimeImageCount == 0) {
601 buildTimeImageCount =
602 1 + os_get_build_time_shared_libraries(15u,
603 NULL, 1+(void**)buildTimeImages, NULL);
605 for (i = 0; i<buildTimeImageCount && (!result); ++i) {
606 result = GetProcAddress(buildTimeImages[i], name);
611 #endif /* SB_DYNAMIC_CORE */
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
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).
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.
633 To summarize, let's list the assumptions we make:
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
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. */
655 #ifdef LISP_FEATURE_X86
656 DWORD slots[TLS_MINIMUM_AVAILABLE];
659 for (i=0; i<TLS_MINIMUM_AVAILABLE; ++i) {
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);
670 slots[n_slots++]=key;
672 for (i=0; i<n_slots; ++i) {
675 if (key!=OUR_TLS_INDEX) {
676 lose("TLS slot assertion failed: slot 63 is unavailable "
677 "(last TlsAlloc() returned %u)",key);
681 #endif /* LISP_FEATURE_SB_THREAD */
683 int os_number_of_processors = 1;
685 BOOL WINAPI CancelIoEx(HANDLE handle, LPOVERLAPPED overlapped);
686 typeof(CancelIoEx) *ptr_CancelIoEx;
687 BOOL WINAPI CancelSynchronousIo(HANDLE threadHandle);
688 typeof(CancelSynchronousIo) *ptr_CancelSynchronousIo;
690 #define RESOLVE(hmodule,fn) \
692 ptr_##fn = (typeof(ptr_##fn)) \
693 GetProcAddress(hmodule,#fn); \
696 static void resolve_optional_imports()
698 HMODULE kernel32 = GetModuleHandleA("kernel32");
700 RESOLVE(kernel32,CancelIoEx);
701 RESOLVE(kernel32,CancelSynchronousIo);
707 intptr_t win32_get_module_handle_by_address(os_vm_address_t addr)
710 /* So apparently we could use VirtualQuery instead of
711 * GetModuleHandleEx if we wanted to support pre-XP, pre-2003
712 * versions of Windows (i.e. Windows 2000). I've opted against such
713 * special-casing. :-). --DFL */
714 return (intptr_t)(GetModuleHandleEx(
715 GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS |
716 GET_MODULE_HANDLE_EX_FLAG_UNCHANGED_REFCOUNT,
717 (LPCSTR)addr, &result)
721 void os_init(char *argv[], char *envp[])
723 SYSTEM_INFO system_info;
724 GetSystemInfo(&system_info);
725 os_vm_page_size = system_info.dwPageSize > BACKEND_PAGE_BYTES?
726 system_info.dwPageSize : BACKEND_PAGE_BYTES;
727 #if defined(LISP_FEATURE_X86)
728 fast_bzero_pointer = fast_bzero_detect;
730 os_number_of_processors = system_info.dwNumberOfProcessors;
732 base_seh_frame = get_seh_frame();
734 resolve_optional_imports();
735 runtime_module_handle = (HMODULE)win32_get_module_handle_by_address(&runtime_module_handle);
738 static inline boolean local_thread_stack_address_p(os_vm_address_t address)
740 return this_thread &&
741 (((((u64)address >= (u64)this_thread->os_address) &&
742 ((u64)address < ((u64)this_thread)-THREAD_CSP_PAGE_SIZE))||
743 (((u64)address >= (u64)this_thread->control_stack_start)&&
744 ((u64)address < (u64)this_thread->control_stack_end))));
748 * So we have three fun scenarios here.
750 * First, we could be being called to reserve the memory areas
751 * during initialization (prior to loading the core file).
753 * Second, we could be being called by the GC to commit a page
754 * that has just been decommitted (for easy zero-fill).
756 * Third, we could be being called by create_thread_struct()
757 * in order to create the sundry and various stacks.
759 * The third case is easy to pick out because it passes an
762 * The second case is easy to pick out because it will be for
763 * a range of memory that is MEM_RESERVE rather than MEM_FREE.
765 * The second case is also an easy implement, because we leave
766 * the memory as reserved (since we do lazy commits).
770 os_validate(os_vm_address_t addr, os_vm_size_t len)
772 MEMORY_BASIC_INFORMATION mem_info;
775 /* the simple case first */
777 AVERLAX(VirtualAlloc(addr, len, MEM_RESERVE|MEM_COMMIT, PAGE_EXECUTE_READWRITE));
780 if (!AVERLAX(VirtualQuery(addr, &mem_info, sizeof mem_info)))
783 if ((mem_info.State == MEM_RESERVE) && (mem_info.RegionSize >=len)) {
784 /* It would be correct to return here. However, support for Wine
785 * is beneficial, and Wine has a strange behavior in this
786 * department. It reports all memory below KERNEL32.DLL as
787 * reserved, but disallows MEM_COMMIT.
789 * Let's work around it: reserve the region we need for a second
790 * time. The second reservation is documented to fail on normal NT
791 * family, but it will succeed on Wine if this region is
794 VirtualAlloc(addr, len, MEM_RESERVE, PAGE_EXECUTE_READWRITE);
795 /* If it is wine, the second call has succeded, and now the region
796 * is really reserved. */
800 if (mem_info.State == MEM_RESERVE) {
801 fprintf(stderr, "validation of reserved space too short.\n");
803 /* Oddly, we do not treat this assertion as fatal; hence also the
804 * provision for MEM_RESERVE in the following code, I suppose: */
807 if (!AVERLAX(VirtualAlloc(addr, len, (mem_info.State == MEM_RESERVE)?
808 MEM_COMMIT: MEM_RESERVE, PAGE_EXECUTE_READWRITE)))
815 * For os_invalidate(), we merely decommit the memory rather than
816 * freeing the address space. This loses when freeing per-thread
817 * data and related memory since it leaks address space.
819 * So far the original comment (author unknown). It used to continue as
822 * It's not too lossy, however, since the two scenarios I'm aware of
823 * are fd-stream buffers, which are pooled rather than torched, and
824 * thread information, which I hope to pool (since windows creates
825 * threads at its own whim, and we probably want to be able to have
826 * them callback without funky magic on the part of the user, and
827 * full-on thread allocation is fairly heavyweight).
829 * But: As it turns out, we are no longer content with decommitting
830 * without freeing, and have now grown a second function
831 * os_invalidate_free(), sort of a really_os_invalidate().
833 * As discussed on #lisp, this is not a satisfactory solution, and probably
834 * ought to be rectified in the following way:
836 * - Any cases currently going through the non-freeing version of
837 * os_invalidate() are ultimately meant for zero-filling applications.
838 * Replace those use cases with an os_revalidate_bzero() or similarly
839 * named function, which explicitly takes care of that aspect of
842 * - The remaining uses of os_invalidate should actually free, and once
843 * the above is implemented, we can rename os_invalidate_free back to
844 * just os_invalidate().
846 * So far the new plan, as yet unimplemented. -- DFL
850 os_invalidate(os_vm_address_t addr, os_vm_size_t len)
852 AVERLAX(VirtualFree(addr, len, MEM_DECOMMIT));
856 os_invalidate_free(os_vm_address_t addr, os_vm_size_t len)
858 AVERLAX(VirtualFree(addr, 0, MEM_RELEASE));
862 os_invalidate_free_by_any_address(os_vm_address_t addr, os_vm_size_t len)
864 MEMORY_BASIC_INFORMATION minfo;
865 AVERLAX(VirtualQuery(addr, &minfo, sizeof minfo));
866 AVERLAX(minfo.AllocationBase);
867 AVERLAX(VirtualFree(minfo.AllocationBase, 0, MEM_RELEASE));
870 /* os_validate doesn't commit, i.e. doesn't actually "validate" in the
871 * sense that we could start using the space afterwards. Usually it's
872 * os_map or Lisp code that will run into that, in which case we recommit
873 * elsewhere in this file. For cases where C wants to write into newly
874 * os_validate()d memory, it needs to commit it explicitly first:
877 os_validate_recommit(os_vm_address_t addr, os_vm_size_t len)
880 AVERLAX(VirtualAlloc(addr, len, MEM_COMMIT, PAGE_EXECUTE_READWRITE));
884 * os_map() is called to map a chunk of the core file into memory.
886 * Unfortunately, Windows semantics completely screws this up, so
887 * we just add backing store from the swapfile to where the chunk
888 * goes and read it up like a normal file. We could consider using
889 * a lazy read (demand page) setup, but that would mean keeping an
890 * open file pointer for the core indefinately (and be one more
891 * thing to maintain).
895 os_map(int fd, int offset, os_vm_address_t addr, os_vm_size_t len)
899 AVER(VirtualAlloc(addr, len, MEM_COMMIT, PAGE_EXECUTE_READWRITE)||
900 VirtualAlloc(addr, len, MEM_RESERVE|MEM_COMMIT,
901 PAGE_EXECUTE_READWRITE));
903 CRT_AVER_NONNEGATIVE(lseek(fd, offset, SEEK_SET));
905 count = read(fd, addr, len);
906 CRT_AVER( count == len );
911 static DWORD os_protect_modes[8] = {
918 PAGE_EXECUTE_READWRITE,
919 PAGE_EXECUTE_READWRITE,
923 os_protect(os_vm_address_t address, os_vm_size_t length, os_vm_prot_t prot)
927 DWORD new_prot = os_protect_modes[prot];
928 AVER(VirtualProtect(address, length, new_prot, &old_prot)||
929 (VirtualAlloc(address, length, MEM_COMMIT, new_prot) &&
930 VirtualProtect(address, length, new_prot, &old_prot)));
931 odxprint(misc,"Protecting %p + %p vmaccess %d "
932 "newprot %08x oldprot %08x",
933 address,length,prot,new_prot,old_prot);
936 /* FIXME: Now that FOO_END, rather than FOO_SIZE, is the fundamental
937 * description of a space, we could probably punt this and just do
938 * (FOO_START <= x && x < FOO_END) everywhere it's called. */
940 in_range_p(os_vm_address_t a, lispobj sbeg, size_t slen)
942 char* beg = (char*)((uword_t)sbeg);
943 char* end = (char*)((uword_t)sbeg) + slen;
944 char* adr = (char*)a;
945 return (adr >= beg && adr < end);
949 is_linkage_table_addr(os_vm_address_t addr)
951 return in_range_p(addr, LINKAGE_TABLE_SPACE_START, LINKAGE_TABLE_SPACE_END);
954 static boolean is_some_thread_local_addr(os_vm_address_t addr);
957 is_valid_lisp_addr(os_vm_address_t addr)
959 if(in_range_p(addr, READ_ONLY_SPACE_START, READ_ONLY_SPACE_SIZE) ||
960 in_range_p(addr, STATIC_SPACE_START , STATIC_SPACE_SIZE) ||
961 in_range_p(addr, DYNAMIC_SPACE_START , dynamic_space_size) ||
962 is_some_thread_local_addr(addr))
967 /* test if an address is within thread-local space */
969 is_thread_local_addr(struct thread* th, os_vm_address_t addr)
971 /* Assuming that this is correct, it would warrant further comment,
972 * I think. Based on what our call site is doing, we have been
973 * tasked to check for the address of a lisp object; not merely any
974 * foreign address within the thread's area. Indeed, this used to
975 * be a check for control and binding stack only, rather than the
976 * full thread "struct". So shouldn't the THREAD_STRUCT_SIZE rather
977 * be (thread_control_stack_size+BINDING_STACK_SIZE) instead? That
978 * would also do away with the LISP_FEATURE_SB_THREAD case. Or does
979 * it simply not matter? --DFL */
980 ptrdiff_t diff = ((char*)th->os_address)-(char*)addr;
981 return diff > (ptrdiff_t)0 && diff < (ptrdiff_t)THREAD_STRUCT_SIZE
982 #ifdef LISP_FEATURE_SB_THREAD
983 && addr != (os_vm_address_t) th->csp_around_foreign_call
989 is_some_thread_local_addr(os_vm_address_t addr)
992 #ifdef LISP_FEATURE_SB_THREAD
994 pthread_mutex_lock(&all_threads_lock);
995 for_each_thread(th) {
996 if(is_thread_local_addr(th,addr)) {
1001 pthread_mutex_unlock(&all_threads_lock);
1007 /* A tiny bit of interrupt.c state we want our paws on. */
1008 extern boolean internal_errors_enabled;
1010 extern void exception_handler_wrapper();
1013 c_level_backtrace(const char* header, int depth)
1019 for (lastseh = get_seh_frame(); lastseh && (lastseh!=(void*)-1);
1020 lastseh = *lastseh);
1022 fprintf(stderr, "Backtrace: %s (thread %p)\n", header, this_thread);
1023 for (frame = __builtin_frame_address(0); frame; frame=*(void**)frame)
1027 fprintf(stderr, "[#%02d]: ebp = 0x%p, ret = 0x%p\n",n,
1028 frame, ((void**)frame)[1]);
1032 #ifdef LISP_FEATURE_X86
1033 #define voidreg(ctxptr,name) ((void*)((ctxptr)->E##name))
1035 #define voidreg(ctxptr,name) ((void*)((ctxptr)->R##name))
1039 #if defined(LISP_FEATURE_X86)
1041 handle_single_step(os_context_t *ctx)
1043 if (!single_stepping)
1046 /* We are doing a displaced instruction. At least function
1047 * end breakpoints use this. */
1048 WITH_GC_AT_SAFEPOINTS_ONLY () /* Todo: Is it really gc-unsafe? */
1049 restore_breakpoint_from_single_step(ctx);
1055 #ifdef LISP_FEATURE_UD2_BREAKPOINTS
1056 #define SBCL_EXCEPTION_BREAKPOINT EXCEPTION_ILLEGAL_INSTRUCTION
1057 #define TRAP_CODE_WIDTH 2
1059 #define SBCL_EXCEPTION_BREAKPOINT EXCEPTION_BREAKPOINT
1060 #define TRAP_CODE_WIDTH 1
1064 handle_breakpoint_trap(os_context_t *ctx, struct thread* self)
1066 #ifdef LISP_FEATURE_UD2_BREAKPOINTS
1067 if (((unsigned short *)((ctx->win32_context)->Eip))[0] != 0x0b0f)
1071 /* Unlike some other operating systems, Win32 leaves EIP
1072 * pointing to the breakpoint instruction. */
1073 (*os_context_pc_addr(ctx)) += TRAP_CODE_WIDTH;
1075 /* Now EIP points just after the INT3 byte and aims at the
1076 * 'kind' value (eg trap_Cerror). */
1077 unsigned trap = *(unsigned char *)(*os_context_pc_addr(ctx));
1079 #ifdef LISP_FEATURE_SB_THREAD
1080 /* Before any other trap handler: gc_safepoint ensures that
1081 inner alloc_sap for passing the context won't trap on
1083 if (trap == trap_PendingInterrupt) {
1084 /* Done everything needed for this trap, except EIP
1086 arch_skip_instruction(ctx);
1087 thread_interrupted(ctx);
1092 /* This is just for info in case the monitor wants to print an
1094 access_control_stack_pointer(self) =
1095 (lispobj *)*os_context_sp_addr(ctx);
1097 WITH_GC_AT_SAFEPOINTS_ONLY() {
1098 #if defined(LISP_FEATURE_SB_THREAD)
1099 block_blockable_signals(0,&ctx->sigmask);
1101 handle_trap(ctx, trap);
1102 #if defined(LISP_FEATURE_SB_THREAD)
1103 thread_sigmask(SIG_SETMASK,&ctx->sigmask,NULL);
1107 /* Done, we're good to go! */
1112 handle_access_violation(os_context_t *ctx,
1113 EXCEPTION_RECORD *exception_record,
1114 void *fault_address,
1115 struct thread* self)
1117 CONTEXT *win32_context = ctx->win32_context;
1119 #if defined(LISP_FEATURE_X86)
1120 odxprint(pagefaults,
1121 "SEGV. ThSap %p, Eip %p, Esp %p, Esi %p, Edi %p, "
1122 "Addr %p Access %d\n",
1129 exception_record->ExceptionInformation[0]);
1131 odxprint(pagefaults,
1132 "SEGV. ThSap %p, Eip %p, Esp %p, Esi %p, Edi %p, "
1133 "Addr %p Access %d\n",
1140 exception_record->ExceptionInformation[0]);
1143 /* Stack: This case takes care of our various stack exhaustion
1144 * protect pages (with the notable exception of the control stack!). */
1145 if (self && local_thread_stack_address_p(fault_address)) {
1146 if (handle_guard_page_triggered(ctx, fault_address))
1147 return 0; /* gc safety? */
1151 /* Safepoint pages */
1152 #ifdef LISP_FEATURE_SB_THREAD
1153 if (fault_address == (void *) GC_SAFEPOINT_PAGE_ADDR) {
1154 thread_in_lisp_raised(ctx);
1158 if ((((u64)fault_address) == ((u64)self->csp_around_foreign_call))){
1159 thread_in_safety_transition(ctx);
1165 page_index_t index = find_page_index(fault_address);
1168 * Now, if the page is supposedly write-protected and this
1169 * is a write, tell the gc that it's been hit.
1171 if (page_table[index].write_protected) {
1172 gencgc_handle_wp_violation(fault_address);
1174 AVER(VirtualAlloc(PTR_ALIGN_DOWN(fault_address,os_vm_page_size),
1176 MEM_COMMIT, PAGE_EXECUTE_READWRITE));
1181 if (fault_address == undefined_alien_address)
1184 /* linkage table or a "valid_lisp_addr" outside of dynamic space (?) */
1185 if (is_linkage_table_addr(fault_address)
1186 || is_valid_lisp_addr(fault_address))
1192 /* First use of a new page, lets get some memory for it. */
1194 #if defined(LISP_FEATURE_X86)
1195 AVER(VirtualAlloc(PTR_ALIGN_DOWN(fault_address,os_vm_page_size),
1197 MEM_COMMIT, PAGE_EXECUTE_READWRITE)
1198 ||(fprintf(stderr,"Unable to recommit addr %p eip 0x%08lx\n",
1199 fault_address, win32_context->Eip) &&
1200 (c_level_backtrace("BT",5),
1201 fake_foreign_function_call(ctx),
1202 lose("Lispy backtrace"),
1205 AVER(VirtualAlloc(PTR_ALIGN_DOWN(fault_address,os_vm_page_size),
1207 MEM_COMMIT, PAGE_EXECUTE_READWRITE)
1208 ||(fprintf(stderr,"Unable to recommit addr %p eip 0x%p\n",
1209 fault_address, (void*)win32_context->Rip) &&
1210 (c_level_backtrace("BT",5),
1211 fake_foreign_function_call(ctx),
1212 lose("Lispy backtrace"),
1220 signal_internal_error_or_lose(os_context_t *ctx,
1221 EXCEPTION_RECORD *exception_record,
1222 void *fault_address)
1225 * If we fall through to here then we need to either forward
1226 * the exception to the lisp-side exception handler if it's
1227 * set up, or drop to LDB.
1230 if (internal_errors_enabled) {
1231 lispobj context_sap;
1232 lispobj exception_record_sap;
1235 /* We're making the somewhat arbitrary decision that having
1236 * internal errors enabled means that lisp has sufficient
1237 * marbles to be able to handle exceptions, but exceptions
1238 * aren't supposed to happen during cold init or reinit
1241 #if defined(LISP_FEATURE_SB_THREAD)
1242 block_blockable_signals(0,&ctx->sigmask);
1244 fake_foreign_function_call(ctx);
1246 WITH_GC_AT_SAFEPOINTS_ONLY() {
1247 /* Allocate the SAP objects while the "interrupts" are still
1249 context_sap = alloc_sap(ctx);
1250 exception_record_sap = alloc_sap(exception_record);
1251 #if defined(LISP_FEATURE_SB_THREAD)
1252 thread_sigmask(SIG_SETMASK, &ctx->sigmask, NULL);
1255 /* The exception system doesn't automatically clear pending
1256 * exceptions, so we lose as soon as we execute any FP
1257 * instruction unless we do this first. */
1258 /* Call into lisp to handle things. */
1259 funcall2(StaticSymbolFunction(HANDLE_WIN32_EXCEPTION),
1261 exception_record_sap);
1263 /* If Lisp doesn't nlx, we need to put things back. */
1264 undo_fake_foreign_function_call(ctx);
1265 #if defined(LISP_FEATURE_SB_THREAD)
1266 thread_sigmask(SIG_SETMASK, &ctx->sigmask, NULL);
1268 /* FIXME: HANDLE-WIN32-EXCEPTION should be allowed to decline */
1272 fprintf(stderr, "Exception Code: 0x%p.\n",
1273 (void*)(intptr_t)exception_record->ExceptionCode);
1274 fprintf(stderr, "Faulting IP: 0x%p.\n",
1275 (void*)(intptr_t)exception_record->ExceptionAddress);
1276 if (exception_record->ExceptionCode == EXCEPTION_ACCESS_VIOLATION) {
1277 MEMORY_BASIC_INFORMATION mem_info;
1279 if (VirtualQuery(fault_address, &mem_info, sizeof mem_info)) {
1280 fprintf(stderr, "page status: 0x%lx.\n", mem_info.State);
1283 fprintf(stderr, "Was writing: %p, where: 0x%p.\n",
1284 (void*)exception_record->ExceptionInformation[0],
1290 fake_foreign_function_call(ctx);
1291 lose("Exception too early in cold init, cannot continue.");
1295 * A good explanation of the exception handling semantics is
1296 * http://win32assembly.online.fr/Exceptionhandling.html (possibly defunct)
1298 * http://www.microsoft.com/msj/0197/exception/exception.aspx
1301 EXCEPTION_DISPOSITION
1302 handle_exception(EXCEPTION_RECORD *exception_record,
1303 struct lisp_exception_frame *exception_frame,
1304 CONTEXT *win32_context,
1305 void *dispatcher_context)
1308 /* Not certain why this should be possible, but let's be safe... */
1309 return ExceptionContinueSearch;
1311 if (exception_record->ExceptionFlags & (EH_UNWINDING | EH_EXIT_UNWIND)) {
1312 /* If we're being unwound, be graceful about it. */
1314 /* Undo any dynamic bindings. */
1315 unbind_to_here(exception_frame->bindstack_pointer,
1316 arch_os_get_current_thread());
1317 return ExceptionContinueSearch;
1320 DWORD lastError = GetLastError();
1321 DWORD lastErrno = errno;
1322 DWORD code = exception_record->ExceptionCode;
1323 struct thread* self = arch_os_get_current_thread();
1325 os_context_t context, *ctx = &context;
1326 context.win32_context = win32_context;
1327 #if defined(LISP_FEATURE_SB_THREAD)
1328 context.sigmask = self ? self->os_thread->blocked_signal_set : 0;
1331 /* For EXCEPTION_ACCESS_VIOLATION only. */
1332 void *fault_address = (void *)exception_record->ExceptionInformation[1];
1335 "SEH: rec %p, ctxptr %p, rip %p, fault %p\n"
1336 "... code %p, rcx %p, fp-tags %p\n\n",
1339 voidreg(win32_context,ip),
1341 (void*)(intptr_t)code,
1342 voidreg(win32_context,cx),
1343 win32_context->FloatSave.TagWord);
1345 /* This function had become unwieldy. Let's cut it down into
1346 * pieces based on the different exception codes. Each exception
1347 * code handler gets the chance to decline by returning non-zero if it
1352 case EXCEPTION_ACCESS_VIOLATION:
1353 rc = handle_access_violation(
1354 ctx, exception_record, fault_address, self);
1357 case SBCL_EXCEPTION_BREAKPOINT:
1358 rc = handle_breakpoint_trap(ctx, self);
1361 #if defined(LISP_FEATURE_X86)
1362 case EXCEPTION_SINGLE_STEP:
1363 rc = handle_single_step(ctx);
1372 /* All else failed, drop through to the lisp-side exception handler. */
1373 signal_internal_error_or_lose(ctx, exception_record, fault_address);
1376 SetLastError(lastError);
1377 return ExceptionContinueExecution;
1381 wos_install_interrupt_handlers(struct lisp_exception_frame *handler)
1383 #ifdef LISP_FEATURE_X86
1384 handler->next_frame = get_seh_frame();
1385 handler->handler = (void*)exception_handler_wrapper;
1386 set_seh_frame(handler);
1388 static int once = 0;
1390 AddVectoredExceptionHandler(1,veh);
1395 * The stubs below are replacements for the windows versions,
1396 * which can -fail- when used in our memory spaces because they
1397 * validate the memory spaces they are passed in a way that
1398 * denies our exception handler a chance to run.
1401 void *memmove(void *dest, const void *src, size_t n)
1405 for (i = 0; i < n; i++) *(((char *)dest)+i) = *(((char *)src)+i);
1407 while (n--) *(((char *)dest)+n) = *(((char *)src)+n);
1412 void *memcpy(void *dest, const void *src, size_t n)
1414 while (n--) *(((char *)dest)+n) = *(((char *)src)+n);
1418 char *dirname(char *path)
1420 static char buf[PATH_MAX + 1];
1421 size_t pathlen = strlen(path);
1424 if (pathlen >= sizeof(buf)) {
1425 lose("Pathname too long in dirname.\n");
1430 for (i = pathlen; i >= 0; --i) {
1431 if (buf[i] == '/' || buf[i] == '\\') {
1440 // 0 - not a socket or other error, 1 - has input, 2 - has no input
1442 socket_input_available(HANDLE socket)
1444 unsigned long count = 0, count_size = 0;
1445 int wsaErrno = GetLastError();
1446 int err = WSAIoctl((SOCKET)socket, FIONREAD, NULL, 0,
1447 &count, sizeof(count), &count_size, NULL, NULL);
1452 ret = (count > 0) ? 1 : 2;
1455 SetLastError(wsaErrno);
1459 /* Unofficial but widely used property of console handles: they have
1460 #b11 in two minor bits, opposed to other handles, that are
1461 machine-word-aligned. Properly emulated even on wine.
1463 Console handles are special in many aspects, e.g. they aren't NTDLL
1464 system handles: kernel32 redirects console operations to CSRSS
1465 requests. Using the hack below to distinguish console handles is
1466 justified, as it's the only method that won't hang during
1467 outstanding reads, won't try to lock NT kernel object (if there is
1468 one; console isn't), etc. */
1470 console_handle_p(HANDLE handle)
1472 return (handle != NULL)&&
1473 (handle != INVALID_HANDLE_VALUE)&&
1474 ((((int)(intptr_t)handle)&3)==3);
1477 /* Atomically mark current thread as (probably) doing synchronous I/O
1478 * on handle, if no cancellation is requested yet (and return TRUE),
1479 * otherwise clear thread's I/O cancellation flag and return false.
1482 boolean io_begin_interruptible(HANDLE handle)
1484 /* No point in doing it unless OS supports cancellation from other
1486 if (!ptr_CancelIoEx)
1489 if (!__sync_bool_compare_and_swap(&this_thread->synchronous_io_handle_and_flag,
1491 ResetEvent(this_thread->private_events.events[0]);
1492 this_thread->synchronous_io_handle_and_flag = 0;
1498 static pthread_mutex_t interrupt_io_lock = PTHREAD_MUTEX_INITIALIZER;
1500 /* Unmark current thread as (probably) doing synchronous I/O; if an
1501 * I/O cancellation was requested, postpone it until next
1502 * io_begin_interruptible */
1504 io_end_interruptible(HANDLE handle)
1506 if (!ptr_CancelIoEx)
1508 pthread_mutex_lock(&interrupt_io_lock);
1509 __sync_bool_compare_and_swap(&this_thread->synchronous_io_handle_and_flag,
1511 pthread_mutex_unlock(&interrupt_io_lock);
1514 /* Documented limit for ReadConsole/WriteConsole is 64K bytes.
1515 Real limit observed on W2K-SP3 is somewhere in between 32KiB and 64Kib...
1517 #define MAX_CONSOLE_TCHARS 16384
1520 win32_write_unicode_console(HANDLE handle, void * buf, int count)
1526 if (nchars>MAX_CONSOLE_TCHARS) nchars = MAX_CONSOLE_TCHARS;
1528 if (!io_begin_interruptible(handle)) {
1532 result = WriteConsoleW(handle,buf,nchars,&written,NULL);
1533 io_end_interruptible(handle);
1543 DWORD err = GetLastError();
1544 odxprint(io,"WriteConsole fails => %u\n", err);
1545 errno = (err==ERROR_OPERATION_ABORTED ? EINTR : EIO);
1553 * It may be unobvious, but (probably) the most straightforward way of
1554 * providing some sane CL:LISTEN semantics for line-mode console
1555 * channel requires _dedicated input thread_.
1557 * LISTEN should return true iff the next (READ-CHAR) won't have to
1558 * wait. As our console may be shared with another process, entirely
1559 * out of our control, looking at the events in PeekConsoleEvent
1560 * result (and searching for #\Return) doesn't cut it.
1562 * We decided that console input thread must do something smarter than
1563 * a bare loop of continuous ReadConsoleW(). On Unix, user experience
1564 * with the terminal is entirely unaffected by the fact that some
1565 * process does (or doesn't) call read(); the situation on MS Windows
1568 * Echo output and line editing present on MS Windows while some
1569 * process is waiting in ReadConsole(); otherwise all input events are
1570 * buffered. If our thread were calling ReadConsole() all the time, it
1571 * would feel like Unix cooked mode.
1573 * But we don't write a Unix emulator here, even if it sometimes feels
1574 * like that; therefore preserving this aspect of console I/O seems a
1577 * LISTEN itself becomes trivial with dedicated input thread, but the
1578 * goal stated above -- provide `native' user experience with blocked
1579 * console -- don't play well with this trivial implementation.
1581 * What's currently implemented is a compromise, looking as something
1582 * in between Unix cooked mode and Win32 line mode.
1584 * 1. As long as no console I/O function is called (incl. CL:LISTEN),
1585 * console looks `blocked': no echo, no line editing.
1587 * 2. (READ-CHAR), (READ-SEQUENCE) and other functions doing real
1588 * input result in the ReadConsole request (in a dedicated thread);
1590 * 3. Once ReadConsole is called, it is not cancelled in the
1591 * middle. In line mode, it returns when <Enter> key is hit (or
1592 * something like that happens). Therefore, if line editing and echo
1593 * output had a chance to happen, console won't look `blocked' until
1594 * the line is entered (even if line input was triggered by
1597 * 4. LISTEN may request ReadConsole too (if no other thread is
1598 * reading the console and no data are queued). It's the only case
1599 * when the console becomes `unblocked' without any actual input
1600 * requested by Lisp code. LISTEN check if there is at least one
1601 * input event in PeekConsole queue; unless there is such an event,
1602 * ReadConsole is not triggered by LISTEN.
1604 * 5. Console-reading Lisp thread now may be interrupted immediately;
1605 * ReadConsole call itself, however, continues until the line is
1610 WCHAR buffer[MAX_CONSOLE_TCHARS];
1612 pthread_mutex_t lock;
1613 pthread_cond_t cond_has_data;
1614 pthread_cond_t cond_has_client;
1616 boolean initialized;
1618 boolean in_progress;
1619 } ttyinput = {.lock = PTHREAD_MUTEX_INITIALIZER};
1622 tty_read_line_server()
1624 pthread_mutex_lock(&ttyinput.lock);
1625 while (ttyinput.handle) {
1629 while (!ttyinput.in_progress)
1630 pthread_cond_wait(&ttyinput.cond_has_client,&ttyinput.lock);
1632 pthread_mutex_unlock(&ttyinput.lock);
1634 ok = ReadConsoleW(ttyinput.handle,
1635 &ttyinput.buffer[ttyinput.tail],
1636 MAX_CONSOLE_TCHARS-ttyinput.tail,
1639 pthread_mutex_lock(&ttyinput.lock);
1642 ttyinput.tail += nchars;
1643 pthread_cond_broadcast(&ttyinput.cond_has_data);
1645 ttyinput.in_progress = 0;
1647 pthread_mutex_unlock(&ttyinput.lock);
1652 tty_maybe_initialize_unlocked(HANDLE handle)
1654 if (!ttyinput.initialized) {
1655 if (!DuplicateHandle(GetCurrentProcess(),handle,
1656 GetCurrentProcess(),&ttyinput.handle,
1657 0,FALSE,DUPLICATE_SAME_ACCESS)) {
1660 pthread_cond_init(&ttyinput.cond_has_data,NULL);
1661 pthread_cond_init(&ttyinput.cond_has_client,NULL);
1662 pthread_create(&ttyinput.thread,NULL,tty_read_line_server,NULL);
1663 ttyinput.initialized = 1;
1669 win32_tty_listen(HANDLE handle)
1674 pthread_mutex_lock(&ttyinput.lock);
1675 if (!tty_maybe_initialize_unlocked(handle))
1678 if (ttyinput.in_progress) {
1681 if (ttyinput.head != ttyinput.tail) {
1684 if (PeekConsoleInput(ttyinput.handle,&ir,1,&nevents) && nevents) {
1685 ttyinput.in_progress = 1;
1686 pthread_cond_broadcast(&ttyinput.cond_has_client);
1690 pthread_mutex_unlock(&ttyinput.lock);
1695 tty_read_line_client(HANDLE handle, void* buf, int count)
1698 int nchars = count / sizeof(WCHAR);
1703 if (nchars>MAX_CONSOLE_TCHARS)
1704 nchars=MAX_CONSOLE_TCHARS;
1706 count = nchars*sizeof(WCHAR);
1708 pthread_mutex_lock(&ttyinput.lock);
1710 if (!tty_maybe_initialize_unlocked(handle)) {
1717 while (ttyinput.head == ttyinput.tail) {
1718 if (!io_begin_interruptible(ttyinput.handle)) {
1719 ttyinput.in_progress = 0;
1724 if (!ttyinput.in_progress) {
1725 /* We are to wait */
1726 ttyinput.in_progress=1;
1727 /* wake console reader */
1728 pthread_cond_broadcast(&ttyinput.cond_has_client);
1730 pthread_cond_wait(&ttyinput.cond_has_data, &ttyinput.lock);
1731 io_end_interruptible(ttyinput.handle);
1734 result = sizeof(WCHAR)*(ttyinput.tail-ttyinput.head);
1735 if (result > count) {
1740 DWORD nch,offset = 0;
1743 memcpy(buf,&ttyinput.buffer[ttyinput.head],count);
1744 ttyinput.head += (result / sizeof(WCHAR));
1745 if (ttyinput.head == ttyinput.tail)
1746 ttyinput.head = ttyinput.tail = 0;
1748 for (nch=0;nch<result/sizeof(WCHAR);++nch) {
1749 if (ubuf[nch]==13) {
1752 ubuf[nch-offset]=ubuf[nch];
1755 result-=offset*sizeof(WCHAR);
1760 ttyinput.head = ttyinput.tail = 0;
1765 pthread_mutex_unlock(&ttyinput.lock);
1770 win32_read_unicode_console(HANDLE handle, void* buf, int count)
1774 result = tty_read_line_client(handle,buf,count);
1779 win32_maybe_interrupt_io(void* thread)
1781 struct thread *th = thread;
1783 if (ptr_CancelIoEx) {
1784 pthread_mutex_lock(&interrupt_io_lock);
1786 InterlockedExchangePointer((volatile LPVOID *)
1787 &th->synchronous_io_handle_and_flag,
1788 (LPVOID)INVALID_HANDLE_VALUE);
1789 if (h && (h!=INVALID_HANDLE_VALUE)) {
1790 if (console_handle_p(h)) {
1791 pthread_mutex_lock(&ttyinput.lock);
1792 pthread_cond_broadcast(&ttyinput.cond_has_data);
1793 pthread_mutex_unlock(&ttyinput.lock);
1795 if (ptr_CancelSynchronousIo) {
1796 pthread_mutex_lock(&th->os_thread->fiber_lock);
1797 done = !!ptr_CancelSynchronousIo(th->os_thread->fiber_group->handle);
1798 pthread_mutex_unlock(&th->os_thread->fiber_lock);
1800 done |= !!ptr_CancelIoEx(h,NULL);
1802 pthread_mutex_unlock(&interrupt_io_lock);
1807 static const LARGE_INTEGER zero_large_offset = {.QuadPart = 0LL};
1810 win32_unix_write(HANDLE handle, void * buf, int count)
1812 DWORD written_bytes;
1813 OVERLAPPED overlapped;
1814 struct thread * self = arch_os_get_current_thread();
1816 LARGE_INTEGER file_position;
1820 if (console_handle_p(handle))
1821 return win32_write_unicode_console(handle,buf,count);
1823 overlapped.hEvent = self->private_events.events[0];
1824 seekable = SetFilePointerEx(handle,
1829 overlapped.Offset = file_position.LowPart;
1830 overlapped.OffsetHigh = file_position.HighPart;
1832 overlapped.Offset = 0;
1833 overlapped.OffsetHigh = 0;
1835 if (!io_begin_interruptible(handle)) {
1839 ok = WriteFile(handle, buf, count, &written_bytes, &overlapped);
1840 io_end_interruptible(handle);
1843 goto done_something;
1845 DWORD errorCode = GetLastError();
1846 if (errorCode==ERROR_OPERATION_ABORTED) {
1847 GetOverlappedResult(handle,&overlapped,&written_bytes,FALSE);
1851 if (errorCode!=ERROR_IO_PENDING) {
1855 if(WaitForMultipleObjects(2,self->private_events.events,
1856 FALSE,INFINITE) != WAIT_OBJECT_0) {
1862 if (!GetOverlappedResult(handle,&overlapped,&written_bytes,waitInGOR)) {
1863 if (GetLastError()==ERROR_OPERATION_ABORTED) {
1870 goto done_something;
1876 file_position.QuadPart += written_bytes;
1877 SetFilePointerEx(handle,file_position,NULL,FILE_BEGIN);
1879 return written_bytes;
1883 win32_unix_read(HANDLE handle, void * buf, int count)
1885 OVERLAPPED overlapped = {.Internal=0};
1886 DWORD read_bytes = 0;
1887 struct thread * self = arch_os_get_current_thread();
1888 DWORD errorCode = 0;
1889 BOOL waitInGOR = FALSE;
1891 LARGE_INTEGER file_position;
1894 if (console_handle_p(handle))
1895 return win32_read_unicode_console(handle,buf,count);
1897 overlapped.hEvent = self->private_events.events[0];
1898 /* If it has a position, we won't try overlapped */
1899 seekable = SetFilePointerEx(handle,
1904 overlapped.Offset = file_position.LowPart;
1905 overlapped.OffsetHigh = file_position.HighPart;
1907 overlapped.Offset = 0;
1908 overlapped.OffsetHigh = 0;
1910 if (!io_begin_interruptible(handle)) {
1914 ok = ReadFile(handle,buf,count,&read_bytes, &overlapped);
1915 io_end_interruptible(handle);
1918 goto done_something;
1920 errorCode = GetLastError();
1921 if (errorCode == ERROR_HANDLE_EOF ||
1922 errorCode == ERROR_BROKEN_PIPE ||
1923 errorCode == ERROR_NETNAME_DELETED) {
1925 goto done_something;
1927 if (errorCode==ERROR_OPERATION_ABORTED) {
1928 GetOverlappedResult(handle,&overlapped,&read_bytes,FALSE);
1932 if (errorCode!=ERROR_IO_PENDING) {
1933 /* is it some _real_ error? */
1938 if( (ret = WaitForMultipleObjects(2,self->private_events.events,
1939 FALSE,INFINITE)) != WAIT_OBJECT_0) {
1942 /* Waiting for IO only */
1946 ok = GetOverlappedResult(handle,&overlapped,&read_bytes,waitInGOR);
1948 errorCode = GetLastError();
1949 if (errorCode == ERROR_HANDLE_EOF ||
1950 errorCode == ERROR_BROKEN_PIPE ||
1951 errorCode == ERROR_NETNAME_DELETED) {
1953 goto done_something;
1955 if (errorCode == ERROR_OPERATION_ABORTED)
1956 errno = EINTR; /* that's it. */
1958 errno = EIO; /* something unspecific */
1962 goto done_something;
1967 file_position.QuadPart += read_bytes;
1968 SetFilePointerEx(handle,file_position,NULL,FILE_BEGIN);
1973 void __stdcall RtlUnwind(void *, void *, void *, void *); /* I don't have winternl.h */
1975 /* We used to have a scratch() function listing all symbols needed by
1976 * Lisp. Much rejoicing commenced upon its removal. However, I would
1977 * like cold init to fail aggressively when encountering unused symbols.
1978 * That poses a problem, however, since our C code no longer includes
1979 * any references to symbols in ws2_32.dll, and hence the linker
1980 * completely ignores our request to reference it (--no-as-needed does
1981 * not work). Warm init would later load the DLLs explicitly, but then
1982 * it's too late for an early sanity check. In the unfortunate spirit
1983 * of scratch(), continue to reference some required DLLs explicitly by
1984 * means of one scratch symbol per DLL.
1988 /* a function from ws2_32.dll */
1991 /* a function from shell32.dll */
1992 SHGetFolderPathA(0, 0, 0, 0, 0);
1996 os_get_runtime_executable_path(int external)
1998 char path[MAX_PATH + 1];
1999 DWORD bufsize = sizeof(path);
2002 if ((size = GetModuleFileNameA(NULL, path, bufsize)) == 0)
2004 else if (size == bufsize && GetLastError() == ERROR_INSUFFICIENT_BUFFER)
2007 return copied_string(path);
2010 #ifdef LISP_FEATURE_SB_THREAD
2013 win32_wait_object_or_signal(HANDLE waitFor)
2015 struct thread * self = arch_os_get_current_thread();
2017 handles[0] = waitFor;
2018 handles[1] = self->private_events.events[1];
2020 WaitForMultipleObjects(2,handles, FALSE,INFINITE);
2024 * Portability glue for win32 waitable timers.
2026 * One may ask: Why is there a wrapper in C when the calls are so
2027 * obvious that Lisp could do them directly (as it did on Windows)?
2029 * But the answer is that on POSIX platforms, we now emulate the win32
2030 * calls and hide that emulation behind this os_* abstraction.
2035 return CreateWaitableTimer(0, 0, 0);
2039 os_wait_for_wtimer(HANDLE handle)
2041 return win32_wait_object_or_signal(handle);
2045 os_close_wtimer(HANDLE handle)
2047 CloseHandle(handle);
2051 os_set_wtimer(HANDLE handle, int sec, int nsec)
2053 /* in units of 100ns, i.e. 0.1us. Negative for relative semantics. */
2055 = -(((long long) sec) * 10000000
2056 + ((long long) nsec + 99) / 100);
2057 SetWaitableTimer(handle, (LARGE_INTEGER*) &dueTime, 0, 0, 0, 0);
2061 os_cancel_wtimer(HANDLE handle)
2063 CancelWaitableTimer(handle);