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

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

Try to ensure that the stack size(s) passed around are "natural"
integers. (On some platforms, mmap() may not be willing/able to
map more than a integer's worth of bytes in one swell foop; this
and related changes probably need a bit of thought; something
should enforce real stack size limits, somewhere.)

Please don't propagate these changes to other branches until we
see how this works.

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