source: trunk/source/lisp-kernel/pmcl-kernel.c @ 11633

Last change on this file since 11633 was 11633, checked in by gb, 12 years ago

(experimentally) set MAXIMUM_MAPPABLE_MEMORY to 3GB on x8632 Linux.

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