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

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

Do GC notification if dynamic heap shrinks in ensure_static_conses().

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