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

Last change on this file since 8616 was 8616, checked in by gb, 12 years ago

set HEAP_START, HEAP_END earlier

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