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

Last change on this file since 12129 was 12129, checked in by gb, 10 years ago

Try to set the new KERNEL-PATH kernel global to the value of
real_executable_name; try harder to ensure that real_executable_name
and the image name are fully qualified and resolved pathnames.

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