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

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

No longer look for image in LX86CL64 (r13592)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 47.2 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
835#ifdef WINDOWS
836wchar_t *
837default_image_name(wchar_t *orig)
838{
839  wchar_t *path = chop_exe_suffix(orig);
840  wchar_t *image_name = path_by_appending_image(path);
841  return image_name;
842}
843#else
844char *
845default_image_name(char *orig)
846{
847  char *path = orig;
848  char *image_name = path_by_appending_image(path);
849  return image_name;
850}
851#endif
852
853
854
855char *program_name = NULL;
856#ifdef WINDOWS
857wchar_t *real_executable_name = NULL;
858#else
859char *real_executable_name = NULL;
860#endif
861
862#ifndef WINDOWS
863
864char *
865ensure_real_path(char *path)
866{
867  char buf[PATH_MAX*2], *p, *q;
868  int n;
869
870  p = realpath(path, buf);
871 
872  if (p == NULL) {
873    return path;
874  }
875  n = strlen(p);
876  q = malloc(n+1);
877  strcpy(q,p);
878  return q;
879}
880
881char *
882determine_executable_name(char *argv0)
883{
884#ifdef DARWIN
885  uint32_t len = 1024;
886  char exepath[1024], *p = NULL;
887
888  if (_NSGetExecutablePath(exepath, (void *)&len) == 0) {
889    p = malloc(len+1);
890    memmove(p, exepath, len);
891    p[len]=0;
892    return ensure_real_path(p);
893  } 
894  return ensure_real_path(argv0);
895#endif
896#ifdef LINUX
897  char exepath[PATH_MAX], *p;
898  int n;
899
900  if ((n = readlink("/proc/self/exe", exepath, PATH_MAX)) > 0) {
901    p = malloc(n+1);
902    memmove(p,exepath,n);
903    p[n]=0;
904    return p;
905  }
906  return argv0;
907#endif
908#ifdef FREEBSD
909  return ensure_real_path(argv0);
910#endif
911#ifdef SOLARIS
912  char exepath[PATH_MAX], proc_path[PATH_MAX], *p;
913  int n;
914
915  snprintf(proc_path,PATH_MAX-1,"/proc/%d/path/a.out",getpid());
916
917  if ((n = readlink(proc_path, exepath, PATH_MAX)) > 0) {
918    p = malloc(n+1);
919    memmove(p,exepath,n);
920    p[n]=0;
921    return p;
922  }
923  return ensure_real_path(argv0);
924#endif
925  return ensure_real_path(argv0);
926}
927#endif
928
929#ifdef WINDOWS
930wchar_t *
931determine_executable_name()
932{
933  DWORD nsize = 512, result;
934  wchar_t *buf = malloc(nsize*sizeof(wchar_t));
935
936  do {
937    result = GetModuleFileNameW(NULL, buf, nsize);
938    if (result == nsize) {
939      nsize *= 2;
940      buf = realloc(buf,nsize*sizeof(wchar_t));
941    } else {
942      return buf;
943    }
944  } while (1);
945}
946
947
948wchar_t *
949ensure_real_path(wchar_t *path)
950{
951  int bufsize = 256, n;
952
953  do {
954    wchar_t buf[bufsize];
955
956    n = GetFullPathNameW(path,bufsize,buf,NULL);
957    if (n == 0) {
958      return path;
959    }
960
961    if (n < bufsize) {
962      int i;
963      wchar_t *q = calloc(n+1,sizeof(wchar_t));
964
965      for (i = 0; i < n; i++) {
966        q[i] = buf[i];
967      }
968      return q;
969    }
970    bufsize = n+1;
971  } while (1);
972}
973#endif
974
975void
976usage_exit(char *herald, int exit_status, char* other_args)
977{
978  if (herald && *herald) {
979    fprintf(dbgout, "%s\n", herald);
980  }
981  fprintf(dbgout, "usage: %s <options>\n", program_name);
982  fprintf(dbgout, "\t or %s <image-name>\n", program_name);
983  fprintf(dbgout, "\t where <options> are one or more of:\n");
984  if (other_args && *other_args) {
985    fputs(other_args, dbgout);
986  }
987  fprintf(dbgout, "\t-R, --heap-reserve <n>: reserve <n> (default: %lld)\n",
988          (u64_t) reserved_area_size);
989  fprintf(dbgout, "\t\t bytes for heap expansion\n");
990  fprintf(dbgout, "\t-S, --stack-size <n>: set  size of initial thread's control stack to <n>\n");
991  fprintf(dbgout, "\t-Z, --thread-stack-size <n>: set default size of first (listener)  thread's stacks based on <n>\n");
992  fprintf(dbgout, "\t-b, --batch: exit when EOF on *STANDARD-INPUT*\n");
993  fprintf(dbgout, "\t--no-sigtrap : obscure option for running under GDB\n");
994  fprintf(dbgout, "\t-I, --image-name <image-name>\n");
995#ifndef WINDOWS
996  fprintf(dbgout, "\t and <image-name> defaults to %s\n", 
997          default_image_name(program_name));
998#endif
999  fprintf(dbgout, "\n");
1000  _exit(exit_status);
1001}
1002
1003int no_sigtrap = 0;
1004#ifdef WINDOWS
1005wchar_t *image_name = NULL;
1006#else
1007char *image_name = NULL;
1008#endif
1009int batch_flag = 0;
1010
1011
1012natural
1013parse_numeric_option(char *arg, char *argname, natural default_val)
1014{
1015  char *tail;
1016  natural val = 0;
1017
1018  val = strtoul(arg, &tail, 0);
1019  switch(*tail) {
1020  case '\0':
1021    break;
1022   
1023  case 'M':
1024  case 'm':
1025    val = val << 20;
1026    break;
1027   
1028  case 'K':
1029  case 'k':
1030    val = val << 10;
1031    break;
1032   
1033  case 'G':
1034  case 'g':
1035    val = val << 30;
1036    break;
1037   
1038  default:
1039    fprintf(dbgout, "couldn't parse %s argument %s", argname, arg);
1040    val = default_val;
1041    break;
1042  }
1043  return val;
1044}
1045 
1046
1047
1048/*
1049   The set of arguments recognized by the kernel is
1050   likely to remain pretty small and pretty simple.
1051   This removes everything it recognizes from argv;
1052   remaining args will be processed by lisp code.
1053*/
1054
1055void
1056process_options(int argc, char *argv[], wchar_t *shadow[])
1057{
1058  int i, j, k, num_elide, flag, arg_error;
1059  char *arg, *val;
1060  wchar_t *warg, *wval;
1061#ifdef DARWIN
1062  extern int NXArgc;
1063#endif
1064
1065  for (i = 1; i < argc;) {
1066    arg = argv[i];
1067    if (shadow) {
1068      warg = shadow[i];
1069    }
1070    arg_error = 0;
1071    if (*arg != '-') {
1072      i++;
1073    } else {
1074      num_elide = 0;
1075      val = NULL;
1076      if ((flag = (strncmp(arg, "-I", 2) == 0)) ||
1077          (strcmp (arg, "--image-name") == 0)) {
1078        if (flag && arg[2]) {
1079          val = arg+2;         
1080          if (shadow) {
1081            wval = warg+2;
1082          }
1083          num_elide = 1;
1084        } else {
1085          if ((i+1) < argc) {
1086            val = argv[i+1];
1087            if (shadow) {
1088              wval = shadow[i+1];
1089            }
1090            num_elide = 2;
1091          } else {
1092            arg_error = 1;
1093          }
1094        }
1095        if (val) {
1096#ifdef WINDOWS
1097          image_name = wval;
1098#else
1099          image_name = val;
1100#endif
1101        }
1102      } else if ((flag = (strncmp(arg, "-R", 2) == 0)) ||
1103                 (strcmp(arg, "--heap-reserve") == 0)) {
1104        natural reserved_size = reserved_area_size;
1105
1106        if (flag && arg[2]) {
1107          val = arg+2;
1108          num_elide = 1;
1109        } else {
1110          if ((i+1) < argc) {
1111            val = argv[i+1];
1112            num_elide = 2;
1113          } else {
1114            arg_error = 1;
1115          }
1116        }
1117
1118        if (val) {
1119          reserved_size = parse_numeric_option(val, 
1120                                               "-R/--heap-reserve", 
1121                                               reserved_area_size);
1122        }
1123
1124        if (reserved_size <= MAXIMUM_MAPPABLE_MEMORY) {
1125          reserved_area_size = reserved_size;
1126        }
1127
1128      } else if ((flag = (strncmp(arg, "-S", 2) == 0)) ||
1129                 (strcmp(arg, "--stack-size") == 0)) {
1130        natural stack_size;
1131
1132        if (flag && arg[2]) {
1133          val = arg+2;
1134          num_elide = 1;
1135        } else {
1136          if ((i+1) < argc) {
1137            val = argv[i+1];
1138            num_elide = 2;
1139          } else {
1140            arg_error = 1;
1141          }
1142        }
1143
1144        if (val) {
1145          stack_size = parse_numeric_option(val, 
1146                                            "-S/--stack-size", 
1147                                            initial_stack_size);
1148         
1149
1150          if (stack_size >= MIN_CSTACK_SIZE) {
1151            initial_stack_size = stack_size;
1152          }
1153        }
1154
1155      } else if ((flag = (strncmp(arg, "-Z", 2) == 0)) ||
1156                 (strcmp(arg, "--thread-stack-size") == 0)) {
1157        natural stack_size;
1158
1159        if (flag && arg[2]) {
1160          val = arg+2;
1161          num_elide = 1;
1162        } else {
1163          if ((i+1) < argc) {
1164            val = argv[i+1];
1165            num_elide = 2;
1166          } else {
1167            arg_error = 1;
1168          }
1169        }
1170
1171        if (val) {
1172          stack_size = parse_numeric_option(val, 
1173                                            "-Z/--thread-stack-size", 
1174                                            thread_stack_size);
1175         
1176
1177          if (stack_size >= MIN_CSTACK_SIZE) {
1178           thread_stack_size = stack_size;
1179          }
1180          if (thread_stack_size >= (1LL<<((WORD_SIZE-fixnumshift)-1))) {
1181            thread_stack_size = (1LL<<((WORD_SIZE-fixnumshift)-1))-1;
1182          }
1183         
1184        }
1185
1186      } else if (strcmp(arg, "--no-sigtrap") == 0) {
1187        no_sigtrap = 1;
1188        num_elide = 1;
1189      } else if ((strcmp(arg, "-b") == 0) ||
1190                 (strcmp(arg, "--batch") == 0)) {
1191        batch_flag = 1;
1192        num_elide = 1;
1193      } else if (strcmp(arg,"--") == 0) {
1194        break;
1195      } else {
1196        i++;
1197      }
1198      if (arg_error) {
1199        usage_exit("error in program arguments", 1, "");
1200      }
1201      if (num_elide) {
1202        for (j = i+num_elide, k=i; j < argc; j++, k++) {
1203          argv[k] = argv[j];
1204          if (shadow) {
1205            shadow[k] = shadow[j];
1206          }
1207        }
1208        argc -= num_elide;
1209#ifdef DARWIN
1210        NXArgc -= num_elide;
1211#endif
1212        argv[argc] = NULL;
1213        if (shadow) {
1214          shadow[argc] = NULL;
1215        }
1216      }
1217    }
1218  }
1219}
1220
1221#ifdef WINDOWS
1222void
1223terminate_lisp()
1224{
1225  _exit(EXIT_FAILURE);
1226}
1227#else
1228pid_t main_thread_pid = (pid_t)0;
1229
1230void
1231terminate_lisp()
1232{
1233  kill(main_thread_pid, SIGKILL);
1234  _exit(-1);
1235}
1236#endif
1237
1238#ifdef DARWIN
1239#define min_os_version "8.0"    /* aka Tiger */
1240#endif
1241#ifdef LINUX
1242#ifdef PPC
1243#define min_os_version "2.2"
1244#endif
1245#ifdef X86
1246#define min_os_version "2.6"
1247#endif
1248#endif
1249#ifdef FREEBSD
1250#define min_os_version "6.0"
1251#endif
1252#ifdef SOLARIS
1253#define min_os_version "5.10"
1254#endif
1255
1256#ifdef PPC
1257#if defined(PPC64) || !defined(DARWIN)
1258/* ld64 on Darwin doesn't offer anything close to reliable control
1259   over the layout of a program in memory.  About all that we can
1260   be assured of is that the canonical subprims jump table address
1261   (currently 0x5000) is unmapped.  Map that page, and copy the
1262   actual spjump table there. */
1263
1264
1265void
1266remap_spjump()
1267{
1268  extern opcode spjump_start, spjump_end;
1269  pc new,
1270    old = &spjump_start,
1271    limit = &spjump_end,
1272    work;
1273  opcode instr;
1274  void *target;
1275  int disp;
1276 
1277  if (old != (pc)SPJUMP_TARGET_ADDRESS) {
1278    new = mmap((pc) SPJUMP_TARGET_ADDRESS,
1279               0x1000,
1280               PROT_READ | PROT_WRITE | PROT_EXEC,
1281               MAP_PRIVATE | MAP_ANON | MAP_FIXED,
1282               -1,
1283               0);
1284    if (new != (pc) SPJUMP_TARGET_ADDRESS) {
1285      perror("remap spjump");
1286      _exit(1);
1287    }
1288   
1289    for (work = new; old < limit; work++, old++) {
1290      instr = *old;
1291      disp = instr & ((1<<26)-1);
1292      target = (void*)old+disp;
1293      disp = target-(void *)work;
1294      *work = ((instr >> 26) << 26) | disp;
1295    }
1296    xMakeDataExecutable(new, (void*)work-(void*)new);
1297    ProtectMemory(new, 0x1000);
1298  }
1299}
1300#endif
1301#endif
1302
1303#ifdef X86
1304#ifdef WINDOWS
1305
1306/* By using linker tricks, we ensure there's memory between 0x11000
1307   and 0x21000, so we just need to fix permissions and copy the spjump
1308   table. */
1309
1310void
1311remap_spjump()
1312{
1313  extern opcode spjump_start;
1314  DWORD old_protect;
1315
1316  if ((void *)(&spjump_start) != (void *) SPJUMP_TARGET_ADDRESS) {
1317    if (!VirtualProtect((pc) SPJUMP_TARGET_ADDRESS,
1318                        0x1000,
1319                        PAGE_EXECUTE_READWRITE,
1320                        &old_protect)) {
1321      wperror("VirtualProtect spjump");
1322      _exit(1);
1323    }
1324    memmove((pc) SPJUMP_TARGET_ADDRESS, &spjump_start, 0x1000);
1325  }
1326}
1327#else
1328void
1329remap_spjump()
1330{
1331  extern opcode spjump_start;
1332  pc new = mmap((pc) SPJUMP_TARGET_ADDRESS,
1333                0x1000,
1334                PROT_READ | PROT_WRITE | PROT_EXEC,
1335                MAP_PRIVATE | MAP_ANON | MAP_FIXED,
1336                -1,
1337                0),
1338    old = &spjump_start;
1339  if (new == (pc)-1) {
1340    perror("remap spjump");
1341    _exit(1);
1342  }
1343  memmove(new, old, 0x1000);
1344}
1345#endif
1346#endif
1347
1348
1349void
1350check_os_version(char *progname)
1351{
1352#ifdef WINDOWS
1353  /* 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. */
1354#else
1355  struct utsname uts;
1356  long got, want;
1357  char *got_end,*want_end;
1358#ifdef X8632
1359  extern Boolean rcontext_readonly;
1360#endif
1361
1362  want = strtoul(min_os_version,&want_end,10);
1363
1364  uname(&uts);
1365  got = strtoul(uts.release,&got_end,10);
1366#ifdef X8632
1367#ifdef FREEBSD
1368  if (!strcmp(uts.machine,"amd64")) {
1369    rcontext_readonly = true;
1370  }
1371#endif
1372#endif
1373  while (got == want) {
1374    if (*want_end == '.') {
1375      want = strtoul(want_end+1,&want_end,10);
1376      got = 0;
1377      if (*got_end == '.') {
1378        got = strtoul(got_end+1,&got_end,10);
1379      } else {
1380        break;
1381      }
1382    } else {
1383      break;
1384    }
1385  }
1386
1387  if (got < want) {
1388    fprintf(dbgout, "\n%s requires %s version %s or later; the current version is %s.\n", progname, uts.sysname, min_os_version, uts.release);
1389    exit(1);
1390  }
1391#endif
1392}
1393
1394#ifdef X86
1395/*
1396  This should determine the cache block size.  It should also
1397  probably complain if we don't have (at least) SSE2.
1398*/
1399extern int cpuid(natural, natural*, natural*, natural*);
1400
1401#define X86_FEATURE_CMOV    (1<<15)
1402#define X86_FEATURE_CLFLUSH (1<<19)
1403#define X86_FEATURE_MMX     (1<<23)
1404#define X86_FEATURE_SSE     (1<<25)
1405#define X86_FEATURE_SSE2    (1<<26)
1406
1407#define X86_REQUIRED_FEATURES (X86_FEATURE_CMOV|X86_FEATURE_MMX|X86_FEATURE_SSE|X86_FEATURE_SSE2)
1408
1409Boolean
1410check_x86_cpu()
1411{
1412  natural eax, ebx, ecx, edx;
1413
1414  eax = cpuid(0, &ebx, &ecx, &edx);
1415
1416  if (eax >= 1) {
1417    eax = cpuid(1, &ebx, &ecx, &edx);
1418    cache_block_size = (ebx & 0xff00) >> 5;
1419    if ((X86_REQUIRED_FEATURES & edx) == X86_REQUIRED_FEATURES) {
1420      return true;
1421    }
1422    /* It's very unlikely that SSE2 would be present and other things
1423       that we want wouldn't.  If they don't have MMX or CMOV either,
1424       might as well tell them. */
1425    if ((edx & X86_FEATURE_SSE2) == 0) {
1426      fprintf(dbgout, "This CPU doesn't support the SSE2 instruction set\n");
1427    }
1428    if ((edx & X86_FEATURE_MMX) == 0) {
1429      fprintf(dbgout, "This CPU doesn't support the MMX instruction set\n");
1430    }
1431    if ((edx & X86_FEATURE_CMOV) == 0) {
1432      fprintf(dbgout, "This CPU doesn't support the CMOV instruction\n");
1433    }
1434   
1435  }
1436  return false;
1437}
1438#endif
1439
1440void
1441lazarus()
1442{
1443  TCR *tcr = get_tcr(false);
1444  if (tcr) {
1445    /* Some threads may be dying; no threads should be created. */
1446    LOCK(lisp_global(TCR_AREA_LOCK),tcr);
1447    tcr->vs_area->active = tcr->vs_area->high - node_size;
1448    tcr->save_vsp = (LispObj *)(tcr->vs_area->active);
1449    tcr->ts_area->active = tcr->ts_area->high;
1450    tcr->save_tsp = (LispObj *)(tcr->ts_area->active);
1451    tcr->catch_top = 0;
1452    tcr->db_link = 0;
1453    tcr->xframe = 0;
1454    start_lisp(tcr, 0);
1455  }
1456}
1457
1458#ifdef LINUX
1459#ifdef X8664
1460#include <asm/prctl.h>
1461#include <sys/prctl.h>
1462
1463void
1464ensure_gs_available(char *progname)
1465{
1466  LispObj fs_addr = 0L, gs_addr = 0L, cur_thread = (LispObj)pthread_self();
1467  char *gnu_get_libc_version(void);
1468 
1469  arch_prctl(ARCH_GET_GS, &gs_addr);
1470  arch_prctl(ARCH_GET_FS, &fs_addr);
1471  if ((gs_addr == cur_thread) && (fs_addr != cur_thread)) {
1472    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);
1473    _exit(1);
1474  }
1475}
1476#endif
1477#endif
1478
1479Boolean
1480bogus_fp_exceptions = false;
1481
1482typedef
1483float (*float_arg_returns_float)(float);
1484
1485float
1486fcallf(float_arg_returns_float fun, float arg)
1487{
1488  return fun(arg);
1489}
1490
1491void
1492check_bogus_fp_exceptions()
1493{
1494#ifdef X8664
1495  float asinf(float),result;
1496   
1497
1498  natural save_mxcsr = get_mxcsr(), post_mxcsr;
1499  set_mxcsr(0x1f80);
1500
1501  result = fcallf(asinf, 1.0);
1502  post_mxcsr = get_mxcsr();
1503  set_mxcsr(save_mxcsr);
1504  if (post_mxcsr & (FE_ALL_EXCEPT & (~FE_INEXACT))) {
1505    bogus_fp_exceptions = true;
1506  }
1507#endif
1508}
1509
1510#ifdef WINDOWS
1511char *
1512utf_16_to_utf_8(wchar_t *utf_16)
1513{
1514  int utf8len = WideCharToMultiByte(CP_UTF8,
1515                                    0,
1516                                    utf_16,
1517                                    -1,
1518                                    NULL,
1519                                    0,
1520                                    NULL,
1521                                    NULL);
1522
1523  char *utf_8 = malloc(utf8len);
1524
1525  WideCharToMultiByte(CP_UTF8,
1526                      0,
1527                      utf_16,
1528                      -1,
1529                      utf_8,
1530                      utf8len,
1531                      NULL,
1532                      NULL);
1533
1534  return utf_8;
1535}
1536
1537char **
1538wide_argv_to_utf_8(wchar_t *wide_argv[], int argc)
1539{
1540  char** argv = calloc(argc+1,sizeof(char *));
1541  int i;
1542
1543  for (i = 0; i < argc; i++) {
1544    if (wide_argv[i]) {
1545      argv[i] = utf_16_to_utf_8(wide_argv[i]);
1546    } else {
1547      argv[i] = NULL;
1548    }
1549  }
1550  return argv;
1551}
1552#endif
1553
1554
1555 
1556
1557
1558int
1559main(int argc, char *argv[]
1560#ifndef WINDOWS
1561, char *envp[], void *aux
1562#endif
1563)
1564{
1565  extern int page_size;
1566  natural default_g0_threshold = G0_AREA_THRESHOLD,
1567    default_g1_threshold = G1_AREA_THRESHOLD,
1568    default_g2_threshold = G2_AREA_THRESHOLD,
1569    lisp_heap_threshold_from_image = 0;
1570  Boolean egc_enabled =
1571#ifdef DISABLE_EGC
1572    false
1573#else
1574    true
1575#endif
1576    ;
1577  Boolean lisp_heap_threshold_set_from_command_line = false;
1578  wchar_t **utf_16_argv = NULL;
1579
1580#ifdef PPC
1581  extern int altivec_present;
1582#endif
1583#ifdef WINDOWS
1584  extern LispObj load_image(wchar_t *);
1585#else
1586  extern LispObj load_image(char *);
1587#endif
1588  area *a;
1589  BytePtr stack_base, current_sp = (BytePtr) current_stack_pointer();
1590  TCR *tcr;
1591
1592  dbgout = stderr;
1593
1594#ifdef WINDOWS
1595  {
1596    int wide_argc;
1597    extern void init_winsock(void);
1598    extern void init_windows_io(void);
1599
1600    _fmode = O_BINARY;
1601    _setmode(1, O_BINARY);
1602    _setmode(2, O_BINARY);
1603    setvbuf(dbgout, NULL, _IONBF, 0);
1604    init_winsock();
1605    init_windows_io();
1606    utf_16_argv = CommandLineToArgvW(GetCommandLineW(),&wide_argc);
1607  }
1608#endif
1609
1610  check_os_version(argv[0]);
1611#ifdef WINDOWS
1612  real_executable_name = determine_executable_name();
1613#else
1614  real_executable_name = determine_executable_name(argv[0]);
1615#endif
1616  page_size = getpagesize(); /* Implement with GetSystemInfo on Windows w/o MinGW */
1617
1618  check_bogus_fp_exceptions();
1619#ifdef LINUX
1620#ifdef X8664
1621  ensure_gs_available(real_executable_name);
1622#endif
1623#endif
1624#if (defined(DARWIN) && defined(PPC64)) || (defined(LINUX) && defined(PPC))|| defined(X8664) || (defined(X8632) && !defined(DARWIN))
1625  remap_spjump();
1626#endif
1627
1628#ifdef PPC
1629#ifdef LINUX
1630  {
1631    ElfW(auxv_t) *av = aux;
1632    int hwcap, done = false;
1633   
1634    if (av) {
1635      do {
1636        switch (av->a_type) {
1637        case AT_DCACHEBSIZE:
1638          cache_block_size = av->a_un.a_val;
1639          break;
1640
1641        case AT_HWCAP:
1642          hwcap = av->a_un.a_val;
1643          altivec_present = ((hwcap & PPC_FEATURE_HAS_ALTIVEC) != 0);
1644          break;
1645
1646        case AT_NULL:
1647          done = true;
1648          break;
1649        }
1650        av++;
1651      } while (!done);
1652    }
1653  }
1654#endif
1655#ifdef DARWIN
1656  {
1657    unsigned value = 0;
1658    size_t len = sizeof(value);
1659    int mib[2];
1660   
1661    mib[0] = CTL_HW;
1662    mib[1] = HW_CACHELINE;
1663    if (sysctl(mib,2,&value,&len, NULL, 0) != -1) {
1664      if (len == sizeof(value)) {
1665        cache_block_size = value;
1666      }
1667    }
1668    mib[1] = HW_VECTORUNIT;
1669    value = 0;
1670    len = sizeof(value);
1671    if (sysctl(mib,2,&value,&len, NULL, 0) != -1) {
1672      if (len == sizeof(value)) {
1673        altivec_present = value;
1674      }
1675    }
1676  }
1677#endif
1678#endif
1679
1680#ifdef X86
1681  if (!check_x86_cpu()) {
1682    fprintf(dbgout, "CPU doesn't support required features\n");
1683    exit(1);
1684  }
1685#endif
1686
1687#ifdef SOLARIS
1688#ifdef X8632
1689  {
1690    extern void solaris_ldt_init(void);
1691    solaris_ldt_init();
1692  }
1693#endif
1694#endif
1695
1696#ifndef WINDOWS
1697  main_thread_pid = getpid();
1698#endif
1699  tcr_area_lock = (void *)new_recursive_lock();
1700
1701  program_name = argv[0];
1702  if ((argc == 2) && (*argv[1] != '-')) {
1703#ifdef WINDOWS
1704    image_name = utf_16_argv[1];
1705#else
1706    image_name = argv[1];
1707#endif
1708    argv[1] = NULL;
1709#ifdef WINDOWS
1710    utf_16_argv[1] = NULL;
1711#endif
1712  } else {
1713    process_options(argc,argv,utf_16_argv);
1714  }
1715  if (lisp_heap_gc_threshold != DEFAULT_LISP_HEAP_GC_THRESHOLD) {
1716    lisp_heap_threshold_set_from_command_line = true;
1717  }
1718
1719  initial_stack_size = ensure_stack_limit(initial_stack_size);
1720  if (image_name == NULL) {
1721    if (check_for_embedded_image(real_executable_name)) {
1722      image_name = real_executable_name;
1723    } else {
1724      image_name = default_image_name(real_executable_name);
1725    }
1726  }
1727
1728  while (1) {
1729    if (create_reserved_area(reserved_area_size)) {
1730      break;
1731    }
1732    reserved_area_size = reserved_area_size *.9;
1733  }
1734
1735  gc_init();
1736
1737  set_nil(load_image(image_name));
1738  lisp_heap_threshold_from_image = lisp_global(LISP_HEAP_THRESHOLD);
1739  if (lisp_heap_threshold_from_image) {
1740    if ((!lisp_heap_threshold_set_from_command_line) &&
1741        (lisp_heap_threshold_from_image != lisp_heap_gc_threshold)) {
1742      lisp_heap_gc_threshold = lisp_heap_threshold_from_image;
1743      resize_dynamic_heap(active_dynamic_area->active,lisp_heap_gc_threshold);
1744    }
1745    /* If lisp_heap_threshold_from_image was set, other image params are
1746       valid. */
1747    default_g0_threshold = lisp_global(G0_THRESHOLD);
1748    default_g1_threshold = lisp_global(G1_THRESHOLD);
1749    default_g2_threshold = lisp_global(G2_THRESHOLD);
1750    egc_enabled = lisp_global(EGC_ENABLED);
1751  }
1752
1753  lisp_global(TCR_AREA_LOCK) = ptr_to_lispobj(tcr_area_lock);
1754
1755#ifdef X86
1756  lisp_global(SUBPRIMS_BASE) = (LispObj)((1<<16)+(5<<10));
1757#else
1758  lisp_global(SUBPRIMS_BASE) = (LispObj)(5<<10);
1759#endif
1760  lisp_global(RET1VALN) = (LispObj)&ret1valn;
1761  lisp_global(LEXPR_RETURN) = (LispObj)&nvalret;
1762  lisp_global(LEXPR_RETURN1V) = (LispObj)&popj;
1763  lisp_global(ALL_AREAS) = ptr_to_lispobj(all_areas);
1764  lisp_global(DEFAULT_ALLOCATION_QUANTUM) = log2_heap_segment_size << fixnumshift;
1765  lisp_global(STACK_SIZE) = thread_stack_size<<fixnumshift;
1766
1767
1768  exception_init();
1769
1770 
1771
1772#ifdef WINDOWS
1773  lisp_global(IMAGE_NAME) = ptr_to_lispobj(utf_16_to_utf_8(ensure_real_path(image_name)));
1774  lisp_global(KERNEL_PATH) = ptr_to_lispobj(utf_16_to_utf_8(real_executable_name));
1775  lisp_global(ARGV) = ptr_to_lispobj(wide_argv_to_utf_8(utf_16_argv, argc));
1776#else
1777  lisp_global(IMAGE_NAME) = ptr_to_lispobj(ensure_real_path(image_name));
1778  lisp_global(KERNEL_PATH) = ptr_to_lispobj(real_executable_name);
1779  lisp_global(ARGV) = ptr_to_lispobj(argv);
1780#endif
1781  lisp_global(KERNEL_IMPORTS) = (LispObj)import_ptrs_base;
1782
1783  lisp_global(GET_TCR) = (LispObj) get_tcr;
1784  *(double *) &(lisp_global(DOUBLE_FLOAT_ONE)) = (double) 1.0;
1785
1786  lisp_global(HOST_PLATFORM) = (LispObj) PLATFORM << fixnumshift;
1787
1788  lisp_global(BATCH_FLAG) = (batch_flag << fixnumshift);
1789
1790  a = active_dynamic_area;
1791
1792  if (nilreg_area != NULL) {
1793    BytePtr lowptr = (BytePtr) a->low;
1794
1795    /* Create these areas as AREA_STATIC, change them to AREA_DYNAMIC */
1796    g1_area = new_area(lowptr, lowptr, AREA_STATIC);
1797    g2_area = new_area(lowptr, lowptr, AREA_STATIC);
1798    tenured_area = new_area(lowptr, lowptr, AREA_STATIC);
1799    add_area_holding_area_lock(tenured_area);
1800    add_area_holding_area_lock(g2_area);
1801    add_area_holding_area_lock(g1_area);
1802
1803    g1_area->code = AREA_DYNAMIC;
1804    g2_area->code = AREA_DYNAMIC;
1805    tenured_area->code = AREA_DYNAMIC;
1806
1807/*    a->older = g1_area; */ /* Not yet: this is what "enabling the EGC" does. */
1808    g1_area->younger = a;
1809    g1_area->older = g2_area;
1810    g2_area->younger = g1_area;
1811    g2_area->older = tenured_area;
1812    tenured_area->younger = g2_area;
1813    tenured_area->refbits = a->markbits;
1814    tenured_area->static_dnodes = a->static_dnodes;
1815    a->static_dnodes = 0;
1816    tenured_area->static_used = a->static_used;
1817    a->static_used = 0;
1818    lisp_global(TENURED_AREA) = ptr_to_lispobj(tenured_area);
1819    lisp_global(REFBITS) = ptr_to_lispobj(tenured_area->refbits);
1820    g2_area->threshold = default_g2_threshold;
1821    g1_area->threshold = default_g1_threshold;
1822    a->threshold = default_g0_threshold;
1823  }
1824
1825  tcr = new_tcr(initial_stack_size, MIN_TSTACK_SIZE);
1826  stack_base = initial_stack_bottom()-xStackSpace();
1827  init_threads((void *)(stack_base), tcr);
1828  thread_init_tcr(tcr, current_sp, current_sp-stack_base);
1829
1830  lisp_global(EXCEPTION_LOCK) = ptr_to_lispobj(new_recursive_lock());
1831  enable_fp_exceptions();
1832  register_user_signal_handler();
1833
1834#ifdef PPC
1835  lisp_global(ALTIVEC_PRESENT) = altivec_present << fixnumshift;
1836#endif
1837#if STATIC
1838  lisp_global(STATICALLY_LINKED) = 1 << fixnumshift;
1839#endif
1840  tcr->prev = tcr->next = tcr;
1841#ifndef WINDOWS
1842  lisp_global(INTERRUPT_SIGNAL) = (LispObj) box_fixnum(SIGNAL_FOR_PROCESS_INTERRUPT);
1843#endif
1844  tcr->vs_area->active -= node_size;
1845  *(--tcr->save_vsp) = nrs_TOPLFUNC.vcell;
1846  nrs_TOPLFUNC.vcell = lisp_nil;
1847#ifdef GC_INTEGRITY_CHECKING
1848  (nrs_GC_EVENT_STATUS_BITS.vcell |= gc_integrity_check_bit);
1849#endif
1850  if (egc_enabled) {
1851    egc_control(true, NULL);
1852  }
1853  atexit(lazarus);
1854  start_lisp(TCR_TO_TSD(tcr), 0);
1855  _exit(0);
1856}
1857
1858area *
1859set_nil(LispObj r)
1860{
1861
1862  if (lisp_nil == (LispObj)NULL) {
1863
1864    lisp_nil = r;
1865  }
1866  return NULL;
1867}
1868
1869
1870void
1871xMakeDataExecutable(void *start, unsigned long nbytes)
1872{
1873#ifndef X86
1874  extern void flush_cache_lines();
1875  natural ustart = (natural) start, base, end;
1876 
1877  base = (ustart) & ~(cache_block_size-1);
1878  end = (ustart + nbytes + cache_block_size - 1) & ~(cache_block_size-1);
1879  flush_cache_lines(base, (end-base)/cache_block_size, cache_block_size);
1880#endif
1881}
1882
1883natural
1884xStackSpace()
1885{
1886  return initial_stack_size+CSTACK_HARDPROT+CSTACK_SOFTPROT;
1887}
1888
1889#ifndef DARWIN
1890#ifdef WINDOWS
1891extern void *windows_open_shared_library(char *);
1892
1893void *
1894xGetSharedLibrary(char *path, int mode)
1895{
1896  return windows_open_shared_library(path);
1897}
1898#else
1899void *
1900xGetSharedLibrary(char *path, int mode)
1901{
1902  return dlopen(path, mode);
1903}
1904#endif
1905#else
1906void *
1907xGetSharedLibrary(char *path, int *resultType)
1908{
1909  const char *error;
1910  void *result;
1911
1912  result = dlopen(path, RTLD_NOW | RTLD_GLOBAL);
1913 
1914  if (result == NULL) {
1915    error = dlerror();
1916    *resultType = 0;
1917    return (void *)error;
1918  }
1919  *resultType = 1;
1920  return result;
1921}
1922#endif
1923
1924
1925
1926int
1927fd_setsize_bytes()
1928{
1929  return FD_SETSIZE/8;
1930}
1931
1932void
1933do_fd_set(int fd, fd_set *fdsetp)
1934{
1935  FD_SET(fd, fdsetp);
1936}
1937
1938void
1939do_fd_clr(int fd, fd_set *fdsetp)
1940{
1941  FD_CLR(fd, fdsetp);
1942}
1943
1944int
1945do_fd_is_set(int fd, fd_set *fdsetp)
1946{
1947  return FD_ISSET(fd,fdsetp);
1948}
1949
1950
1951void
1952do_fd_zero(fd_set *fdsetp)
1953{
1954  FD_ZERO(fdsetp);
1955}
1956
1957#include "image.h"
1958
1959
1960
1961Boolean
1962check_for_embedded_image (
1963#ifdef WINDOWS
1964                          wchar_t *path
1965#else
1966                          char *path
1967#endif
1968                          )
1969{
1970#ifdef WINDOWS
1971  int fd = wopen(path, O_RDONLY);
1972#else 
1973  int fd = open(path, O_RDONLY);
1974#endif
1975
1976  Boolean image_is_embedded = false;
1977
1978  if (fd >= 0) {
1979    openmcl_image_file_header h;
1980
1981    if (find_openmcl_image_file_header (fd, &h)) {
1982      image_is_embedded = true;
1983    }
1984    close (fd);
1985  }
1986  return image_is_embedded;
1987}
1988
1989LispObj
1990load_image(
1991#ifdef WINDOWS
1992           wchar_t * path
1993#else
1994           char *path
1995#endif
1996)
1997{
1998#ifdef WINDOWS
1999  int fd = wopen(path, O_RDONLY, 0666), err;
2000#else
2001  int fd = open(path, O_RDONLY, 0666), err;
2002#endif
2003  LispObj image_nil = 0;
2004
2005  if (fd > 0) {
2006    openmcl_image_file_header ih;
2007
2008    errno = 0;
2009    image_nil = load_openmcl_image(fd, &ih);
2010    /* We -were- using a duplicate fd to map the file; that
2011       seems to confuse Darwin (doesn't everything ?), so
2012       we'll instead keep the original file open.
2013    */
2014    err = errno;
2015    if (!image_nil) {
2016      close(fd);
2017    }
2018#ifdef WINDOWS
2019    /* We currently don't actually map the image, and leaving the file
2020       open seems to make it difficult to write to reliably. */
2021    if (image_nil) {
2022      close(fd);
2023    }
2024#endif
2025  } else {
2026    err = errno;
2027  }
2028  if (image_nil == 0) {
2029#ifdef WINDOWS
2030    char *fmt = "Couldn't load lisp heap image from %ls";
2031#else
2032    char *fmt = "Couldn't load lisp heap image from %s";
2033#endif
2034
2035    fprintf(dbgout, fmt, path);
2036    if (err == 0) {
2037      fprintf(dbgout, "\n");
2038    } else {
2039      fprintf(dbgout, ": %s\n", strerror(err));
2040    }
2041    exit(-1);
2042  }
2043  return image_nil;
2044}
2045
2046int
2047set_errno(int val)
2048{
2049  errno = val;
2050  return -1;
2051}
2052
2053/* A horrible hack to allow us to initialize a JVM instance from lisp.
2054   On Darwin, creating a JVM instance clobbers the thread's existing
2055   Mach exception infrastructure, so we save and restore it here.
2056*/
2057
2058typedef int (*jvm_initfunc)(void*,void*,void*);
2059
2060int
2061jvm_init(jvm_initfunc f,void*arg0,void*arg1,void*arg2)
2062{
2063  int result = -1;
2064  TCR *tcr = get_tcr(1);
2065#ifdef DARWIN
2066  extern kern_return_t tcr_establish_lisp_exception_port(TCR *);
2067#endif
2068 
2069  result = f(arg0,arg1,arg2);
2070#ifdef DARWIN
2071  tcr_establish_lisp_exception_port(tcr);
2072#endif
2073  return result;
2074}
2075 
2076
2077
2078
2079void *
2080xFindSymbol(void* handle, char *name)
2081{
2082#if defined(LINUX) || defined(FREEBSD) || defined(SOLARIS)
2083  return dlsym(handle, name);
2084#endif
2085#ifdef DARWIN
2086  void *result;
2087
2088  if ((handle == NULL) || (handle == ((void *) -1))) {
2089    handle = RTLD_DEFAULT;
2090  }   
2091  result = dlsym(handle, name);
2092  if ((result == NULL) && (*name == '_')) {
2093    result = dlsym(handle, name+1);
2094  }
2095  return result;
2096#endif
2097#ifdef WINDOWS
2098  extern void *windows_find_symbol(void *, char *);
2099  return windows_find_symbol(handle, name);
2100#endif
2101}
2102
2103void *
2104get_r_debug()
2105{
2106#if defined(LINUX) || defined(FREEBSD) || defined(SOLARIS)
2107#if WORD_SIZE == 64
2108  extern Elf64_Dyn _DYNAMIC[];
2109  Elf64_Dyn *dp;
2110#else
2111  extern Elf32_Dyn _DYNAMIC[];
2112  Elf32_Dyn *dp;
2113#endif
2114  int tag;
2115
2116  for (dp = _DYNAMIC; (tag = dp->d_tag) != 0; dp++) {
2117    if (tag == DT_DEBUG) {
2118      return (void *)(dp->d_un.d_ptr);
2119    }
2120  }
2121#endif
2122  return NULL;
2123}
2124
2125
2126#ifdef DARWIN
2127void
2128sample_paging_info(paging_info *stats)
2129{
2130  mach_msg_type_number_t count = TASK_EVENTS_INFO_COUNT;
2131
2132  task_info(mach_task_self(),
2133            TASK_EVENTS_INFO,
2134            (task_info_t)stats,
2135            &count);
2136}
2137
2138void
2139report_paging_info_delta(FILE *out, paging_info *start, paging_info *stop)
2140{
2141  fprintf(out,";;; %d soft faults, %d faults, %d pageins\n\n",
2142          stop->cow_faults-start->cow_faults,
2143          stop->faults-start->faults,
2144          stop->pageins-start->pageins);
2145}
2146
2147#else
2148#ifdef WINDOWS
2149void
2150sample_paging_info(paging_info *stats)
2151{
2152}
2153
2154void
2155report_paging_info_delta(FILE *out, paging_info *start, paging_info *stop)
2156{
2157}
2158#else
2159void
2160sample_paging_info(paging_info *stats)
2161{
2162  getrusage(RUSAGE_SELF, stats);
2163}
2164
2165void
2166report_paging_info_delta(FILE *out, paging_info *start, paging_info *stop)
2167{
2168  fprintf(out,";;; %ld soft faults, %ld faults, %ld pageins\n\n",
2169          stop->ru_minflt-start->ru_minflt,
2170          stop->ru_majflt-start->ru_majflt,
2171          stop->ru_nswap-start->ru_nswap);
2172}
2173
2174#endif
2175#endif
Note: See TracBrowser for help on using the repository browser.