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

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

Remove unused variables. (May need to compile with -Wall to find
more unused vars on PPC, too.)

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