source: branches/win64/lisp-kernel/pmcl-kernel.c @ 8626

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

Rebase PE image address to 0x10000, so we have allocated memory from
0x11000-0x21000. Also, code to find full executable path name, and
to print Windows error messages.

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