source: branches/arm/lisp-kernel/pmcl-kernel.c @ 13923

Last change on this file since 13923 was 13789, checked in by gb, 9 years ago

Lots of (mostly small) changes.

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