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

Last change on this file since 8575 was 8575, checked in by andreas, 13 years ago

Make C-callable X86-64 assembler functions platform independent by introducing symbolic register
names. Also fix some of the C prototypes for these functions that used "unsigned" when they
really meant "natural" (unsigned is 32 bits on Windows).

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