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

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

On 64-bit Darwin platforms, define 'objc_personality_v0" as an opaque
pointer, and initiallze the OBJC_2_PERSONALITY kernel global to point
to it. (This has to do with working around limitations of new, improved
linkers.)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 48.4 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    /* It's very unlikely that SSE2 would be present and other things
1407       that we want wouldn't.  If they don't have MMX or CMOV either,
1408       might as well tell them. */
1409    if ((edx & X86_FEATURE_SSE2) == 0) {
1410      fprintf(dbgout, "This CPU doesn't support the SSE2 instruction set\n");
1411    }
1412    if ((edx & X86_FEATURE_MMX) == 0) {
1413      fprintf(dbgout, "This CPU doesn't support the MMX instruction set\n");
1414    }
1415    if ((edx & X86_FEATURE_CMOV) == 0) {
1416      fprintf(dbgout, "This CPU doesn't support the CMOV instruction\n");
1417    }
1418   
1419  }
1420  return false;
1421}
1422#endif
1423
1424void
1425lazarus()
1426{
1427  TCR *tcr = get_tcr(false);
1428  if (tcr) {
1429    /* Some threads may be dying; no threads should be created. */
1430    LOCK(lisp_global(TCR_AREA_LOCK),tcr);
1431    tcr->vs_area->active = tcr->vs_area->high - node_size;
1432    tcr->save_vsp = (LispObj *)(tcr->vs_area->active);
1433    tcr->ts_area->active = tcr->ts_area->high;
1434    tcr->save_tsp = (LispObj *)(tcr->ts_area->active);
1435    tcr->catch_top = 0;
1436    tcr->db_link = 0;
1437    tcr->xframe = 0;
1438    start_lisp(tcr, 0);
1439  }
1440}
1441
1442#ifdef LINUX
1443#ifdef X8664
1444#include <asm/prctl.h>
1445#include <sys/prctl.h>
1446
1447void
1448ensure_gs_available(char *progname)
1449{
1450  LispObj fs_addr = 0L, gs_addr = 0L, cur_thread = (LispObj)pthread_self();
1451  char *gnu_get_libc_version(void);
1452 
1453  arch_prctl(ARCH_GET_GS, &gs_addr);
1454  arch_prctl(ARCH_GET_FS, &fs_addr);
1455  if ((gs_addr == cur_thread) && (fs_addr != cur_thread)) {
1456    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);
1457    _exit(1);
1458  }
1459}
1460#endif
1461#endif
1462
1463Boolean
1464bogus_fp_exceptions = false;
1465
1466typedef
1467float (*float_arg_returns_float)(float);
1468
1469float
1470fcallf(float_arg_returns_float fun, float arg)
1471{
1472  return fun(arg);
1473}
1474
1475void
1476check_bogus_fp_exceptions()
1477{
1478#ifdef X8664
1479  float asinf(float),result;
1480   
1481
1482  natural save_mxcsr = get_mxcsr(), post_mxcsr;
1483  set_mxcsr(0x1f80);
1484
1485  result = fcallf(asinf, 1.0);
1486  post_mxcsr = get_mxcsr();
1487  set_mxcsr(save_mxcsr);
1488  if (post_mxcsr & (FE_ALL_EXCEPT & (~FE_INEXACT))) {
1489    bogus_fp_exceptions = true;
1490  }
1491#endif
1492}
1493
1494#ifdef DARWIN
1495#if WORD_SIZE==64
1496void *__objc_personality_v0 = NULL;
1497#endif
1498#endif
1499
1500int
1501main(int argc, char *argv[]
1502#ifndef WINDOWS
1503, char *envp[], void *aux
1504#endif
1505)
1506{
1507  extern int page_size;
1508  natural default_g0_threshold = G0_AREA_THRESHOLD,
1509    default_g1_threshold = G1_AREA_THRESHOLD,
1510    default_g2_threshold = G2_AREA_THRESHOLD,
1511    lisp_heap_threshold_from_image = 0;
1512  Boolean egc_enabled =
1513#ifdef DISABLE_EGC
1514    false
1515#else
1516    true
1517#endif
1518    ;
1519  Boolean lisp_heap_threshold_set_from_command_line = false;
1520
1521#ifdef PPC
1522  extern int altivec_present;
1523#endif
1524  extern LispObj load_image(char *);
1525  area *a;
1526  BytePtr stack_base, current_sp = (BytePtr) current_stack_pointer();
1527  TCR *tcr;
1528
1529  dbgout = stderr;
1530
1531#ifdef WINDOWS
1532  {
1533    extern void init_winsock(void);
1534    extern void init_windows_io(void);
1535
1536    _fmode = O_BINARY;
1537    _setmode(1, O_BINARY);
1538    _setmode(2, O_BINARY);
1539    setvbuf(dbgout, NULL, _IONBF, 0);
1540    init_winsock();
1541    init_windows_io();
1542  }
1543#endif
1544
1545  check_os_version(argv[0]);
1546  real_executable_name = determine_executable_name(argv[0]);
1547  page_size = getpagesize(); /* Implement with GetSystemInfo on Windows w/o MinGW */
1548
1549  check_bogus_fp_exceptions();
1550#ifdef LINUX
1551#ifdef X8664
1552  ensure_gs_available(real_executable_name);
1553#endif
1554#endif
1555#if (defined(DARWIN) && defined(PPC64)) || (defined(LINUX) && defined(PPC))|| defined(X8664) || (defined(X8632) && !defined(DARWIN))
1556  remap_spjump();
1557#endif
1558
1559#ifdef PPC
1560#ifdef LINUX
1561  {
1562    ElfW(auxv_t) *av = aux;
1563    int hwcap, done = false;
1564   
1565    if (av) {
1566      do {
1567        switch (av->a_type) {
1568        case AT_DCACHEBSIZE:
1569          cache_block_size = av->a_un.a_val;
1570          break;
1571
1572        case AT_HWCAP:
1573          hwcap = av->a_un.a_val;
1574          altivec_present = ((hwcap & PPC_FEATURE_HAS_ALTIVEC) != 0);
1575          break;
1576
1577        case AT_NULL:
1578          done = true;
1579          break;
1580        }
1581        av++;
1582      } while (!done);
1583    }
1584  }
1585#endif
1586#ifdef DARWIN
1587  {
1588    unsigned value = 0;
1589    size_t len = sizeof(value);
1590    int mib[2];
1591   
1592    mib[0] = CTL_HW;
1593    mib[1] = HW_CACHELINE;
1594    if (sysctl(mib,2,&value,&len, NULL, 0) != -1) {
1595      if (len == sizeof(value)) {
1596        cache_block_size = value;
1597      }
1598    }
1599    mib[1] = HW_VECTORUNIT;
1600    value = 0;
1601    len = sizeof(value);
1602    if (sysctl(mib,2,&value,&len, NULL, 0) != -1) {
1603      if (len == sizeof(value)) {
1604        altivec_present = value;
1605      }
1606    }
1607  }
1608#endif
1609#endif
1610
1611#ifdef X86
1612  if (!check_x86_cpu()) {
1613    fprintf(dbgout, "CPU doesn't support required features\n");
1614    exit(1);
1615  }
1616#endif
1617
1618#ifdef SOLARIS
1619#ifdef X8632
1620  {
1621    extern void solaris_ldt_init(void);
1622    solaris_ldt_init();
1623  }
1624#endif
1625#endif
1626
1627#ifndef WINDOWS
1628  main_thread_pid = getpid();
1629#endif
1630  tcr_area_lock = (void *)new_recursive_lock();
1631
1632  program_name = argv[0];
1633  if ((argc == 2) && (*argv[1] != '-')) {
1634    image_name = argv[1];
1635    argv[1] = NULL;
1636  } else {
1637    process_options(argc,argv);
1638  }
1639  if (lisp_heap_gc_threshold != DEFAULT_LISP_HEAP_GC_THRESHOLD) {
1640    lisp_heap_threshold_set_from_command_line = true;
1641  }
1642
1643  initial_stack_size = ensure_stack_limit(initial_stack_size);
1644  if (image_name == NULL) {
1645    if (check_for_embedded_image(real_executable_name)) {
1646      image_name = real_executable_name;
1647    } else {
1648      image_name = default_image_name(real_executable_name);
1649    }
1650  }
1651
1652  while (1) {
1653    if (create_reserved_area(reserved_area_size)) {
1654      break;
1655    }
1656    reserved_area_size = reserved_area_size *.9;
1657  }
1658
1659  gc_init();
1660
1661  set_nil(load_image(image_name));
1662  lisp_heap_threshold_from_image = lisp_global(LISP_HEAP_THRESHOLD);
1663  if (lisp_heap_threshold_from_image) {
1664    if ((!lisp_heap_threshold_set_from_command_line) &&
1665        (lisp_heap_threshold_from_image != lisp_heap_gc_threshold)) {
1666      lisp_heap_gc_threshold = lisp_heap_threshold_from_image;
1667      resize_dynamic_heap(active_dynamic_area->active,lisp_heap_gc_threshold);
1668    }
1669    /* If lisp_heap_threshold_from_image was set, other image params are
1670       valid. */
1671    default_g0_threshold = lisp_global(G0_THRESHOLD);
1672    default_g1_threshold = lisp_global(G1_THRESHOLD);
1673    default_g2_threshold = lisp_global(G2_THRESHOLD);
1674    egc_enabled = lisp_global(EGC_ENABLED);
1675  }
1676
1677  lisp_global(TCR_AREA_LOCK) = ptr_to_lispobj(tcr_area_lock);
1678
1679#ifdef X86
1680  lisp_global(SUBPRIMS_BASE) = (LispObj)((1<<16)+(5<<10));
1681#else
1682  lisp_global(SUBPRIMS_BASE) = (LispObj)(5<<10);
1683#endif
1684  lisp_global(RET1VALN) = (LispObj)&ret1valn;
1685  lisp_global(LEXPR_RETURN) = (LispObj)&nvalret;
1686  lisp_global(LEXPR_RETURN1V) = (LispObj)&popj;
1687  lisp_global(ALL_AREAS) = ptr_to_lispobj(all_areas);
1688#ifdef X86
1689  lisp_global(BAD_FUNCALL) = ptr_to_lispobj(&bad_funcall);
1690#endif
1691  lisp_global(DEFAULT_ALLOCATION_QUANTUM) = log2_heap_segment_size << fixnumshift;
1692  lisp_global(STACK_SIZE) = thread_stack_size<<fixnumshift;
1693
1694
1695  exception_init();
1696
1697 
1698
1699  lisp_global(IMAGE_NAME) = ptr_to_lispobj(image_name);
1700  lisp_global(ARGV) = ptr_to_lispobj(argv);
1701  lisp_global(KERNEL_IMPORTS) = (LispObj)import_ptrs_base;
1702
1703  lisp_global(GET_TCR) = (LispObj) get_tcr;
1704  *(double *) &(lisp_global(DOUBLE_FLOAT_ONE)) = (double) 1.0;
1705
1706  lisp_global(HOST_PLATFORM) = (LispObj) PLATFORM << fixnumshift;
1707
1708  lisp_global(BATCH_FLAG) = (batch_flag << fixnumshift);
1709
1710  a = active_dynamic_area;
1711
1712  if (nilreg_area != NULL) {
1713    BytePtr lowptr = (BytePtr) a->low;
1714
1715    /* Create these areas as AREA_STATIC, change them to AREA_DYNAMIC */
1716    g1_area = new_area(lowptr, lowptr, AREA_STATIC);
1717    g2_area = new_area(lowptr, lowptr, AREA_STATIC);
1718    tenured_area = new_area(lowptr, lowptr, AREA_STATIC);
1719    add_area_holding_area_lock(tenured_area);
1720    add_area_holding_area_lock(g2_area);
1721    add_area_holding_area_lock(g1_area);
1722
1723    g1_area->code = AREA_DYNAMIC;
1724    g2_area->code = AREA_DYNAMIC;
1725    tenured_area->code = AREA_DYNAMIC;
1726
1727/*    a->older = g1_area; */ /* Not yet: this is what "enabling the EGC" does. */
1728    g1_area->younger = a;
1729    g1_area->older = g2_area;
1730    g2_area->younger = g1_area;
1731    g2_area->older = tenured_area;
1732    tenured_area->younger = g2_area;
1733    tenured_area->refbits = a->markbits;
1734    tenured_area->static_dnodes = a->static_dnodes;
1735    a->static_dnodes = 0;
1736    tenured_area->static_used = a->static_used;
1737    a->static_used = 0;
1738    lisp_global(TENURED_AREA) = ptr_to_lispobj(tenured_area);
1739    lisp_global(REFBITS) = ptr_to_lispobj(tenured_area->refbits);
1740    g2_area->threshold = default_g2_threshold;
1741    g1_area->threshold = default_g1_threshold;
1742    a->threshold = default_g0_threshold;
1743  }
1744
1745  tcr = new_tcr(initial_stack_size, MIN_TSTACK_SIZE);
1746  stack_base = initial_stack_bottom()-xStackSpace();
1747  init_threads((void *)(stack_base), tcr);
1748  thread_init_tcr(tcr, current_sp, current_sp-stack_base);
1749
1750  lisp_global(EXCEPTION_LOCK) = ptr_to_lispobj(new_recursive_lock());
1751  enable_fp_exceptions();
1752  register_user_signal_handler();
1753
1754#ifdef PPC
1755  lisp_global(ALTIVEC_PRESENT) = altivec_present << fixnumshift;
1756#endif
1757#if STATIC
1758  lisp_global(STATICALLY_LINKED) = 1 << fixnumshift;
1759#endif
1760  tcr->prev = tcr->next = tcr;
1761#ifndef WINDOWS
1762  lisp_global(INTERRUPT_SIGNAL) = (LispObj) box_fixnum(SIGNAL_FOR_PROCESS_INTERRUPT);
1763#endif
1764#ifdef DARWIN
1765#if WORD_SIZE==64
1766  lisp_global(OBJC_2_PERSONALITY) = (LispObj) &__objc_personality_v0;
1767#endif
1768#endif
1769
1770  tcr->vs_area->active -= node_size;
1771  *(--tcr->save_vsp) = nrs_TOPLFUNC.vcell;
1772  nrs_TOPLFUNC.vcell = lisp_nil;
1773#ifdef GC_INTEGRITY_CHECKING
1774  (nrs_GC_EVENT_STATUS_BITS.vcell |= gc_integrity_check_bit);
1775#endif
1776  if (egc_enabled) {
1777    egc_control(true, NULL);
1778  }
1779  atexit(lazarus);
1780  start_lisp(TCR_TO_TSD(tcr), 0);
1781  _exit(0);
1782}
1783
1784area *
1785set_nil(LispObj r)
1786{
1787
1788  if (lisp_nil == (LispObj)NULL) {
1789
1790    lisp_nil = r;
1791  }
1792  return NULL;
1793}
1794
1795
1796void
1797xMakeDataExecutable(void *start, unsigned long nbytes)
1798{
1799  extern void flush_cache_lines();
1800  natural ustart = (natural) start, base, end;
1801 
1802  base = (ustart) & ~(cache_block_size-1);
1803  end = (ustart + nbytes + cache_block_size - 1) & ~(cache_block_size-1);
1804#ifdef DARWIN
1805  if (running_under_rosetta) {
1806    /* We probably need to flush something's cache even if running
1807       under Rosetta, but (a) this is agonizingly slow and (b) we're
1808       dying before we get to the point where this would matter.
1809    */
1810    return;
1811  }
1812#endif
1813#ifndef X86
1814  flush_cache_lines(base, (end-base)/cache_block_size, cache_block_size);
1815#endif
1816}
1817
1818natural
1819xStackSpace()
1820{
1821  return initial_stack_size+CSTACK_HARDPROT+CSTACK_SOFTPROT;
1822}
1823
1824#ifndef DARWIN
1825#ifdef WINDOWS
1826extern void *windows_open_shared_library(char *);
1827
1828void *
1829xGetSharedLibrary(char *path, int mode)
1830{
1831  return windows_open_shared_library(path);
1832}
1833#else
1834void *
1835xGetSharedLibrary(char *path, int mode)
1836{
1837  return dlopen(path, mode);
1838}
1839#endif
1840#else
1841void *
1842xGetSharedLibrary(char *path, int *resultType)
1843{
1844#if defined(PPC) && (WORD_SIZE == 32)
1845  NSObjectFileImageReturnCode code;
1846  NSObjectFileImage              moduleImage;
1847  NSModule                       module;
1848  const struct mach_header *     header;
1849  const char *                   error;
1850  void *                         result;
1851  /* not thread safe */
1852  /*
1853  static struct {
1854    const struct mach_header  *header;
1855    NSModule                  *module;
1856    const char                *error;
1857  } results;   
1858  */
1859  result = NULL;
1860  error = NULL;
1861
1862  /* first try to open this as a bundle */
1863  code = NSCreateObjectFileImageFromFile(path,&moduleImage);
1864  if (code != NSObjectFileImageSuccess &&
1865      code != NSObjectFileImageInappropriateFile &&
1866      code != NSObjectFileImageAccess)
1867    {
1868      /* compute error strings */
1869      switch (code)
1870        {
1871        case NSObjectFileImageFailure:
1872          error = "NSObjectFileImageFailure";
1873          break;
1874        case NSObjectFileImageArch:
1875          error = "NSObjectFileImageArch";
1876          break;
1877        case NSObjectFileImageFormat:
1878          error = "NSObjectFileImageFormat";
1879          break;
1880        case NSObjectFileImageAccess:
1881          /* can't find the file */
1882          error = "NSObjectFileImageAccess";
1883          break;
1884        default:
1885          error = "unknown error";
1886        }
1887      *resultType = 0;
1888      return (void *)error;
1889    }
1890  if (code == NSObjectFileImageInappropriateFile ||
1891      code == NSObjectFileImageAccess ) {
1892    /* the pathname might be a partial pathane (hence the access error)
1893       or it might be something other than a bundle, if so perhaps
1894       it is a .dylib so now try to open it as a .dylib */
1895
1896    /* protect against redundant loads, Gary Byers noticed possible
1897       heap corruption if this isn't done */
1898    header = NSAddImage(path, NSADDIMAGE_OPTION_RETURN_ON_ERROR |
1899                        NSADDIMAGE_OPTION_WITH_SEARCHING |
1900                        NSADDIMAGE_OPTION_RETURN_ONLY_IF_LOADED);
1901    if (!header)
1902      header = NSAddImage(path, NSADDIMAGE_OPTION_RETURN_ON_ERROR |
1903                          NSADDIMAGE_OPTION_WITH_SEARCHING);
1904    result = (void *)header;
1905    *resultType = 1;
1906  }
1907  else if (code == NSObjectFileImageSuccess) {
1908    /* we have a sucessful module image
1909       try to link it, don't bind symbols privately */
1910
1911    module = NSLinkModule(moduleImage, path,
1912                          NSLINKMODULE_OPTION_RETURN_ON_ERROR | NSLINKMODULE_OPTION_BINDNOW);
1913    NSDestroyObjectFileImage(moduleImage);     
1914    result = (void *)module;
1915    *resultType = 2;
1916  }
1917  if (!result)
1918    {
1919      /* compute error string */
1920      NSLinkEditErrors ler;
1921      int lerno;
1922      const char* file;
1923      NSLinkEditError(&ler,&lerno,&file,&error);
1924      if (error) {
1925        result = (void *)error;
1926        *resultType = 0;
1927      }
1928    }
1929  return result;
1930#else
1931  const char *                   error;
1932  void *                         result;
1933
1934  result = dlopen(path, RTLD_NOW | RTLD_GLOBAL);
1935 
1936  if (result == NULL) {
1937    error = dlerror();
1938    *resultType = 0;
1939    return (void *)error;
1940  }
1941  *resultType = 1;
1942  return result;
1943#endif
1944}
1945#endif
1946
1947
1948
1949int
1950fd_setsize_bytes()
1951{
1952  return FD_SETSIZE/8;
1953}
1954
1955void
1956do_fd_set(int fd, fd_set *fdsetp)
1957{
1958  FD_SET(fd, fdsetp);
1959}
1960
1961void
1962do_fd_clr(int fd, fd_set *fdsetp)
1963{
1964  FD_CLR(fd, fdsetp);
1965}
1966
1967int
1968do_fd_is_set(int fd, fd_set *fdsetp)
1969{
1970  return FD_ISSET(fd,fdsetp);
1971}
1972
1973
1974void
1975do_fd_zero(fd_set *fdsetp)
1976{
1977  FD_ZERO(fdsetp);
1978}
1979
1980#include "image.h"
1981
1982
1983
1984Boolean
1985check_for_embedded_image (char *path)
1986{
1987  int fd = open(path, O_RDONLY);
1988  Boolean image_is_embedded = false;
1989
1990  if (fd >= 0) {
1991    openmcl_image_file_header h;
1992
1993    if (find_openmcl_image_file_header (fd, &h)) {
1994      image_is_embedded = true;
1995    }
1996    close (fd);
1997  }
1998  return image_is_embedded;
1999}
2000
2001LispObj
2002load_image(char *path)
2003{
2004  int fd = open(path, O_RDONLY, 0666), err;
2005  LispObj image_nil = 0;
2006
2007  errno = 0;
2008  if (fd > 0) {
2009    openmcl_image_file_header ih;
2010    image_nil = load_openmcl_image(fd, &ih);
2011    /* We -were- using a duplicate fd to map the file; that
2012       seems to confuse Darwin (doesn't everything ?), so
2013       we'll instead keep the original file open.
2014    */
2015    err = errno;
2016    if (!image_nil) {
2017      close(fd);
2018    }
2019#ifdef WINDOWS
2020    /* We currently don't actually map the image, and leaving the file
2021       open seems to make it difficult to write to reliably. */
2022    if (image_nil) {
2023      close(fd);
2024    }
2025#endif
2026  } else {
2027    err = errno;
2028  }
2029  if (image_nil == 0) {
2030    if (err == 0) {
2031      fprintf(dbgout, "Couldn't load lisp heap image from %s\n", path);
2032    } else {
2033      fprintf(dbgout, "Couldn't load lisp heap image from %s:\n%s\n", path, strerror(err));
2034    }
2035    exit(-1);
2036  }
2037  return image_nil;
2038}
2039
2040int
2041set_errno(int val)
2042{
2043  errno = val;
2044  return -1;
2045}
2046
2047/* A horrible hack to allow us to initialize a JVM instance from lisp.
2048   On Darwin, creating a JVM instance clobbers the thread's existing
2049   Mach exception infrastructure, so we save and restore it here.
2050*/
2051
2052typedef int (*jvm_initfunc)(void*,void*,void*);
2053
2054int
2055jvm_init(jvm_initfunc f,void*arg0,void*arg1,void*arg2)
2056{
2057  int result = -1;
2058  TCR *tcr = get_tcr(1);
2059#ifdef DARWIN
2060  extern kern_return_t tcr_establish_lisp_exception_port(TCR *);
2061#endif
2062 
2063  result = f(arg0,arg1,arg2);
2064#ifdef DARWIN
2065  tcr_establish_lisp_exception_port(tcr);
2066#endif
2067  return result;
2068}
2069 
2070
2071
2072
2073void *
2074xFindSymbol(void* handle, char *name)
2075{
2076#if defined(LINUX) || defined(FREEBSD) || defined(SOLARIS)
2077  return dlsym(handle, name);
2078#endif
2079#ifdef DARWIN
2080#if defined(PPC64) || defined(X86)
2081  if ((handle == NULL) || (handle == ((void *) -1))) {
2082    handle = RTLD_DEFAULT;
2083  }   
2084  if (*name == '_') {
2085    name++;
2086  }
2087  return dlsym(handle, name);
2088#else
2089  natural address = 0;
2090
2091  if ((handle == NULL) ||
2092      (handle == (void *)-1) ||
2093      (handle == (void *)-2)){
2094    if (NSIsSymbolNameDefined(name)) { /* Keep dyld_lookup from crashing */
2095      _dyld_lookup_and_bind(name, (void *) &address, (void*) NULL);
2096    }
2097    return (void *)address;
2098  }
2099  Bug(NULL, "How did this happen ?");
2100#endif
2101#endif
2102#ifdef WINDOWS
2103  extern void *windows_find_symbol(void *, char *);
2104  return windows_find_symbol(handle, name);
2105#endif
2106}
2107
2108void *
2109get_r_debug()
2110{
2111#if defined(LINUX) || defined(FREEBSD) || defined(SOLARIS)
2112#if WORD_SIZE == 64
2113  extern Elf64_Dyn _DYNAMIC[];
2114  Elf64_Dyn *dp;
2115#else
2116  extern Elf32_Dyn _DYNAMIC[];
2117  Elf32_Dyn *dp;
2118#endif
2119  int tag;
2120
2121  for (dp = _DYNAMIC; (tag = dp->d_tag) != 0; dp++) {
2122    if (tag == DT_DEBUG) {
2123      return (void *)(dp->d_un.d_ptr);
2124    }
2125  }
2126#endif
2127  return NULL;
2128}
2129
2130
2131#ifdef DARWIN
2132void
2133sample_paging_info(paging_info *stats)
2134{
2135  mach_msg_type_number_t count = TASK_EVENTS_INFO_COUNT;
2136
2137  task_info(mach_task_self(),
2138            TASK_EVENTS_INFO,
2139            (task_info_t)stats,
2140            &count);
2141}
2142
2143void
2144report_paging_info_delta(FILE *out, paging_info *start, paging_info *stop)
2145{
2146  fprintf(out,";;; %d soft faults, %d faults, %d pageins\n\n",
2147          stop->cow_faults-start->cow_faults,
2148          stop->faults-start->faults,
2149          stop->pageins-start->pageins);
2150}
2151
2152#else
2153#ifdef WINDOWS
2154void
2155sample_paging_info(paging_info *stats)
2156{
2157}
2158
2159void
2160report_paging_info_delta(FILE *out, paging_info *start, paging_info *stop)
2161{
2162}
2163#else
2164void
2165sample_paging_info(paging_info *stats)
2166{
2167  getrusage(RUSAGE_SELF, stats);
2168}
2169
2170void
2171report_paging_info_delta(FILE *out, paging_info *start, paging_info *stop)
2172{
2173  fprintf(out,";;; %ld soft faults, %ld faults, %ld pageins\n\n",
2174          stop->ru_minflt-start->ru_minflt,
2175          stop->ru_majflt-start->ru_majflt,
2176          stop->ru_nswap-start->ru_nswap);
2177}
2178
2179#endif
2180#endif
Note: See TracBrowser for help on using the repository browser.