source: branches/1.1/ccl/lisp-kernel/pmcl-kernel.c @ 8617

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

Set HEAP_START and HEAP_END earlier.

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