source: branches/qres/ccl/lisp-kernel/pmcl-kernel.c @ 14049

Last change on this file since 14049 was 14049, checked in by gz, 9 years ago

Misc tweaks and fixes from trunk (r13550,r13560,r13568,r13569,r13581,r13583,r13633-13636,r13647,r13648,r13657-r13659,r13675,r13678,r13688,r13743,r13744,r13769,r13773,r13782,r13813,r13814,r13869,r13870,r13873,r13901,r13930,r13943,r13946,r13954,r13961,r13974,r13975,r13978,r13990,r14010,r14012,r14020,r14028-r14030)

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