source: branches/purify/source/lisp-kernel/pmcl-kernel.c @ 12886

Last change on this file since 12886 was 12886, checked in by gb, 11 years ago

Write a (possibly empty) static-cons-area to image file;
read it. Change image version.

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