source: trunk/ccl/lisp-kernel/pmcl-kernel.c @ 5683

Last change on this file since 5683 was 5683, checked in by gb, 14 years ago

Try to check for old libc versions (which may use %gs instead of %fs for tls).

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