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

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

From trunk: formatting tweaks, non-linux changes, doc and error message fixes

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 48.9 KB
Line 
1/*
2   Copyright (C) 2009 Clozure Associates
3   Copyright (C) 1994-2001 Digitool, Inc
4   This file is part of Clozure CL. 
5
6   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7   License , known as the LLGPL and distributed with Clozure CL as the
8   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9   which is distributed with Clozure CL as the file "LGPL".  Where these
10   conflict, the preamble takes precedence. 
11
12   Clozure CL is referenced in the preamble as the "LIBRARY."
13
14   The LLGPL is also available online at
15   http://opensource.franz.com/preamble.html
16*/
17
18#ifdef DARWIN
19/*      dyld.h included here because something in "lisp.h" causes
20    a conflict (actually I think the problem is in "constants.h")
21*/
22#include <mach-o/dyld.h>
23
24#endif
25#include "lisp.h"
26#include "lisp_globals.h"
27#include "gc.h"
28#include "area.h"
29#include <stdlib.h>
30#include <string.h>
31#include "lisp-exceptions.h"
32#include <stdio.h>
33#include <stdlib.h>
34#ifndef WINDOWS
35#include <sys/mman.h>
36#endif
37#include <fcntl.h>
38#include <signal.h>
39#include <errno.h>
40#ifndef WINDOWS
41#include <sys/utsname.h>
42#include <unistd.h>
43#endif
44
45#ifdef LINUX
46#include <mcheck.h>
47#include <dirent.h>
48#include <dlfcn.h>
49#include <sys/time.h>
50#include <sys/resource.h>
51#include <link.h>
52#include <elf.h>
53
54/*
55   The version of <asm/cputable.h> provided by some distributions will
56   claim that <asm-ppc64/cputable.h> doesn't exist.  It may be present
57   in the Linux kernel source tree even if it's not copied to
58   /usr/include/asm-ppc64.  Hopefully, this will be straightened out
59   soon (and/or the PPC_FEATURE_HAS_ALTIVEC constant will be defined
60   in a less volatile place.)  Until that's straightened out, it may
61   be necessary to install a copy of the kernel header in the right
62   place and/or persuade <asm/cputable> to lighten up a bit.
63*/
64
65#ifdef PPC
66#ifndef PPC64
67#include <asm/cputable.h>
68#endif
69#ifndef PPC_FEATURE_HAS_ALTIVEC
70#define PPC_FEATURE_HAS_ALTIVEC 0x10000000
71#endif
72#endif
73#endif
74
75Boolean use_mach_exception_handling = 
76#ifdef DARWIN
77  true
78#else
79  false
80#endif
81;
82
83#ifdef DARWIN
84#include <sys/types.h>
85#include <sys/time.h>
86#include <sys/mman.h>
87#include <sys/resource.h>
88#include <mach/mach_types.h>
89#include <mach/message.h>
90#include <mach/vm_region.h>
91#include <mach/port.h>
92#include <sys/sysctl.h>
93#include <dlfcn.h>
94#endif
95
96#if defined(FREEBSD) || defined(SOLARIS)
97#include <sys/time.h>
98#include <sys/resource.h>
99#include <dlfcn.h>
100#include <elf.h> 
101#include <link.h>
102#endif
103
104#include <ctype.h>
105#ifndef WINDOWS
106#include <sys/select.h>
107#endif
108#include "Threads.h"
109
110#include <fenv.h>
111#include <sys/stat.h>
112
113#ifndef MAP_NORESERVE
114#define MAP_NORESERVE (0)
115#endif
116
117#ifdef WINDOWS
118#include <windows.h>
119#include <stdio.h>
120void
121wperror(char* message)
122{
123  char* buffer;
124  DWORD last_error = GetLastError();
125 
126  FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER|
127                FORMAT_MESSAGE_FROM_SYSTEM|
128                FORMAT_MESSAGE_IGNORE_INSERTS,
129                NULL,
130                last_error,
131                MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
132                (LPTSTR)&buffer,
133                0, NULL);
134  fprintf(dbgout, "%s: 0x%x %s\n", message, (unsigned) last_error, buffer);
135  LocalFree(buffer);
136}
137#endif
138
139LispObj lisp_nil = (LispObj) 0;
140bitvector global_mark_ref_bits = NULL;
141
142
143/* These are all "persistent" : they're initialized when
144   subprims are first loaded and should never change. */
145extern LispObj ret1valn;
146extern LispObj nvalret;
147extern LispObj popj;
148
149LispObj text_start = 0;
150
151/* A pointer to some of the kernel's own data; also persistent. */
152
153extern LispObj import_ptrs_base;
154
155
156
157void
158xMakeDataExecutable(void *, unsigned long);
159
160void
161make_dynamic_heap_executable(LispObj *p, LispObj *q)
162{
163  void * cache_start = (void *) p;
164  natural ncacheflush = (natural) q - (natural) p;
165
166  xMakeDataExecutable(cache_start, ncacheflush); 
167}
168     
169size_t
170ensure_stack_limit(size_t stack_size)
171{
172#ifdef WINDOWS
173  extern void os_get_current_thread_stack_bounds(void **, natural*);
174  natural totalsize;
175  void *ignored;
176 
177  os_get_current_thread_stack_bounds(&ignored, &totalsize);
178
179  return (size_t)totalsize-(size_t)(CSTACK_HARDPROT+CSTACK_SOFTPROT);
180
181#else
182  struct rlimit limits;
183  rlim_t cur_stack_limit, max_stack_limit;
184 
185  stack_size += (CSTACK_HARDPROT+CSTACK_SOFTPROT);
186  getrlimit(RLIMIT_STACK, &limits);
187  cur_stack_limit = limits.rlim_cur;
188  max_stack_limit = limits.rlim_max;
189  if (stack_size > max_stack_limit) {
190    stack_size = max_stack_limit;
191  }
192  if (cur_stack_limit < stack_size) {
193    limits.rlim_cur = stack_size;
194    errno = 0;
195    if (setrlimit(RLIMIT_STACK, &limits)) {
196      int e = errno;
197      fprintf(dbgout, "errno = %d\n", e);
198      Fatal(": Stack resource limit too small", "");
199    }
200  }
201#endif
202  return stack_size;
203}
204
205
206/* This should write-protect the bottom of the stack.
207   Doing so reliably involves ensuring that everything's unprotected on exit.
208*/
209
210BytePtr
211allocate_lisp_stack(natural useable,
212                    unsigned softsize,
213                    unsigned hardsize,
214                    lisp_protection_kind softkind,
215                    lisp_protection_kind hardkind,
216                    Ptr *h_p,
217                    BytePtr *base_p,
218                    protected_area_ptr *softp,
219                    protected_area_ptr *hardp)
220{
221  void *allocate_stack(natural);
222  void free_stack(void *);
223  natural size = useable+softsize+hardsize;
224  natural overhead;
225  BytePtr base, softlimit, hardlimit;
226  Ptr h = allocate_stack(size+4095);
227  protected_area_ptr hprotp = NULL, sprotp;
228
229  if (h == NULL) {
230    return NULL;
231  }
232  if (h_p) *h_p = h;
233  base = (BytePtr) align_to_power_of_2( h, log2_page_size);
234  hardlimit = (BytePtr) (base+hardsize);
235  softlimit = hardlimit+softsize;
236
237  overhead = (base - (BytePtr) h);
238  if (hardsize) {
239    hprotp = new_protected_area((BytePtr)base,hardlimit,hardkind, hardsize, true);
240    if (hprotp == NULL) {
241      if (base_p) *base_p = NULL;
242      if (h_p) *h_p = NULL;
243      deallocate(h);
244      return NULL;
245    }
246    if (hardp) *hardp = hprotp;
247  }
248  if (softsize) {
249    sprotp = new_protected_area(hardlimit,softlimit, softkind, softsize, true);
250    if (sprotp == NULL) {
251      if (base_p) *base_p = NULL;
252      if (h_p) *h_p = NULL;
253      if (hardp) *hardp = NULL;
254      if (hprotp) delete_protected_area(hprotp);
255      free_stack(h);
256      return NULL;
257    }
258    if (softp) *softp = sprotp;
259  }
260  if (base_p) *base_p = base;
261  return (BytePtr) ((natural)(base+size));
262}
263
264/*
265  This should only called by something that owns the area_lock, or
266  by the initial thread before other threads exist.
267*/
268area *
269allocate_lisp_stack_area(area_code stack_type,
270                         natural usable,
271                         unsigned softsize, 
272                         unsigned hardsize, 
273                         lisp_protection_kind softkind, 
274                         lisp_protection_kind hardkind)
275
276{
277  BytePtr base, bottom;
278  Ptr h;
279  area *a = NULL;
280  protected_area_ptr soft_area=NULL, hard_area=NULL;
281
282  bottom = allocate_lisp_stack(usable, 
283                               softsize, 
284                               hardsize, 
285                               softkind, 
286                               hardkind, 
287                               &h, 
288                               &base,
289                               &soft_area, 
290                               &hard_area);
291
292  if (bottom) {
293    a = new_area(base, bottom, stack_type);
294    a->hardlimit = base+hardsize;
295    a->softlimit = base+hardsize+softsize;
296    a->h = h;
297    a->softprot = soft_area;
298    a->hardprot = hard_area;
299    add_area_holding_area_lock(a);
300  }
301  return a;
302}
303
304/*
305  Also assumes ownership of the area_lock
306*/
307area*
308register_cstack_holding_area_lock(BytePtr bottom, natural size)
309{
310  BytePtr lowlimit = (BytePtr) (((((natural)bottom)-size)+4095)&~4095);
311  area *a = new_area((BytePtr) bottom-size, bottom, AREA_CSTACK);
312  a->hardlimit = lowlimit+CSTACK_HARDPROT;
313  a->softlimit = a->hardlimit+CSTACK_SOFTPROT;
314#ifdef USE_SIGALTSTACK
315  setup_sigaltstack(a);
316#endif
317  add_area_holding_area_lock(a);
318  return a;
319}
320 
321
322area*
323allocate_vstack_holding_area_lock(natural usable)
324{
325  return allocate_lisp_stack_area(AREA_VSTACK, 
326                                  usable > MIN_VSTACK_SIZE ?
327                                  usable : MIN_VSTACK_SIZE,
328                                  VSTACK_SOFTPROT,
329                                  VSTACK_HARDPROT,
330                                  kVSPsoftguard,
331                                  kVSPhardguard);
332}
333
334area *
335allocate_tstack_holding_area_lock(natural usable)
336{
337  return allocate_lisp_stack_area(AREA_TSTACK, 
338                                  usable > MIN_TSTACK_SIZE ?
339                                  usable : MIN_TSTACK_SIZE,
340                                  TSTACK_SOFTPROT,
341                                  TSTACK_HARDPROT,
342                                  kTSPsoftguard,
343                                  kTSPhardguard);
344}
345
346
347/* It's hard to believe that max & min don't exist already */
348unsigned unsigned_min(unsigned x, unsigned y)
349{
350  if (x <= y) {
351    return x;
352  } else {
353    return y;
354  }
355}
356
357unsigned unsigned_max(unsigned x, unsigned y)
358{
359  if (x >= y) {
360    return x;
361  } else {
362    return y;
363  }
364}
365
366#if WORD_SIZE == 64
367#ifdef DARWIN
368#define MAXIMUM_MAPPABLE_MEMORY (512L<<30L)
369#endif
370#ifdef FREEBSD
371#define MAXIMUM_MAPPABLE_MEMORY (512L<<30L)
372#endif
373#ifdef SOLARIS
374#define MAXIMUM_MAPPABLE_MEMORY (128L<<30L)
375#endif
376#ifdef LINUX
377#ifdef X8664
378#define MAXIMUM_MAPPABLE_MEMORY (512L<<30L)
379#endif
380#ifdef PPC
381#define MAXIMUM_MAPPABLE_MEMORY (128L<<30L)
382#endif
383#endif
384#ifdef WINDOWS
385/* Supposedly, the high-end version of Vista allow 128GB of pageable memory */
386#define MAXIMUM_MAPPABLE_MEMORY (120LL<<30LL)
387#endif
388#else
389#ifdef DARWIN
390#define MAXIMUM_MAPPABLE_MEMORY ((1U<<31)-2*heap_segment_size)
391#endif
392#ifdef LINUX
393#ifdef X86
394#define MAXIMUM_MAPPABLE_MEMORY (9U<<28)
395#else
396#define MAXIMUM_MAPPABLE_MEMORY (1U<<30)
397#endif
398#endif
399#ifdef WINDOWS
400#define MAXIMUM_MAPPABLE_MEMORY (1U<<30)
401#endif
402#ifdef FREEBSD
403#define MAXIMUM_MAPPABLE_MEMORY (1U<<30)
404#endif
405#ifdef SOLARIS
406#define MAXIMUM_MAPPABLE_MEMORY (1U<<30)
407#endif
408#endif
409
410natural
411reserved_area_size = MAXIMUM_MAPPABLE_MEMORY;
412
413area
414  *nilreg_area=NULL,
415  *tenured_area=NULL, 
416  *g2_area=NULL, 
417  *g1_area=NULL,
418  *managed_static_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  const char *error;
1992  void *result;
1993
1994  result = dlopen(path, RTLD_NOW | RTLD_GLOBAL);
1995 
1996  if (result == NULL) {
1997    error = dlerror();
1998    *resultType = 0;
1999    return (void *)error;
2000  }
2001  *resultType = 1;
2002  return result;
2003}
2004#endif
2005
2006
2007
2008int
2009fd_setsize_bytes()
2010{
2011  return FD_SETSIZE/8;
2012}
2013
2014void
2015do_fd_set(int fd, fd_set *fdsetp)
2016{
2017  FD_SET(fd, fdsetp);
2018}
2019
2020void
2021do_fd_clr(int fd, fd_set *fdsetp)
2022{
2023  FD_CLR(fd, fdsetp);
2024}
2025
2026int
2027do_fd_is_set(int fd, fd_set *fdsetp)
2028{
2029  return FD_ISSET(fd,fdsetp);
2030}
2031
2032
2033void
2034do_fd_zero(fd_set *fdsetp)
2035{
2036  FD_ZERO(fdsetp);
2037}
2038
2039#include "image.h"
2040
2041
2042
2043Boolean
2044check_for_embedded_image (
2045#ifdef WINDOWS
2046                          wchar_t *path
2047#else
2048                          char *path
2049#endif
2050                          )
2051{
2052#ifdef WINDOWS
2053  int fd = wopen(path, O_RDONLY);
2054#else 
2055  int fd = open(path, O_RDONLY);
2056#endif
2057
2058  Boolean image_is_embedded = false;
2059
2060  if (fd >= 0) {
2061    openmcl_image_file_header h;
2062
2063    if (find_openmcl_image_file_header (fd, &h)) {
2064      image_is_embedded = true;
2065    }
2066    close (fd);
2067  }
2068  return image_is_embedded;
2069}
2070
2071LispObj
2072load_image(
2073#ifdef WINDOWS
2074           wchar_t * path
2075#else
2076           char *path
2077#endif
2078)
2079{
2080#ifdef WINDOWS
2081  int fd = wopen(path, O_RDONLY, 0666), err;
2082#else
2083  int fd = open(path, O_RDONLY, 0666), err;
2084#endif
2085  LispObj image_nil = 0;
2086
2087  if (fd > 0) {
2088    openmcl_image_file_header ih;
2089
2090    errno = 0;
2091    image_nil = load_openmcl_image(fd, &ih);
2092    /* We -were- using a duplicate fd to map the file; that
2093       seems to confuse Darwin (doesn't everything ?), so
2094       we'll instead keep the original file open.
2095    */
2096    err = errno;
2097    if (!image_nil) {
2098      close(fd);
2099    }
2100#ifdef WINDOWS
2101    /* We currently don't actually map the image, and leaving the file
2102       open seems to make it difficult to write to reliably. */
2103    if (image_nil) {
2104      close(fd);
2105    }
2106#endif
2107  } else {
2108    err = errno;
2109  }
2110  if (image_nil == 0) {
2111#ifdef WINDOWS
2112    char *fmt = "Couldn't load lisp heap image from %ls";
2113#else
2114    char *fmt = "Couldn't load lisp heap image from %s";
2115#endif
2116
2117    fprintf(dbgout, fmt, path);
2118    if (err == 0) {
2119      fprintf(dbgout, "\n");
2120    } else {
2121      fprintf(dbgout, ": %s\n", strerror(err));
2122    }
2123    exit(-1);
2124  }
2125  return image_nil;
2126}
2127
2128int
2129set_errno(int val)
2130{
2131  errno = val;
2132  return -1;
2133}
2134
2135/* A horrible hack to allow us to initialize a JVM instance from lisp.
2136   On Darwin, creating a JVM instance clobbers the thread's existing
2137   Mach exception infrastructure, so we save and restore it here.
2138*/
2139
2140typedef int (*jvm_initfunc)(void*,void*,void*);
2141
2142int
2143jvm_init(jvm_initfunc f,void*arg0,void*arg1,void*arg2)
2144{
2145  int result = -1;
2146  TCR *tcr = get_tcr(1);
2147#ifdef DARWIN
2148  extern kern_return_t tcr_establish_lisp_exception_port(TCR *);
2149#endif
2150 
2151  result = f(arg0,arg1,arg2);
2152#ifdef DARWIN
2153  tcr_establish_lisp_exception_port(tcr);
2154#endif
2155  return result;
2156}
2157 
2158
2159
2160
2161void *
2162xFindSymbol(void* handle, char *name)
2163{
2164#if defined(LINUX) || defined(FREEBSD) || defined(SOLARIS)
2165  return dlsym(handle, name);
2166#endif
2167#ifdef DARWIN
2168  void *result;
2169
2170  if ((handle == NULL) || (handle == ((void *) -1))) {
2171    handle = RTLD_DEFAULT;
2172  }   
2173  result = dlsym(handle, name);
2174  if ((result == NULL) && (*name == '_')) {
2175    result = dlsym(handle, name+1);
2176  }
2177  return result;
2178#endif
2179#ifdef WINDOWS
2180  extern void *windows_find_symbol(void *, char *);
2181  return windows_find_symbol(handle, name);
2182#endif
2183}
2184
2185void *
2186get_r_debug()
2187{
2188#if defined(LINUX) || defined(FREEBSD) || defined(SOLARIS)
2189#if WORD_SIZE == 64
2190  extern Elf64_Dyn _DYNAMIC[];
2191  Elf64_Dyn *dp;
2192#else
2193  extern Elf32_Dyn _DYNAMIC[];
2194  Elf32_Dyn *dp;
2195#endif
2196  int tag;
2197
2198  for (dp = _DYNAMIC; (tag = dp->d_tag) != 0; dp++) {
2199    if (tag == DT_DEBUG) {
2200      return (void *)(dp->d_un.d_ptr);
2201    }
2202  }
2203#endif
2204  return NULL;
2205}
2206
2207
2208#ifdef DARWIN
2209void
2210sample_paging_info(paging_info *stats)
2211{
2212  mach_msg_type_number_t count = TASK_EVENTS_INFO_COUNT;
2213
2214  task_info(mach_task_self(),
2215            TASK_EVENTS_INFO,
2216            (task_info_t)stats,
2217            &count);
2218}
2219
2220void
2221report_paging_info_delta(FILE *out, paging_info *start, paging_info *stop)
2222{
2223  fprintf(out,";;; %d soft faults, %d faults, %d pageins\n\n",
2224          stop->cow_faults-start->cow_faults,
2225          stop->faults-start->faults,
2226          stop->pageins-start->pageins);
2227}
2228
2229#else
2230#ifdef WINDOWS
2231void
2232sample_paging_info(paging_info *stats)
2233{
2234}
2235
2236void
2237report_paging_info_delta(FILE *out, paging_info *start, paging_info *stop)
2238{
2239}
2240#else
2241void
2242sample_paging_info(paging_info *stats)
2243{
2244  getrusage(RUSAGE_SELF, stats);
2245}
2246
2247void
2248report_paging_info_delta(FILE *out, paging_info *start, paging_info *stop)
2249{
2250  fprintf(out,";;; %ld soft faults, %ld faults, %ld pageins\n\n",
2251          stop->ru_minflt-start->ru_minflt,
2252          stop->ru_majflt-start->ru_majflt,
2253          stop->ru_nswap-start->ru_nswap);
2254}
2255
2256#endif
2257#endif
Note: See TracBrowser for help on using the repository browser.