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

Last change on this file since 11412 was 11412, checked in by gz, 13 years ago

from trunk, assorted changes for other platforms

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