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

Last change on this file since 8787 was 8787, checked in by gb, 13 years ago

LOGIOR in O_BINARY when calling MS C library's open().

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