source: release/1.3/source/lisp-kernel/pmcl-kernel.c @ 11697

Last change on this file since 11697 was 11697, checked in by rme, 11 years ago

Merge r11694-r11696 from trunk.

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