1 | /* |
---|
2 | Copyright (C) 1994-2001 Digitool, Inc |
---|
3 | This file is part of OpenMCL. |
---|
4 | |
---|
5 | OpenMCL is licensed under the terms of the Lisp Lesser GNU Public |
---|
6 | License , known as the LLGPL and distributed with OpenMCL as the |
---|
7 | file "LICENSE". The LLGPL consists of a preamble and the LGPL, |
---|
8 | which is distributed with OpenMCL as the file "LGPL". Where these |
---|
9 | conflict, the preamble takes precedence. |
---|
10 | |
---|
11 | OpenMCL is referenced in the preamble as the "LIBRARY." |
---|
12 | |
---|
13 | The LLGPL is also available online at |
---|
14 | http://opensource.franz.com/preamble.html |
---|
15 | */ |
---|
16 | |
---|
17 | #ifdef DARWIN |
---|
18 | /* dyld.h included here because something in "lisp.h" causes |
---|
19 | a conflict (actually I think the problem is in "constants.h") |
---|
20 | */ |
---|
21 | #include <mach-o/dyld.h> |
---|
22 | |
---|
23 | #endif |
---|
24 | #include "lisp.h" |
---|
25 | #include "lisp_globals.h" |
---|
26 | #include "gc.h" |
---|
27 | #include "area.h" |
---|
28 | #include <stdlib.h> |
---|
29 | #include <string.h> |
---|
30 | #include "lisp-exceptions.h" |
---|
31 | #include <stdio.h> |
---|
32 | #include <stdlib.h> |
---|
33 | #ifndef WINDOWS |
---|
34 | #include <sys/mman.h> |
---|
35 | #endif |
---|
36 | #include <fcntl.h> |
---|
37 | #include <signal.h> |
---|
38 | #include <errno.h> |
---|
39 | #ifndef WINDOWS |
---|
40 | #include <sys/utsname.h> |
---|
41 | #include <unistd.h> |
---|
42 | #endif |
---|
43 | |
---|
44 | #ifdef LINUX |
---|
45 | #include <mcheck.h> |
---|
46 | #include <dirent.h> |
---|
47 | #include <dlfcn.h> |
---|
48 | #include <sys/time.h> |
---|
49 | #include <sys/resource.h> |
---|
50 | #include <link.h> |
---|
51 | #include <elf.h> |
---|
52 | |
---|
53 | /* |
---|
54 | The version of <asm/cputable.h> provided by some distributions will |
---|
55 | claim that <asm-ppc64/cputable.h> doesn't exist. It may be present |
---|
56 | in the Linux kernel source tree even if it's not copied to |
---|
57 | /usr/include/asm-ppc64. Hopefully, this will be straightened out |
---|
58 | soon (and/or the PPC_FEATURE_HAS_ALTIVEC constant will be defined |
---|
59 | in a less volatile place.) Until that's straightened out, it may |
---|
60 | be necessary to install a copy of the kernel header in the right |
---|
61 | place and/or persuade <asm/cputable> to lighten up a bit. |
---|
62 | */ |
---|
63 | |
---|
64 | #ifdef PPC |
---|
65 | #ifndef PPC64 |
---|
66 | #include <asm/cputable.h> |
---|
67 | #endif |
---|
68 | #ifndef PPC_FEATURE_HAS_ALTIVEC |
---|
69 | #define PPC_FEATURE_HAS_ALTIVEC 0x10000000 |
---|
70 | #endif |
---|
71 | #endif |
---|
72 | #endif |
---|
73 | |
---|
74 | Boolean use_mach_exception_handling = |
---|
75 | #ifdef DARWIN |
---|
76 | true |
---|
77 | #else |
---|
78 | false |
---|
79 | #endif |
---|
80 | ; |
---|
81 | |
---|
82 | #ifdef DARWIN |
---|
83 | #include <sys/types.h> |
---|
84 | #include <sys/time.h> |
---|
85 | #include <sys/mman.h> |
---|
86 | #include <sys/resource.h> |
---|
87 | #include <mach/mach_types.h> |
---|
88 | #include <mach/message.h> |
---|
89 | #include <mach/vm_region.h> |
---|
90 | #include <mach/port.h> |
---|
91 | #include <sys/sysctl.h> |
---|
92 | #include <dlfcn.h> |
---|
93 | #endif |
---|
94 | |
---|
95 | #if defined(FREEBSD) || defined(SOLARIS) |
---|
96 | #include <sys/time.h> |
---|
97 | #include <sys/resource.h> |
---|
98 | #include <dlfcn.h> |
---|
99 | #include <elf.h> |
---|
100 | #include <link.h> |
---|
101 | #endif |
---|
102 | |
---|
103 | #include <ctype.h> |
---|
104 | #ifndef WINDOWS |
---|
105 | #include <sys/select.h> |
---|
106 | #endif |
---|
107 | #include "Threads.h" |
---|
108 | |
---|
109 | #include <fenv.h> |
---|
110 | #include <sys/stat.h> |
---|
111 | |
---|
112 | #ifndef MAP_NORESERVE |
---|
113 | #define MAP_NORESERVE (0) |
---|
114 | #endif |
---|
115 | |
---|
116 | #ifdef WINDOWS |
---|
117 | #include <windows.h> |
---|
118 | #include <stdio.h> |
---|
119 | void |
---|
120 | wperror(char* message) |
---|
121 | { |
---|
122 | char* buffer; |
---|
123 | DWORD last_error = GetLastError(); |
---|
124 | |
---|
125 | FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER| |
---|
126 | FORMAT_MESSAGE_FROM_SYSTEM| |
---|
127 | FORMAT_MESSAGE_IGNORE_INSERTS, |
---|
128 | NULL, |
---|
129 | last_error, |
---|
130 | MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), |
---|
131 | (LPTSTR)&buffer, |
---|
132 | 0, NULL); |
---|
133 | fprintf(dbgout, "%s: 0x%x %s\n", message, (unsigned) last_error, buffer); |
---|
134 | LocalFree(buffer); |
---|
135 | } |
---|
136 | #endif |
---|
137 | |
---|
138 | LispObj lisp_nil = (LispObj) 0; |
---|
139 | bitvector global_mark_ref_bits = NULL; |
---|
140 | |
---|
141 | |
---|
142 | /* These are all "persistent" : they're initialized when |
---|
143 | subprims are first loaded and should never change. */ |
---|
144 | extern LispObj ret1valn; |
---|
145 | extern LispObj nvalret; |
---|
146 | extern LispObj popj; |
---|
147 | |
---|
148 | LispObj text_start = 0; |
---|
149 | |
---|
150 | /* A pointer to some of the kernel's own data; also persistent. */ |
---|
151 | |
---|
152 | extern LispObj import_ptrs_base; |
---|
153 | |
---|
154 | |
---|
155 | |
---|
156 | void |
---|
157 | xMakeDataExecutable(void *, unsigned long); |
---|
158 | |
---|
159 | void |
---|
160 | make_dynamic_heap_executable(LispObj *p, LispObj *q) |
---|
161 | { |
---|
162 | void * cache_start = (void *) p; |
---|
163 | natural ncacheflush = (natural) q - (natural) p; |
---|
164 | |
---|
165 | xMakeDataExecutable(cache_start, ncacheflush); |
---|
166 | } |
---|
167 | |
---|
168 | size_t |
---|
169 | ensure_stack_limit(size_t stack_size) |
---|
170 | { |
---|
171 | #ifdef WINDOWS |
---|
172 | extern void os_get_current_thread_stack_bounds(void **, natural*); |
---|
173 | natural totalsize; |
---|
174 | void *ignored; |
---|
175 | |
---|
176 | os_get_current_thread_stack_bounds(&ignored, &totalsize); |
---|
177 | |
---|
178 | return (size_t)totalsize-(size_t)(CSTACK_HARDPROT+CSTACK_SOFTPROT); |
---|
179 | |
---|
180 | #else |
---|
181 | struct rlimit limits; |
---|
182 | rlim_t cur_stack_limit, max_stack_limit; |
---|
183 | |
---|
184 | stack_size += (CSTACK_HARDPROT+CSTACK_SOFTPROT); |
---|
185 | getrlimit(RLIMIT_STACK, &limits); |
---|
186 | cur_stack_limit = limits.rlim_cur; |
---|
187 | max_stack_limit = limits.rlim_max; |
---|
188 | if (stack_size > max_stack_limit) { |
---|
189 | stack_size = max_stack_limit; |
---|
190 | } |
---|
191 | if (cur_stack_limit < stack_size) { |
---|
192 | limits.rlim_cur = stack_size; |
---|
193 | errno = 0; |
---|
194 | if (setrlimit(RLIMIT_STACK, &limits)) { |
---|
195 | int e = errno; |
---|
196 | fprintf(dbgout, "errno = %d\n", e); |
---|
197 | Fatal(": Stack resource limit too small", ""); |
---|
198 | } |
---|
199 | } |
---|
200 | #endif |
---|
201 | return stack_size; |
---|
202 | } |
---|
203 | |
---|
204 | |
---|
205 | /* This should write-protect the bottom of the stack. |
---|
206 | Doing so reliably involves ensuring that everything's unprotected on exit. |
---|
207 | */ |
---|
208 | |
---|
209 | BytePtr |
---|
210 | allocate_lisp_stack(natural useable, |
---|
211 | unsigned softsize, |
---|
212 | unsigned hardsize, |
---|
213 | lisp_protection_kind softkind, |
---|
214 | lisp_protection_kind hardkind, |
---|
215 | Ptr *h_p, |
---|
216 | BytePtr *base_p, |
---|
217 | protected_area_ptr *softp, |
---|
218 | protected_area_ptr *hardp) |
---|
219 | { |
---|
220 | void *allocate_stack(natural); |
---|
221 | void free_stack(void *); |
---|
222 | natural size = useable+softsize+hardsize; |
---|
223 | natural overhead; |
---|
224 | BytePtr base, softlimit, hardlimit; |
---|
225 | Ptr h = allocate_stack(size+4095); |
---|
226 | protected_area_ptr hprotp = NULL, sprotp; |
---|
227 | |
---|
228 | if (h == NULL) { |
---|
229 | return NULL; |
---|
230 | } |
---|
231 | if (h_p) *h_p = h; |
---|
232 | base = (BytePtr) align_to_power_of_2( h, log2_page_size); |
---|
233 | hardlimit = (BytePtr) (base+hardsize); |
---|
234 | softlimit = hardlimit+softsize; |
---|
235 | |
---|
236 | overhead = (base - (BytePtr) h); |
---|
237 | if (hardsize) { |
---|
238 | hprotp = new_protected_area((BytePtr)base,hardlimit,hardkind, hardsize, true); |
---|
239 | if (hprotp == NULL) { |
---|
240 | if (base_p) *base_p = NULL; |
---|
241 | if (h_p) *h_p = NULL; |
---|
242 | deallocate(h); |
---|
243 | return NULL; |
---|
244 | } |
---|
245 | if (hardp) *hardp = hprotp; |
---|
246 | } |
---|
247 | if (softsize) { |
---|
248 | sprotp = new_protected_area(hardlimit,softlimit, softkind, softsize, true); |
---|
249 | if (sprotp == NULL) { |
---|
250 | if (base_p) *base_p = NULL; |
---|
251 | if (h_p) *h_p = NULL; |
---|
252 | if (hardp) *hardp = NULL; |
---|
253 | if (hprotp) delete_protected_area(hprotp); |
---|
254 | free_stack(h); |
---|
255 | return NULL; |
---|
256 | } |
---|
257 | if (softp) *softp = sprotp; |
---|
258 | } |
---|
259 | if (base_p) *base_p = base; |
---|
260 | return (BytePtr) ((natural)(base+size)); |
---|
261 | } |
---|
262 | |
---|
263 | /* |
---|
264 | This should only called by something that owns the area_lock, or |
---|
265 | by the initial thread before other threads exist. |
---|
266 | */ |
---|
267 | area * |
---|
268 | allocate_lisp_stack_area(area_code stack_type, |
---|
269 | natural usable, |
---|
270 | unsigned softsize, |
---|
271 | unsigned hardsize, |
---|
272 | lisp_protection_kind softkind, |
---|
273 | lisp_protection_kind hardkind) |
---|
274 | |
---|
275 | { |
---|
276 | BytePtr base, bottom; |
---|
277 | Ptr h; |
---|
278 | area *a = NULL; |
---|
279 | protected_area_ptr soft_area=NULL, hard_area=NULL; |
---|
280 | |
---|
281 | bottom = allocate_lisp_stack(usable, |
---|
282 | softsize, |
---|
283 | hardsize, |
---|
284 | softkind, |
---|
285 | hardkind, |
---|
286 | &h, |
---|
287 | &base, |
---|
288 | &soft_area, |
---|
289 | &hard_area); |
---|
290 | |
---|
291 | if (bottom) { |
---|
292 | a = new_area(base, bottom, stack_type); |
---|
293 | a->hardlimit = base+hardsize; |
---|
294 | a->softlimit = base+hardsize+softsize; |
---|
295 | a->h = h; |
---|
296 | a->softprot = soft_area; |
---|
297 | a->hardprot = hard_area; |
---|
298 | add_area_holding_area_lock(a); |
---|
299 | } |
---|
300 | return a; |
---|
301 | } |
---|
302 | |
---|
303 | /* |
---|
304 | Also assumes ownership of the area_lock |
---|
305 | */ |
---|
306 | area* |
---|
307 | register_cstack_holding_area_lock(BytePtr bottom, natural size) |
---|
308 | { |
---|
309 | BytePtr lowlimit = (BytePtr) (((((natural)bottom)-size)+4095)&~4095); |
---|
310 | area *a = new_area((BytePtr) bottom-size, bottom, AREA_CSTACK); |
---|
311 | a->hardlimit = lowlimit+CSTACK_HARDPROT; |
---|
312 | a->softlimit = a->hardlimit+CSTACK_SOFTPROT; |
---|
313 | #ifdef USE_SIGALTSTACK |
---|
314 | setup_sigaltstack(a); |
---|
315 | #endif |
---|
316 | add_area_holding_area_lock(a); |
---|
317 | return a; |
---|
318 | } |
---|
319 | |
---|
320 | |
---|
321 | area* |
---|
322 | allocate_vstack_holding_area_lock(natural usable) |
---|
323 | { |
---|
324 | return allocate_lisp_stack_area(AREA_VSTACK, |
---|
325 | usable > MIN_VSTACK_SIZE ? |
---|
326 | usable : MIN_VSTACK_SIZE, |
---|
327 | VSTACK_SOFTPROT, |
---|
328 | VSTACK_HARDPROT, |
---|
329 | kVSPsoftguard, |
---|
330 | kVSPhardguard); |
---|
331 | } |
---|
332 | |
---|
333 | area * |
---|
334 | allocate_tstack_holding_area_lock(natural usable) |
---|
335 | { |
---|
336 | return allocate_lisp_stack_area(AREA_TSTACK, |
---|
337 | usable > MIN_TSTACK_SIZE ? |
---|
338 | usable : MIN_TSTACK_SIZE, |
---|
339 | TSTACK_SOFTPROT, |
---|
340 | TSTACK_HARDPROT, |
---|
341 | kTSPsoftguard, |
---|
342 | kTSPhardguard); |
---|
343 | } |
---|
344 | |
---|
345 | |
---|
346 | /* It's hard to believe that max & min don't exist already */ |
---|
347 | unsigned unsigned_min(unsigned x, unsigned y) |
---|
348 | { |
---|
349 | if (x <= y) { |
---|
350 | return x; |
---|
351 | } else { |
---|
352 | return y; |
---|
353 | } |
---|
354 | } |
---|
355 | |
---|
356 | unsigned unsigned_max(unsigned x, unsigned y) |
---|
357 | { |
---|
358 | if (x >= y) { |
---|
359 | return x; |
---|
360 | } else { |
---|
361 | return y; |
---|
362 | } |
---|
363 | } |
---|
364 | |
---|
365 | #if WORD_SIZE == 64 |
---|
366 | #ifdef DARWIN |
---|
367 | #define MAXIMUM_MAPPABLE_MEMORY (512L<<30L) |
---|
368 | #endif |
---|
369 | #ifdef FREEBSD |
---|
370 | #define MAXIMUM_MAPPABLE_MEMORY (512L<<30L) |
---|
371 | #endif |
---|
372 | #ifdef SOLARIS |
---|
373 | #define MAXIMUM_MAPPABLE_MEMORY (128L<<30L) |
---|
374 | #endif |
---|
375 | #ifdef LINUX |
---|
376 | #ifdef X8664 |
---|
377 | #define MAXIMUM_MAPPABLE_MEMORY (512L<<30L) |
---|
378 | #endif |
---|
379 | #ifdef PPC |
---|
380 | #define MAXIMUM_MAPPABLE_MEMORY (128L<<30L) |
---|
381 | #endif |
---|
382 | #endif |
---|
383 | #ifdef WINDOWS |
---|
384 | /* Supposedly, the high-end version of Vista allow 128GB of pageable memory */ |
---|
385 | #define MAXIMUM_MAPPABLE_MEMORY (120LL<<30LL) |
---|
386 | #endif |
---|
387 | #else |
---|
388 | #ifdef DARWIN |
---|
389 | #define MAXIMUM_MAPPABLE_MEMORY ((1U<<31)-2*heap_segment_size) |
---|
390 | #endif |
---|
391 | #ifdef LINUX |
---|
392 | #ifdef X86 |
---|
393 | #define MAXIMUM_MAPPABLE_MEMORY (9U<<28) |
---|
394 | #else |
---|
395 | #define MAXIMUM_MAPPABLE_MEMORY (1U<<30) |
---|
396 | #endif |
---|
397 | #endif |
---|
398 | #ifdef WINDOWS |
---|
399 | #define MAXIMUM_MAPPABLE_MEMORY (1U<<30) |
---|
400 | #endif |
---|
401 | #ifdef FREEBSD |
---|
402 | #define MAXIMUM_MAPPABLE_MEMORY (1U<<30) |
---|
403 | #endif |
---|
404 | #ifdef SOLARIS |
---|
405 | #define MAXIMUM_MAPPABLE_MEMORY (1U<<30) |
---|
406 | #endif |
---|
407 | #endif |
---|
408 | |
---|
409 | natural |
---|
410 | reserved_area_size = MAXIMUM_MAPPABLE_MEMORY; |
---|
411 | |
---|
412 | area |
---|
413 | *nilreg_area=NULL, |
---|
414 | *tenured_area=NULL, |
---|
415 | *g2_area=NULL, |
---|
416 | *g1_area=NULL, |
---|
417 | *managed_static_area=NULL, |
---|
418 | *readonly_area=NULL; |
---|
419 | |
---|
420 | area *all_areas=NULL; |
---|
421 | int cache_block_size=32; |
---|
422 | |
---|
423 | |
---|
424 | #if WORD_SIZE == 64 |
---|
425 | #define DEFAULT_LISP_HEAP_GC_THRESHOLD (32<<20) |
---|
426 | #define G2_AREA_THRESHOLD (8<<20) |
---|
427 | #define G1_AREA_THRESHOLD (4<<20) |
---|
428 | #define G0_AREA_THRESHOLD (2<<20) |
---|
429 | #else |
---|
430 | #define DEFAULT_LISP_HEAP_GC_THRESHOLD (16<<20) |
---|
431 | #define G2_AREA_THRESHOLD (4<<20) |
---|
432 | #define G1_AREA_THRESHOLD (2<<20) |
---|
433 | #define G0_AREA_THRESHOLD (1<<20) |
---|
434 | #endif |
---|
435 | |
---|
436 | #define MIN_DYNAMIC_SIZE (DEFAULT_LISP_HEAP_GC_THRESHOLD *2) |
---|
437 | |
---|
438 | #if (WORD_SIZE == 32) |
---|
439 | #define DEFAULT_INITIAL_STACK_SIZE (1<<20) |
---|
440 | #else |
---|
441 | #define DEFAULT_INITIAL_STACK_SIZE (2<<20) |
---|
442 | #endif |
---|
443 | |
---|
444 | natural |
---|
445 | lisp_heap_gc_threshold = DEFAULT_LISP_HEAP_GC_THRESHOLD; |
---|
446 | |
---|
447 | natural |
---|
448 | initial_stack_size = DEFAULT_INITIAL_STACK_SIZE; |
---|
449 | |
---|
450 | natural |
---|
451 | thread_stack_size = 0; |
---|
452 | |
---|
453 | |
---|
454 | /* |
---|
455 | 'start' should be on a segment boundary; 'len' should be |
---|
456 | an integral number of segments. remap the entire range. |
---|
457 | */ |
---|
458 | |
---|
459 | void |
---|
460 | uncommit_pages(void *start, size_t len) |
---|
461 | { |
---|
462 | UnCommitMemory(start, len); |
---|
463 | } |
---|
464 | |
---|
465 | #define TOUCH_PAGES_ON_COMMIT 0 |
---|
466 | |
---|
467 | Boolean |
---|
468 | touch_all_pages(void *start, size_t len) |
---|
469 | { |
---|
470 | #if TOUCH_PAGES_ON_COMMIT |
---|
471 | extern Boolean touch_page(void *); |
---|
472 | char *p = (char *)start; |
---|
473 | |
---|
474 | while (len) { |
---|
475 | if (!touch_page(p)) { |
---|
476 | return false; |
---|
477 | } |
---|
478 | len -= page_size; |
---|
479 | p += page_size; |
---|
480 | } |
---|
481 | #endif |
---|
482 | return true; |
---|
483 | } |
---|
484 | |
---|
485 | Boolean |
---|
486 | commit_pages(void *start, size_t len) |
---|
487 | { |
---|
488 | if (len != 0) { |
---|
489 | if (CommitMemory(start, len)) { |
---|
490 | if (touch_all_pages(start, len)) { |
---|
491 | return true; |
---|
492 | } |
---|
493 | } |
---|
494 | } |
---|
495 | return true; |
---|
496 | } |
---|
497 | |
---|
498 | area * |
---|
499 | find_readonly_area() |
---|
500 | { |
---|
501 | area *a; |
---|
502 | |
---|
503 | for (a = active_dynamic_area->succ; a != all_areas; a = a->succ) { |
---|
504 | if (a->code == AREA_READONLY) { |
---|
505 | return a; |
---|
506 | } |
---|
507 | } |
---|
508 | return NULL; |
---|
509 | } |
---|
510 | |
---|
511 | area * |
---|
512 | extend_readonly_area(unsigned more) |
---|
513 | { |
---|
514 | area *a; |
---|
515 | unsigned mask; |
---|
516 | BytePtr new_start, new_end; |
---|
517 | |
---|
518 | if ((a = find_readonly_area()) != NULL) { |
---|
519 | if ((a->active + more) > a->high) { |
---|
520 | return NULL; |
---|
521 | } |
---|
522 | mask = ((natural)a->active) & (page_size-1); |
---|
523 | if (mask) { |
---|
524 | UnProtectMemory(a->active-mask, page_size); |
---|
525 | } |
---|
526 | new_start = (BytePtr)(align_to_power_of_2(a->active,log2_page_size)); |
---|
527 | new_end = (BytePtr)(align_to_power_of_2(a->active+more,log2_page_size)); |
---|
528 | if (!CommitMemory(new_start, new_end-new_start)) { |
---|
529 | return NULL; |
---|
530 | } |
---|
531 | return a; |
---|
532 | } |
---|
533 | return NULL; |
---|
534 | } |
---|
535 | |
---|
536 | LispObj image_base=0; |
---|
537 | BytePtr pure_space_start, pure_space_active, pure_space_limit; |
---|
538 | BytePtr static_space_start, static_space_active, static_space_limit; |
---|
539 | |
---|
540 | void |
---|
541 | raise_limit() |
---|
542 | { |
---|
543 | #ifdef RLIMIT_AS |
---|
544 | struct rlimit r; |
---|
545 | if (getrlimit(RLIMIT_AS, &r) == 0) { |
---|
546 | r.rlim_cur = r.rlim_max; |
---|
547 | setrlimit(RLIMIT_AS, &r); |
---|
548 | /* Could limit heaplimit to rlim_max here if smaller? */ |
---|
549 | } |
---|
550 | #endif |
---|
551 | } |
---|
552 | |
---|
553 | |
---|
554 | area * |
---|
555 | create_reserved_area(natural totalsize) |
---|
556 | { |
---|
557 | Ptr h; |
---|
558 | natural base; |
---|
559 | BytePtr |
---|
560 | end, |
---|
561 | lastbyte, |
---|
562 | start, |
---|
563 | want = (BytePtr)IMAGE_BASE_ADDRESS; |
---|
564 | area *reserved; |
---|
565 | Boolean fatal = false; |
---|
566 | |
---|
567 | totalsize = align_to_power_of_2((void *)totalsize, log2_heap_segment_size); |
---|
568 | |
---|
569 | if (totalsize < (PURESPACE_RESERVE + MIN_DYNAMIC_SIZE)) { |
---|
570 | totalsize = PURESPACE_RESERVE + MIN_DYNAMIC_SIZE; |
---|
571 | fatal = true; |
---|
572 | } |
---|
573 | |
---|
574 | start = ReserveMemoryForHeap(want, totalsize); |
---|
575 | |
---|
576 | if (start == NULL) { |
---|
577 | if (fatal) { |
---|
578 | perror("minimal initial mmap"); |
---|
579 | exit(1); |
---|
580 | } |
---|
581 | return NULL; |
---|
582 | } |
---|
583 | |
---|
584 | h = (Ptr) start; |
---|
585 | base = (natural) start; |
---|
586 | image_base = base; |
---|
587 | lastbyte = (BytePtr) (start+totalsize); |
---|
588 | static_space_start = static_space_active = (BytePtr)STATIC_BASE_ADDRESS; |
---|
589 | static_space_limit = static_space_start + STATIC_RESERVE; |
---|
590 | pure_space_start = pure_space_active = start; |
---|
591 | pure_space_limit = start + PURESPACE_RESERVE; |
---|
592 | start = pure_space_limit; |
---|
593 | |
---|
594 | /* |
---|
595 | Allocate mark bits here. They need to be 1/64 the size of the |
---|
596 | maximum useable area of the heap (+ 3 words for the EGC.) |
---|
597 | */ |
---|
598 | end = lastbyte; |
---|
599 | end = (BytePtr) ((natural)((((natural)end) - ((totalsize+63)>>6)) & ~4095)); |
---|
600 | |
---|
601 | global_mark_ref_bits = (bitvector)end; |
---|
602 | end = (BytePtr) ((natural)((((natural)end) - ((totalsize+63) >> 6)) & ~4095)); |
---|
603 | global_reloctab = (LispObj *) end; |
---|
604 | reserved = new_area(start, end, AREA_VOID); |
---|
605 | /* The root of all evil is initially linked to itself. */ |
---|
606 | reserved->pred = reserved->succ = reserved; |
---|
607 | all_areas = reserved; |
---|
608 | reserved->markbits = global_mark_ref_bits; |
---|
609 | return reserved; |
---|
610 | } |
---|
611 | |
---|
612 | void * |
---|
613 | allocate_from_reserved_area(natural size) |
---|
614 | { |
---|
615 | area *reserved = reserved_area; |
---|
616 | BytePtr low = reserved->low, high = reserved->high; |
---|
617 | natural avail = high-low; |
---|
618 | |
---|
619 | size = align_to_power_of_2(size, log2_heap_segment_size); |
---|
620 | |
---|
621 | if (size > avail) { |
---|
622 | return NULL; |
---|
623 | } |
---|
624 | reserved->low += size; |
---|
625 | reserved->active = reserved->low; |
---|
626 | reserved->ndnodes -= (size>>dnode_shift); |
---|
627 | return low; |
---|
628 | } |
---|
629 | |
---|
630 | |
---|
631 | |
---|
632 | BytePtr reloctab_limit = NULL, markbits_limit = NULL; |
---|
633 | |
---|
634 | void |
---|
635 | ensure_gc_structures_writable() |
---|
636 | { |
---|
637 | natural |
---|
638 | ndnodes = area_dnode(lisp_global(HEAP_END),lisp_global(HEAP_START)), |
---|
639 | markbits_size = (3*sizeof(LispObj))+((ndnodes+7)>>3), |
---|
640 | reloctab_size = (sizeof(LispObj)*(((ndnodes+((1<<bitmap_shift)-1))>>bitmap_shift)+1)), |
---|
641 | n; |
---|
642 | BytePtr |
---|
643 | new_reloctab_limit = (BytePtr)align_to_power_of_2(((natural)global_reloctab)+reloctab_size,log2_page_size), |
---|
644 | new_markbits_limit = (BytePtr)align_to_power_of_2(((natural)global_mark_ref_bits)+markbits_size,log2_page_size); |
---|
645 | |
---|
646 | if (new_reloctab_limit > reloctab_limit) { |
---|
647 | n = new_reloctab_limit - reloctab_limit; |
---|
648 | CommitMemory(reloctab_limit, n); |
---|
649 | UnProtectMemory(reloctab_limit, n); |
---|
650 | reloctab_limit = new_reloctab_limit; |
---|
651 | } |
---|
652 | |
---|
653 | if (new_markbits_limit > markbits_limit) { |
---|
654 | n = new_markbits_limit-markbits_limit; |
---|
655 | CommitMemory(markbits_limit, n); |
---|
656 | UnProtectMemory(markbits_limit, n); |
---|
657 | markbits_limit = new_markbits_limit; |
---|
658 | } |
---|
659 | } |
---|
660 | |
---|
661 | |
---|
662 | area * |
---|
663 | allocate_dynamic_area(natural initsize) |
---|
664 | { |
---|
665 | natural totalsize = align_to_power_of_2(initsize, log2_heap_segment_size); |
---|
666 | BytePtr start, end; |
---|
667 | area *a; |
---|
668 | |
---|
669 | start = allocate_from_reserved_area(totalsize); |
---|
670 | if (start == NULL) { |
---|
671 | fprintf(dbgout, "reserved area too small to load heap image\n"); |
---|
672 | exit(1); |
---|
673 | } |
---|
674 | end = start + totalsize; |
---|
675 | a = new_area(start, end, AREA_DYNAMIC); |
---|
676 | a->active = start+initsize; |
---|
677 | add_area_holding_area_lock(a); |
---|
678 | a->markbits = reserved_area->markbits; |
---|
679 | reserved_area->markbits = NULL; |
---|
680 | CommitMemory(start, end-start); |
---|
681 | a->h = start; |
---|
682 | a->softprot = NULL; |
---|
683 | a->hardprot = NULL; |
---|
684 | lisp_global(HEAP_START) = ptr_to_lispobj(a->low); |
---|
685 | lisp_global(HEAP_END) = ptr_to_lispobj(a->high); |
---|
686 | markbits_limit = (BytePtr)global_mark_ref_bits; |
---|
687 | reloctab_limit = (BytePtr)global_reloctab; |
---|
688 | ensure_gc_structures_writable(); |
---|
689 | return a; |
---|
690 | } |
---|
691 | |
---|
692 | |
---|
693 | Boolean |
---|
694 | grow_dynamic_area(natural delta) |
---|
695 | { |
---|
696 | area *a = active_dynamic_area, *reserved = reserved_area; |
---|
697 | natural avail = reserved->high - reserved->low; |
---|
698 | |
---|
699 | delta = align_to_power_of_2(delta, log2_heap_segment_size); |
---|
700 | if (delta > avail) { |
---|
701 | return false; |
---|
702 | } |
---|
703 | |
---|
704 | if (!commit_pages(a->high,delta)) { |
---|
705 | return false; |
---|
706 | } |
---|
707 | |
---|
708 | |
---|
709 | if (!allocate_from_reserved_area(delta)) { |
---|
710 | return false; |
---|
711 | } |
---|
712 | |
---|
713 | |
---|
714 | a->high += delta; |
---|
715 | a->ndnodes = area_dnode(a->high, a->low); |
---|
716 | lisp_global(HEAP_END) += delta; |
---|
717 | ensure_gc_structures_writable(); |
---|
718 | return true; |
---|
719 | } |
---|
720 | |
---|
721 | /* |
---|
722 | As above. Pages that're returned to the reserved_area are |
---|
723 | "condemned" (e.g, we try to convince the OS that they never |
---|
724 | existed ...) |
---|
725 | */ |
---|
726 | Boolean |
---|
727 | shrink_dynamic_area(natural delta) |
---|
728 | { |
---|
729 | area *a = active_dynamic_area, *reserved = reserved_area; |
---|
730 | |
---|
731 | delta = align_to_power_of_2(delta, log2_heap_segment_size); |
---|
732 | |
---|
733 | a->high -= delta; |
---|
734 | a->ndnodes = area_dnode(a->high, a->low); |
---|
735 | a->hardlimit = a->high; |
---|
736 | uncommit_pages(a->high, delta); |
---|
737 | reserved->low -= delta; |
---|
738 | reserved->ndnodes += (delta>>dnode_shift); |
---|
739 | lisp_global(HEAP_END) -= delta; |
---|
740 | return true; |
---|
741 | } |
---|
742 | |
---|
743 | |
---|
744 | #ifndef WINDOWS |
---|
745 | void |
---|
746 | user_signal_handler (int signum, siginfo_t *info, ExceptionInformation *context) |
---|
747 | { |
---|
748 | if (signum == SIGINT) { |
---|
749 | lisp_global(INTFLAG) = (((signum<<8) + 1) << fixnumshift); |
---|
750 | } |
---|
751 | else if (signum == SIGTERM) { |
---|
752 | lisp_global(INTFLAG) = (((signum<<8) + 2) << fixnumshift); |
---|
753 | } |
---|
754 | else if (signum == SIGQUIT) { |
---|
755 | lisp_global(INTFLAG) = (((signum<<8) + 2) << fixnumshift); |
---|
756 | } |
---|
757 | #ifdef DARWIN |
---|
758 | DarwinSigReturn(context); |
---|
759 | #endif |
---|
760 | } |
---|
761 | |
---|
762 | #endif |
---|
763 | |
---|
764 | void |
---|
765 | register_user_signal_handler() |
---|
766 | { |
---|
767 | #ifdef WINDOWS |
---|
768 | extern BOOL CALLBACK ControlEventHandler(DWORD); |
---|
769 | |
---|
770 | signal(SIGINT, SIG_IGN); |
---|
771 | |
---|
772 | SetConsoleCtrlHandler(ControlEventHandler,TRUE); |
---|
773 | #else |
---|
774 | install_signal_handler(SIGINT, (void *)user_signal_handler); |
---|
775 | install_signal_handler(SIGTERM, (void *)user_signal_handler); |
---|
776 | #endif |
---|
777 | } |
---|
778 | |
---|
779 | |
---|
780 | |
---|
781 | BytePtr |
---|
782 | initial_stack_bottom() |
---|
783 | { |
---|
784 | #ifndef WINDOWS |
---|
785 | extern char **environ; |
---|
786 | char *p = *environ; |
---|
787 | while (*p) { |
---|
788 | p += (1+strlen(p)); |
---|
789 | } |
---|
790 | return (BytePtr)((((natural) p) +4095) & ~4095); |
---|
791 | #endif |
---|
792 | #ifdef WINDOWS |
---|
793 | return (BytePtr)((current_stack_pointer() + 4095) & ~ 4095); |
---|
794 | #endif |
---|
795 | } |
---|
796 | |
---|
797 | |
---|
798 | |
---|
799 | Ptr fatal_spare_ptr = NULL; |
---|
800 | |
---|
801 | |
---|
802 | void |
---|
803 | Fatal(StringPtr param0, StringPtr param1) |
---|
804 | { |
---|
805 | |
---|
806 | if (fatal_spare_ptr) { |
---|
807 | deallocate(fatal_spare_ptr); |
---|
808 | fatal_spare_ptr = NULL; |
---|
809 | } |
---|
810 | fprintf(dbgout, "Fatal error: %s\n%s\n", param0, param1); |
---|
811 | _exit(-1); |
---|
812 | } |
---|
813 | |
---|
814 | OSErr application_load_err = noErr; |
---|
815 | |
---|
816 | area * |
---|
817 | set_nil(LispObj); |
---|
818 | |
---|
819 | |
---|
820 | /* Check for the existence of a file named by 'path'; return true |
---|
821 | if it seems to exist, without checking size, permissions, or |
---|
822 | anything else. */ |
---|
823 | Boolean |
---|
824 | probe_file(char *path) |
---|
825 | { |
---|
826 | struct stat st; |
---|
827 | |
---|
828 | return (stat(path,&st) == 0); |
---|
829 | } |
---|
830 | |
---|
831 | |
---|
832 | #ifdef WINDOWS |
---|
833 | /* Chop the trailing ".exe" from the kernel image name */ |
---|
834 | wchar_t * |
---|
835 | chop_exe_suffix(wchar_t *path) |
---|
836 | { |
---|
837 | int len = wcslen(path); |
---|
838 | wchar_t *copy = malloc((len+1)*sizeof(wchar_t)), *tail; |
---|
839 | |
---|
840 | wcscpy(copy,path); |
---|
841 | tail = wcsrchr(copy, '.'); |
---|
842 | if (tail) { |
---|
843 | *tail = 0; |
---|
844 | } |
---|
845 | return copy; |
---|
846 | } |
---|
847 | #endif |
---|
848 | |
---|
849 | #ifdef WINDOWS |
---|
850 | wchar_t * |
---|
851 | path_by_appending_image(wchar_t *path) |
---|
852 | { |
---|
853 | int len = wcslen(path) + wcslen(L".image") + 1; |
---|
854 | wchar_t *copy = (wchar_t *) malloc(len*sizeof(wchar_t)); |
---|
855 | |
---|
856 | if (copy) { |
---|
857 | wcscpy(copy, path); |
---|
858 | wcscat(copy, L".image"); |
---|
859 | } |
---|
860 | return copy; |
---|
861 | } |
---|
862 | #else |
---|
863 | char * |
---|
864 | path_by_appending_image(char *path) |
---|
865 | { |
---|
866 | int len = strlen(path) + strlen(".image") + 1; |
---|
867 | char *copy = (char *) malloc(len); |
---|
868 | |
---|
869 | if (copy) { |
---|
870 | strcpy(copy, path); |
---|
871 | strcat(copy, ".image"); |
---|
872 | } |
---|
873 | return copy; |
---|
874 | } |
---|
875 | #endif |
---|
876 | |
---|
877 | char * |
---|
878 | case_inverted_path(char *path) |
---|
879 | { |
---|
880 | char *copy = strdup(path), *base = copy, *work = copy, c; |
---|
881 | if (copy == NULL) { |
---|
882 | return NULL; |
---|
883 | } |
---|
884 | while(*work) { |
---|
885 | if (*work++ == '/') { |
---|
886 | base = work; |
---|
887 | } |
---|
888 | } |
---|
889 | work = base; |
---|
890 | while ((c = *work) != '\0') { |
---|
891 | if (islower(c)) { |
---|
892 | *work++ = toupper(c); |
---|
893 | } else { |
---|
894 | *work++ = tolower(c); |
---|
895 | } |
---|
896 | } |
---|
897 | return copy; |
---|
898 | } |
---|
899 | /* |
---|
900 | The underlying file system may be case-insensitive (e.g., HFS), |
---|
901 | so we can't just case-invert the kernel's name. |
---|
902 | Tack ".image" onto the end of the kernel's name. Much better ... |
---|
903 | */ |
---|
904 | #ifdef WINDOWS |
---|
905 | wchar_t * |
---|
906 | default_image_name(wchar_t *orig) |
---|
907 | { |
---|
908 | wchar_t *path = chop_exe_suffix(orig); |
---|
909 | wchar_t *image_name = path_by_appending_image(path); |
---|
910 | return image_name; |
---|
911 | } |
---|
912 | #else |
---|
913 | char * |
---|
914 | default_image_name(char *orig) |
---|
915 | { |
---|
916 | #ifdef WINDOWS |
---|
917 | char *path = chop_exe_suffix(orig); |
---|
918 | #else |
---|
919 | char *path = orig; |
---|
920 | #endif |
---|
921 | char *image_name = path_by_appending_image(path); |
---|
922 | #if !defined(WINDOWS) && !defined(DARWIN) |
---|
923 | if (!probe_file(image_name)) { |
---|
924 | char *legacy = case_inverted_path(path); |
---|
925 | if (probe_file(legacy)) { |
---|
926 | image_name = legacy; |
---|
927 | } |
---|
928 | } |
---|
929 | #endif |
---|
930 | return image_name; |
---|
931 | } |
---|
932 | #endif |
---|
933 | |
---|
934 | |
---|
935 | |
---|
936 | char *program_name = NULL; |
---|
937 | #ifdef WINDOWS |
---|
938 | wchar_t *real_executable_name = NULL; |
---|
939 | #else |
---|
940 | char *real_executable_name = NULL; |
---|
941 | #endif |
---|
942 | |
---|
943 | #ifndef WINDOWS |
---|
944 | |
---|
945 | char * |
---|
946 | ensure_real_path(char *path) |
---|
947 | { |
---|
948 | char buf[PATH_MAX*2], *p, *q; |
---|
949 | int n; |
---|
950 | |
---|
951 | p = realpath(path, buf); |
---|
952 | |
---|
953 | if (p == NULL) { |
---|
954 | return path; |
---|
955 | } |
---|
956 | n = strlen(p); |
---|
957 | q = malloc(n+1); |
---|
958 | strcpy(q,p); |
---|
959 | return q; |
---|
960 | } |
---|
961 | |
---|
962 | char * |
---|
963 | determine_executable_name(char *argv0) |
---|
964 | { |
---|
965 | #ifdef DARWIN |
---|
966 | uint32_t len = 1024; |
---|
967 | char exepath[1024], *p = NULL; |
---|
968 | |
---|
969 | if (_NSGetExecutablePath(exepath, (void *)&len) == 0) { |
---|
970 | p = malloc(len+1); |
---|
971 | memmove(p, exepath, len); |
---|
972 | p[len]=0; |
---|
973 | return ensure_real_path(p); |
---|
974 | } |
---|
975 | return ensure_real_path(argv0); |
---|
976 | #endif |
---|
977 | #ifdef LINUX |
---|
978 | char exepath[PATH_MAX], *p; |
---|
979 | int n; |
---|
980 | |
---|
981 | if ((n = readlink("/proc/self/exe", exepath, PATH_MAX)) > 0) { |
---|
982 | p = malloc(n+1); |
---|
983 | memmove(p,exepath,n); |
---|
984 | p[n]=0; |
---|
985 | return p; |
---|
986 | } |
---|
987 | return argv0; |
---|
988 | #endif |
---|
989 | #ifdef FREEBSD |
---|
990 | return ensure_real_path(argv0); |
---|
991 | #endif |
---|
992 | #ifdef SOLARIS |
---|
993 | char exepath[PATH_MAX], proc_path[PATH_MAX], *p; |
---|
994 | int n; |
---|
995 | |
---|
996 | snprintf(proc_path,PATH_MAX-1,"/proc/%d/path/a.out",getpid()); |
---|
997 | |
---|
998 | if ((n = readlink(proc_path, exepath, PATH_MAX)) > 0) { |
---|
999 | p = malloc(n+1); |
---|
1000 | memmove(p,exepath,n); |
---|
1001 | p[n]=0; |
---|
1002 | return p; |
---|
1003 | } |
---|
1004 | return ensure_real_path(argv0); |
---|
1005 | #endif |
---|
1006 | return ensure_real_path(argv0); |
---|
1007 | } |
---|
1008 | #endif |
---|
1009 | |
---|
1010 | #ifdef WINDOWS |
---|
1011 | wchar_t * |
---|
1012 | determine_executable_name() |
---|
1013 | { |
---|
1014 | DWORD nsize = 512, result; |
---|
1015 | wchar_t *buf = malloc(nsize*sizeof(wchar_t)); |
---|
1016 | |
---|
1017 | do { |
---|
1018 | result = GetModuleFileNameW(NULL, buf, nsize); |
---|
1019 | if (result == nsize) { |
---|
1020 | nsize *= 2; |
---|
1021 | buf = realloc(buf,nsize*sizeof(wchar_t)); |
---|
1022 | } else { |
---|
1023 | return buf; |
---|
1024 | } |
---|
1025 | } while (1); |
---|
1026 | } |
---|
1027 | |
---|
1028 | |
---|
1029 | wchar_t * |
---|
1030 | ensure_real_path(wchar_t *path) |
---|
1031 | { |
---|
1032 | int bufsize = 256, n; |
---|
1033 | |
---|
1034 | do { |
---|
1035 | wchar_t buf[bufsize]; |
---|
1036 | |
---|
1037 | n = GetFullPathNameW(path,bufsize,buf,NULL); |
---|
1038 | if (n == 0) { |
---|
1039 | return path; |
---|
1040 | } |
---|
1041 | |
---|
1042 | if (n < bufsize) { |
---|
1043 | int i; |
---|
1044 | wchar_t *q = calloc(n+1,sizeof(wchar_t)); |
---|
1045 | |
---|
1046 | for (i = 0; i < n; i++) { |
---|
1047 | q[i] = buf[i]; |
---|
1048 | } |
---|
1049 | return q; |
---|
1050 | } |
---|
1051 | bufsize = n+1; |
---|
1052 | } while (1); |
---|
1053 | } |
---|
1054 | #endif |
---|
1055 | |
---|
1056 | void |
---|
1057 | usage_exit(char *herald, int exit_status, char* other_args) |
---|
1058 | { |
---|
1059 | if (herald && *herald) { |
---|
1060 | fprintf(dbgout, "%s\n", herald); |
---|
1061 | } |
---|
1062 | fprintf(dbgout, "usage: %s <options>\n", program_name); |
---|
1063 | fprintf(dbgout, "\t or %s <image-name>\n", program_name); |
---|
1064 | fprintf(dbgout, "\t where <options> are one or more of:\n"); |
---|
1065 | if (other_args && *other_args) { |
---|
1066 | fputs(other_args, dbgout); |
---|
1067 | } |
---|
1068 | fprintf(dbgout, "\t-R, --heap-reserve <n>: reserve <n> (default: %lld)\n", |
---|
1069 | (u64_t) reserved_area_size); |
---|
1070 | fprintf(dbgout, "\t\t bytes for heap expansion\n"); |
---|
1071 | fprintf(dbgout, "\t-S, --stack-size <n>: set size of initial thread's control stack to <n>\n"); |
---|
1072 | fprintf(dbgout, "\t-Z, --thread-stack-size <n>: set default size of first (listener) thread's stacks based on <n>\n"); |
---|
1073 | fprintf(dbgout, "\t-b, --batch: exit when EOF on *STANDARD-INPUT*\n"); |
---|
1074 | fprintf(dbgout, "\t--no-sigtrap : obscure option for running under GDB\n"); |
---|
1075 | fprintf(dbgout, "\t-I, --image-name <image-name>\n"); |
---|
1076 | #ifndef WINDOWS |
---|
1077 | fprintf(dbgout, "\t and <image-name> defaults to %s\n", |
---|
1078 | default_image_name(program_name)); |
---|
1079 | #endif |
---|
1080 | fprintf(dbgout, "\n"); |
---|
1081 | _exit(exit_status); |
---|
1082 | } |
---|
1083 | |
---|
1084 | int no_sigtrap = 0; |
---|
1085 | #ifdef WINDOWS |
---|
1086 | wchar_t *image_name = NULL; |
---|
1087 | #else |
---|
1088 | char *image_name = NULL; |
---|
1089 | #endif |
---|
1090 | int batch_flag = 0; |
---|
1091 | |
---|
1092 | |
---|
1093 | natural |
---|
1094 | parse_numeric_option(char *arg, char *argname, natural default_val) |
---|
1095 | { |
---|
1096 | char *tail; |
---|
1097 | natural val = 0; |
---|
1098 | |
---|
1099 | val = strtoul(arg, &tail, 0); |
---|
1100 | switch(*tail) { |
---|
1101 | case '\0': |
---|
1102 | break; |
---|
1103 | |
---|
1104 | case 'M': |
---|
1105 | case 'm': |
---|
1106 | val = val << 20; |
---|
1107 | break; |
---|
1108 | |
---|
1109 | case 'K': |
---|
1110 | case 'k': |
---|
1111 | val = val << 10; |
---|
1112 | break; |
---|
1113 | |
---|
1114 | case 'G': |
---|
1115 | case 'g': |
---|
1116 | val = val << 30; |
---|
1117 | break; |
---|
1118 | |
---|
1119 | default: |
---|
1120 | fprintf(dbgout, "couldn't parse %s argument %s", argname, arg); |
---|
1121 | val = default_val; |
---|
1122 | break; |
---|
1123 | } |
---|
1124 | return val; |
---|
1125 | } |
---|
1126 | |
---|
1127 | |
---|
1128 | |
---|
1129 | /* |
---|
1130 | The set of arguments recognized by the kernel is |
---|
1131 | likely to remain pretty small and pretty simple. |
---|
1132 | This removes everything it recognizes from argv; |
---|
1133 | remaining args will be processed by lisp code. |
---|
1134 | */ |
---|
1135 | |
---|
1136 | void |
---|
1137 | process_options(int argc, char *argv[], wchar_t *shadow[]) |
---|
1138 | { |
---|
1139 | int i, j, k, num_elide, flag, arg_error; |
---|
1140 | char *arg, *val; |
---|
1141 | wchar_t *warg, *wval; |
---|
1142 | #ifdef DARWIN |
---|
1143 | extern int NXArgc; |
---|
1144 | #endif |
---|
1145 | |
---|
1146 | for (i = 1; i < argc;) { |
---|
1147 | arg = argv[i]; |
---|
1148 | if (shadow) { |
---|
1149 | warg = shadow[i]; |
---|
1150 | } |
---|
1151 | arg_error = 0; |
---|
1152 | if (*arg != '-') { |
---|
1153 | i++; |
---|
1154 | } else { |
---|
1155 | num_elide = 0; |
---|
1156 | val = NULL; |
---|
1157 | if ((flag = (strncmp(arg, "-I", 2) == 0)) || |
---|
1158 | (strcmp (arg, "--image-name") == 0)) { |
---|
1159 | if (flag && arg[2]) { |
---|
1160 | val = arg+2; |
---|
1161 | if (shadow) { |
---|
1162 | wval = warg+2; |
---|
1163 | } |
---|
1164 | num_elide = 1; |
---|
1165 | } else { |
---|
1166 | if ((i+1) < argc) { |
---|
1167 | val = argv[i+1]; |
---|
1168 | if (shadow) { |
---|
1169 | wval = shadow[i+1]; |
---|
1170 | } |
---|
1171 | num_elide = 2; |
---|
1172 | } else { |
---|
1173 | arg_error = 1; |
---|
1174 | } |
---|
1175 | } |
---|
1176 | if (val) { |
---|
1177 | #ifdef WINDOWS |
---|
1178 | image_name = wval; |
---|
1179 | #else |
---|
1180 | image_name = val; |
---|
1181 | #endif |
---|
1182 | } |
---|
1183 | } else if ((flag = (strncmp(arg, "-R", 2) == 0)) || |
---|
1184 | (strcmp(arg, "--heap-reserve") == 0)) { |
---|
1185 | natural reserved_size = reserved_area_size; |
---|
1186 | |
---|
1187 | if (flag && arg[2]) { |
---|
1188 | val = arg+2; |
---|
1189 | num_elide = 1; |
---|
1190 | } else { |
---|
1191 | if ((i+1) < argc) { |
---|
1192 | val = argv[i+1]; |
---|
1193 | num_elide = 2; |
---|
1194 | } else { |
---|
1195 | arg_error = 1; |
---|
1196 | } |
---|
1197 | } |
---|
1198 | |
---|
1199 | if (val) { |
---|
1200 | reserved_size = parse_numeric_option(val, |
---|
1201 | "-R/--heap-reserve", |
---|
1202 | reserved_area_size); |
---|
1203 | } |
---|
1204 | |
---|
1205 | if (reserved_size <= MAXIMUM_MAPPABLE_MEMORY) { |
---|
1206 | reserved_area_size = reserved_size; |
---|
1207 | } |
---|
1208 | |
---|
1209 | } else if ((flag = (strncmp(arg, "-S", 2) == 0)) || |
---|
1210 | (strcmp(arg, "--stack-size") == 0)) { |
---|
1211 | natural stack_size; |
---|
1212 | |
---|
1213 | if (flag && arg[2]) { |
---|
1214 | val = arg+2; |
---|
1215 | num_elide = 1; |
---|
1216 | } else { |
---|
1217 | if ((i+1) < argc) { |
---|
1218 | val = argv[i+1]; |
---|
1219 | num_elide = 2; |
---|
1220 | } else { |
---|
1221 | arg_error = 1; |
---|
1222 | } |
---|
1223 | } |
---|
1224 | |
---|
1225 | if (val) { |
---|
1226 | stack_size = parse_numeric_option(val, |
---|
1227 | "-S/--stack-size", |
---|
1228 | initial_stack_size); |
---|
1229 | |
---|
1230 | |
---|
1231 | if (stack_size >= MIN_CSTACK_SIZE) { |
---|
1232 | initial_stack_size = stack_size; |
---|
1233 | } |
---|
1234 | } |
---|
1235 | |
---|
1236 | } else if ((flag = (strncmp(arg, "-Z", 2) == 0)) || |
---|
1237 | (strcmp(arg, "--thread-stack-size") == 0)) { |
---|
1238 | natural stack_size; |
---|
1239 | |
---|
1240 | if (flag && arg[2]) { |
---|
1241 | val = arg+2; |
---|
1242 | num_elide = 1; |
---|
1243 | } else { |
---|
1244 | if ((i+1) < argc) { |
---|
1245 | val = argv[i+1]; |
---|
1246 | num_elide = 2; |
---|
1247 | } else { |
---|
1248 | arg_error = 1; |
---|
1249 | } |
---|
1250 | } |
---|
1251 | |
---|
1252 | if (val) { |
---|
1253 | stack_size = parse_numeric_option(val, |
---|
1254 | "-Z/--thread-stack-size", |
---|
1255 | thread_stack_size); |
---|
1256 | |
---|
1257 | |
---|
1258 | if (stack_size >= MIN_CSTACK_SIZE) { |
---|
1259 | thread_stack_size = stack_size; |
---|
1260 | } |
---|
1261 | if (thread_stack_size >= (1LL<<((WORD_SIZE-fixnumshift)-1))) { |
---|
1262 | thread_stack_size = (1LL<<((WORD_SIZE-fixnumshift)-1))-1; |
---|
1263 | } |
---|
1264 | |
---|
1265 | } |
---|
1266 | |
---|
1267 | } else if (strcmp(arg, "--no-sigtrap") == 0) { |
---|
1268 | no_sigtrap = 1; |
---|
1269 | num_elide = 1; |
---|
1270 | } else if ((strcmp(arg, "-b") == 0) || |
---|
1271 | (strcmp(arg, "--batch") == 0)) { |
---|
1272 | batch_flag = 1; |
---|
1273 | num_elide = 1; |
---|
1274 | } else if (strcmp(arg,"--") == 0) { |
---|
1275 | break; |
---|
1276 | } else { |
---|
1277 | i++; |
---|
1278 | } |
---|
1279 | if (arg_error) { |
---|
1280 | usage_exit("error in program arguments", 1, ""); |
---|
1281 | } |
---|
1282 | if (num_elide) { |
---|
1283 | for (j = i+num_elide, k=i; j < argc; j++, k++) { |
---|
1284 | argv[k] = argv[j]; |
---|
1285 | if (shadow) { |
---|
1286 | shadow[k] = shadow[j]; |
---|
1287 | } |
---|
1288 | } |
---|
1289 | argc -= num_elide; |
---|
1290 | #ifdef DARWIN |
---|
1291 | NXArgc -= num_elide; |
---|
1292 | #endif |
---|
1293 | argv[argc] = NULL; |
---|
1294 | if (shadow) { |
---|
1295 | shadow[argc] = NULL; |
---|
1296 | } |
---|
1297 | } |
---|
1298 | } |
---|
1299 | } |
---|
1300 | } |
---|
1301 | |
---|
1302 | #ifdef WINDOWS |
---|
1303 | void |
---|
1304 | terminate_lisp() |
---|
1305 | { |
---|
1306 | _exit(EXIT_FAILURE); |
---|
1307 | } |
---|
1308 | #else |
---|
1309 | pid_t main_thread_pid = (pid_t)0; |
---|
1310 | |
---|
1311 | void |
---|
1312 | terminate_lisp() |
---|
1313 | { |
---|
1314 | kill(main_thread_pid, SIGKILL); |
---|
1315 | _exit(-1); |
---|
1316 | } |
---|
1317 | #endif |
---|
1318 | |
---|
1319 | #ifdef DARWIN |
---|
1320 | #define min_os_version "8.0" /* aka Tiger */ |
---|
1321 | #endif |
---|
1322 | #ifdef LINUX |
---|
1323 | #ifdef PPC |
---|
1324 | #define min_os_version "2.2" |
---|
1325 | #endif |
---|
1326 | #ifdef X86 |
---|
1327 | #define min_os_version "2.6" |
---|
1328 | #endif |
---|
1329 | #endif |
---|
1330 | #ifdef FREEBSD |
---|
1331 | #define min_os_version "6.0" |
---|
1332 | #endif |
---|
1333 | #ifdef SOLARIS |
---|
1334 | #define min_os_version "5.10" |
---|
1335 | #endif |
---|
1336 | |
---|
1337 | #ifdef PPC |
---|
1338 | #if defined(PPC64) || !defined(DARWIN) |
---|
1339 | /* ld64 on Darwin doesn't offer anything close to reliable control |
---|
1340 | over the layout of a program in memory. About all that we can |
---|
1341 | be assured of is that the canonical subprims jump table address |
---|
1342 | (currently 0x5000) is unmapped. Map that page, and copy the |
---|
1343 | actual spjump table there. */ |
---|
1344 | |
---|
1345 | |
---|
1346 | void |
---|
1347 | remap_spjump() |
---|
1348 | { |
---|
1349 | extern opcode spjump_start, spjump_end; |
---|
1350 | pc new, |
---|
1351 | old = &spjump_start, |
---|
1352 | limit = &spjump_end, |
---|
1353 | work; |
---|
1354 | opcode instr; |
---|
1355 | void *target; |
---|
1356 | int disp; |
---|
1357 | |
---|
1358 | if (old != (pc)SPJUMP_TARGET_ADDRESS) { |
---|
1359 | new = mmap((pc) SPJUMP_TARGET_ADDRESS, |
---|
1360 | 0x1000, |
---|
1361 | PROT_READ | PROT_WRITE | PROT_EXEC, |
---|
1362 | MAP_PRIVATE | MAP_ANON | MAP_FIXED, |
---|
1363 | -1, |
---|
1364 | 0); |
---|
1365 | if (new != (pc) SPJUMP_TARGET_ADDRESS) { |
---|
1366 | perror("remap spjump"); |
---|
1367 | _exit(1); |
---|
1368 | } |
---|
1369 | |
---|
1370 | for (work = new; old < limit; work++, old++) { |
---|
1371 | instr = *old; |
---|
1372 | disp = instr & ((1<<26)-1); |
---|
1373 | target = (void*)old+disp; |
---|
1374 | disp = target-(void *)work; |
---|
1375 | *work = ((instr >> 26) << 26) | disp; |
---|
1376 | } |
---|
1377 | xMakeDataExecutable(new, (void*)work-(void*)new); |
---|
1378 | ProtectMemory(new, 0x1000); |
---|
1379 | } |
---|
1380 | } |
---|
1381 | #endif |
---|
1382 | #endif |
---|
1383 | |
---|
1384 | #ifdef X86 |
---|
1385 | #ifdef WINDOWS |
---|
1386 | |
---|
1387 | /* By using linker tricks, we ensure there's memory between 0x11000 |
---|
1388 | and 0x21000, so we just need to fix permissions and copy the spjump |
---|
1389 | table. */ |
---|
1390 | |
---|
1391 | void |
---|
1392 | remap_spjump() |
---|
1393 | { |
---|
1394 | extern opcode spjump_start; |
---|
1395 | DWORD old_protect; |
---|
1396 | |
---|
1397 | if ((void *)(&spjump_start) != (void *) SPJUMP_TARGET_ADDRESS) { |
---|
1398 | if (!VirtualProtect((pc) SPJUMP_TARGET_ADDRESS, |
---|
1399 | 0x1000, |
---|
1400 | PAGE_EXECUTE_READWRITE, |
---|
1401 | &old_protect)) { |
---|
1402 | wperror("VirtualProtect spjump"); |
---|
1403 | _exit(1); |
---|
1404 | } |
---|
1405 | memmove((pc) SPJUMP_TARGET_ADDRESS, &spjump_start, 0x1000); |
---|
1406 | } |
---|
1407 | } |
---|
1408 | #else |
---|
1409 | void |
---|
1410 | remap_spjump() |
---|
1411 | { |
---|
1412 | extern opcode spjump_start; |
---|
1413 | pc new = mmap((pc) SPJUMP_TARGET_ADDRESS, |
---|
1414 | 0x1000, |
---|
1415 | PROT_READ | PROT_WRITE | PROT_EXEC, |
---|
1416 | MAP_PRIVATE | MAP_ANON | MAP_FIXED, |
---|
1417 | -1, |
---|
1418 | 0), |
---|
1419 | old = &spjump_start; |
---|
1420 | if (new == (pc)-1) { |
---|
1421 | perror("remap spjump"); |
---|
1422 | _exit(1); |
---|
1423 | } |
---|
1424 | memmove(new, old, 0x1000); |
---|
1425 | } |
---|
1426 | #endif |
---|
1427 | #endif |
---|
1428 | |
---|
1429 | |
---|
1430 | void |
---|
1431 | check_os_version(char *progname) |
---|
1432 | { |
---|
1433 | #ifdef WINDOWS |
---|
1434 | /* We should be able to run with any version of Windows that actually gets here executing the binary, so don't do anything for now. */ |
---|
1435 | #else |
---|
1436 | struct utsname uts; |
---|
1437 | long got, want; |
---|
1438 | char *got_end,*want_end; |
---|
1439 | #ifdef X8632 |
---|
1440 | extern Boolean rcontext_readonly; |
---|
1441 | #endif |
---|
1442 | |
---|
1443 | want = strtoul(min_os_version,&want_end,10); |
---|
1444 | |
---|
1445 | uname(&uts); |
---|
1446 | got = strtoul(uts.release,&got_end,10); |
---|
1447 | #ifdef X8632 |
---|
1448 | #ifdef FREEBSD |
---|
1449 | if (!strcmp(uts.machine,"amd64")) { |
---|
1450 | rcontext_readonly = true; |
---|
1451 | } |
---|
1452 | #endif |
---|
1453 | #endif |
---|
1454 | while (got == want) { |
---|
1455 | if (*want_end == '.') { |
---|
1456 | want = strtoul(want_end+1,&want_end,10); |
---|
1457 | got = 0; |
---|
1458 | if (*got_end == '.') { |
---|
1459 | got = strtoul(got_end+1,&got_end,10); |
---|
1460 | } else { |
---|
1461 | break; |
---|
1462 | } |
---|
1463 | } else { |
---|
1464 | break; |
---|
1465 | } |
---|
1466 | } |
---|
1467 | |
---|
1468 | if (got < want) { |
---|
1469 | fprintf(dbgout, "\n%s requires %s version %s or later; the current version is %s.\n", progname, uts.sysname, min_os_version, uts.release); |
---|
1470 | exit(1); |
---|
1471 | } |
---|
1472 | #endif |
---|
1473 | } |
---|
1474 | |
---|
1475 | #ifdef X86 |
---|
1476 | /* |
---|
1477 | This should determine the cache block size. It should also |
---|
1478 | probably complain if we don't have (at least) SSE2. |
---|
1479 | */ |
---|
1480 | extern int cpuid(natural, natural*, natural*, natural*); |
---|
1481 | |
---|
1482 | #define X86_FEATURE_CMOV (1<<15) |
---|
1483 | #define X86_FEATURE_CLFLUSH (1<<19) |
---|
1484 | #define X86_FEATURE_MMX (1<<23) |
---|
1485 | #define X86_FEATURE_SSE (1<<25) |
---|
1486 | #define X86_FEATURE_SSE2 (1<<26) |
---|
1487 | |
---|
1488 | #define X86_REQUIRED_FEATURES (X86_FEATURE_CMOV|X86_FEATURE_MMX|X86_FEATURE_SSE|X86_FEATURE_SSE2) |
---|
1489 | |
---|
1490 | Boolean |
---|
1491 | check_x86_cpu() |
---|
1492 | { |
---|
1493 | natural eax, ebx, ecx, edx; |
---|
1494 | |
---|
1495 | eax = cpuid(0, &ebx, &ecx, &edx); |
---|
1496 | |
---|
1497 | if (eax >= 1) { |
---|
1498 | eax = cpuid(1, &ebx, &ecx, &edx); |
---|
1499 | cache_block_size = (ebx & 0xff00) >> 5; |
---|
1500 | if ((X86_REQUIRED_FEATURES & edx) == X86_REQUIRED_FEATURES) { |
---|
1501 | return true; |
---|
1502 | } |
---|
1503 | /* It's very unlikely that SSE2 would be present and other things |
---|
1504 | that we want wouldn't. If they don't have MMX or CMOV either, |
---|
1505 | might as well tell them. */ |
---|
1506 | if ((edx & X86_FEATURE_SSE2) == 0) { |
---|
1507 | fprintf(dbgout, "This CPU doesn't support the SSE2 instruction set\n"); |
---|
1508 | } |
---|
1509 | if ((edx & X86_FEATURE_MMX) == 0) { |
---|
1510 | fprintf(dbgout, "This CPU doesn't support the MMX instruction set\n"); |
---|
1511 | } |
---|
1512 | if ((edx & X86_FEATURE_CMOV) == 0) { |
---|
1513 | fprintf(dbgout, "This CPU doesn't support the CMOV instruction\n"); |
---|
1514 | } |
---|
1515 | |
---|
1516 | } |
---|
1517 | return false; |
---|
1518 | } |
---|
1519 | #endif |
---|
1520 | |
---|
1521 | void |
---|
1522 | lazarus() |
---|
1523 | { |
---|
1524 | TCR *tcr = get_tcr(false); |
---|
1525 | if (tcr) { |
---|
1526 | /* Some threads may be dying; no threads should be created. */ |
---|
1527 | LOCK(lisp_global(TCR_AREA_LOCK),tcr); |
---|
1528 | tcr->vs_area->active = tcr->vs_area->high - node_size; |
---|
1529 | tcr->save_vsp = (LispObj *)(tcr->vs_area->active); |
---|
1530 | tcr->ts_area->active = tcr->ts_area->high; |
---|
1531 | tcr->save_tsp = (LispObj *)(tcr->ts_area->active); |
---|
1532 | tcr->catch_top = 0; |
---|
1533 | tcr->db_link = 0; |
---|
1534 | tcr->xframe = 0; |
---|
1535 | start_lisp(tcr, 0); |
---|
1536 | } |
---|
1537 | } |
---|
1538 | |
---|
1539 | #ifdef LINUX |
---|
1540 | #ifdef X8664 |
---|
1541 | #include <asm/prctl.h> |
---|
1542 | #include <sys/prctl.h> |
---|
1543 | |
---|
1544 | void |
---|
1545 | ensure_gs_available(char *progname) |
---|
1546 | { |
---|
1547 | LispObj fs_addr = 0L, gs_addr = 0L, cur_thread = (LispObj)pthread_self(); |
---|
1548 | char *gnu_get_libc_version(void); |
---|
1549 | |
---|
1550 | arch_prctl(ARCH_GET_GS, &gs_addr); |
---|
1551 | arch_prctl(ARCH_GET_FS, &fs_addr); |
---|
1552 | if ((gs_addr == cur_thread) && (fs_addr != cur_thread)) { |
---|
1553 | fprintf(dbgout, "The installed C library - version %s - seems to be using the %%gs register for thread storage.\n\"%s\" cannot run, since it expects to be\nable to use that register for its own purposes.\n", gnu_get_libc_version(),progname); |
---|
1554 | _exit(1); |
---|
1555 | } |
---|
1556 | } |
---|
1557 | #endif |
---|
1558 | #endif |
---|
1559 | |
---|
1560 | Boolean |
---|
1561 | bogus_fp_exceptions = false; |
---|
1562 | |
---|
1563 | typedef |
---|
1564 | float (*float_arg_returns_float)(float); |
---|
1565 | |
---|
1566 | float |
---|
1567 | fcallf(float_arg_returns_float fun, float arg) |
---|
1568 | { |
---|
1569 | return fun(arg); |
---|
1570 | } |
---|
1571 | |
---|
1572 | void |
---|
1573 | check_bogus_fp_exceptions() |
---|
1574 | { |
---|
1575 | #ifdef X8664 |
---|
1576 | float asinf(float),result; |
---|
1577 | |
---|
1578 | |
---|
1579 | natural save_mxcsr = get_mxcsr(), post_mxcsr; |
---|
1580 | set_mxcsr(0x1f80); |
---|
1581 | |
---|
1582 | result = fcallf(asinf, 1.0); |
---|
1583 | post_mxcsr = get_mxcsr(); |
---|
1584 | set_mxcsr(save_mxcsr); |
---|
1585 | if (post_mxcsr & (FE_ALL_EXCEPT & (~FE_INEXACT))) { |
---|
1586 | bogus_fp_exceptions = true; |
---|
1587 | } |
---|
1588 | #endif |
---|
1589 | } |
---|
1590 | |
---|
1591 | #ifdef WINDOWS |
---|
1592 | char * |
---|
1593 | utf_16_to_utf_8(wchar_t *utf_16) |
---|
1594 | { |
---|
1595 | int utf8len = WideCharToMultiByte(CP_UTF8, |
---|
1596 | 0, |
---|
1597 | utf_16, |
---|
1598 | -1, |
---|
1599 | NULL, |
---|
1600 | 0, |
---|
1601 | NULL, |
---|
1602 | NULL); |
---|
1603 | |
---|
1604 | char *utf_8 = malloc(utf8len); |
---|
1605 | |
---|
1606 | WideCharToMultiByte(CP_UTF8, |
---|
1607 | 0, |
---|
1608 | utf_16, |
---|
1609 | -1, |
---|
1610 | utf_8, |
---|
1611 | utf8len, |
---|
1612 | NULL, |
---|
1613 | NULL); |
---|
1614 | |
---|
1615 | return utf_8; |
---|
1616 | } |
---|
1617 | |
---|
1618 | char ** |
---|
1619 | wide_argv_to_utf_8(wchar_t *wide_argv[], int argc) |
---|
1620 | { |
---|
1621 | char** argv = calloc(argc+1,sizeof(char *)); |
---|
1622 | int i; |
---|
1623 | |
---|
1624 | for (i = 0; i < argc; i++) { |
---|
1625 | if (wide_argv[i]) { |
---|
1626 | argv[i] = utf_16_to_utf_8(wide_argv[i]); |
---|
1627 | } else { |
---|
1628 | argv[i] = NULL; |
---|
1629 | } |
---|
1630 | } |
---|
1631 | return argv; |
---|
1632 | } |
---|
1633 | #endif |
---|
1634 | |
---|
1635 | |
---|
1636 | |
---|
1637 | |
---|
1638 | |
---|
1639 | int |
---|
1640 | main(int argc, char *argv[] |
---|
1641 | #ifndef WINDOWS |
---|
1642 | , char *envp[], void *aux |
---|
1643 | #endif |
---|
1644 | ) |
---|
1645 | { |
---|
1646 | extern int page_size; |
---|
1647 | natural default_g0_threshold = G0_AREA_THRESHOLD, |
---|
1648 | default_g1_threshold = G1_AREA_THRESHOLD, |
---|
1649 | default_g2_threshold = G2_AREA_THRESHOLD, |
---|
1650 | lisp_heap_threshold_from_image = 0; |
---|
1651 | Boolean egc_enabled = |
---|
1652 | #ifdef DISABLE_EGC |
---|
1653 | false |
---|
1654 | #else |
---|
1655 | true |
---|
1656 | #endif |
---|
1657 | ; |
---|
1658 | Boolean lisp_heap_threshold_set_from_command_line = false; |
---|
1659 | wchar_t **utf_16_argv = NULL; |
---|
1660 | |
---|
1661 | #ifdef PPC |
---|
1662 | extern int altivec_present; |
---|
1663 | #endif |
---|
1664 | #ifdef WINDOWS |
---|
1665 | extern LispObj load_image(wchar_t *); |
---|
1666 | #else |
---|
1667 | extern LispObj load_image(char *); |
---|
1668 | #endif |
---|
1669 | area *a; |
---|
1670 | BytePtr stack_base, current_sp = (BytePtr) current_stack_pointer(); |
---|
1671 | TCR *tcr; |
---|
1672 | |
---|
1673 | dbgout = stderr; |
---|
1674 | |
---|
1675 | #ifdef WINDOWS |
---|
1676 | { |
---|
1677 | int wide_argc; |
---|
1678 | extern void init_winsock(void); |
---|
1679 | extern void init_windows_io(void); |
---|
1680 | |
---|
1681 | _fmode = O_BINARY; |
---|
1682 | _setmode(1, O_BINARY); |
---|
1683 | _setmode(2, O_BINARY); |
---|
1684 | setvbuf(dbgout, NULL, _IONBF, 0); |
---|
1685 | init_winsock(); |
---|
1686 | init_windows_io(); |
---|
1687 | utf_16_argv = CommandLineToArgvW(GetCommandLineW(),&wide_argc); |
---|
1688 | } |
---|
1689 | #endif |
---|
1690 | |
---|
1691 | check_os_version(argv[0]); |
---|
1692 | #ifdef WINDOWS |
---|
1693 | real_executable_name = determine_executable_name(); |
---|
1694 | #else |
---|
1695 | real_executable_name = determine_executable_name(argv[0]); |
---|
1696 | #endif |
---|
1697 | page_size = getpagesize(); /* Implement with GetSystemInfo on Windows w/o MinGW */ |
---|
1698 | |
---|
1699 | check_bogus_fp_exceptions(); |
---|
1700 | #ifdef LINUX |
---|
1701 | #ifdef X8664 |
---|
1702 | ensure_gs_available(real_executable_name); |
---|
1703 | #endif |
---|
1704 | #endif |
---|
1705 | #if (defined(DARWIN) && defined(PPC64)) || (defined(LINUX) && defined(PPC))|| defined(X8664) || (defined(X8632) && !defined(DARWIN)) |
---|
1706 | remap_spjump(); |
---|
1707 | #endif |
---|
1708 | |
---|
1709 | #ifdef PPC |
---|
1710 | #ifdef LINUX |
---|
1711 | { |
---|
1712 | ElfW(auxv_t) *av = aux; |
---|
1713 | int hwcap, done = false; |
---|
1714 | |
---|
1715 | if (av) { |
---|
1716 | do { |
---|
1717 | switch (av->a_type) { |
---|
1718 | case AT_DCACHEBSIZE: |
---|
1719 | cache_block_size = av->a_un.a_val; |
---|
1720 | break; |
---|
1721 | |
---|
1722 | case AT_HWCAP: |
---|
1723 | hwcap = av->a_un.a_val; |
---|
1724 | altivec_present = ((hwcap & PPC_FEATURE_HAS_ALTIVEC) != 0); |
---|
1725 | break; |
---|
1726 | |
---|
1727 | case AT_NULL: |
---|
1728 | done = true; |
---|
1729 | break; |
---|
1730 | } |
---|
1731 | av++; |
---|
1732 | } while (!done); |
---|
1733 | } |
---|
1734 | } |
---|
1735 | #endif |
---|
1736 | #ifdef DARWIN |
---|
1737 | { |
---|
1738 | unsigned value = 0; |
---|
1739 | size_t len = sizeof(value); |
---|
1740 | int mib[2]; |
---|
1741 | |
---|
1742 | mib[0] = CTL_HW; |
---|
1743 | mib[1] = HW_CACHELINE; |
---|
1744 | if (sysctl(mib,2,&value,&len, NULL, 0) != -1) { |
---|
1745 | if (len == sizeof(value)) { |
---|
1746 | cache_block_size = value; |
---|
1747 | } |
---|
1748 | } |
---|
1749 | mib[1] = HW_VECTORUNIT; |
---|
1750 | value = 0; |
---|
1751 | len = sizeof(value); |
---|
1752 | if (sysctl(mib,2,&value,&len, NULL, 0) != -1) { |
---|
1753 | if (len == sizeof(value)) { |
---|
1754 | altivec_present = value; |
---|
1755 | } |
---|
1756 | } |
---|
1757 | } |
---|
1758 | #endif |
---|
1759 | #endif |
---|
1760 | |
---|
1761 | #ifdef X86 |
---|
1762 | if (!check_x86_cpu()) { |
---|
1763 | fprintf(dbgout, "CPU doesn't support required features\n"); |
---|
1764 | exit(1); |
---|
1765 | } |
---|
1766 | #endif |
---|
1767 | |
---|
1768 | #ifdef SOLARIS |
---|
1769 | #ifdef X8632 |
---|
1770 | { |
---|
1771 | extern void solaris_ldt_init(void); |
---|
1772 | solaris_ldt_init(); |
---|
1773 | } |
---|
1774 | #endif |
---|
1775 | #endif |
---|
1776 | |
---|
1777 | #ifndef WINDOWS |
---|
1778 | main_thread_pid = getpid(); |
---|
1779 | #endif |
---|
1780 | tcr_area_lock = (void *)new_recursive_lock(); |
---|
1781 | |
---|
1782 | program_name = argv[0]; |
---|
1783 | if ((argc == 2) && (*argv[1] != '-')) { |
---|
1784 | #ifdef WINDOWS |
---|
1785 | image_name = utf_16_argv[1]; |
---|
1786 | #else |
---|
1787 | image_name = argv[1]; |
---|
1788 | #endif |
---|
1789 | argv[1] = NULL; |
---|
1790 | #ifdef WINDOWS |
---|
1791 | utf_16_argv[1] = NULL; |
---|
1792 | #endif |
---|
1793 | } else { |
---|
1794 | process_options(argc,argv,utf_16_argv); |
---|
1795 | } |
---|
1796 | if (lisp_heap_gc_threshold != DEFAULT_LISP_HEAP_GC_THRESHOLD) { |
---|
1797 | lisp_heap_threshold_set_from_command_line = true; |
---|
1798 | } |
---|
1799 | |
---|
1800 | initial_stack_size = ensure_stack_limit(initial_stack_size); |
---|
1801 | if (image_name == NULL) { |
---|
1802 | if (check_for_embedded_image(real_executable_name)) { |
---|
1803 | image_name = real_executable_name; |
---|
1804 | } else { |
---|
1805 | image_name = default_image_name(real_executable_name); |
---|
1806 | } |
---|
1807 | } |
---|
1808 | |
---|
1809 | while (1) { |
---|
1810 | if (create_reserved_area(reserved_area_size)) { |
---|
1811 | break; |
---|
1812 | } |
---|
1813 | reserved_area_size = reserved_area_size *.9; |
---|
1814 | } |
---|
1815 | |
---|
1816 | gc_init(); |
---|
1817 | |
---|
1818 | set_nil(load_image(image_name)); |
---|
1819 | lisp_heap_threshold_from_image = lisp_global(LISP_HEAP_THRESHOLD); |
---|
1820 | if (lisp_heap_threshold_from_image) { |
---|
1821 | if ((!lisp_heap_threshold_set_from_command_line) && |
---|
1822 | (lisp_heap_threshold_from_image != lisp_heap_gc_threshold)) { |
---|
1823 | lisp_heap_gc_threshold = lisp_heap_threshold_from_image; |
---|
1824 | resize_dynamic_heap(active_dynamic_area->active,lisp_heap_gc_threshold); |
---|
1825 | } |
---|
1826 | /* If lisp_heap_threshold_from_image was set, other image params are |
---|
1827 | valid. */ |
---|
1828 | default_g0_threshold = lisp_global(G0_THRESHOLD); |
---|
1829 | default_g1_threshold = lisp_global(G1_THRESHOLD); |
---|
1830 | default_g2_threshold = lisp_global(G2_THRESHOLD); |
---|
1831 | egc_enabled = lisp_global(EGC_ENABLED); |
---|
1832 | } |
---|
1833 | |
---|
1834 | lisp_global(TCR_AREA_LOCK) = ptr_to_lispobj(tcr_area_lock); |
---|
1835 | |
---|
1836 | #ifdef X86 |
---|
1837 | lisp_global(SUBPRIMS_BASE) = (LispObj)((1<<16)+(5<<10)); |
---|
1838 | #else |
---|
1839 | lisp_global(SUBPRIMS_BASE) = (LispObj)(5<<10); |
---|
1840 | #endif |
---|
1841 | lisp_global(RET1VALN) = (LispObj)&ret1valn; |
---|
1842 | lisp_global(LEXPR_RETURN) = (LispObj)&nvalret; |
---|
1843 | lisp_global(LEXPR_RETURN1V) = (LispObj)&popj; |
---|
1844 | lisp_global(ALL_AREAS) = ptr_to_lispobj(all_areas); |
---|
1845 | lisp_global(DEFAULT_ALLOCATION_QUANTUM) = log2_heap_segment_size << fixnumshift; |
---|
1846 | lisp_global(STACK_SIZE) = thread_stack_size<<fixnumshift; |
---|
1847 | |
---|
1848 | |
---|
1849 | exception_init(); |
---|
1850 | |
---|
1851 | |
---|
1852 | |
---|
1853 | #ifdef WINDOWS |
---|
1854 | lisp_global(IMAGE_NAME) = ptr_to_lispobj(utf_16_to_utf_8(ensure_real_path(image_name))); |
---|
1855 | lisp_global(KERNEL_PATH) = ptr_to_lispobj(utf_16_to_utf_8(real_executable_name)); |
---|
1856 | lisp_global(ARGV) = ptr_to_lispobj(wide_argv_to_utf_8(utf_16_argv, argc)); |
---|
1857 | #else |
---|
1858 | lisp_global(IMAGE_NAME) = ptr_to_lispobj(ensure_real_path(image_name)); |
---|
1859 | lisp_global(KERNEL_PATH) = ptr_to_lispobj(real_executable_name); |
---|
1860 | lisp_global(ARGV) = ptr_to_lispobj(argv); |
---|
1861 | #endif |
---|
1862 | lisp_global(KERNEL_IMPORTS) = (LispObj)import_ptrs_base; |
---|
1863 | |
---|
1864 | lisp_global(GET_TCR) = (LispObj) get_tcr; |
---|
1865 | *(double *) &(lisp_global(DOUBLE_FLOAT_ONE)) = (double) 1.0; |
---|
1866 | |
---|
1867 | lisp_global(HOST_PLATFORM) = (LispObj) PLATFORM << fixnumshift; |
---|
1868 | |
---|
1869 | lisp_global(BATCH_FLAG) = (batch_flag << fixnumshift); |
---|
1870 | |
---|
1871 | a = active_dynamic_area; |
---|
1872 | |
---|
1873 | if (nilreg_area != NULL) { |
---|
1874 | BytePtr lowptr = (BytePtr) a->low; |
---|
1875 | |
---|
1876 | /* Create these areas as AREA_STATIC, change them to AREA_DYNAMIC */ |
---|
1877 | g1_area = new_area(lowptr, lowptr, AREA_STATIC); |
---|
1878 | g2_area = new_area(lowptr, lowptr, AREA_STATIC); |
---|
1879 | tenured_area = new_area(lowptr, lowptr, AREA_STATIC); |
---|
1880 | add_area_holding_area_lock(tenured_area); |
---|
1881 | add_area_holding_area_lock(g2_area); |
---|
1882 | add_area_holding_area_lock(g1_area); |
---|
1883 | |
---|
1884 | g1_area->code = AREA_DYNAMIC; |
---|
1885 | g2_area->code = AREA_DYNAMIC; |
---|
1886 | tenured_area->code = AREA_DYNAMIC; |
---|
1887 | |
---|
1888 | /* a->older = g1_area; */ /* Not yet: this is what "enabling the EGC" does. */ |
---|
1889 | g1_area->younger = a; |
---|
1890 | g1_area->older = g2_area; |
---|
1891 | g2_area->younger = g1_area; |
---|
1892 | g2_area->older = tenured_area; |
---|
1893 | tenured_area->younger = g2_area; |
---|
1894 | tenured_area->refbits = a->markbits; |
---|
1895 | tenured_area->static_dnodes = a->static_dnodes; |
---|
1896 | a->static_dnodes = 0; |
---|
1897 | tenured_area->static_used = a->static_used; |
---|
1898 | a->static_used = 0; |
---|
1899 | lisp_global(TENURED_AREA) = ptr_to_lispobj(tenured_area); |
---|
1900 | lisp_global(REFBITS) = ptr_to_lispobj(tenured_area->refbits); |
---|
1901 | g2_area->threshold = default_g2_threshold; |
---|
1902 | g1_area->threshold = default_g1_threshold; |
---|
1903 | a->threshold = default_g0_threshold; |
---|
1904 | } |
---|
1905 | |
---|
1906 | tcr = new_tcr(initial_stack_size, MIN_TSTACK_SIZE); |
---|
1907 | stack_base = initial_stack_bottom()-xStackSpace(); |
---|
1908 | init_threads((void *)(stack_base), tcr); |
---|
1909 | thread_init_tcr(tcr, current_sp, current_sp-stack_base); |
---|
1910 | |
---|
1911 | lisp_global(EXCEPTION_LOCK) = ptr_to_lispobj(new_recursive_lock()); |
---|
1912 | enable_fp_exceptions(); |
---|
1913 | register_user_signal_handler(); |
---|
1914 | |
---|
1915 | #ifdef PPC |
---|
1916 | lisp_global(ALTIVEC_PRESENT) = altivec_present << fixnumshift; |
---|
1917 | #endif |
---|
1918 | #if STATIC |
---|
1919 | lisp_global(STATICALLY_LINKED) = 1 << fixnumshift; |
---|
1920 | #endif |
---|
1921 | tcr->prev = tcr->next = tcr; |
---|
1922 | #ifndef WINDOWS |
---|
1923 | lisp_global(INTERRUPT_SIGNAL) = (LispObj) box_fixnum(SIGNAL_FOR_PROCESS_INTERRUPT); |
---|
1924 | #endif |
---|
1925 | tcr->vs_area->active -= node_size; |
---|
1926 | *(--tcr->save_vsp) = nrs_TOPLFUNC.vcell; |
---|
1927 | nrs_TOPLFUNC.vcell = lisp_nil; |
---|
1928 | #ifdef GC_INTEGRITY_CHECKING |
---|
1929 | (nrs_GC_EVENT_STATUS_BITS.vcell |= gc_integrity_check_bit); |
---|
1930 | #endif |
---|
1931 | if (egc_enabled) { |
---|
1932 | egc_control(true, NULL); |
---|
1933 | } |
---|
1934 | atexit(lazarus); |
---|
1935 | start_lisp(TCR_TO_TSD(tcr), 0); |
---|
1936 | _exit(0); |
---|
1937 | } |
---|
1938 | |
---|
1939 | area * |
---|
1940 | set_nil(LispObj r) |
---|
1941 | { |
---|
1942 | |
---|
1943 | if (lisp_nil == (LispObj)NULL) { |
---|
1944 | |
---|
1945 | lisp_nil = r; |
---|
1946 | } |
---|
1947 | return NULL; |
---|
1948 | } |
---|
1949 | |
---|
1950 | |
---|
1951 | void |
---|
1952 | xMakeDataExecutable(void *start, unsigned long nbytes) |
---|
1953 | { |
---|
1954 | #ifndef X86 |
---|
1955 | extern void flush_cache_lines(); |
---|
1956 | natural ustart = (natural) start, base, end; |
---|
1957 | |
---|
1958 | base = (ustart) & ~(cache_block_size-1); |
---|
1959 | end = (ustart + nbytes + cache_block_size - 1) & ~(cache_block_size-1); |
---|
1960 | flush_cache_lines(base, (end-base)/cache_block_size, cache_block_size); |
---|
1961 | #endif |
---|
1962 | } |
---|
1963 | |
---|
1964 | natural |
---|
1965 | xStackSpace() |
---|
1966 | { |
---|
1967 | return initial_stack_size+CSTACK_HARDPROT+CSTACK_SOFTPROT; |
---|
1968 | } |
---|
1969 | |
---|
1970 | #ifndef DARWIN |
---|
1971 | #ifdef WINDOWS |
---|
1972 | extern void *windows_open_shared_library(char *); |
---|
1973 | |
---|
1974 | void * |
---|
1975 | xGetSharedLibrary(char *path, int mode) |
---|
1976 | { |
---|
1977 | return windows_open_shared_library(path); |
---|
1978 | } |
---|
1979 | #else |
---|
1980 | void * |
---|
1981 | xGetSharedLibrary(char *path, int mode) |
---|
1982 | { |
---|
1983 | return dlopen(path, mode); |
---|
1984 | } |
---|
1985 | #endif |
---|
1986 | #else |
---|
1987 | void * |
---|
1988 | xGetSharedLibrary(char *path, int *resultType) |
---|
1989 | { |
---|
1990 | #if 0 |
---|
1991 | NSObjectFileImageReturnCode code; |
---|
1992 | NSObjectFileImage moduleImage; |
---|
1993 | NSModule module; |
---|
1994 | const struct mach_header * header; |
---|
1995 | const char * error; |
---|
1996 | void * result; |
---|
1997 | /* not thread safe */ |
---|
1998 | /* |
---|
1999 | static struct { |
---|
2000 | const struct mach_header *header; |
---|
2001 | NSModule *module; |
---|
2002 | const char *error; |
---|
2003 | } results; |
---|
2004 | */ |
---|
2005 | result = NULL; |
---|
2006 | error = NULL; |
---|
2007 | |
---|
2008 | /* first try to open this as a bundle */ |
---|
2009 | code = NSCreateObjectFileImageFromFile(path,&moduleImage); |
---|
2010 | if (code != NSObjectFileImageSuccess && |
---|
2011 | code != NSObjectFileImageInappropriateFile && |
---|
2012 | code != NSObjectFileImageAccess) |
---|
2013 | { |
---|
2014 | /* compute error strings */ |
---|
2015 | switch (code) |
---|
2016 | { |
---|
2017 | case NSObjectFileImageFailure: |
---|
2018 | error = "NSObjectFileImageFailure"; |
---|
2019 | break; |
---|
2020 | case NSObjectFileImageArch: |
---|
2021 | error = "NSObjectFileImageArch"; |
---|
2022 | break; |
---|
2023 | case NSObjectFileImageFormat: |
---|
2024 | error = "NSObjectFileImageFormat"; |
---|
2025 | break; |
---|
2026 | case NSObjectFileImageAccess: |
---|
2027 | /* can't find the file */ |
---|
2028 | error = "NSObjectFileImageAccess"; |
---|
2029 | break; |
---|
2030 | default: |
---|
2031 | error = "unknown error"; |
---|
2032 | } |
---|
2033 | *resultType = 0; |
---|
2034 | return (void *)error; |
---|
2035 | } |
---|
2036 | if (code == NSObjectFileImageInappropriateFile || |
---|
2037 | code == NSObjectFileImageAccess ) { |
---|
2038 | /* the pathname might be a partial pathane (hence the access error) |
---|
2039 | or it might be something other than a bundle, if so perhaps |
---|
2040 | it is a .dylib so now try to open it as a .dylib */ |
---|
2041 | |
---|
2042 | /* protect against redundant loads, Gary Byers noticed possible |
---|
2043 | heap corruption if this isn't done */ |
---|
2044 | header = NSAddImage(path, NSADDIMAGE_OPTION_RETURN_ON_ERROR | |
---|
2045 | NSADDIMAGE_OPTION_WITH_SEARCHING | |
---|
2046 | NSADDIMAGE_OPTION_RETURN_ONLY_IF_LOADED); |
---|
2047 | if (!header) |
---|
2048 | header = NSAddImage(path, NSADDIMAGE_OPTION_RETURN_ON_ERROR | |
---|
2049 | NSADDIMAGE_OPTION_WITH_SEARCHING); |
---|
2050 | result = (void *)header; |
---|
2051 | *resultType = 1; |
---|
2052 | } |
---|
2053 | else if (code == NSObjectFileImageSuccess) { |
---|
2054 | /* we have a sucessful module image |
---|
2055 | try to link it, don't bind symbols privately */ |
---|
2056 | |
---|
2057 | module = NSLinkModule(moduleImage, path, |
---|
2058 | NSLINKMODULE_OPTION_RETURN_ON_ERROR | NSLINKMODULE_OPTION_BINDNOW); |
---|
2059 | NSDestroyObjectFileImage(moduleImage); |
---|
2060 | result = (void *)module; |
---|
2061 | *resultType = 2; |
---|
2062 | } |
---|
2063 | if (!result) |
---|
2064 | { |
---|
2065 | /* compute error string */ |
---|
2066 | NSLinkEditErrors ler; |
---|
2067 | int lerno; |
---|
2068 | const char* file; |
---|
2069 | NSLinkEditError(&ler,&lerno,&file,&error); |
---|
2070 | if (error) { |
---|
2071 | result = (void *)error; |
---|
2072 | *resultType = 0; |
---|
2073 | } |
---|
2074 | } |
---|
2075 | return result; |
---|
2076 | #else |
---|
2077 | const char * error; |
---|
2078 | void * result; |
---|
2079 | |
---|
2080 | result = dlopen(path, RTLD_NOW | RTLD_GLOBAL); |
---|
2081 | |
---|
2082 | if (result == NULL) { |
---|
2083 | error = dlerror(); |
---|
2084 | *resultType = 0; |
---|
2085 | return (void *)error; |
---|
2086 | } |
---|
2087 | *resultType = 1; |
---|
2088 | return result; |
---|
2089 | #endif |
---|
2090 | } |
---|
2091 | #endif |
---|
2092 | |
---|
2093 | |
---|
2094 | |
---|
2095 | int |
---|
2096 | fd_setsize_bytes() |
---|
2097 | { |
---|
2098 | return FD_SETSIZE/8; |
---|
2099 | } |
---|
2100 | |
---|
2101 | void |
---|
2102 | do_fd_set(int fd, fd_set *fdsetp) |
---|
2103 | { |
---|
2104 | FD_SET(fd, fdsetp); |
---|
2105 | } |
---|
2106 | |
---|
2107 | void |
---|
2108 | do_fd_clr(int fd, fd_set *fdsetp) |
---|
2109 | { |
---|
2110 | FD_CLR(fd, fdsetp); |
---|
2111 | } |
---|
2112 | |
---|
2113 | int |
---|
2114 | do_fd_is_set(int fd, fd_set *fdsetp) |
---|
2115 | { |
---|
2116 | return FD_ISSET(fd,fdsetp); |
---|
2117 | } |
---|
2118 | |
---|
2119 | |
---|
2120 | void |
---|
2121 | do_fd_zero(fd_set *fdsetp) |
---|
2122 | { |
---|
2123 | FD_ZERO(fdsetp); |
---|
2124 | } |
---|
2125 | |
---|
2126 | #include "image.h" |
---|
2127 | |
---|
2128 | |
---|
2129 | |
---|
2130 | Boolean |
---|
2131 | check_for_embedded_image ( |
---|
2132 | #ifdef WINDOWS |
---|
2133 | wchar_t *path |
---|
2134 | #else |
---|
2135 | char *path |
---|
2136 | #endif |
---|
2137 | ) |
---|
2138 | { |
---|
2139 | #ifdef WINDOWS |
---|
2140 | int fd = wopen(path, O_RDONLY); |
---|
2141 | #else |
---|
2142 | int fd = open(path, O_RDONLY); |
---|
2143 | #endif |
---|
2144 | |
---|
2145 | Boolean image_is_embedded = false; |
---|
2146 | |
---|
2147 | if (fd >= 0) { |
---|
2148 | openmcl_image_file_header h; |
---|
2149 | |
---|
2150 | if (find_openmcl_image_file_header (fd, &h)) { |
---|
2151 | image_is_embedded = true; |
---|
2152 | } |
---|
2153 | close (fd); |
---|
2154 | } |
---|
2155 | return image_is_embedded; |
---|
2156 | } |
---|
2157 | |
---|
2158 | LispObj |
---|
2159 | load_image( |
---|
2160 | #ifdef WINDOWS |
---|
2161 | wchar_t * path |
---|
2162 | #else |
---|
2163 | char *path |
---|
2164 | #endif |
---|
2165 | ) |
---|
2166 | { |
---|
2167 | #ifdef WINDOWS |
---|
2168 | int fd = wopen(path, O_RDONLY, 0666), err; |
---|
2169 | #else |
---|
2170 | int fd = open(path, O_RDONLY, 0666), err; |
---|
2171 | #endif |
---|
2172 | LispObj image_nil = 0; |
---|
2173 | |
---|
2174 | if (fd > 0) { |
---|
2175 | openmcl_image_file_header ih; |
---|
2176 | |
---|
2177 | errno = 0; |
---|
2178 | image_nil = load_openmcl_image(fd, &ih); |
---|
2179 | /* We -were- using a duplicate fd to map the file; that |
---|
2180 | seems to confuse Darwin (doesn't everything ?), so |
---|
2181 | we'll instead keep the original file open. |
---|
2182 | */ |
---|
2183 | err = errno; |
---|
2184 | if (!image_nil) { |
---|
2185 | close(fd); |
---|
2186 | } |
---|
2187 | #ifdef WINDOWS |
---|
2188 | /* We currently don't actually map the image, and leaving the file |
---|
2189 | open seems to make it difficult to write to reliably. */ |
---|
2190 | if (image_nil) { |
---|
2191 | close(fd); |
---|
2192 | } |
---|
2193 | #endif |
---|
2194 | } else { |
---|
2195 | err = errno; |
---|
2196 | } |
---|
2197 | if (image_nil == 0) { |
---|
2198 | if (err == 0) { |
---|
2199 | fprintf(dbgout, "Couldn't load lisp heap image from %s\n", path); |
---|
2200 | } else { |
---|
2201 | fprintf(dbgout, "Couldn't load lisp heap image from %s:\n%s\n", path, strerror(err)); |
---|
2202 | } |
---|
2203 | exit(-1); |
---|
2204 | } |
---|
2205 | return image_nil; |
---|
2206 | } |
---|
2207 | |
---|
2208 | int |
---|
2209 | set_errno(int val) |
---|
2210 | { |
---|
2211 | errno = val; |
---|
2212 | return -1; |
---|
2213 | } |
---|
2214 | |
---|
2215 | /* A horrible hack to allow us to initialize a JVM instance from lisp. |
---|
2216 | On Darwin, creating a JVM instance clobbers the thread's existing |
---|
2217 | Mach exception infrastructure, so we save and restore it here. |
---|
2218 | */ |
---|
2219 | |
---|
2220 | typedef int (*jvm_initfunc)(void*,void*,void*); |
---|
2221 | |
---|
2222 | int |
---|
2223 | jvm_init(jvm_initfunc f,void*arg0,void*arg1,void*arg2) |
---|
2224 | { |
---|
2225 | int result = -1; |
---|
2226 | TCR *tcr = get_tcr(1); |
---|
2227 | #ifdef DARWIN |
---|
2228 | extern kern_return_t tcr_establish_lisp_exception_port(TCR *); |
---|
2229 | #endif |
---|
2230 | |
---|
2231 | result = f(arg0,arg1,arg2); |
---|
2232 | #ifdef DARWIN |
---|
2233 | tcr_establish_lisp_exception_port(tcr); |
---|
2234 | #endif |
---|
2235 | return result; |
---|
2236 | } |
---|
2237 | |
---|
2238 | |
---|
2239 | |
---|
2240 | |
---|
2241 | void * |
---|
2242 | xFindSymbol(void* handle, char *name) |
---|
2243 | { |
---|
2244 | #if defined(LINUX) || defined(FREEBSD) || defined(SOLARIS) |
---|
2245 | return dlsym(handle, name); |
---|
2246 | #endif |
---|
2247 | #ifdef DARWIN |
---|
2248 | #if 1 |
---|
2249 | void *result; |
---|
2250 | |
---|
2251 | if ((handle == NULL) || (handle == ((void *) -1))) { |
---|
2252 | handle = RTLD_DEFAULT; |
---|
2253 | } |
---|
2254 | result = dlsym(handle, name); |
---|
2255 | if ((result == NULL) && (*name == '_')) { |
---|
2256 | result = dlsym(handle, name+1); |
---|
2257 | } |
---|
2258 | return result; |
---|
2259 | #else |
---|
2260 | natural address = 0; |
---|
2261 | |
---|
2262 | if ((handle == NULL) || |
---|
2263 | (handle == (void *)-1) || |
---|
2264 | (handle == (void *)-2)){ |
---|
2265 | if (NSIsSymbolNameDefined(name)) { /* Keep dyld_lookup from crashing */ |
---|
2266 | _dyld_lookup_and_bind(name, (void *) &address, (void*) NULL); |
---|
2267 | } |
---|
2268 | return (void *)address; |
---|
2269 | } |
---|
2270 | Bug(NULL, "How did this happen ?"); |
---|
2271 | #endif |
---|
2272 | #endif |
---|
2273 | #ifdef WINDOWS |
---|
2274 | extern void *windows_find_symbol(void *, char *); |
---|
2275 | return windows_find_symbol(handle, name); |
---|
2276 | #endif |
---|
2277 | } |
---|
2278 | |
---|
2279 | void * |
---|
2280 | get_r_debug() |
---|
2281 | { |
---|
2282 | #if defined(LINUX) || defined(FREEBSD) || defined(SOLARIS) |
---|
2283 | #if WORD_SIZE == 64 |
---|
2284 | extern Elf64_Dyn _DYNAMIC[]; |
---|
2285 | Elf64_Dyn *dp; |
---|
2286 | #else |
---|
2287 | extern Elf32_Dyn _DYNAMIC[]; |
---|
2288 | Elf32_Dyn *dp; |
---|
2289 | #endif |
---|
2290 | int tag; |
---|
2291 | |
---|
2292 | for (dp = _DYNAMIC; (tag = dp->d_tag) != 0; dp++) { |
---|
2293 | if (tag == DT_DEBUG) { |
---|
2294 | return (void *)(dp->d_un.d_ptr); |
---|
2295 | } |
---|
2296 | } |
---|
2297 | #endif |
---|
2298 | return NULL; |
---|
2299 | } |
---|
2300 | |
---|
2301 | |
---|
2302 | #ifdef DARWIN |
---|
2303 | void |
---|
2304 | sample_paging_info(paging_info *stats) |
---|
2305 | { |
---|
2306 | mach_msg_type_number_t count = TASK_EVENTS_INFO_COUNT; |
---|
2307 | |
---|
2308 | task_info(mach_task_self(), |
---|
2309 | TASK_EVENTS_INFO, |
---|
2310 | (task_info_t)stats, |
---|
2311 | &count); |
---|
2312 | } |
---|
2313 | |
---|
2314 | void |
---|
2315 | report_paging_info_delta(FILE *out, paging_info *start, paging_info *stop) |
---|
2316 | { |
---|
2317 | fprintf(out,";;; %d soft faults, %d faults, %d pageins\n\n", |
---|
2318 | stop->cow_faults-start->cow_faults, |
---|
2319 | stop->faults-start->faults, |
---|
2320 | stop->pageins-start->pageins); |
---|
2321 | } |
---|
2322 | |
---|
2323 | #else |
---|
2324 | #ifdef WINDOWS |
---|
2325 | void |
---|
2326 | sample_paging_info(paging_info *stats) |
---|
2327 | { |
---|
2328 | } |
---|
2329 | |
---|
2330 | void |
---|
2331 | report_paging_info_delta(FILE *out, paging_info *start, paging_info *stop) |
---|
2332 | { |
---|
2333 | } |
---|
2334 | #else |
---|
2335 | void |
---|
2336 | sample_paging_info(paging_info *stats) |
---|
2337 | { |
---|
2338 | getrusage(RUSAGE_SELF, stats); |
---|
2339 | } |
---|
2340 | |
---|
2341 | void |
---|
2342 | report_paging_info_delta(FILE *out, paging_info *start, paging_info *stop) |
---|
2343 | { |
---|
2344 | fprintf(out,";;; %ld soft faults, %ld faults, %ld pageins\n\n", |
---|
2345 | stop->ru_minflt-start->ru_minflt, |
---|
2346 | stop->ru_majflt-start->ru_majflt, |
---|
2347 | stop->ru_nswap-start->ru_nswap); |
---|
2348 | } |
---|
2349 | |
---|
2350 | #endif |
---|
2351 | #endif |
---|