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

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

On Windows, try to obtain the UTF-16 version of argv; change some
of the functions that deal with determining the image name and
opening the image to accept UTF-16-encoded strings. When the
kernel's done with the image name and argv, convert the strings
involved to UTF-8 (since this doesn't lose information and makes
it a little easier to bootstrap changes to the lisp side of this.)

On the lisp side of this (when obtaining the heap image name and
command-line arguments), assume that the strings are UTF-8-encoded
and possibly do platform-dependent postprocessing. (I honestly
don't know how to reliably tell what encoding was used for things
that come from the command line on other platforms; if they may
not be UTF-8, we might want to make similar changes in the kernel
to support other encodings.

This is supposed to help address ticket:475; I don't know yet if
it does, or if the kernel changes will compie on non-Windows platforms.
One way to find out ...

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