0.9.13.46: GET-INTERNAL-RUN-TIME on Windows, + Windows cleanups
[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 <stdio.h>
30 #include <sys/param.h>
31 #include <sys/file.h>
32 #include <io.h>
33 #include "sbcl.h"
34 #include "./signal.h"
35 #include "os.h"
36 #include "arch.h"
37 #include "globals.h"
38 #include "sbcl.h"
39 #include "interrupt.h"
40 #include "interr.h"
41 #include "lispregs.h"
42 #include "runtime.h"
43 #include "alloc.h"
44 #include "genesis/primitive-objects.h"
45
46 #include <sys/types.h>
47 #include <signal.h>
48 #include <sys/time.h>
49 #include <sys/stat.h>
50 #include <unistd.h>
51 #include <shlobj.h>
52
53 #include <excpt.h>
54
55 #include "validate.h"
56 #include "thread.h"
57 size_t os_vm_page_size;
58
59
60 #include "gc.h"
61 #include "gencgc-internal.h"
62
63 #if 0
64 int linux_sparc_siginfo_bug = 0;
65 int linux_supports_futex=0;
66 #endif
67
68 /* The exception handling function looks like this: */
69 EXCEPTION_DISPOSITION handle_exception(EXCEPTION_RECORD *,
70                                        struct lisp_exception_frame *,
71                                        CONTEXT *,
72                                        void *);
73
74 void *base_seh_frame;
75
76 static void *get_seh_frame(void)
77 {
78     void* retval;
79     asm volatile ("movl %%fs:0,%0": "=r" (retval));
80     return retval;
81 }
82
83 static void set_seh_frame(void *frame)
84 {
85     asm volatile ("movl %0,%%fs:0": : "r" (frame));
86 }
87
88 static struct lisp_exception_frame *find_our_seh_frame(void)
89 {
90     struct lisp_exception_frame *frame = get_seh_frame();
91
92     while (frame->handler != handle_exception)
93         frame = frame->next_frame;
94
95     return frame;
96 }
97
98 #if 0
99 inline static void *get_stack_frame(void)
100 {
101     void* retval;
102     asm volatile ("movl %%ebp,%0": "=r" (retval));
103     return retval;
104 }
105 #endif
106
107 void os_init(char *argv[], char *envp[])
108 {
109     SYSTEM_INFO system_info;
110
111     GetSystemInfo(&system_info);
112     os_vm_page_size = system_info.dwPageSize;
113
114     base_seh_frame = get_seh_frame();
115 }
116
117
118 /*
119  * So we have three fun scenarios here.
120  *
121  * First, we could be being called to reserve the memory areas
122  * during initialization (prior to loading the core file).
123  *
124  * Second, we could be being called by the GC to commit a page
125  * that has just been decommitted (for easy zero-fill).
126  *
127  * Third, we could be being called by create_thread_struct()
128  * in order to create the sundry and various stacks.
129  *
130  * The third case is easy to pick out because it passes an
131  * addr of 0.
132  *
133  * The second case is easy to pick out because it will be for
134  * a range of memory that is MEM_RESERVE rather than MEM_FREE.
135  *
136  * The second case is also an easy implement, because we leave
137  * the memory as reserved (since we do lazy commits).
138  */
139
140 os_vm_address_t
141 os_validate(os_vm_address_t addr, os_vm_size_t len)
142 {
143     MEMORY_BASIC_INFORMATION mem_info;
144
145     if (!addr) {
146         /* the simple case first */
147         os_vm_address_t real_addr;
148         if (!(real_addr = VirtualAlloc(addr, len, MEM_COMMIT, PAGE_EXECUTE_READWRITE))) {
149             perror("VirtualAlloc");
150             return 0;
151         }
152
153         return real_addr;
154     }
155
156     if (!VirtualQuery(addr, &mem_info, sizeof mem_info)) {
157         perror("VirtualQuery");
158         return 0;
159     }
160
161     if ((mem_info.State == MEM_RESERVE) && (mem_info.RegionSize >=len)) return addr;
162
163     if (mem_info.State == MEM_RESERVE) {
164         fprintf(stderr, "validation of reserved space too short.\n");
165         fflush(stderr);
166     }
167
168     if (!VirtualAlloc(addr, len, (mem_info.State == MEM_RESERVE)? MEM_COMMIT: MEM_RESERVE, PAGE_EXECUTE_READWRITE)) {
169         perror("VirtualAlloc");
170         return 0;
171     }
172
173     return addr;
174 }
175
176 /*
177  * For os_invalidate(), we merely decommit the memory rather than
178  * freeing the address space. This loses when freeing per-thread
179  * data and related memory since it leaks address space. It's not
180  * too lossy, however, since the two scenarios I'm aware of are
181  * fd-stream buffers, which are pooled rather than torched, and
182  * thread information, which I hope to pool (since windows creates
183  * threads at its own whim, and we probably want to be able to
184  * have them callback without funky magic on the part of the user,
185  * and full-on thread allocation is fairly heavyweight). Someone
186  * will probably shoot me down on this with some pithy comment on
187  * the use of (setf symbol-value) on a special variable. I'm happy
188  * for them.
189  */
190
191 void
192 os_invalidate(os_vm_address_t addr, os_vm_size_t len)
193 {
194     if (!VirtualFree(addr, len, MEM_DECOMMIT)) {
195         perror("VirtualFree");
196     }
197 }
198
199 /*
200  * os_map() is called to map a chunk of the core file into memory.
201  *
202  * Unfortunately, Windows semantics completely screws this up, so
203  * we just add backing store from the swapfile to where the chunk
204  * goes and read it up like a normal file. We could consider using
205  * a lazy read (demand page) setup, but that would mean keeping an
206  * open file pointer for the core indefinately (and be one more
207  * thing to maintain).
208  */
209
210 os_vm_address_t
211 os_map(int fd, int offset, os_vm_address_t addr, os_vm_size_t len)
212 {
213     os_vm_size_t count;
214
215     fprintf(stderr, "os_map: %d, 0x%x, %p, 0x%x.\n", fd, offset, addr, len);
216     fflush(stderr);
217
218     if (!VirtualAlloc(addr, len, MEM_COMMIT, PAGE_EXECUTE_READWRITE)) {
219         perror("VirtualAlloc");
220         lose("os_map: VirtualAlloc failure");
221     }
222
223     if (lseek(fd, offset, SEEK_SET) == -1) {
224         lose("os_map: Seek failure.");
225     }
226
227     count = read(fd, addr, len);
228     if (count != len) {
229         fprintf(stderr, "expected 0x%x, read 0x%x.\n", len, count);
230         lose("os_map: Failed to read enough bytes.");
231     }
232
233     return addr;
234 }
235
236 static DWORD os_protect_modes[8] = {
237     PAGE_NOACCESS,
238     PAGE_READONLY,
239     PAGE_READWRITE,
240     PAGE_READWRITE,
241     PAGE_EXECUTE,
242     PAGE_EXECUTE_READ,
243     PAGE_EXECUTE_READWRITE,
244     PAGE_EXECUTE_READWRITE,
245 };
246
247 void
248 os_protect(os_vm_address_t address, os_vm_size_t length, os_vm_prot_t prot)
249 {
250     DWORD old_prot;
251
252     if (!VirtualProtect(address, length, os_protect_modes[prot], &old_prot)) {
253         fprintf(stderr, "VirtualProtect failed, code 0x%lx.\n", GetLastError());
254         fflush(stderr);
255     }
256 }
257
258 /* FIXME: Now that FOO_END, rather than FOO_SIZE, is the fundamental
259  * description of a space, we could probably punt this and just do
260  * (FOO_START <= x && x < FOO_END) everywhere it's called. */
261 static boolean
262 in_range_p(os_vm_address_t a, lispobj sbeg, size_t slen)
263 {
264     char* beg = (char*)((long)sbeg);
265     char* end = (char*)((long)sbeg) + slen;
266     char* adr = (char*)a;
267     return (adr >= beg && adr < end);
268 }
269
270 boolean
271 is_valid_lisp_addr(os_vm_address_t addr)
272 {
273     struct thread *th;
274     if(in_range_p(addr, READ_ONLY_SPACE_START, READ_ONLY_SPACE_SIZE) ||
275        in_range_p(addr, STATIC_SPACE_START   , STATIC_SPACE_SIZE) ||
276        in_range_p(addr, DYNAMIC_SPACE_START  , DYNAMIC_SPACE_SIZE))
277         return 1;
278     for_each_thread(th) {
279         if(((os_vm_address_t)th->control_stack_start <= addr) && (addr < (os_vm_address_t)th->control_stack_end))
280             return 1;
281         if(in_range_p(addr, (unsigned long)th->binding_stack_start, BINDING_STACK_SIZE))
282             return 1;
283     }
284     return 0;
285 }
286
287 /*
288  * any OS-dependent special low-level handling for signals
289  */
290
291 /* A tiny bit of interrupt.c state we want our paws on. */
292 extern boolean internal_errors_enabled;
293
294 /*
295  * FIXME: There is a potential problem with foreign code here.
296  * If we are running foreign code instead of lisp code and an
297  * exception occurs we arrange a call into Lisp. If the
298  * foreign code has installed an exception handler, we run the
299  * very great risk of throwing through their exception handler
300  * without asking it to unwind. This is more a problem with
301  * non-sigtrap (EXCEPTION_BREAKPOINT) exceptions, as they could
302  * reasonably be expected to happen in foreign code. We need to
303  * figure out the exception handler unwind semantics and adhere
304  * to them (probably by abusing the Lisp unwind-protect system)
305  * if we are going to handle this scenario correctly.
306  *
307  * A good explanation of the exception handling semantics is
308  * http://win32assembly.online.fr/Exceptionhandling.html .
309  * We will also need to handle this ourselves when foreign
310  * code tries to unwind -us-.
311  *
312  * When unwinding through foreign code we should unwind the
313  * Lisp stack to the entry from foreign code, then unwind the
314  * foreign code stack to the entry from Lisp, then resume
315  * unwinding in Lisp.
316  */
317
318 EXCEPTION_DISPOSITION sigtrap_emulator(CONTEXT *context,
319                                        struct lisp_exception_frame *exception_frame)
320 {
321     if (*((char *)context->Eip + 1) == trap_ContextRestore) {
322         /*
323          * This is the cleanup for what is immediately below, and
324          * for the generic exception handling further below. We
325          * have to memcpy() the original context (emulated sigtrap
326          * or normal exception) over our context and resume it.
327          */
328         memcpy(context, &exception_frame->context, sizeof(CONTEXT));
329         return ExceptionContinueExecution;
330
331     } else { /* Not a trap_ContextRestore, must be a sigtrap. */
332         /* sigtrap_trampoline is defined in x86-assem.S. */
333         extern void sigtrap_trampoline;
334
335         /*
336          * Unlike some other operating systems, Win32 leaves EIP
337          * pointing to the breakpoint instruction.
338          */
339         context->Eip++;
340
341         /*
342          * We're not on an alternate stack like we would be in some
343          * other operating systems, and we don't want to risk leaking
344          * any important resources if we throw out of the sigtrap
345          * handler, so we need to copy off our context to a "safe"
346          * place and then monkey with the return EIP to point to a
347          * trampoline which calls another function which copies the
348          * context out to a really-safe place and then calls the real
349          * sigtrap handler. When the real sigtrap handler returns, the
350          * trampoline then contains another breakpoint with a code of
351          * trap_ContextRestore (see above). Essentially the same
352          * mechanism is used by the generic exception path. There is
353          * a small window of opportunity between us copying the
354          * context to the "safe" place and the sigtrap wrapper copying
355          * it to the really-safe place (allocated in its stack frame)
356          * during which the context can be smashed. The only scenario
357          * I can come up with for this, however, involves a stack
358          * overflow occuring at just the wrong time (which makes one
359          * wonder how stack overflow exceptions even happen, given
360          * that we don't switch stacks for exception processing...)
361          */
362         memcpy(&exception_frame->context, context, sizeof(CONTEXT));
363         context->Eax = context->Eip;
364         context->Eip = (unsigned long)&sigtrap_trampoline;
365
366         /* and return */
367         return ExceptionContinueExecution;
368     }
369 }
370
371 void sigtrap_wrapper(void)
372 {
373     /*
374      * This is the wrapper around the sigtrap handler called from
375      * the trampoline returned to from the function above.
376      *
377      * There actually is a point to some of the commented-out code
378      * in this function, although it really belongs to the callback
379      * wrappers. Once it is installed there, it can probably be
380      * removed from here.
381      */
382
383     extern void sigtrap_handler(int signal, siginfo_t *info, void *context);
384
385 /*     volatile struct { */
386 /*      void *handler[2]; */
387     CONTEXT context;
388 /*     } handler; */
389
390     struct lisp_exception_frame *frame = find_our_seh_frame();
391
392 /*     wos_install_interrupt_handlers(handler); */
393 /*     handler.handler[0] = get_seh_frame(); */
394 /*     handler.handler[1] = &handle_exception; */
395 /*     set_seh_frame(&handler); */
396
397     memcpy(&context, &frame->context, sizeof(CONTEXT));
398     sigtrap_handler(0, NULL, &context);
399     memcpy(&frame->context, &context, sizeof(CONTEXT));
400
401 /*     set_seh_frame(handler.handler[0]); */
402 }
403
404 EXCEPTION_DISPOSITION handle_exception(EXCEPTION_RECORD *exception_record,
405                                        struct lisp_exception_frame *exception_frame,
406                                        CONTEXT *context,
407                                        void *dc) /* FIXME: What's dc again? */
408 {
409
410     /* For EXCEPTION_ACCESS_VIOLATION only. */
411     void *fault_address = (void *)exception_record->ExceptionInformation[1];
412
413     if (exception_record->ExceptionCode == EXCEPTION_BREAKPOINT) {
414         /* Pick off sigtrap case first. */
415         return sigtrap_emulator(context, exception_frame);
416
417     } else if (exception_record->ExceptionCode == EXCEPTION_ACCESS_VIOLATION &&
418                (is_valid_lisp_addr(fault_address) ||
419                 /* the linkage table does not contain valid lisp
420                  * objects, but is also committed on-demand here
421                  */
422                 in_range_p(fault_address, LINKAGE_TABLE_SPACE_START,
423                            LINKAGE_TABLE_SPACE_END))) {
424         /* Pick off GC-related memory fault next. */
425         MEMORY_BASIC_INFORMATION mem_info;
426
427         if (!VirtualQuery(fault_address, &mem_info, sizeof mem_info)) {
428             fprintf(stderr, "VirtualQuery: 0x%lx.\n", GetLastError());
429             lose("handle_exception: VirtualQuery failure");
430         }
431
432         if (mem_info.State == MEM_RESERVE) {
433             /* First use new page, lets get some memory for it. */
434             if (!VirtualAlloc(mem_info.BaseAddress, os_vm_page_size,
435                               MEM_COMMIT, PAGE_EXECUTE_READWRITE)) {
436                 fprintf(stderr, "VirtualAlloc: 0x%lx.\n", GetLastError());
437                 lose("handle_exception: VirtualAlloc failure");
438
439             } else {
440                 /*
441                  * Now, if the page is supposedly write-protected and this
442                  * is a write, tell the gc that it's been hit.
443                  *
444                  * FIXME: Are we supposed to fall-through to the Lisp
445                  * exception handler if the gc doesn't take the wp violation?
446                  */
447                 if (exception_record->ExceptionInformation[0]) {
448                     int index = find_page_index(fault_address);
449                     if ((index != -1) && (page_table[index].write_protected)) {
450                         gencgc_handle_wp_violation(fault_address);
451                     }
452                 }
453                 return ExceptionContinueExecution;
454             }
455
456         } else if (gencgc_handle_wp_violation(fault_address)) {
457             /* gc accepts the wp violation, so resume where we left off. */
458             return ExceptionContinueExecution;
459         }
460
461         /* All else failed, drop through to the lisp-side exception handler. */
462     }
463
464     /*
465      * If we fall through to here then we need to either forward
466      * the exception to the lisp-side exception handler if it's
467      * set up, or drop to LDB.
468      */
469
470     if (internal_errors_enabled) {
471         /* exception_trampoline is defined in x86-assem.S. */
472         extern void exception_trampoline;
473
474         /*
475          * We're making the somewhat arbitrary decision that
476          * having internal errors enabled means that lisp has
477          * sufficient marbles to be able to handle exceptions.
478          *
479          * Exceptions aren't supposed to happen during cold
480          * init or reinit anyway.
481          */
482
483         /*
484          * We use the same mechanism as the sigtrap emulator above
485          * with just a couple changes. We obviously use a different
486          * trampoline and wrapper function, we kill out any live
487          * floating point exceptions, and we save off the exception
488          * record as well as the context.
489          */
490
491         /* Save off context and exception information */
492         memcpy(&exception_frame->context, context, sizeof(CONTEXT));
493         memcpy(&exception_frame->exception, exception_record, sizeof(EXCEPTION_RECORD));
494
495         /* Set up to activate trampoline when we return */
496         context->Eax = context->Eip;
497         context->Eip = (unsigned long)&exception_trampoline;
498
499         /* Make sure a floating-point trap doesn't kill us */
500         context->FloatSave.StatusWord &= ~0x3f;
501
502         /* And return */
503         return ExceptionContinueExecution;
504     }
505
506     fprintf(stderr, "Exception Code: 0x%lx.\n", exception_record->ExceptionCode);
507     fprintf(stderr, "Faulting IP: 0x%lx.\n", (DWORD)exception_record->ExceptionAddress);
508     if (exception_record->ExceptionCode == EXCEPTION_ACCESS_VIOLATION) {
509         MEMORY_BASIC_INFORMATION mem_info;
510
511         if (VirtualQuery(fault_address, &mem_info, sizeof mem_info)) {
512             fprintf(stderr, "page status: 0x%lx.\n", mem_info.State);
513         }
514
515         fprintf(stderr, "Was writing: %ld, where: 0x%lx.\n",
516                 exception_record->ExceptionInformation[0],
517                 (DWORD)fault_address);
518     }
519
520     fflush(stderr);
521
522     fake_foreign_function_call(context);
523     lose("fake_foreign_function_call fell through");
524
525     /* FIXME: WTF? How are we supposed to end up here? */
526     return ExceptionContinueSearch;
527 }
528
529 void handle_win32_exception_wrapper(void)
530 {
531     struct lisp_exception_frame *frame = find_our_seh_frame();
532     CONTEXT context;
533     EXCEPTION_RECORD exception_record;
534     lispobj context_sap;
535     lispobj exception_record_sap;
536
537     memcpy(&context, &frame->context, sizeof(CONTEXT));
538     memcpy(&exception_record, &frame->exception, sizeof(EXCEPTION_RECORD));
539
540     fake_foreign_function_call(&context);
541
542     /* Allocate the SAP objects while the "interrupts" are still
543      * disabled. */
544     context_sap = alloc_sap(&context);
545     exception_record_sap = alloc_sap(&exception_record);
546
547     funcall2(SymbolFunction(HANDLE_WIN32_EXCEPTION), context_sap,
548              exception_record_sap);
549
550     undo_fake_foreign_function_call(&context);
551
552     memcpy(&frame->context, &context, sizeof(CONTEXT));
553 }
554
555 void
556 wos_install_interrupt_handlers(struct lisp_exception_frame *handler)
557 {
558     handler->next_frame = get_seh_frame();
559     handler->handler = &handle_exception;
560     set_seh_frame(handler);
561 }
562
563 void bcopy(const void *src, void *dest, size_t n)
564 {
565     MoveMemory(dest, src, n);
566 }
567
568 /*
569  * The stubs below are replacements for the windows versions,
570  * which can -fail- when used in our memory spaces because they
571  * validate the memory spaces they are passed in a way that
572  * denies our exception handler a chance to run.
573  */
574
575 void *memmove(void *dest, const void *src, size_t n)
576 {
577     if (dest < src) {
578         int i;
579         for (i = 0; i < n; i++) *(((char *)dest)+i) = *(((char *)src)+i);
580     } else {
581         while (n--) *(((char *)dest)+n) = *(((char *)src)+n);
582     }
583     return dest;
584 }
585
586 void *memcpy(void *dest, const void *src, size_t n)
587 {
588     while (n--) *(((char *)dest)+n) = *(((char *)src)+n);
589     return dest;
590 }
591
592 char *dirname(char *path)
593 {
594     static char buf[PATH_MAX + 1];
595     size_t pathlen = strlen(path);
596     int i;
597
598     if (pathlen >= sizeof(buf)) {
599         lose("Pathname too long in dirname.\n");
600         return NULL;
601     }
602
603     strcpy(buf, path);
604     for (i = pathlen; i >= 0; --i) {
605         if (buf[i] == '/' || buf[i] == '\\') {
606             buf[i] = '\0';
607             break;
608         }
609     }
610
611     return buf;
612 }
613
614 /* This is a manually-maintained version of ldso_stubs.S. */
615
616 void scratch(void)
617 {
618     strerror(42);
619     asin(0);
620     acos(0);
621     sinh(0);
622     cosh(0);
623     hypot(0, 0);
624     write(0, 0, 0);
625     close(0);
626     #ifndef LISP_FEATURE_SB_UNICODE
627       MoveFileA(0,0);
628     #else
629       MoveFileW(0,0);
630     #endif
631     #ifndef LISP_FEATURE_SB_UNICODE
632       GetCurrentDirectoryA(0,0);
633     #else
634       GetCurrentDirectoryW(0,0);
635     #endif
636     dup(0);
637     LoadLibrary(0);
638     GetProcAddress(0, 0);
639     FreeLibrary(0);
640     #ifndef LISP_FEATURE_SB_UNICODE
641       CreateDirectoryA(0,0);
642     #else
643       CreateDirectoryW(0,0);
644     #endif
645     _pipe(0,0,0);
646     isatty(0);
647     access(0,0);
648     GetLastError();
649     FormatMessageA(0, 0, 0, 0, 0, 0, 0);
650     #ifdef LISP_FEATURE_SB_UNICODE
651       FormatMessageW(0, 0, 0, 0, 0, 0, 0);
652     #endif
653     _get_osfhandle(0);
654     ReadFile(0, 0, 0, 0, 0);
655     WriteFile(0, 0, 0, 0, 0);
656     PeekNamedPipe(0, 0, 0, 0, 0, 0);
657     FlushConsoleInputBuffer(0);
658     PeekConsoleInput(0, 0, 0, 0);
659     Sleep(0);
660     #ifndef LISP_FEATURE_SB_UNICODE
661       SHGetFolderPathA(0, 0, 0, 0, 0);
662     #else
663       SHGetFolderPathW(0, 0, 0, 0, 0);
664     #endif
665     GetACP();
666     GetOEMCP();
667     LocalFree(0);
668     #ifndef LISP_FEATURE_SB_UNICODE
669       GetEnvironmentVariableA(0, 0, 0);
670     #else
671       GetEnvironmentVariableW(0, 0, 0);
672     #endif
673     GetConsoleCP();
674     GetConsoleOutputCP();
675     GetExitCodeProcess(0, 0);
676     GetCurrentProcess();
677     GetProcessTimes(0, 0, 0, 0, 0);
678 }
679
680 char *
681 os_get_runtime_executable_path()
682 {
683     char path[MAX_PATH + 1];
684     DWORD bufsize = sizeof(path);
685     DWORD size;
686
687     if ((size = GetModuleFileNameA(NULL, path, bufsize)) == 0)
688         return NULL;
689     else if (size == bufsize && GetLastError() == ERROR_INSUFFICIENT_BUFFER)
690         return NULL;
691
692     return copied_string(path);
693 }
694
695 /* EOF */