source: trunk/source/lisp-kernel/pmcl-kernel.c @ 11635

Last change on this file since 11635 was 11635, checked in by gb, 11 years ago

The "experimental" setting for MAXIMUM_MAPPABLE_MEMORY for x8632 Linux
seems to work on a Fedora x8664 kernel, but it's too big for a 32-bit
Ubuntu 8.04 system. Try for a little over 2GB; need to leave some
memory for stacks/malloc/etc.

If allocate_dynamic_area() fails, print an error message and exit (rather
than segfaulting.)

#define MIN_DYNAMIC_SIZE (arbitrarily) as twice the default gc threshold.

In create_reserved_area(), ensure that the requested size is at least
as large as PURESPACE_RESERVE + MIN_DYNAMIC_SIZE. If the supplied size
would have been less than that, consider failure to be fatal (and exit).
In other cases, create_reserved_area() returns NULL on failure.

Expect ReserveMemoryForHeap?() to return NULL on failure (as it did until
a few hours ago.)

Keep calling create_reserved_area() until it succeeds or exits, trying
90% of the previous size on each subsequent attempt.

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