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

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

Propagate r11952 (don't zero refbits when growing heap) to 1.3.

  • 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    n;
653  BytePtr
654    new_reloctab_limit = (BytePtr)align_to_power_of_2(((natural)global_reloctab)+reloctab_size,log2_page_size),
655    new_markbits_limit = (BytePtr)align_to_power_of_2(((natural)global_mark_ref_bits)+markbits_size,log2_page_size);
656
657  if (new_reloctab_limit > reloctab_limit) {
658    n = new_reloctab_limit - reloctab_limit;
659    CommitMemory(reloctab_limit, n);
660    UnProtectMemory(reloctab_limit, n);
661    reloctab_limit = new_reloctab_limit;
662  }
663 
664  if (new_markbits_limit > markbits_limit) {
665    n = new_markbits_limit-markbits_limit;
666    CommitMemory(markbits_limit, n);
667    UnProtectMemory(markbits_limit, n);
668    markbits_limit = new_markbits_limit;
669  }
670}
671
672
673area *
674allocate_dynamic_area(natural initsize)
675{
676  natural totalsize = align_to_power_of_2(initsize, log2_heap_segment_size);
677  BytePtr start, end;
678  area *a;
679
680  start = allocate_from_reserved_area(totalsize);
681  if (start == NULL) {
682    fprintf(dbgout, "reserved area too small to load heap image\n");
683    exit(1);
684  }
685  end = start + totalsize;
686  a = new_area(start, end, AREA_DYNAMIC);
687  a->active = start+initsize;
688  add_area_holding_area_lock(a);
689  a->markbits = reserved_area->markbits;
690  reserved_area->markbits = NULL;
691  CommitMemory(start, end-start);
692  a->h = start;
693  a->softprot = NULL;
694  a->hardprot = NULL;
695  lisp_global(HEAP_START) = ptr_to_lispobj(a->low);
696  lisp_global(HEAP_END) = ptr_to_lispobj(a->high);
697  markbits_limit = (BytePtr)global_mark_ref_bits;
698  reloctab_limit = (BytePtr)global_reloctab;
699  ensure_gc_structures_writable();
700  return a;
701 }
702
703
704Boolean
705grow_dynamic_area(natural delta)
706{
707  area *a = active_dynamic_area, *reserved = reserved_area;
708  natural avail = reserved->high - reserved->low;
709 
710  delta = align_to_power_of_2(delta, log2_heap_segment_size);
711  if (delta > avail) {
712    return false;
713  }
714
715  if (!commit_pages(a->high,delta)) {
716    return false;
717  }
718
719
720  if (!allocate_from_reserved_area(delta)) {
721    return false;
722  }
723
724
725  a->high += delta;
726  a->ndnodes = area_dnode(a->high, a->low);
727  lisp_global(HEAP_END) += delta;
728  ensure_gc_structures_writable();
729  return true;
730}
731
732/*
733  As above.  Pages that're returned to the reserved_area are
734  "condemned" (e.g, we try to convince the OS that they never
735  existed ...)
736*/
737Boolean
738shrink_dynamic_area(natural delta)
739{
740  area *a = active_dynamic_area, *reserved = reserved_area;
741 
742  delta = align_to_power_of_2(delta, log2_heap_segment_size);
743
744  a->high -= delta;
745  a->ndnodes = area_dnode(a->high, a->low);
746  a->hardlimit = a->high;
747  uncommit_pages(a->high, delta);
748  reserved->low -= delta;
749  reserved->ndnodes += (delta>>dnode_shift);
750  lisp_global(HEAP_END) -= delta;
751  return true;
752}
753
754
755
756void
757user_signal_handler (int signum, siginfo_t *info, ExceptionInformation *context)
758{
759  if (signum == SIGINT) {
760    lisp_global(INTFLAG) = (1 << fixnumshift);
761  }
762  else if (signum == SIGTERM) {
763    lisp_global(INTFLAG) = (2 << fixnumshift);
764  }
765#ifdef DARWIN
766  DarwinSigReturn(context);
767#endif
768}
769
770
771void
772register_user_signal_handler()
773{
774#ifdef WINDOWS
775  extern BOOL CALLBACK ControlEventHandler(DWORD);
776
777  signal(SIGINT, SIG_IGN);
778
779  SetConsoleCtrlHandler(ControlEventHandler,TRUE);
780#else
781  install_signal_handler(SIGINT, (void *)user_signal_handler);
782  install_signal_handler(SIGTERM, (void *)user_signal_handler);
783#endif
784}
785
786
787
788BytePtr
789initial_stack_bottom()
790{
791#ifndef WINDOWS
792  extern char **environ;
793  char *p = *environ;
794  while (*p) {
795    p += (1+strlen(p));
796  }
797  return (BytePtr)((((natural) p) +4095) & ~4095);
798#endif
799#ifdef WINDOWS
800  return (BytePtr)((current_stack_pointer() + 4095) & ~ 4095);
801#endif
802}
803
804
805 
806Ptr fatal_spare_ptr = NULL;
807
808
809void
810Fatal(StringPtr param0, StringPtr param1)
811{
812
813  if (fatal_spare_ptr) {
814    deallocate(fatal_spare_ptr);
815    fatal_spare_ptr = NULL;
816  }
817  fprintf(dbgout, "Fatal error: %s\n%s\n", param0, param1);
818  _exit(-1);
819}
820
821OSErr application_load_err = noErr;
822
823area *
824set_nil(LispObj);
825
826
827/* Check for the existence of a file named by 'path'; return true
828   if it seems to exist, without checking size, permissions, or
829   anything else. */
830Boolean
831probe_file(char *path)
832{
833  struct stat st;
834
835  return (stat(path,&st) == 0);
836}
837
838
839#ifdef WINDOWS
840/* Chop the trailing ".exe" from the kernel image name */
841char *
842chop_exe_suffix(char *path)
843{
844  int len = strlen(path);
845  char *copy = malloc(len+1), *tail;
846
847  strcpy(copy,path);
848  tail = strrchr(copy, '.');
849  if (tail) {
850    *tail = 0;
851  }
852  return copy;
853}
854#endif
855
856char *
857path_by_appending_image(char *path)
858{
859  int len = strlen(path) + strlen(".image") + 1;
860  char *copy = (char *) malloc(len);
861
862  if (copy) {
863    strcpy(copy, path);
864    strcat(copy, ".image");
865  }
866  return copy;
867}
868
869char *
870case_inverted_path(char *path)
871{
872  char *copy = strdup(path), *base = copy, *work = copy, c;
873  if (copy == NULL) {
874    return NULL;
875  }
876  while(*work) {
877    if (*work++ == '/') {
878      base = work;
879    }
880  }
881  work = base;
882  while ((c = *work) != '\0') {
883    if (islower(c)) {
884      *work++ = toupper(c);
885    } else {
886      *work++ = tolower(c);
887    }
888  }
889  return copy;
890}
891/*
892   The underlying file system may be case-insensitive (e.g., HFS),
893   so we can't just case-invert the kernel's name.
894   Tack ".image" onto the end of the kernel's name.  Much better ...
895*/
896char *
897default_image_name(char *orig)
898{
899#ifdef WINDOWS
900  char *path = chop_exe_suffix(orig);
901#else
902  char *path = orig;
903#endif
904  char *image_name = path_by_appending_image(path);
905#if !defined(WINDOWS) && !defined(DARWIN)
906  if (!probe_file(image_name)) {
907    char *legacy = case_inverted_path(path);
908    if (probe_file(legacy)) {
909      image_name = legacy;
910    }
911  }
912#endif
913  return image_name;
914}
915
916
917
918char *program_name = NULL;
919char *real_executable_name = NULL;
920
921char *
922determine_executable_name(char *argv0)
923{
924#ifdef DARWIN
925  uint32_t len = 1024;
926  char exepath[1024], *p = NULL;
927
928  if (_NSGetExecutablePath(exepath, (void *)&len) == 0) {
929    p = malloc(len+1);
930    memmove(p, exepath, len);
931    p[len]=0;
932    return p;
933  } 
934  return argv0;
935#endif
936#ifdef LINUX
937  char exepath[PATH_MAX], *p;
938  int n;
939
940  if ((n = readlink("/proc/self/exe", exepath, PATH_MAX)) > 0) {
941    p = malloc(n+1);
942    memmove(p,exepath,n);
943    p[n]=0;
944    return p;
945  }
946  return argv0;
947#endif
948#ifdef FREEBSD
949  return argv0;
950#endif
951#ifdef SOLARIS
952  char exepath[PATH_MAX], proc_path[PATH_MAX], *p;
953  int n;
954
955  snprintf(proc_path,PATH_MAX-1,"/proc/%d/path/a.out",getpid());
956
957  if ((n = readlink(proc_path, exepath, PATH_MAX)) > 0) {
958    p = malloc(n+1);
959    memmove(p,exepath,n);
960    p[n]=0;
961    return p;
962  }
963  return argv0;
964#endif
965#ifdef WINDOWS
966  char path[PATH_MAX], *p;
967  int len = GetModuleFileName(NULL, path, PATH_MAX);
968  if (len > 0) {
969    p = malloc(len + 1);
970    memmove(p, path, len);
971    p[len] = 0;
972    return p;
973  }
974  return argv0;
975#endif
976}
977
978void
979usage_exit(char *herald, int exit_status, char* other_args)
980{
981  if (herald && *herald) {
982    fprintf(dbgout, "%s\n", herald);
983  }
984  fprintf(dbgout, "usage: %s <options>\n", program_name);
985  fprintf(dbgout, "\t or %s <image-name>\n", program_name);
986  fprintf(dbgout, "\t where <options> are one or more of:\n");
987  if (other_args && *other_args) {
988    fputs(other_args, dbgout);
989  }
990  fprintf(dbgout, "\t-R, --heap-reserve <n>: reserve <n> (default: %lld)\n",
991          (u64_t) reserved_area_size);
992  fprintf(dbgout, "\t\t bytes for heap expansion\n");
993  fprintf(dbgout, "\t-S, --stack-size <n>: set  size of initial thread's control stack to <n>\n");
994  fprintf(dbgout, "\t-Z, --thread-stack-size <n>: set default size of first (listener)  thread's stacks based on <n>\n");
995  fprintf(dbgout, "\t-b, --batch: exit when EOF on *STANDARD-INPUT*\n");
996  fprintf(dbgout, "\t--no-sigtrap : obscure option for running under GDB\n");
997  fprintf(dbgout, "\t-I, --image-name <image-name>\n");
998  fprintf(dbgout, "\t and <image-name> defaults to %s\n", 
999          default_image_name(program_name));
1000  fprintf(dbgout, "\n");
1001  _exit(exit_status);
1002}
1003
1004int no_sigtrap = 0;
1005char *image_name = NULL;
1006int batch_flag = 0;
1007
1008
1009natural
1010parse_numeric_option(char *arg, char *argname, natural default_val)
1011{
1012  char *tail;
1013  natural val = 0;
1014
1015  val = strtoul(arg, &tail, 0);
1016  switch(*tail) {
1017  case '\0':
1018    break;
1019   
1020  case 'M':
1021  case 'm':
1022    val = val << 20;
1023    break;
1024   
1025  case 'K':
1026  case 'k':
1027    val = val << 10;
1028    break;
1029   
1030  case 'G':
1031  case 'g':
1032    val = val << 30;
1033    break;
1034   
1035  default:
1036    fprintf(dbgout, "couldn't parse %s argument %s", argname, arg);
1037    val = default_val;
1038    break;
1039  }
1040  return val;
1041}
1042 
1043
1044
1045/*
1046   The set of arguments recognized by the kernel is
1047   likely to remain pretty small and pretty simple.
1048   This removes everything it recognizes from argv;
1049   remaining args will be processed by lisp code.
1050*/
1051
1052void
1053process_options(int argc, char *argv[])
1054{
1055  int i, j, k, num_elide, flag, arg_error;
1056  char *arg, *val;
1057#ifdef DARWIN
1058  extern int NXArgc;
1059#endif
1060
1061  for (i = 1; i < argc;) {
1062    arg = argv[i];
1063    arg_error = 0;
1064    if (*arg != '-') {
1065      i++;
1066    } else {
1067      num_elide = 0;
1068      val = NULL;
1069      if ((flag = (strncmp(arg, "-I", 2) == 0)) ||
1070          (strcmp (arg, "--image-name") == 0)) {
1071        if (flag && arg[2]) {
1072          val = arg+2;
1073          num_elide = 1;
1074        } else {
1075          if ((i+1) < argc) {
1076            val = argv[i+1];
1077            num_elide = 2;
1078          } else {
1079            arg_error = 1;
1080          }
1081        }
1082        if (val) {
1083          image_name = val;
1084        }
1085      } else if ((flag = (strncmp(arg, "-R", 2) == 0)) ||
1086                 (strcmp(arg, "--heap-reserve") == 0)) {
1087        natural reserved_size = reserved_area_size;
1088
1089        if (flag && arg[2]) {
1090          val = arg+2;
1091          num_elide = 1;
1092        } else {
1093          if ((i+1) < argc) {
1094            val = argv[i+1];
1095            num_elide = 2;
1096          } else {
1097            arg_error = 1;
1098          }
1099        }
1100
1101        if (val) {
1102          reserved_size = parse_numeric_option(val, 
1103                                               "-R/--heap-reserve", 
1104                                               reserved_area_size);
1105        }
1106
1107        if (reserved_size <= MAXIMUM_MAPPABLE_MEMORY) {
1108          reserved_area_size = reserved_size;
1109        }
1110
1111      } else if ((flag = (strncmp(arg, "-S", 2) == 0)) ||
1112                 (strcmp(arg, "--stack-size") == 0)) {
1113        natural stack_size;
1114
1115        if (flag && arg[2]) {
1116          val = arg+2;
1117          num_elide = 1;
1118        } else {
1119          if ((i+1) < argc) {
1120            val = argv[i+1];
1121            num_elide = 2;
1122          } else {
1123            arg_error = 1;
1124          }
1125        }
1126
1127        if (val) {
1128          stack_size = parse_numeric_option(val, 
1129                                            "-S/--stack-size", 
1130                                            initial_stack_size);
1131         
1132
1133          if (stack_size >= MIN_CSTACK_SIZE) {
1134            initial_stack_size = stack_size;
1135          }
1136        }
1137
1138      } else if ((flag = (strncmp(arg, "-Z", 2) == 0)) ||
1139                 (strcmp(arg, "--thread-stack-size") == 0)) {
1140        natural stack_size;
1141
1142        if (flag && arg[2]) {
1143          val = arg+2;
1144          num_elide = 1;
1145        } else {
1146          if ((i+1) < argc) {
1147            val = argv[i+1];
1148            num_elide = 2;
1149          } else {
1150            arg_error = 1;
1151          }
1152        }
1153
1154        if (val) {
1155          stack_size = parse_numeric_option(val, 
1156                                            "-Z/--thread-stack-size", 
1157                                            thread_stack_size);
1158         
1159
1160          if (stack_size >= MIN_CSTACK_SIZE) {
1161           thread_stack_size = stack_size;
1162          }
1163          if (thread_stack_size >= (1LL<<((WORD_SIZE-fixnumshift)-1))) {
1164            thread_stack_size = (1LL<<((WORD_SIZE-fixnumshift)-1))-1;
1165          }
1166         
1167        }
1168
1169      } else if (strcmp(arg, "--no-sigtrap") == 0) {
1170        no_sigtrap = 1;
1171        num_elide = 1;
1172      } else if ((strcmp(arg, "-b") == 0) ||
1173                 (strcmp(arg, "--batch") == 0)) {
1174        batch_flag = 1;
1175        num_elide = 1;
1176      } else if (strcmp(arg,"--") == 0) {
1177        break;
1178      } else {
1179        i++;
1180      }
1181      if (arg_error) {
1182        usage_exit("error in program arguments", 1, "");
1183      }
1184      if (num_elide) {
1185        for (j = i+num_elide, k=i; j < argc; j++, k++) {
1186          argv[k] = argv[j];
1187        }
1188        argc -= num_elide;
1189#ifdef DARWIN
1190        NXArgc -= num_elide;
1191#endif
1192        argv[argc] = NULL;
1193      }
1194    }
1195  }
1196}
1197
1198#ifdef WINDOWS
1199void
1200terminate_lisp()
1201{
1202  _exit(EXIT_FAILURE);
1203}
1204#else
1205pid_t main_thread_pid = (pid_t)0;
1206
1207void
1208terminate_lisp()
1209{
1210  kill(main_thread_pid, SIGKILL);
1211  _exit(-1);
1212}
1213#endif
1214
1215#ifdef DARWIN
1216#define min_os_version "8.0"    /* aka Tiger */
1217#endif
1218#ifdef LINUX
1219#ifdef PPC
1220#define min_os_version "2.2"
1221#endif
1222#ifdef X86
1223#define min_os_version "2.6"
1224#endif
1225#endif
1226#ifdef FREEBSD
1227#define min_os_version "6.0"
1228#endif
1229#ifdef SOLARIS
1230#define min_os_version "5.10"
1231#endif
1232
1233#ifdef PPC
1234#if defined(PPC64) || !defined(DARWIN)
1235/* ld64 on Darwin doesn't offer anything close to reliable control
1236   over the layout of a program in memory.  About all that we can
1237   be assured of is that the canonical subprims jump table address
1238   (currently 0x5000) is unmapped.  Map that page, and copy the
1239   actual spjump table there. */
1240
1241
1242void
1243remap_spjump()
1244{
1245  extern opcode spjump_start, spjump_end;
1246  pc new,
1247    old = &spjump_start,
1248    limit = &spjump_end,
1249    work;
1250  opcode instr;
1251  void *target;
1252  int disp;
1253 
1254  if (old != (pc)SPJUMP_TARGET_ADDRESS) {
1255    new = mmap((pc) SPJUMP_TARGET_ADDRESS,
1256               0x1000,
1257               PROT_READ | PROT_WRITE | PROT_EXEC,
1258               MAP_PRIVATE | MAP_ANON | MAP_FIXED,
1259               -1,
1260               0);
1261    if (new != (pc) SPJUMP_TARGET_ADDRESS) {
1262      perror("remap spjump");
1263      _exit(1);
1264    }
1265   
1266    for (work = new; old < limit; work++, old++) {
1267      instr = *old;
1268      disp = instr & ((1<<26)-1);
1269      target = (void*)old+disp;
1270      disp = target-(void *)work;
1271      *work = ((instr >> 26) << 26) | disp;
1272    }
1273    xMakeDataExecutable(new, (void*)work-(void*)new);
1274    ProtectMemory(new, 0x1000);
1275  }
1276}
1277#endif
1278#endif
1279
1280#ifdef X86
1281#ifdef WINDOWS
1282
1283/* By using linker tricks, we ensure there's memory between 0x11000
1284   and 0x21000, so we just need to fix permissions and copy the spjump
1285   table. */
1286
1287void
1288remap_spjump()
1289{
1290  extern opcode spjump_start;
1291  DWORD old_protect;
1292
1293  if ((void *)(&spjump_start) != (void *) SPJUMP_TARGET_ADDRESS) {
1294    if (!VirtualProtect((pc) SPJUMP_TARGET_ADDRESS,
1295                        0x1000,
1296                        PAGE_EXECUTE_READWRITE,
1297                        &old_protect)) {
1298      wperror("VirtualProtect spjump");
1299      _exit(1);
1300    }
1301    memmove((pc) SPJUMP_TARGET_ADDRESS, &spjump_start, 0x1000);
1302  }
1303}
1304#else
1305void
1306remap_spjump()
1307{
1308  extern opcode spjump_start;
1309  pc new = mmap((pc) SPJUMP_TARGET_ADDRESS,
1310                0x1000,
1311                PROT_READ | PROT_WRITE | PROT_EXEC,
1312                MAP_PRIVATE | MAP_ANON | MAP_FIXED,
1313                -1,
1314                0),
1315    old = &spjump_start;
1316  if (new == (pc)-1) {
1317    perror("remap spjump");
1318    _exit(1);
1319  }
1320  memmove(new, old, 0x1000);
1321}
1322#endif
1323#endif
1324
1325
1326void
1327check_os_version(char *progname)
1328{
1329#ifdef WINDOWS
1330  /* 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. */
1331#else
1332  struct utsname uts;
1333  long got, want;
1334  char *got_end,*want_end;
1335#ifdef X8632
1336  extern Boolean rcontext_readonly;
1337#endif
1338
1339  want = strtoul(min_os_version,&want_end,10);
1340
1341  uname(&uts);
1342  got = strtoul(uts.release,&got_end,10);
1343#ifdef X8632
1344#ifdef FREEBSD
1345  if (!strcmp(uts.machine,"amd64")) {
1346    rcontext_readonly = true;
1347  }
1348#endif
1349#endif
1350  while (got == want) {
1351    if (*want_end == '.') {
1352      want = strtoul(want_end+1,&want_end,10);
1353      got = 0;
1354      if (*got_end == '.') {
1355        got = strtoul(got_end+1,&got_end,10);
1356      } else {
1357        break;
1358      }
1359    } else {
1360      break;
1361    }
1362  }
1363
1364  if (got < want) {
1365    fprintf(dbgout, "\n%s requires %s version %s or later; the current version is %s.\n", progname, uts.sysname, min_os_version, uts.release);
1366    exit(1);
1367  }
1368#ifdef PPC
1369#ifdef DARWIN
1370  {
1371    char *hosttype = getenv("HOSTTYPE");
1372    if (hosttype && !strncmp("intel", hosttype, 5)) {
1373      running_under_rosetta = true;
1374      use_mach_exception_handling = false;
1375      reserved_area_size = 1U << 30;
1376    }
1377  }
1378#endif
1379#endif
1380#endif
1381}
1382
1383#ifdef X86
1384/*
1385  This should determine the cache block size.  It should also
1386  probably complain if we don't have (at least) SSE2.
1387*/
1388extern int cpuid(natural, natural*, natural*, natural*);
1389
1390#define X86_FEATURE_CMOV    (1<<15)
1391#define X86_FEATURE_CLFLUSH (1<<19)
1392#define X86_FEATURE_MMX     (1<<23)
1393#define X86_FEATURE_SSE     (1<<25)
1394#define X86_FEATURE_SSE2    (1<<26)
1395
1396#define X86_REQUIRED_FEATURES (X86_FEATURE_CMOV|X86_FEATURE_MMX|X86_FEATURE_SSE|X86_FEATURE_SSE2)
1397
1398Boolean
1399check_x86_cpu()
1400{
1401  natural eax, ebx, ecx, edx;
1402
1403  eax = cpuid(0, &ebx, &ecx, &edx);
1404
1405  if (eax >= 1) {
1406    eax = cpuid(1, &ebx, &ecx, &edx);
1407    cache_block_size = (ebx & 0xff00) >> 5;
1408    if ((X86_REQUIRED_FEATURES & edx) == X86_REQUIRED_FEATURES) {
1409      return true;
1410    }
1411    /* It's very unlikely that SSE2 would be present and other things
1412       that we want wouldn't.  If they don't have MMX or CMOV either,
1413       might as well tell them. */
1414    if ((edx & X86_FEATURE_SSE2) == 0) {
1415      fprintf(dbgout, "This CPU doesn't support the SSE2 instruction set\n");
1416    }
1417    if ((edx & X86_FEATURE_MMX) == 0) {
1418      fprintf(dbgout, "This CPU doesn't support the MMX instruction set\n");
1419    }
1420    if ((edx & X86_FEATURE_CMOV) == 0) {
1421      fprintf(dbgout, "This CPU doesn't support the CMOV instruction\n");
1422    }
1423   
1424  }
1425  return false;
1426}
1427#endif
1428
1429void
1430lazarus()
1431{
1432  TCR *tcr = get_tcr(false);
1433  if (tcr) {
1434    /* Some threads may be dying; no threads should be created. */
1435    LOCK(lisp_global(TCR_AREA_LOCK),tcr);
1436    tcr->vs_area->active = tcr->vs_area->high - node_size;
1437    tcr->save_vsp = (LispObj *)(tcr->vs_area->active);
1438    tcr->ts_area->active = tcr->ts_area->high;
1439    tcr->save_tsp = (LispObj *)(tcr->ts_area->active);
1440    tcr->catch_top = 0;
1441    tcr->db_link = 0;
1442    tcr->xframe = 0;
1443    start_lisp(tcr, 0);
1444  }
1445}
1446
1447#ifdef LINUX
1448#ifdef X8664
1449#include <asm/prctl.h>
1450#include <sys/prctl.h>
1451
1452void
1453ensure_gs_available(char *progname)
1454{
1455  LispObj fs_addr = 0L, gs_addr = 0L, cur_thread = (LispObj)pthread_self();
1456  char *gnu_get_libc_version(void);
1457 
1458  arch_prctl(ARCH_GET_GS, &gs_addr);
1459  arch_prctl(ARCH_GET_FS, &fs_addr);
1460  if ((gs_addr == cur_thread) && (fs_addr != cur_thread)) {
1461    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);
1462    _exit(1);
1463  }
1464}
1465#endif
1466#endif
1467
1468Boolean
1469bogus_fp_exceptions = false;
1470
1471typedef
1472float (*float_arg_returns_float)(float);
1473
1474float
1475fcallf(float_arg_returns_float fun, float arg)
1476{
1477  return fun(arg);
1478}
1479
1480void
1481check_bogus_fp_exceptions()
1482{
1483#ifdef X8664
1484  float asinf(float),result;
1485   
1486
1487  natural save_mxcsr = get_mxcsr(), post_mxcsr;
1488  set_mxcsr(0x1f80);
1489
1490  result = fcallf(asinf, 1.0);
1491  post_mxcsr = get_mxcsr();
1492  set_mxcsr(save_mxcsr);
1493  if (post_mxcsr & (FE_ALL_EXCEPT & (~FE_INEXACT))) {
1494    bogus_fp_exceptions = true;
1495  }
1496#endif
1497}
1498
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  tcr->vs_area->active -= node_size;
1765  *(--tcr->save_vsp) = nrs_TOPLFUNC.vcell;
1766  nrs_TOPLFUNC.vcell = lisp_nil;
1767#ifdef GC_INTEGRITY_CHECKING
1768  (nrs_GC_EVENT_STATUS_BITS.vcell |= gc_integrity_check_bit);
1769#endif
1770  if (egc_enabled) {
1771    egc_control(true, NULL);
1772  }
1773  atexit(lazarus);
1774  start_lisp(TCR_TO_TSD(tcr), 0);
1775  _exit(0);
1776}
1777
1778area *
1779set_nil(LispObj r)
1780{
1781
1782  if (lisp_nil == (LispObj)NULL) {
1783
1784    lisp_nil = r;
1785  }
1786  return NULL;
1787}
1788
1789
1790void
1791xMakeDataExecutable(void *start, unsigned long nbytes)
1792{
1793  extern void flush_cache_lines();
1794  natural ustart = (natural) start, base, end;
1795 
1796  base = (ustart) & ~(cache_block_size-1);
1797  end = (ustart + nbytes + cache_block_size - 1) & ~(cache_block_size-1);
1798#ifdef DARWIN
1799  if (running_under_rosetta) {
1800    /* We probably need to flush something's cache even if running
1801       under Rosetta, but (a) this is agonizingly slow and (b) we're
1802       dying before we get to the point where this would matter.
1803    */
1804    return;
1805  }
1806#endif
1807#ifndef X86
1808  flush_cache_lines(base, (end-base)/cache_block_size, cache_block_size);
1809#endif
1810}
1811
1812natural
1813xStackSpace()
1814{
1815  return initial_stack_size+CSTACK_HARDPROT+CSTACK_SOFTPROT;
1816}
1817
1818#ifndef DARWIN
1819#ifdef WINDOWS
1820extern void *windows_open_shared_library(char *);
1821
1822void *
1823xGetSharedLibrary(char *path, int mode)
1824{
1825  return windows_open_shared_library(path);
1826}
1827#else
1828void *
1829xGetSharedLibrary(char *path, int mode)
1830{
1831  return dlopen(path, mode);
1832}
1833#endif
1834#else
1835void *
1836xGetSharedLibrary(char *path, int *resultType)
1837{
1838#if defined(PPC) && (WORD_SIZE == 32)
1839  NSObjectFileImageReturnCode code;
1840  NSObjectFileImage              moduleImage;
1841  NSModule                       module;
1842  const struct mach_header *     header;
1843  const char *                   error;
1844  void *                         result;
1845  /* not thread safe */
1846  /*
1847  static struct {
1848    const struct mach_header  *header;
1849    NSModule                  *module;
1850    const char                *error;
1851  } results;   
1852  */
1853  result = NULL;
1854  error = NULL;
1855
1856  /* first try to open this as a bundle */
1857  code = NSCreateObjectFileImageFromFile(path,&moduleImage);
1858  if (code != NSObjectFileImageSuccess &&
1859      code != NSObjectFileImageInappropriateFile &&
1860      code != NSObjectFileImageAccess)
1861    {
1862      /* compute error strings */
1863      switch (code)
1864        {
1865        case NSObjectFileImageFailure:
1866          error = "NSObjectFileImageFailure";
1867          break;
1868        case NSObjectFileImageArch:
1869          error = "NSObjectFileImageArch";
1870          break;
1871        case NSObjectFileImageFormat:
1872          error = "NSObjectFileImageFormat";
1873          break;
1874        case NSObjectFileImageAccess:
1875          /* can't find the file */
1876          error = "NSObjectFileImageAccess";
1877          break;
1878        default:
1879          error = "unknown error";
1880        }
1881      *resultType = 0;
1882      return (void *)error;
1883    }
1884  if (code == NSObjectFileImageInappropriateFile ||
1885      code == NSObjectFileImageAccess ) {
1886    /* the pathname might be a partial pathane (hence the access error)
1887       or it might be something other than a bundle, if so perhaps
1888       it is a .dylib so now try to open it as a .dylib */
1889
1890    /* protect against redundant loads, Gary Byers noticed possible
1891       heap corruption if this isn't done */
1892    header = NSAddImage(path, NSADDIMAGE_OPTION_RETURN_ON_ERROR |
1893                        NSADDIMAGE_OPTION_WITH_SEARCHING |
1894                        NSADDIMAGE_OPTION_RETURN_ONLY_IF_LOADED);
1895    if (!header)
1896      header = NSAddImage(path, NSADDIMAGE_OPTION_RETURN_ON_ERROR |
1897                          NSADDIMAGE_OPTION_WITH_SEARCHING);
1898    result = (void *)header;
1899    *resultType = 1;
1900  }
1901  else if (code == NSObjectFileImageSuccess) {
1902    /* we have a sucessful module image
1903       try to link it, don't bind symbols privately */
1904
1905    module = NSLinkModule(moduleImage, path,
1906                          NSLINKMODULE_OPTION_RETURN_ON_ERROR | NSLINKMODULE_OPTION_BINDNOW);
1907    NSDestroyObjectFileImage(moduleImage);     
1908    result = (void *)module;
1909    *resultType = 2;
1910  }
1911  if (!result)
1912    {
1913      /* compute error string */
1914      NSLinkEditErrors ler;
1915      int lerno;
1916      const char* file;
1917      NSLinkEditError(&ler,&lerno,&file,&error);
1918      if (error) {
1919        result = (void *)error;
1920        *resultType = 0;
1921      }
1922    }
1923  return result;
1924#else
1925  const char *                   error;
1926  void *                         result;
1927
1928  result = dlopen(path, RTLD_NOW | RTLD_GLOBAL);
1929 
1930  if (result == NULL) {
1931    error = dlerror();
1932    *resultType = 0;
1933    return (void *)error;
1934  }
1935  *resultType = 1;
1936  return result;
1937#endif
1938}
1939#endif
1940
1941
1942
1943int
1944fd_setsize_bytes()
1945{
1946  return FD_SETSIZE/8;
1947}
1948
1949void
1950do_fd_set(int fd, fd_set *fdsetp)
1951{
1952  FD_SET(fd, fdsetp);
1953}
1954
1955void
1956do_fd_clr(int fd, fd_set *fdsetp)
1957{
1958  FD_CLR(fd, fdsetp);
1959}
1960
1961int
1962do_fd_is_set(int fd, fd_set *fdsetp)
1963{
1964  return FD_ISSET(fd,fdsetp);
1965}
1966
1967
1968void
1969do_fd_zero(fd_set *fdsetp)
1970{
1971  FD_ZERO(fdsetp);
1972}
1973
1974#include "image.h"
1975
1976
1977
1978Boolean
1979check_for_embedded_image (char *path)
1980{
1981  int fd = open(path, O_RDONLY);
1982  Boolean image_is_embedded = false;
1983
1984  if (fd >= 0) {
1985    openmcl_image_file_header h;
1986
1987    if (find_openmcl_image_file_header (fd, &h)) {
1988      image_is_embedded = true;
1989    }
1990    close (fd);
1991  }
1992  return image_is_embedded;
1993}
1994
1995LispObj
1996load_image(char *path)
1997{
1998  int fd = open(path, O_RDONLY, 0666), err;
1999  LispObj image_nil = 0;
2000
2001  errno = 0;
2002  if (fd > 0) {
2003    openmcl_image_file_header ih;
2004    image_nil = load_openmcl_image(fd, &ih);
2005    /* We -were- using a duplicate fd to map the file; that
2006       seems to confuse Darwin (doesn't everything ?), so
2007       we'll instead keep the original file open.
2008    */
2009    err = errno;
2010    if (!image_nil) {
2011      close(fd);
2012    }
2013#ifdef WINDOWS
2014    /* We currently don't actually map the image, and leaving the file
2015       open seems to make it difficult to write to reliably. */
2016    if (image_nil) {
2017      close(fd);
2018    }
2019#endif
2020  } else {
2021    err = errno;
2022  }
2023  if (image_nil == 0) {
2024    if (err == 0) {
2025      fprintf(dbgout, "Couldn't load lisp heap image from %s\n", path);
2026    } else {
2027      fprintf(dbgout, "Couldn't load lisp heap image from %s:\n%s\n", path, strerror(err));
2028    }
2029    exit(-1);
2030  }
2031  return image_nil;
2032}
2033
2034int
2035set_errno(int val)
2036{
2037  errno = val;
2038  return -1;
2039}
2040
2041/* A horrible hack to allow us to initialize a JVM instance from lisp.
2042   On Darwin, creating a JVM instance clobbers the thread's existing
2043   Mach exception infrastructure, so we save and restore it here.
2044*/
2045
2046typedef int (*jvm_initfunc)(void*,void*,void*);
2047
2048int
2049jvm_init(jvm_initfunc f,void*arg0,void*arg1,void*arg2)
2050{
2051  int result = -1;
2052  TCR *tcr = get_tcr(1);
2053#ifdef DARWIN
2054  extern kern_return_t tcr_establish_lisp_exception_port(TCR *);
2055#endif
2056 
2057  result = f(arg0,arg1,arg2);
2058#ifdef DARWIN
2059  tcr_establish_lisp_exception_port(tcr);
2060#endif
2061  return result;
2062}
2063 
2064
2065
2066
2067void *
2068xFindSymbol(void* handle, char *name)
2069{
2070#if defined(LINUX) || defined(FREEBSD) || defined(SOLARIS)
2071  return dlsym(handle, name);
2072#endif
2073#ifdef DARWIN
2074#if defined(PPC64) || defined(X86)
2075  if ((handle == NULL) || (handle == ((void *) -1))) {
2076    handle = RTLD_DEFAULT;
2077  }   
2078  if (*name == '_') {
2079    name++;
2080  }
2081  return dlsym(handle, name);
2082#else
2083  natural address = 0;
2084
2085  if ((handle == NULL) ||
2086      (handle == (void *)-1) ||
2087      (handle == (void *)-2)){
2088    if (NSIsSymbolNameDefined(name)) { /* Keep dyld_lookup from crashing */
2089      _dyld_lookup_and_bind(name, (void *) &address, (void*) NULL);
2090    }
2091    return (void *)address;
2092  }
2093  Bug(NULL, "How did this happen ?");
2094#endif
2095#endif
2096#ifdef WINDOWS
2097  extern void *windows_find_symbol(void *, char *);
2098  return windows_find_symbol(handle, name);
2099#endif
2100}
2101
2102void *
2103get_r_debug()
2104{
2105#if defined(LINUX) || defined(FREEBSD) || defined(SOLARIS)
2106#if WORD_SIZE == 64
2107  extern Elf64_Dyn _DYNAMIC[];
2108  Elf64_Dyn *dp;
2109#else
2110  extern Elf32_Dyn _DYNAMIC[];
2111  Elf32_Dyn *dp;
2112#endif
2113  int tag;
2114
2115  for (dp = _DYNAMIC; (tag = dp->d_tag) != 0; dp++) {
2116    if (tag == DT_DEBUG) {
2117      return (void *)(dp->d_un.d_ptr);
2118    }
2119  }
2120#endif
2121  return NULL;
2122}
2123
2124
2125#ifdef DARWIN
2126void
2127sample_paging_info(paging_info *stats)
2128{
2129  mach_msg_type_number_t count = TASK_EVENTS_INFO_COUNT;
2130
2131  task_info(mach_task_self(),
2132            TASK_EVENTS_INFO,
2133            (task_info_t)stats,
2134            &count);
2135}
2136
2137void
2138report_paging_info_delta(FILE *out, paging_info *start, paging_info *stop)
2139{
2140  fprintf(out,";;; %d soft faults, %d faults, %d pageins\n\n",
2141          stop->cow_faults-start->cow_faults,
2142          stop->faults-start->faults,
2143          stop->pageins-start->pageins);
2144}
2145
2146#else
2147#ifdef WINDOWS
2148void
2149sample_paging_info(paging_info *stats)
2150{
2151}
2152
2153void
2154report_paging_info_delta(FILE *out, paging_info *start, paging_info *stop)
2155{
2156}
2157#else
2158void
2159sample_paging_info(paging_info *stats)
2160{
2161  getrusage(RUSAGE_SELF, stats);
2162}
2163
2164void
2165report_paging_info_delta(FILE *out, paging_info *start, paging_info *stop)
2166{
2167  fprintf(out,";;; %ld soft faults, %ld faults, %ld pageins\n\n",
2168          stop->ru_minflt-start->ru_minflt,
2169          stop->ru_majflt-start->ru_majflt,
2170          stop->ru_nswap-start->ru_nswap);
2171}
2172
2173#endif
2174#endif
Note: See TracBrowser for help on using the repository browser.