source: branches/working-0711/ccl/lisp-kernel/pmcl-kernel.c @ 11482

Last change on this file since 11482 was 11482, checked in by gz, 11 years ago

r11450 from trunk: *quit-interrupt-hook*

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