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

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

In the Darwin version of xFindSym (foreign symbol lookup), try
to find the symbol without stripping leading underscores and only
do the stripping if that fails.

(We ultimately want to stop prepending underscores to foreign
symbols on Darwin.)

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