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

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

Fix typo in ensure_gc_structures_writeable(). Set HEAP_START/HEAP_END
globals just before calling it.
Provide some win64 definitions (terminate_lisp(), etc.)
Set _fmode (default text/binary mode for open()), so we don't have to
remember to say O_BINARY, make stderr unbuffered on Windows

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