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

Last change on this file since 6142 was 6142, checked in by gb, 13 years ago

Patch from Andi Kleen: set vmemoryuse (RLIMIT_AS) current resource
limit to max limit, since some distros limit it.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 42.8 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
581void
582raise_limit()
583{
584#ifdef RLIMIT_AS
585  struct rlimit r;
586  if (getrlimit(RLIMIT_AS, &r) == 0) {
587    r.rlim_cur = r.rlim_max;
588    setrlimit(RLIMIT_AS, &r);
589    /* Could limit heaplimit to rlim_max here if smaller? */
590  }
591#endif
592} 
593
594
595
596area *
597create_reserved_area(unsigned long totalsize)
598{
599  OSErr err;
600  Ptr h;
601  natural base, n;
602  BytePtr
603    end, 
604    lastbyte, 
605    start, 
606    protstart, 
607    p, 
608    want = (BytePtr)IMAGE_BASE_ADDRESS,
609    try2;
610  area *reserved;
611  Boolean fixed_map_ok = false;
612
613  /*
614    Through trial and error, we've found that IMAGE_BASE_ADDRESS is
615    likely to reside near the beginning of an unmapped block of memory
616    that's at least 1GB in size.  We'd like to load the heap image's
617    sections relative to IMAGE_BASE_ADDRESS; if we're able to do so,
618    that'd allow us to file-map those sections (and would enable us to
619    avoid having to relocate references in the data sections.)
620
621    In short, we'd like to reserve 1GB starting at IMAGE_BASE_ADDRESS
622    by creating an anonymous mapping with mmap().
623
624    If we try to insist that mmap() map a 1GB block at
625    IMAGE_BASE_ADDRESS exactly (by specifying the MAP_FIXED flag),
626    mmap() will gleefully clobber any mapped memory that's already
627    there.  (That region's empty at this writing, but some future
628    version of the OS might decide to put something there.)
629
630    If we don't specify MAP_FIXED, mmap() is free to treat the address
631    we give it as a hint; Linux seems to accept the hint if doing so
632    wouldn't cause a problem.  Naturally, that behavior's too useful
633    for Darwin (or perhaps too inconvenient for it): it'll often
634    return another address, even if the hint would have worked fine.
635
636    We call address_unmapped_p() to ask Mach whether using MAP_FIXED
637    would conflict with anything.  Until we discover a need to do
638    otherwise, we'll assume that if Linux's mmap() fails to take the
639    hint, it's because of a legitimate conflict.
640
641    If Linux starts ignoring hints, we can parse /proc/<pid>/maps
642    to implement an address_unmapped_p() for Linux.
643  */
644
645  totalsize = align_to_power_of_2((void *)totalsize, log2_heap_segment_size);
646
647#ifdef DARWIN
648  fixed_map_ok = address_unmapped_p(want,totalsize);
649#endif
650#ifdef SOLARIS
651  fixed_map_ok = true;
652#endif
653  raise_limit();
654  start = mmap((void *)want,
655               totalsize + heap_segment_size,
656               PROT_NONE,
657               MAP_PRIVATE | MAP_ANON | (fixed_map_ok ? MAP_FIXED : 0, MAP_NORESERVE),
658               -1,
659               0);
660  if (start == MAP_FAILED) {
661    perror("Initial mmap");
662    return NULL;
663  }
664
665  if (start != want) {
666    munmap(start, totalsize+heap_segment_size);
667    start = (void *)((((unsigned long)start)+heap_segment_size-1) & ~(heap_segment_size-1));
668    if(mmap(start, totalsize, PROT_NONE, MAP_PRIVATE | MAP_ANON | MAP_FIXED | MAP_NORESERVE, -1, 0) != start) {
669      return NULL;
670    }
671  }
672  mprotect(start, totalsize, PROT_NONE);
673
674  h = (Ptr) start;
675  base = (unsigned long) start;
676  image_base = base;
677  lastbyte = (BytePtr) (start+totalsize);
678  static_space_start = static_space_active = (BytePtr)STATIC_BASE_ADDRESS;
679  static_space_limit = static_space_start + STATIC_RESERVE;
680  pure_space_start = pure_space_active = start;
681  pure_space_limit = start + PURESPACE_RESERVE;
682  start = pure_space_limit;
683
684  /*
685    Allocate mark bits here.  They need to be 1/64 the size of the
686     maximum useable area of the heap (+ 3 words for the EGC.)
687  */
688  end = lastbyte;
689  end = (BytePtr) ((unsigned long)((((unsigned long)end) - ((totalsize+63)>>6)) & ~4095));
690
691  global_mark_ref_bits = (bitvector)end;
692  end = (BytePtr) ((unsigned long)((((unsigned long)end) - ((totalsize+63) >> 6)) & ~4095));
693  global_reloctab = (LispObj *) end;
694  reserved = new_area(start, end, AREA_VOID);
695  /* The root of all evil is initially linked to itself. */
696  reserved->pred = reserved->succ = reserved;
697  all_areas = reserved;
698  reserved->markbits = global_mark_ref_bits;
699  return reserved;
700}
701
702void *
703allocate_from_reserved_area(natural size)
704{
705  area *reserved = reserved_area;
706  BytePtr low = reserved->low, high = reserved->high;
707  natural avail = high-low;
708 
709  size = align_to_power_of_2(size, log2_heap_segment_size);
710
711  if (size > avail) {
712    return NULL;
713  }
714  reserved->low += size;
715  reserved->active = reserved->low;
716  reserved->ndnodes -= (size>>dnode_shift);
717  return low;
718}
719
720
721
722BytePtr reloctab_limit = NULL, markbits_limit = NULL;
723
724void
725ensure_gc_structures_writable()
726{
727  natural
728    ndnodes = area_dnode(lisp_global(HEAP_END),lisp_global(HEAP_START)),
729    npages = (lisp_global(HEAP_END)-lisp_global(HEAP_START)) >> log2_page_size,
730    markbits_size = (3*sizeof(LispObj))+((ndnodes+7)>>3),
731    reloctab_size = (sizeof(LispObj)*(((ndnodes+((1<<bitmap_shift)-1))>>bitmap_shift)+1));
732  BytePtr
733    new_reloctab_limit = ((BytePtr)global_reloctab)+reloctab_size,
734    new_markbits_limit = ((BytePtr)global_mark_ref_bits)+markbits_size;
735
736  if (new_reloctab_limit > reloctab_limit) {
737    UnProtectMemory(global_reloctab, reloctab_size);
738    reloctab_limit = new_reloctab_limit;
739  }
740 
741  if (new_markbits_limit > markbits_limit) {
742    UnProtectMemory(global_mark_ref_bits, markbits_size);
743    markbits_limit = new_markbits_limit;
744  }
745}
746
747
748area *
749allocate_dynamic_area(natural initsize)
750{
751  natural totalsize = align_to_power_of_2(initsize, log2_heap_segment_size);
752  BytePtr start, end;
753  area *a;
754
755  start = allocate_from_reserved_area(totalsize);
756  if (start == NULL) {
757    return NULL;
758  }
759  end = start + totalsize;
760  a = new_area(start, end, AREA_DYNAMIC);
761  a->active = start+initsize;
762  add_area_holding_area_lock(a);
763  a->markbits = reserved_area->markbits;
764  reserved_area->markbits = NULL;
765  UnProtectMemory(start, end-start);
766  a->h = start;
767  a->softprot = NULL;
768  a->hardprot = NULL;
769  ensure_gc_structures_writable();
770  return a;
771 }
772
773
774Boolean
775grow_dynamic_area(natural delta)
776{
777  area *a = active_dynamic_area, *reserved = reserved_area;
778  natural avail = reserved->high - reserved->low;
779 
780  delta = align_to_power_of_2(delta, log2_heap_segment_size);
781  if (delta > avail) {
782    return false;
783  }
784  if (!allocate_from_reserved_area(delta)) {
785    return false;
786  }
787  /*
788    commit_pages(a->high,delta);
789  */
790  commit_pages(HeapHighWaterMark,(a->high+delta)-HeapHighWaterMark);
791
792  a->high += delta;
793  a->ndnodes = area_dnode(a->high, a->low);
794  lisp_global(HEAP_END) += delta;
795  ensure_gc_structures_writable();
796  return true;
797}
798
799/*
800  As above.  Pages that're returned to the reserved_area are
801  "condemned" (e.g, we try to convince the OS that they never
802  existed ...)
803*/
804Boolean
805shrink_dynamic_area(natural delta)
806{
807  area *a = active_dynamic_area, *reserved = reserved_area;
808 
809  delta = align_to_power_of_2(delta, log2_heap_segment_size);
810
811  a->high -= delta;
812  a->ndnodes = area_dnode(a->high, a->low);
813  a->hardlimit = a->high;
814  uncommit_pages(a->high, delta);
815  reserved->low -= delta;
816  reserved->ndnodes += (delta>>dnode_shift);
817  lisp_global(HEAP_END) -= delta;
818  return true;
819}
820
821
822
823void
824sigint_handler (int signum, siginfo_t *info, ExceptionInformation *context)
825{
826  if (signum == SIGINT) {
827    lisp_global(INTFLAG) = (1 << fixnumshift);
828  }
829#ifdef DARWIN
830  DarwinSigReturn(context);
831#endif
832}
833
834
835void
836register_sigint_handler()
837{
838  install_signal_handler(SIGINT, (void *)sigint_handler);
839}
840
841
842
843BytePtr
844initial_stack_bottom()
845{
846  extern char **environ;
847  char *p = *environ;
848  while (*p) {
849    p += (1+strlen(p));
850  }
851  return (BytePtr)((((unsigned long) p) +4095) & ~4095);
852}
853
854
855 
856Ptr fatal_spare_ptr = NULL;
857
858
859void
860Fatal(StringPtr param0, StringPtr param1)
861{
862
863  if (fatal_spare_ptr) {
864    deallocate(fatal_spare_ptr);
865    fatal_spare_ptr = NULL;
866  }
867  fprintf(stderr, "Fatal error: %s\n%s\n", param0, param1);
868  _exit(-1);
869}
870
871OSErr application_load_err = noErr;
872
873area *
874set_nil(LispObj);
875
876
877#ifdef DARWIN
878/*
879   The underlying file system may be case-insensitive (e.g., HFS),
880   so we can't just case-invert the kernel's name.
881   Tack ".image" onto the end of the kernel's name.  Much better ...
882*/
883char *
884default_image_name(char *orig)
885{
886  int len = strlen(orig) + strlen(".image") + 1;
887  char *copy = (char *) malloc(len);
888
889  if (copy) {
890    strcpy(copy, orig);
891    strcat(copy, ".image");
892  }
893  return copy;
894}
895
896#else
897char *
898default_image_name(char *orig)
899{
900  char *copy = strdup(orig), *base = copy, *work = copy, c;
901  if (copy == NULL) {
902    return NULL;
903  }
904  while(*work) {
905    if (*work++ == '/') {
906      base = work;
907    }
908  }
909  work = base;
910  while (c = *work) {
911    if (islower(c)) {
912      *work++ = toupper(c);
913    } else {
914      *work++ = tolower(c);
915    }
916  }
917  return copy;
918}
919#endif
920
921
922char *program_name = NULL;
923char *real_executable_name = NULL;
924
925char *
926determine_executable_name(char *argv0)
927{
928#ifdef DARWIN
929  uint32_t len = 1024;
930  char exepath[1024], *p = NULL;
931
932  if (_NSGetExecutablePath(exepath, (void *)&len) == 0) {
933    p = malloc(len+1);
934    bcopy(exepath, p, len);
935    p[len]=0;
936    return p;
937  } 
938  return argv0;
939#endif
940#ifdef LINUX
941  char exepath[PATH_MAX], *p;
942  int n;
943
944  if ((n = readlink("/proc/self/exe", exepath, PATH_MAX)) > 0) {
945    p = malloc(n+1);
946    bcopy(exepath,p,n);
947    p[n]=0;
948    return p;
949  }
950  return argv0;
951#endif
952#ifdef FREEBSD
953  return argv0;
954#endif
955#ifdef SOLARIS
956  char exepath[PATH_MAX], proc_path[PATH_MAX], *p;
957  int n;
958
959  snprintf(proc_path,PATH_MAX-1,"/proc/%d/path/a.out",getpid());
960
961  if ((n = readlink(proc_path, exepath, PATH_MAX)) > 0) {
962    p = malloc(n+1);
963    bcopy(exepath,p,n);
964    p[n]=0;
965    return p;
966  }
967  return argv0;
968#endif
969}
970
971void
972usage_exit(char *herald, int exit_status, char* other_args)
973{
974  if (herald && *herald) {
975    fprintf(stderr, "%s\n", herald);
976  }
977  fprintf(stderr, "usage: %s <options>\n", program_name);
978  fprintf(stderr, "\t or %s <image-name>\n", program_name);
979  fprintf(stderr, "\t where <options> are one or more of:\n");
980  if (other_args && *other_args) {
981    fputs(other_args, stderr);
982  }
983  fprintf(stderr, "\t-R, --heap-reserve <n>: reserve <n> (default: %ld)\n",
984          reserved_area_size);
985  fprintf(stderr, "\t\t bytes for heap expansion\n");
986  fprintf(stderr, "\t-S, --stack-size <n>: set  size of initial thread's control stack to <n>\n");
987  fprintf(stderr, "\t-Z, --thread-stack-size <n>: set default size of first (listener)  thread's stacks based on <n>\n");
988  fprintf(stderr, "\t-b, --batch: exit when EOF on *STANDARD-INPUT*\n");
989  fprintf(stderr, "\t--no-sigtrap : obscure option for running under GDB\n");
990  fprintf(stderr, "\t-I, --image-name <image-name>\n");
991  fprintf(stderr, "\t and <image-name> defaults to %s\n", 
992          default_image_name(program_name));
993  fprintf(stderr, "\n");
994  exit(exit_status);
995}
996
997int no_sigtrap = 0;
998char *image_name = NULL;
999int batch_flag = 0;
1000
1001
1002natural
1003parse_numeric_option(char *arg, char *argname, natural default_val)
1004{
1005  char *tail;
1006  natural val = 0;
1007
1008  val = strtoul(arg, &tail, 0);
1009  switch(*tail) {
1010  case '\0':
1011    break;
1012   
1013  case 'M':
1014  case 'm':
1015    val = val << 20;
1016    break;
1017   
1018  case 'K':
1019  case 'k':
1020    val = val << 10;
1021    break;
1022   
1023  case 'G':
1024  case 'g':
1025    val = val << 30;
1026    break;
1027   
1028  default:
1029    fprintf(stderr, "couldn't parse %s argument %s", argname, arg);
1030    val = default_val;
1031    break;
1032  }
1033  return val;
1034}
1035 
1036
1037
1038/*
1039   The set of arguments recognized by the kernel is
1040   likely to remain pretty small and pretty simple.
1041   This removes everything it recognizes from argv;
1042   remaining args will be processed by lisp code.
1043*/
1044
1045void
1046process_options(int argc, char *argv[])
1047{
1048  int i, j, k, num_elide, flag, arg_error;
1049  char *arg, *val;
1050#ifdef DARWIN
1051  extern int NXArgc;
1052#endif
1053
1054  for (i = 1; i < argc;) {
1055    arg = argv[i];
1056    arg_error = 0;
1057    if (*arg != '-') {
1058      i++;
1059    } else {
1060      num_elide = 0;
1061      val = NULL;
1062      if ((flag = (strncmp(arg, "-I", 2) == 0)) ||
1063          (strcmp (arg, "--image-name") == 0)) {
1064        if (flag && arg[2]) {
1065          val = arg+2;
1066          num_elide = 1;
1067        } else {
1068          if ((i+1) < argc) {
1069            val = argv[i+1];
1070            num_elide = 2;
1071          } else {
1072            arg_error = 1;
1073          }
1074        }
1075        if (val) {
1076          image_name = val;
1077        }
1078      } else if ((flag = (strncmp(arg, "-R", 2) == 0)) ||
1079                 (strcmp(arg, "--heap-reserve") == 0)) {
1080        natural reserved_size;
1081
1082        if (flag && arg[2]) {
1083          val = arg+2;
1084          num_elide = 1;
1085        } else {
1086          if ((i+1) < argc) {
1087            val = argv[i+1];
1088            num_elide = 2;
1089          } else {
1090            arg_error = 1;
1091          }
1092        }
1093
1094        if (val) {
1095          reserved_size = parse_numeric_option(val, 
1096                                               "-R/--heap-reserve", 
1097                                               reserved_area_size);
1098        }
1099
1100        if (reserved_size <= MAXIMUM_MAPPABLE_MEMORY) {
1101          reserved_area_size = reserved_size;
1102        }
1103
1104      } else if ((flag = (strncmp(arg, "-S", 2) == 0)) ||
1105                 (strcmp(arg, "--stack-size") == 0)) {
1106        natural stack_size;
1107
1108        if (flag && arg[2]) {
1109          val = arg+2;
1110          num_elide = 1;
1111        } else {
1112          if ((i+1) < argc) {
1113            val = argv[i+1];
1114            num_elide = 2;
1115          } else {
1116            arg_error = 1;
1117          }
1118        }
1119
1120        if (val) {
1121          stack_size = parse_numeric_option(val, 
1122                                            "-S/--stack-size", 
1123                                            initial_stack_size);
1124         
1125
1126          if (stack_size >= MIN_CSTACK_SIZE) {
1127            initial_stack_size = stack_size;
1128          }
1129        }
1130
1131      } else if ((flag = (strncmp(arg, "-Z", 2) == 0)) ||
1132                 (strcmp(arg, "--thread-stack-size") == 0)) {
1133        natural stack_size;
1134
1135        if (flag && arg[2]) {
1136          val = arg+2;
1137          num_elide = 1;
1138        } else {
1139          if ((i+1) < argc) {
1140            val = argv[i+1];
1141            num_elide = 2;
1142          } else {
1143            arg_error = 1;
1144          }
1145        }
1146
1147        if (val) {
1148          stack_size = parse_numeric_option(val, 
1149                                            "-Z/--thread-stack-size", 
1150                                            thread_stack_size);
1151         
1152
1153          if (stack_size >= MIN_CSTACK_SIZE) {
1154           thread_stack_size = stack_size;
1155          }
1156          if (thread_stack_size >= (1L<<((WORD_SIZE-fixnumshift)-1))) {
1157            thread_stack_size = (1L<<((WORD_SIZE-fixnumshift)-1))-1;
1158          }
1159         
1160        }
1161
1162      } else if (strcmp(arg, "--no-sigtrap") == 0) {
1163        no_sigtrap = 1;
1164        num_elide = 1;
1165      } else if ((strcmp(arg, "-b") == 0) ||
1166                 (strcmp(arg, "--batch") == 0)) {
1167        batch_flag = 1;
1168        num_elide = 1;
1169      } else if (strcmp(arg,"--") == 0) {
1170        break;
1171      } else {
1172        i++;
1173      }
1174      if (arg_error) {
1175        usage_exit("error in program arguments", 1, "");
1176      }
1177      if (num_elide) {
1178        for (j = i+num_elide, k=i; j < argc; j++, k++) {
1179          argv[k] = argv[j];
1180        }
1181        argc -= num_elide;
1182#ifdef DARWIN
1183        NXArgc -= num_elide;
1184#endif
1185        argv[argc] = NULL;
1186      }
1187    }
1188  }
1189}
1190
1191pid_t main_thread_pid = (pid_t)0;
1192
1193void
1194terminate_lisp()
1195{
1196  kill(main_thread_pid, SIGKILL);
1197  _exit(-1);
1198}
1199
1200#ifdef DARWIN
1201#ifdef PPC64
1202#define min_os_version "8.0"    /* aka Tiger */
1203#else
1204#define min_os_version "7.0"    /* aka Panther */
1205#endif
1206#endif
1207#ifdef LINUX
1208#ifdef PPC
1209#define min_os_version "2.2"
1210#endif
1211#ifdef X86
1212#define min_os_version "2.6"
1213#endif
1214#endif
1215#ifdef FREEBSD
1216#define min_os_version "6.0"
1217#endif
1218#ifdef SOLARIS
1219#define min_os_version "5.10"
1220#endif
1221
1222#ifdef DARWIN
1223#ifdef PPC64
1224/* ld64 on Darwin doesn't offer anything close to reliable control
1225   over the layout of a program in memory.  About all that we can
1226   be assured of is that the canonical subprims jump table address
1227   (currently 0x5000) is unmapped.  Map that page, and copy the
1228   actual spjump table there. */
1229
1230
1231void
1232remap_spjump()
1233{
1234  extern opcode spjump_start, spjump_end;
1235  pc new,
1236    old = &spjump_start,
1237    limit = &spjump_end,
1238    work;
1239  opcode instr;
1240  void *target;
1241  int disp;
1242 
1243  if (old != (pc)0x5000) {
1244    new = mmap((pc) 0x5000,
1245               0x1000,
1246               PROT_READ | PROT_WRITE | PROT_EXEC,
1247               MAP_PRIVATE | MAP_ANON | MAP_FIXED,
1248               -1,
1249               0);
1250    if (new != (pc) 0x5000) {
1251      _exit(1);
1252    }
1253   
1254    for (work = new; old < limit; work++, old++) {
1255      instr = *old;
1256      disp = instr & ((1<<26)-1);
1257      target = (void*)old+disp;
1258      disp = target-(void *)work;
1259      *work = ((instr >> 26) << 26) | disp;
1260    }
1261    xMakeDataExecutable(new, (void*)work-(void*)new);
1262    mprotect(new, 0x1000, PROT_READ | PROT_EXEC);
1263  }
1264}
1265#endif
1266#endif
1267
1268#ifdef X8664
1269void
1270remap_spjump()
1271{
1272  extern opcode spjump_start;
1273  pc new = mmap((pc) 0x5000,
1274                0x1000,
1275                PROT_READ | PROT_WRITE | PROT_EXEC,
1276                MAP_PRIVATE | MAP_ANON | MAP_FIXED,
1277                -1,
1278                0),
1279    old = &spjump_start;
1280  if (new == (pc)-1) {
1281    perror("remap spjump");
1282    _exit(1);
1283  }
1284  bcopy(old, new, 0x1000);
1285}
1286#endif
1287
1288void
1289check_os_version(char *progname)
1290{
1291  struct utsname uts;
1292
1293  uname(&uts);
1294  if (strcmp(uts.release, min_os_version) < 0) {
1295    fprintf(stderr, "\n%s requires %s version %s or later; the current version is %s.\n", progname, uts.sysname, min_os_version, uts.release);
1296    exit(1);
1297  }
1298#ifdef PPC
1299#ifdef DARWIN
1300  {
1301    char *hosttype = getenv("HOSTTYPE");
1302    if (hosttype && !strncmp("intel", hosttype, 5)) {
1303      running_under_rosetta = true;
1304      use_mach_exception_handling = false;
1305      reserved_area_size = 1U << 30;
1306    }
1307  }
1308#endif
1309#endif
1310}
1311
1312#ifdef X86
1313/*
1314  This should determine the cache block size.  It should also
1315  probably complain if we don't have (at least) SSE2.
1316*/
1317extern int cpuid(int, int*, int*, int*);
1318
1319#define X86_FEATURE_CMOV    (1<<15)
1320#define X86_FEATURE_CLFLUSH (1<<19)
1321#define X86_FEATURE_MMX     (1<<23)
1322#define X86_FEATURE_SSE     (1<<25)
1323#define X86_FEATURE_SSE2    (1<<26)
1324
1325#define X86_REQUIRED_FEATURES (X86_FEATURE_CMOV|X86_FEATURE_CLFLUSH|X86_FEATURE_MMX|X86_FEATURE_SSE|X86_FEATURE_SSE2)
1326
1327Boolean
1328check_x86_cpu()
1329{
1330  int eax, ebx, ecx, edx;
1331 
1332  eax = cpuid(0, &ebx, &ecx, &edx);
1333
1334  if (eax >= 1) {
1335    eax = cpuid(1, &ebx, &ecx, &edx);
1336    cache_block_size = (ebx & 0xff00) >> 5;
1337    if ((X86_REQUIRED_FEATURES & edx) == X86_REQUIRED_FEATURES) {
1338      return true;
1339    }
1340  }
1341  return false;
1342}
1343#endif
1344
1345void
1346lazarus()
1347{
1348  TCR *tcr = get_tcr(false);
1349  if (tcr) {
1350    /* Some threads may be dying; no threads should be created. */
1351    LOCK(lisp_global(TCR_AREA_LOCK),tcr);
1352    tcr->vs_area->active = tcr->vs_area->high - node_size;
1353    tcr->save_vsp = (LispObj *)(tcr->vs_area->active);
1354    tcr->ts_area->active = tcr->ts_area->high;
1355    tcr->save_tsp = (LispObj *)(tcr->ts_area->active);
1356    tcr->catch_top = 0;
1357    tcr->db_link = 0;
1358    tcr->xframe = 0;
1359    start_lisp(tcr, 0);
1360  }
1361}
1362
1363#ifdef LINUX
1364#ifdef X8664
1365#include <asm/prctl.h>
1366#include <sys/prctl.h>
1367
1368void
1369ensure_gs_available(char *progname)
1370{
1371  LispObj fs_addr = 0L, gs_addr = 0L, cur_thread = (LispObj)pthread_self();
1372  char *gnu_get_libc_version(void);
1373 
1374  arch_prctl(ARCH_GET_GS, &gs_addr);
1375  arch_prctl(ARCH_GET_FS, &fs_addr);
1376  if ((gs_addr == cur_thread) && (fs_addr != cur_thread)) {
1377    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);
1378    _exit(1);
1379  }
1380}
1381#endif
1382#endif
1383
1384main(int argc, char *argv[], char *envp[], void *aux)
1385{
1386  extern int page_size;
1387
1388#ifdef PPC
1389  extern int altivec_present;
1390#endif
1391  extern LispObj load_image(char *);
1392  long resp;
1393  BytePtr stack_end;
1394  area *a;
1395  BytePtr stack_base, current_sp = (BytePtr) current_stack_pointer();
1396  TCR *tcr;
1397  int i;
1398
1399  check_os_version(argv[0]);
1400  real_executable_name = determine_executable_name(argv[0]);
1401  page_size = getpagesize();
1402
1403#ifdef LINUX
1404#ifdef X8664
1405  ensure_gs_available(real_executable_name);
1406#endif
1407#endif
1408#if (defined(DARWIN) && defined(PPC64)) || defined(X8664)
1409  remap_spjump();
1410#endif
1411
1412#ifdef PPC
1413#ifdef LINUX
1414  {
1415    ElfW(auxv_t) *av = aux;
1416    int hwcap, done = false;
1417   
1418    if (av) {
1419      do {
1420        switch (av->a_type) {
1421        case AT_DCACHEBSIZE:
1422          cache_block_size = av->a_un.a_val;
1423          break;
1424
1425        case AT_HWCAP:
1426          hwcap = av->a_un.a_val;
1427          altivec_present = ((hwcap & PPC_FEATURE_HAS_ALTIVEC) != 0);
1428          break;
1429
1430        case AT_NULL:
1431          done = true;
1432          break;
1433        }
1434        av++;
1435      } while (!done);
1436    }
1437  }
1438#endif
1439#ifdef DARWIN
1440  {
1441    unsigned value = 0;
1442    size_t len = sizeof(value);
1443    int mib[2];
1444   
1445    mib[0] = CTL_HW;
1446    mib[1] = HW_CACHELINE;
1447    if (sysctl(mib,2,&value,&len, NULL, 0) != -1) {
1448      if (len == sizeof(value)) {
1449        cache_block_size = value;
1450      }
1451    }
1452    mib[1] = HW_VECTORUNIT;
1453    value = 0;
1454    len = sizeof(value);
1455    if (sysctl(mib,2,&value,&len, NULL, 0) != -1) {
1456      if (len == sizeof(value)) {
1457        altivec_present = value;
1458      }
1459    }
1460  }
1461#endif
1462#endif
1463
1464#ifdef X86
1465  if (!check_x86_cpu()) {
1466    fprintf(stderr, "CPU doesn't support required features\n");
1467    exit(1);
1468  }
1469#endif
1470
1471  main_thread_pid = getpid();
1472  tcr_area_lock = (void *)new_recursive_lock();
1473
1474  program_name = argv[0];
1475  if ((argc == 2) && (*argv[1] != '-')) {
1476    image_name = argv[1];
1477    argv[1] = NULL;
1478  } else {
1479    process_options(argc,argv);
1480  }
1481  initial_stack_size = ensure_stack_limit(initial_stack_size);
1482  if (image_name == NULL) {
1483    if (check_for_embedded_image(real_executable_name)) {
1484      image_name = real_executable_name;
1485    } else {
1486      image_name = default_image_name(real_executable_name);
1487    }
1488  }
1489
1490
1491  if (!create_reserved_area(reserved_area_size)) {
1492    exit(-1);
1493  }
1494  gc_init();
1495
1496  set_nil(load_image(image_name));
1497  lisp_global(TCR_AREA_LOCK) = ptr_to_lispobj(tcr_area_lock);
1498
1499  lisp_global(SUBPRIMS_BASE) = (LispObj)(5<<10);
1500  lisp_global(RET1VALN) = (LispObj)&ret1valn;
1501  lisp_global(LEXPR_RETURN) = (LispObj)&nvalret;
1502  lisp_global(LEXPR_RETURN1V) = (LispObj)&popj;
1503  lisp_global(ALL_AREAS) = ptr_to_lispobj(all_areas);
1504#ifdef X86
1505  lisp_global(BAD_FUNCALL) = ptr_to_lispobj(&bad_funcall);
1506#endif
1507  lisp_global(DEFAULT_ALLOCATION_QUANTUM) = log2_heap_segment_size << fixnumshift;
1508  lisp_global(STACK_SIZE) = thread_stack_size<<fixnumshift;
1509
1510
1511  exception_init();
1512
1513 
1514
1515  lisp_global(IMAGE_NAME) = ptr_to_lispobj(image_name);
1516  lisp_global(ARGV) = ptr_to_lispobj(argv);
1517  lisp_global(KERNEL_IMPORTS) = (LispObj)import_ptrs_base;
1518
1519  lisp_global(GET_TCR) = (LispObj) get_tcr;
1520  *(double *) &(lisp_global(DOUBLE_FLOAT_ONE)) = (double) 1.0;
1521
1522  lisp_global(HOST_PLATFORM) = (LispObj) PLATFORM << fixnumshift;
1523
1524  lisp_global(BATCH_FLAG) = (batch_flag << fixnumshift);
1525
1526  a = active_dynamic_area;
1527
1528  if (nilreg_area != NULL) {
1529    BytePtr lowptr = (BytePtr) a->low;
1530
1531    /* Create these areas as AREA_STATIC, change them to AREA_DYNAMIC */
1532    g1_area = new_area(lowptr, lowptr, AREA_STATIC);
1533    g2_area = new_area(lowptr, lowptr, AREA_STATIC);
1534    tenured_area = new_area(lowptr, lowptr, AREA_STATIC);
1535    add_area_holding_area_lock(tenured_area);
1536    add_area_holding_area_lock(g2_area);
1537    add_area_holding_area_lock(g1_area);
1538
1539    g1_area->code = AREA_DYNAMIC;
1540    g2_area->code = AREA_DYNAMIC;
1541    tenured_area->code = AREA_DYNAMIC;
1542
1543/*    a->older = g1_area; */ /* Not yet: this is what "enabling the EGC" does. */
1544    g1_area->younger = a;
1545    g1_area->older = g2_area;
1546    g2_area->younger = g1_area;
1547    g2_area->older = tenured_area;
1548    tenured_area->younger = g2_area;
1549    tenured_area->refbits = a->markbits;
1550    tenured_area->static_dnodes = a->static_dnodes;
1551    a->static_dnodes = 0;
1552    tenured_area->static_used = a->static_used;
1553    a->static_used = 0;
1554    lisp_global(TENURED_AREA) = ptr_to_lispobj(tenured_area);
1555    lisp_global(REFBITS) = ptr_to_lispobj(tenured_area->refbits);
1556    g2_area->threshold = G2_AREA_THRESHOLD;
1557    g1_area->threshold = G1_AREA_THRESHOLD;
1558    a->threshold = G0_AREA_THRESHOLD;
1559  }
1560
1561  tcr = new_tcr(initial_stack_size, MIN_TSTACK_SIZE);
1562  stack_base = initial_stack_bottom()-xStackSpace();
1563  init_threads((void *)(stack_base), tcr);
1564  thread_init_tcr(tcr, current_sp, current_sp-stack_base);
1565
1566  lisp_global(EXCEPTION_LOCK) = ptr_to_lispobj(new_recursive_lock());
1567  enable_fp_exceptions();
1568  register_sigint_handler();
1569
1570#ifdef PPC
1571  lisp_global(ALTIVEC_PRESENT) = altivec_present << fixnumshift;
1572#endif
1573#if STATIC
1574  lisp_global(STATICALLY_LINKED) = 1 << fixnumshift;
1575#endif
1576  tcr->prev = tcr->next = tcr;
1577  lisp_global(INTERRUPT_SIGNAL) = (LispObj) box_fixnum(SIGNAL_FOR_PROCESS_INTERRUPT);
1578  tcr->vs_area->active -= node_size;
1579  *(--tcr->save_vsp) = nrs_TOPLFUNC.vcell;
1580  nrs_TOPLFUNC.vcell = lisp_nil;
1581#ifdef GC_INTEGRITY_CHECKING
1582  (nrs_GC_EVENT_STATUS_BITS.vcell |= gc_integrity_check_bit);
1583#endif
1584#ifndef DISABLE_EGC
1585  egc_control(true, NULL);
1586#endif
1587  atexit(lazarus);
1588  start_lisp(TCR_TO_TSD(tcr), 0);
1589  _exit(0);
1590}
1591
1592area *
1593set_nil(LispObj r)
1594{
1595
1596  if (lisp_nil == (LispObj)NULL) {
1597
1598    lisp_nil = r;
1599  }
1600  return NULL;
1601}
1602
1603
1604void
1605xMakeDataExecutable(void *start, unsigned long nbytes)
1606{
1607  extern void flush_cache_lines();
1608  unsigned long ustart = (unsigned long) start, base, end;
1609 
1610  base = (ustart) & ~(cache_block_size-1);
1611  end = (ustart + nbytes + cache_block_size - 1) & ~(cache_block_size-1);
1612  if (running_under_rosetta) {
1613    /* We probably need to flush something's cache even if running
1614       under Rosetta, but (a) this is agonizingly slow and (b) we're
1615       dying before we get to the point where this would matter.
1616    */
1617    return;
1618  }
1619#ifndef X86
1620  flush_cache_lines(base, (end-base)/cache_block_size, cache_block_size);
1621#endif
1622}
1623
1624int
1625xStackSpace()
1626{
1627  return initial_stack_size+CSTACK_HARDPROT+CSTACK_SOFTPROT;
1628}
1629
1630#ifndef DARWIN
1631void *
1632xGetSharedLibrary(char *path, int mode)
1633{
1634  return dlopen(path, mode);
1635}
1636#else
1637void *
1638xGetSharedLibrary(char *path, int *resultType)
1639{
1640#if WORD_SIZE == 32
1641  NSObjectFileImageReturnCode code;
1642  NSObjectFileImage              moduleImage;
1643  NSModule                       module;
1644  const struct mach_header *     header;
1645  const char *                   error;
1646  void *                         result;
1647  /* not thread safe */
1648  /*
1649  static struct {
1650    const struct mach_header  *header;
1651    NSModule                  *module;
1652    const char                *error;
1653  } results;   
1654  */
1655  result = NULL;
1656  error = NULL;
1657
1658  /* first try to open this as a bundle */
1659  code = NSCreateObjectFileImageFromFile(path,&moduleImage);
1660  if (code != NSObjectFileImageSuccess &&
1661      code != NSObjectFileImageInappropriateFile &&
1662      code != NSObjectFileImageAccess)
1663    {
1664      /* compute error strings */
1665      switch (code)
1666        {
1667        case NSObjectFileImageFailure:
1668          error = "NSObjectFileImageFailure";
1669          break;
1670        case NSObjectFileImageArch:
1671          error = "NSObjectFileImageArch";
1672          break;
1673        case NSObjectFileImageFormat:
1674          error = "NSObjectFileImageFormat";
1675          break;
1676        case NSObjectFileImageAccess:
1677          /* can't find the file */
1678          error = "NSObjectFileImageAccess";
1679          break;
1680        default:
1681          error = "unknown error";
1682        }
1683      *resultType = 0;
1684      return (void *)error;
1685    }
1686  if (code == NSObjectFileImageInappropriateFile ||
1687      code == NSObjectFileImageAccess ) {
1688    /* the pathname might be a partial pathane (hence the access error)
1689       or it might be something other than a bundle, if so perhaps
1690       it is a .dylib so now try to open it as a .dylib */
1691
1692    /* protect against redundant loads, Gary Byers noticed possible
1693       heap corruption if this isn't done */
1694    header = NSAddImage(path, NSADDIMAGE_OPTION_RETURN_ON_ERROR |
1695                        NSADDIMAGE_OPTION_WITH_SEARCHING |
1696                        NSADDIMAGE_OPTION_RETURN_ONLY_IF_LOADED);
1697    if (!header)
1698      header = NSAddImage(path, NSADDIMAGE_OPTION_RETURN_ON_ERROR |
1699                          NSADDIMAGE_OPTION_WITH_SEARCHING);
1700    result = (void *)header;
1701    *resultType = 1;
1702  }
1703  else if (code == NSObjectFileImageSuccess) {
1704    /* we have a sucessful module image
1705       try to link it, don't bind symbols privately */
1706
1707    module = NSLinkModule(moduleImage, path,
1708                          NSLINKMODULE_OPTION_RETURN_ON_ERROR | NSLINKMODULE_OPTION_BINDNOW);
1709    NSDestroyObjectFileImage(moduleImage);     
1710    result = (void *)module;
1711    *resultType = 2;
1712  }
1713  if (!result)
1714    {
1715      /* compute error string */
1716      NSLinkEditErrors ler;
1717      int lerno;
1718      const char* file;
1719      NSLinkEditError(&ler,&lerno,&file,&error);
1720      if (error) {
1721        result = (void *)error;
1722        *resultType = 0;
1723      }
1724    }
1725  return result;
1726#else
1727  const char *                   error;
1728  void *                         result;
1729
1730  result = dlopen(path, RTLD_NOW | RTLD_GLOBAL);
1731 
1732  if (result == NULL) {
1733    error = dlerror();
1734    *resultType = 0;
1735    return (void *)error;
1736  }
1737  *resultType = 1;
1738  return result;
1739#endif
1740}
1741#endif
1742
1743
1744
1745int
1746fd_setsize_bytes()
1747{
1748  return FD_SETSIZE/8;
1749}
1750
1751void
1752do_fd_set(int fd, fd_set *fdsetp)
1753{
1754  FD_SET(fd, fdsetp);
1755}
1756
1757void
1758do_fd_clr(int fd, fd_set *fdsetp)
1759{
1760  FD_CLR(fd, fdsetp);
1761}
1762
1763int
1764do_fd_is_set(int fd, fd_set *fdsetp)
1765{
1766  return FD_ISSET(fd,fdsetp);
1767}
1768
1769void
1770do_fd_zero(fd_set *fdsetp)
1771{
1772  FD_ZERO(fdsetp);
1773}
1774
1775#include "image.h"
1776
1777
1778Boolean
1779check_for_embedded_image (char *path)
1780{
1781  int fd = open(path, O_RDONLY);
1782  Boolean image_is_embedded = false;
1783
1784  if (fd >= 0) {
1785    openmcl_image_file_header h;
1786
1787    if (find_openmcl_image_file_header (fd, &h)) {
1788      image_is_embedded = true;
1789    }
1790    close (fd);
1791  }
1792  return image_is_embedded;
1793}
1794
1795LispObj
1796load_image(char *path)
1797{
1798  int fd = open(path, O_RDONLY, 0666);
1799  LispObj image_nil = 0;
1800  if (fd > 0) {
1801    openmcl_image_file_header ih;
1802    image_nil = load_openmcl_image(fd, &ih);
1803    /* We -were- using a duplicate fd to map the file; that
1804       seems to confuse Darwin (doesn't everything ?), so
1805       we'll instead keep the original file open.
1806    */
1807    if (!image_nil) {
1808      close(fd);
1809    }
1810  }
1811  if (image_nil == 0) {
1812    fprintf(stderr, "Couldn't load lisp heap image from %s\n", path);
1813    exit(-1);
1814  }
1815  return image_nil;
1816}
1817
1818int
1819set_errno(int val)
1820{
1821  errno = val;
1822  return -1;
1823}
1824
1825
1826
1827
1828void *
1829xFindSymbol(void* handle, char *name)
1830{
1831#if defined(LINUX) || defined(FREEBSD)
1832  return dlsym(handle, name);
1833#endif
1834#ifdef DARWIN
1835#if defined(PPC64) || defined(X8664)
1836  if (handle == NULL) {
1837    handle = RTLD_DEFAULT;
1838  }   
1839  if (*name == '_') {
1840    name++;
1841  }
1842  return dlsym(handle, name);
1843#else
1844  natural address = 0;
1845
1846  if (handle == NULL) {
1847    if (NSIsSymbolNameDefined(name)) { /* Keep dyld_lookup from crashing */
1848      _dyld_lookup_and_bind(name, (void *) &address, (void*) NULL);
1849    }
1850    return (void *)address;
1851  }
1852  Bug(NULL, "How did this happen ?");
1853#endif
1854#endif
1855}
1856
1857void *
1858get_r_debug()
1859{
1860#if defined(LINUX) || defined(FREEBSD)
1861#if WORD_SIZE == 64
1862  extern Elf64_Dyn _DYNAMIC[];
1863  Elf64_Dyn *dp;
1864#else
1865  extern Elf32_Dyn _DYNAMIC[];
1866  Elf32_Dyn *dp;
1867#endif
1868  int tag;
1869
1870  for (dp = _DYNAMIC; (tag = dp->d_tag) != 0; dp++) {
1871    if (tag == DT_DEBUG) {
1872      return (void *)(dp->d_un.d_ptr);
1873    }
1874  }
1875#endif
1876  return NULL;
1877}
1878
1879
Note: See TracBrowser for help on using the repository browser.