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

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

Handle "handle" on Darwin/x8664.

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