source: branches/working-0711/ccl/lisp-kernel/pmcl-kernel.c @ 7668

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

openSUSE 10.3 (at least) shipped with a buggy version of bcopy();
see <http://lists.opensuse.oorg/opensuse-bugs/2007-09/msg14146.html>
Use memmove() instead. (I don't think any of the uses of any of this
stuff care about overlap, but we might as well use something that
checks for it.)

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