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

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

Pass the signal number through to user handlers, use it to exit by resignalling

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