1.0.7.33: better handling of ASSOC and MEMBER on empty lists
[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 <sys/param.h>
32 #include <sys/file.h>
33 #include <io.h>
34 #include "sbcl.h"
35 #include "./signal.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 <signal.h>
50 #include <sys/time.h>
51 #include <sys/stat.h>
52 #include <unistd.h>
53
54 /* KLUDGE: Avoid double definition of boolean by rpcndr.h included via
55  * shlobj.h.
56  *
57  * FIXME: We should probably arrange to use the rpcndr.h boolean on Windows,
58  * or get rid of our own boolean type.
59  */
60 #define boolean rpcndr_boolean
61 #include <shlobj.h>
62 #undef boolean
63
64 #include <math.h>
65 #include <float.h>
66
67 #include <excpt.h>
68
69 #include "validate.h"
70 #include "thread.h"
71 size_t os_vm_page_size;
72
73 #include "gc.h"
74 #include "gencgc-internal.h"
75
76 #if 0
77 int linux_sparc_siginfo_bug = 0;
78 int linux_supports_futex=0;
79 #endif
80
81 /* The exception handling function looks like this: */
82 EXCEPTION_DISPOSITION handle_exception(EXCEPTION_RECORD *,
83                                        struct lisp_exception_frame *,
84                                        CONTEXT *,
85                                        void *);
86
87 void *base_seh_frame;
88
89 static void *get_seh_frame(void)
90 {
91     void* retval;
92     asm volatile ("movl %%fs:0,%0": "=r" (retval));
93     return retval;
94 }
95
96 static void set_seh_frame(void *frame)
97 {
98     asm volatile ("movl %0,%%fs:0": : "r" (frame));
99 }
100
101 #if 0
102 static struct lisp_exception_frame *find_our_seh_frame(void)
103 {
104     struct lisp_exception_frame *frame = get_seh_frame();
105
106     while (frame->handler != handle_exception)
107         frame = frame->next_frame;
108
109     return frame;
110 }
111
112 inline static void *get_stack_frame(void)
113 {
114     void* retval;
115     asm volatile ("movl %%ebp,%0": "=r" (retval));
116     return retval;
117 }
118 #endif
119
120 void os_init(char *argv[], char *envp[])
121 {
122     SYSTEM_INFO system_info;
123
124     GetSystemInfo(&system_info);
125     os_vm_page_size = system_info.dwPageSize;
126
127     base_seh_frame = get_seh_frame();
128 }
129
130
131 /*
132  * So we have three fun scenarios here.
133  *
134  * First, we could be being called to reserve the memory areas
135  * during initialization (prior to loading the core file).
136  *
137  * Second, we could be being called by the GC to commit a page
138  * that has just been decommitted (for easy zero-fill).
139  *
140  * Third, we could be being called by create_thread_struct()
141  * in order to create the sundry and various stacks.
142  *
143  * The third case is easy to pick out because it passes an
144  * addr of 0.
145  *
146  * The second case is easy to pick out because it will be for
147  * a range of memory that is MEM_RESERVE rather than MEM_FREE.
148  *
149  * The second case is also an easy implement, because we leave
150  * the memory as reserved (since we do lazy commits).
151  */
152
153 os_vm_address_t
154 os_validate(os_vm_address_t addr, os_vm_size_t len)
155 {
156     MEMORY_BASIC_INFORMATION mem_info;
157
158     if (!addr) {
159         /* the simple case first */
160         os_vm_address_t real_addr;
161         if (!(real_addr = VirtualAlloc(addr, len, MEM_COMMIT, PAGE_EXECUTE_READWRITE))) {
162             fprintf(stderr, "VirtualAlloc: 0x%lx.\n", GetLastError());
163             return 0;
164         }
165
166         return real_addr;
167     }
168
169     if (!VirtualQuery(addr, &mem_info, sizeof mem_info)) {
170         fprintf(stderr, "VirtualQuery: 0x%lx.\n", GetLastError());
171         return 0;
172     }
173
174     if ((mem_info.State == MEM_RESERVE) && (mem_info.RegionSize >=len)) return addr;
175
176     if (mem_info.State == MEM_RESERVE) {
177         fprintf(stderr, "validation of reserved space too short.\n");
178         fflush(stderr);
179     }
180
181     if (!VirtualAlloc(addr, len, (mem_info.State == MEM_RESERVE)? MEM_COMMIT: MEM_RESERVE, PAGE_EXECUTE_READWRITE)) {
182         fprintf(stderr, "VirtualAlloc: 0x%lx.\n", GetLastError());
183         return 0;
184     }
185
186     return addr;
187 }
188
189 /*
190  * For os_invalidate(), we merely decommit the memory rather than
191  * freeing the address space. This loses when freeing per-thread
192  * data and related memory since it leaks address space. It's not
193  * too lossy, however, since the two scenarios I'm aware of are
194  * fd-stream buffers, which are pooled rather than torched, and
195  * thread information, which I hope to pool (since windows creates
196  * threads at its own whim, and we probably want to be able to
197  * have them callback without funky magic on the part of the user,
198  * and full-on thread allocation is fairly heavyweight). Someone
199  * will probably shoot me down on this with some pithy comment on
200  * the use of (setf symbol-value) on a special variable. I'm happy
201  * for them.
202  */
203
204 void
205 os_invalidate(os_vm_address_t addr, os_vm_size_t len)
206 {
207     if (!VirtualFree(addr, len, MEM_DECOMMIT)) {
208         fprintf(stderr, "VirtualFree: 0x%lx.\n", GetLastError());
209     }
210 }
211
212 /*
213  * os_map() is called to map a chunk of the core file into memory.
214  *
215  * Unfortunately, Windows semantics completely screws this up, so
216  * we just add backing store from the swapfile to where the chunk
217  * goes and read it up like a normal file. We could consider using
218  * a lazy read (demand page) setup, but that would mean keeping an
219  * open file pointer for the core indefinately (and be one more
220  * thing to maintain).
221  */
222
223 os_vm_address_t
224 os_map(int fd, int offset, os_vm_address_t addr, os_vm_size_t len)
225 {
226     os_vm_size_t count;
227
228 #if 0
229     fprintf(stderr, "os_map: %d, 0x%x, %p, 0x%x.\n", fd, offset, addr, len);
230     fflush(stderr);
231 #endif
232
233     if (!VirtualAlloc(addr, len, MEM_COMMIT, PAGE_EXECUTE_READWRITE)) {
234         fprintf(stderr, "VirtualAlloc: 0x%lx.\n", GetLastError());
235         lose("os_map: VirtualAlloc failure");
236     }
237
238     if (lseek(fd, offset, SEEK_SET) == -1) {
239         lose("os_map: Seek failure.");
240     }
241
242     count = read(fd, addr, len);
243     if (count != len) {
244         fprintf(stderr, "expected 0x%x, read 0x%x.\n", len, count);
245         lose("os_map: Failed to read enough bytes.");
246     }
247
248     return addr;
249 }
250
251 static DWORD os_protect_modes[8] = {
252     PAGE_NOACCESS,
253     PAGE_READONLY,
254     PAGE_READWRITE,
255     PAGE_READWRITE,
256     PAGE_EXECUTE,
257     PAGE_EXECUTE_READ,
258     PAGE_EXECUTE_READWRITE,
259     PAGE_EXECUTE_READWRITE,
260 };
261
262 void
263 os_protect(os_vm_address_t address, os_vm_size_t length, os_vm_prot_t prot)
264 {
265     DWORD old_prot;
266
267     if (!VirtualProtect(address, length, os_protect_modes[prot], &old_prot)) {
268         fprintf(stderr, "VirtualProtect failed, code 0x%lx.\n", GetLastError());
269         fflush(stderr);
270     }
271 }
272
273 /* FIXME: Now that FOO_END, rather than FOO_SIZE, is the fundamental
274  * description of a space, we could probably punt this and just do
275  * (FOO_START <= x && x < FOO_END) everywhere it's called. */
276 static boolean
277 in_range_p(os_vm_address_t a, lispobj sbeg, size_t slen)
278 {
279     char* beg = (char*)((long)sbeg);
280     char* end = (char*)((long)sbeg) + slen;
281     char* adr = (char*)a;
282     return (adr >= beg && adr < end);
283 }
284
285 boolean
286 is_linkage_table_addr(os_vm_address_t addr)
287 {
288     return in_range_p(addr, LINKAGE_TABLE_SPACE_START, LINKAGE_TABLE_SPACE_END);
289 }
290
291 boolean
292 is_valid_lisp_addr(os_vm_address_t addr)
293 {
294     struct thread *th;
295     if(in_range_p(addr, READ_ONLY_SPACE_START, READ_ONLY_SPACE_SIZE) ||
296        in_range_p(addr, STATIC_SPACE_START   , STATIC_SPACE_SIZE) ||
297        in_range_p(addr, DYNAMIC_SPACE_START  , dynamic_space_size))
298         return 1;
299     for_each_thread(th) {
300         if(((os_vm_address_t)th->control_stack_start <= addr) && (addr < (os_vm_address_t)th->control_stack_end))
301             return 1;
302         if(in_range_p(addr, (unsigned long)th->binding_stack_start, BINDING_STACK_SIZE))
303             return 1;
304     }
305     return 0;
306 }
307
308 /* A tiny bit of interrupt.c state we want our paws on. */
309 extern boolean internal_errors_enabled;
310
311 /*
312  * A good explanation of the exception handling semantics is
313  * http://win32assembly.online.fr/Exceptionhandling.html .
314  */
315
316 EXCEPTION_DISPOSITION
317 handle_exception(EXCEPTION_RECORD *exception_record,
318                  struct lisp_exception_frame *exception_frame,
319                  CONTEXT *context,
320                  void *dispatcher_context)
321 {
322     if (exception_record->ExceptionFlags & (EH_UNWINDING | EH_EXIT_UNWIND)) {
323         /* If we're being unwound, be graceful about it. */
324
325         /* Undo any dynamic bindings. */
326         unbind_to_here(exception_frame->bindstack_pointer,
327                        arch_os_get_current_thread());
328
329         return ExceptionContinueSearch;
330     }
331
332     /* For EXCEPTION_ACCESS_VIOLATION only. */
333     void *fault_address = (void *)exception_record->ExceptionInformation[1];
334
335     if (single_stepping &&
336         exception_record->ExceptionCode == EXCEPTION_SINGLE_STEP) {
337         /* We are doing a displaced instruction. At least function
338          * end breakpoints uses this. */
339         restore_breakpoint_from_single_step(context);
340         return ExceptionContinueExecution;
341     }
342
343     if (exception_record->ExceptionCode == EXCEPTION_BREAKPOINT) {
344         unsigned char trap;
345         /* This is just for info in case the monitor wants to print an
346          * approximation. */
347         current_control_stack_pointer =
348             (lispobj *)*os_context_sp_addr(context);
349         /* Unlike some other operating systems, Win32 leaves EIP
350          * pointing to the breakpoint instruction. */
351         context->Eip++;
352         /* Now EIP points just after the INT3 byte and aims at the
353          * 'kind' value (eg trap_Cerror). */
354         trap = *(unsigned char *)(*os_context_pc_addr(context));
355         handle_trap(context, trap);
356         /* Done, we're good to go! */
357         return ExceptionContinueExecution;
358     }
359     else if (exception_record->ExceptionCode == EXCEPTION_ACCESS_VIOLATION &&
360              (is_valid_lisp_addr(fault_address) ||
361               is_linkage_table_addr(fault_address))) {
362         /* Pick off GC-related memory fault next. */
363         MEMORY_BASIC_INFORMATION mem_info;
364
365         if (!VirtualQuery(fault_address, &mem_info, sizeof mem_info)) {
366             fprintf(stderr, "VirtualQuery: 0x%lx.\n", GetLastError());
367             lose("handle_exception: VirtualQuery failure");
368         }
369
370         if (mem_info.State == MEM_RESERVE) {
371             /* First use new page, lets get some memory for it. */
372             if (!VirtualAlloc(mem_info.BaseAddress, os_vm_page_size,
373                               MEM_COMMIT, PAGE_EXECUTE_READWRITE)) {
374                 fprintf(stderr, "VirtualAlloc: 0x%lx.\n", GetLastError());
375                 lose("handle_exception: VirtualAlloc failure");
376
377             } else {
378                 /*
379                  * Now, if the page is supposedly write-protected and this
380                  * is a write, tell the gc that it's been hit.
381                  *
382                  * FIXME: Are we supposed to fall-through to the Lisp
383                  * exception handler if the gc doesn't take the wp violation?
384                  */
385                 if (exception_record->ExceptionInformation[0]) {
386                     int index = find_page_index(fault_address);
387                     if ((index != -1) && (page_table[index].write_protected)) {
388                         gencgc_handle_wp_violation(fault_address);
389                     }
390                 }
391                 return ExceptionContinueExecution;
392             }
393
394         } else if (gencgc_handle_wp_violation(fault_address)) {
395             /* gc accepts the wp violation, so resume where we left off. */
396             return ExceptionContinueExecution;
397         }
398
399         /* All else failed, drop through to the lisp-side exception handler. */
400     }
401
402     /*
403      * If we fall through to here then we need to either forward
404      * the exception to the lisp-side exception handler if it's
405      * set up, or drop to LDB.
406      */
407
408     if (internal_errors_enabled) {
409         lispobj context_sap;
410         lispobj exception_record_sap;
411
412         /* We're making the somewhat arbitrary decision that having
413          * internal errors enabled means that lisp has sufficient
414          * marbles to be able to handle exceptions, but exceptions
415          * aren't supposed to happen during cold init or reinit
416          * anyway. */
417
418         fake_foreign_function_call(context);
419
420         /* Allocate the SAP objects while the "interrupts" are still
421          * disabled. */
422         context_sap = alloc_sap(context);
423         exception_record_sap = alloc_sap(exception_record);
424
425         /* The exception system doesn't automatically clear pending
426          * exceptions, so we lose as soon as we execute any FP
427          * instruction unless we do this first. */
428         _clearfp();
429
430         /* Call into lisp to handle things. */
431         funcall2(SymbolFunction(HANDLE_WIN32_EXCEPTION), context_sap,
432                  exception_record_sap);
433
434         /* If Lisp doesn't nlx, we need to put things back. */
435         undo_fake_foreign_function_call(context);
436
437         /* FIXME: HANDLE-WIN32-EXCEPTION should be allowed to decline */
438         return ExceptionContinueExecution;
439     }
440
441     fprintf(stderr, "Exception Code: 0x%lx.\n", exception_record->ExceptionCode);
442     fprintf(stderr, "Faulting IP: 0x%lx.\n", (DWORD)exception_record->ExceptionAddress);
443     if (exception_record->ExceptionCode == EXCEPTION_ACCESS_VIOLATION) {
444         MEMORY_BASIC_INFORMATION mem_info;
445
446         if (VirtualQuery(fault_address, &mem_info, sizeof mem_info)) {
447             fprintf(stderr, "page status: 0x%lx.\n", mem_info.State);
448         }
449
450         fprintf(stderr, "Was writing: %ld, where: 0x%lx.\n",
451                 exception_record->ExceptionInformation[0],
452                 (DWORD)fault_address);
453     }
454
455     fflush(stderr);
456
457     fake_foreign_function_call(context);
458     lose("Exception too early in cold init, cannot continue.");
459
460     /* FIXME: WTF? How are we supposed to end up here? */
461     return ExceptionContinueSearch;
462 }
463
464 void
465 wos_install_interrupt_handlers(struct lisp_exception_frame *handler)
466 {
467     handler->next_frame = get_seh_frame();
468     handler->handler = &handle_exception;
469     set_seh_frame(handler);
470 }
471
472 void bcopy(const void *src, void *dest, size_t n)
473 {
474     MoveMemory(dest, src, n);
475 }
476
477 /*
478  * The stubs below are replacements for the windows versions,
479  * which can -fail- when used in our memory spaces because they
480  * validate the memory spaces they are passed in a way that
481  * denies our exception handler a chance to run.
482  */
483
484 void *memmove(void *dest, const void *src, size_t n)
485 {
486     if (dest < src) {
487         int i;
488         for (i = 0; i < n; i++) *(((char *)dest)+i) = *(((char *)src)+i);
489     } else {
490         while (n--) *(((char *)dest)+n) = *(((char *)src)+n);
491     }
492     return dest;
493 }
494
495 void *memcpy(void *dest, const void *src, size_t n)
496 {
497     while (n--) *(((char *)dest)+n) = *(((char *)src)+n);
498     return dest;
499 }
500
501 char *dirname(char *path)
502 {
503     static char buf[PATH_MAX + 1];
504     size_t pathlen = strlen(path);
505     int i;
506
507     if (pathlen >= sizeof(buf)) {
508         lose("Pathname too long in dirname.\n");
509         return NULL;
510     }
511
512     strcpy(buf, path);
513     for (i = pathlen; i >= 0; --i) {
514         if (buf[i] == '/' || buf[i] == '\\') {
515             buf[i] = '\0';
516             break;
517         }
518     }
519
520     return buf;
521 }
522
523 /* This is a manually-maintained version of ldso_stubs.S. */
524
525 void __stdcall RtlUnwind(void *, void *, void *, void *); /* I don't have winternl.h */
526
527 void scratch(void)
528 {
529     CloseHandle(0);
530     FlushConsoleInputBuffer(0);
531     FormatMessageA(0, 0, 0, 0, 0, 0, 0);
532     FreeLibrary(0);
533     GetACP();
534     GetConsoleCP();
535     GetConsoleOutputCP();
536     GetCurrentProcess();
537     GetExitCodeProcess(0, 0);
538     GetLastError();
539     GetOEMCP();
540     GetProcAddress(0, 0);
541     GetProcessTimes(0, 0, 0, 0, 0);
542     GetSystemTimeAsFileTime(0);
543     LoadLibrary(0);
544     LocalFree(0);
545     PeekConsoleInput(0, 0, 0, 0);
546     PeekNamedPipe(0, 0, 0, 0, 0, 0);
547     ReadFile(0, 0, 0, 0, 0);
548     Sleep(0);
549     WriteFile(0, 0, 0, 0, 0);
550     _get_osfhandle(0);
551     _pipe(0,0,0);
552     access(0,0);
553     acos(0);
554     asin(0);
555     close(0);
556     cosh(0);
557     dup(0);
558     hypot(0, 0);
559     isatty(0);
560     sinh(0);
561     strerror(42);
562     write(0, 0, 0);
563     RtlUnwind(0, 0, 0, 0);
564     #ifndef LISP_FEATURE_SB_UNICODE
565       CreateDirectoryA(0,0);
566       GetComputerNameA(0, 0);
567       GetCurrentDirectoryA(0,0);
568       GetEnvironmentVariableA(0, 0, 0);
569       GetVersionExA(0);
570       MoveFileA(0,0);
571       SHGetFolderPathA(0, 0, 0, 0, 0);
572       SetCurrentDirectoryA(0);
573       SetEnvironmentVariableA(0, 0);
574     #else
575       CreateDirectoryW(0,0);
576       FormatMessageW(0, 0, 0, 0, 0, 0, 0);
577       GetComputerNameW(0, 0);
578       GetCurrentDirectoryW(0,0);
579       GetEnvironmentVariableW(0, 0, 0);
580       GetVersionExW(0);
581       MoveFileW(0,0);
582       SHGetFolderPathW(0, 0, 0, 0, 0);
583       SetCurrentDirectoryW(0);
584       SetEnvironmentVariableW(0, 0);
585     #endif
586 }
587
588 char *
589 os_get_runtime_executable_path()
590 {
591     char path[MAX_PATH + 1];
592     DWORD bufsize = sizeof(path);
593     DWORD size;
594
595     if ((size = GetModuleFileNameA(NULL, path, bufsize)) == 0)
596         return NULL;
597     else if (size == bufsize && GetLastError() == ERROR_INSUFFICIENT_BUFFER)
598         return NULL;
599
600     return copied_string(path);
601 }
602
603 /* EOF */