source: branches/acl2-egc/source/lisp-kernel/pmcl-kernel.c @ 16375

Last change on this file since 16375 was 16375, checked in by gb, 5 years ago

not there yet

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 62.9 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#include "lisp.h"
19#include "lisp_globals.h"
20#include "gc.h"
21#include "area.h"
22#include <stdlib.h>
23#include <string.h>
24#include "lisp-exceptions.h"
25#include <stdio.h>
26#include <stdlib.h>
27#ifndef WINDOWS
28#include <sys/mman.h>
29#endif
30#include <fcntl.h>
31#include <signal.h>
32#include <errno.h>
33#ifndef WINDOWS
34#include <sys/utsname.h>
35#include <unistd.h>
36#endif
37
38#ifdef LINUX
39#ifndef ANDROID
40#include <mcheck.h>
41#endif
42#include <dirent.h>
43#include <dlfcn.h>
44#include <sys/time.h>
45#include <sys/resource.h>
46#ifdef ANDROID
47#ifdef ARM
48#define ANDROID_ARM_LINKER 1
49#endif
50#include <linker.h>
51#else
52#include <link.h>
53#endif
54#ifndef ANDROID
55#include <elf.h>
56#endif
57
58/*
59   The version of <asm/cputable.h> provided by some distributions will
60   claim that <asm-ppc64/cputable.h> doesn't exist.  It may be present
61   in the Linux kernel source tree even if it's not copied to
62   /usr/include/asm-ppc64.  Hopefully, this will be straightened out
63   soon (and/or the PPC_FEATURE_HAS_ALTIVEC constant will be defined
64   in a less volatile place.)  Until that's straightened out, it may
65   be necessary to install a copy of the kernel header in the right
66   place and/or persuade <asm/cputable> to lighten up a bit.
67*/
68
69#ifdef PPC
70#ifndef PPC64
71#include <asm/cputable.h>
72#endif
73#ifndef PPC_FEATURE_HAS_ALTIVEC
74#define PPC_FEATURE_HAS_ALTIVEC 0x10000000
75#endif
76#endif
77#endif
78
79Boolean use_mach_exception_handling = 
80#ifdef DARWIN
81  true
82#else
83  false
84#endif
85;
86
87#ifdef DARWIN
88#include <sys/types.h>
89#include <sys/time.h>
90#include <sys/mman.h>
91#include <sys/resource.h>
92#include <mach/mach_types.h>
93#include <mach/message.h>
94#include <mach/vm_region.h>
95#include <mach/port.h>
96#include <sys/sysctl.h>
97#undef undefined
98#include <mach-o/dyld.h>
99#include <dlfcn.h>
100#include <libgen.h>
101#endif
102
103#if defined(FREEBSD) || defined(SOLARIS)
104#include <sys/time.h>
105#include <sys/resource.h>
106#include <dlfcn.h>
107#include <elf.h> 
108#include <link.h>
109#endif
110
111#include <ctype.h>
112#ifndef WINDOWS
113#include <sys/select.h>
114#endif
115#include "threads.h"
116
117#if !(defined(DARWIN) && defined(ARM))
118#include <fenv.h>
119#endif
120#include <sys/stat.h>
121
122#ifndef MAP_NORESERVE
123#define MAP_NORESERVE (0)
124#endif
125
126#ifdef WINDOWS
127#include <windows.h>
128#include <stdio.h>
129void
130wperror(char* message)
131{
132  char* buffer;
133  DWORD last_error = GetLastError();
134 
135  FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER|
136                FORMAT_MESSAGE_FROM_SYSTEM|
137                FORMAT_MESSAGE_IGNORE_INSERTS,
138                NULL,
139                last_error,
140                MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
141                (LPTSTR)&buffer,
142                0, NULL);
143  fprintf(dbgout, "%s: 0x%x %s\n", message, (unsigned) last_error, buffer);
144  LocalFree(buffer);
145}
146#endif
147
148LispObj lisp_nil = (LispObj) 0;
149bitvector global_mark_ref_bits = NULL, dynamic_mark_ref_bits = NULL, relocatable_mark_ref_bits = NULL, global_refidx = NULL, dynamic_refidx = NULL,managed_static_refidx = NULL;
150
151
152/* These are all "persistent" : they're initialized when
153   subprims are first loaded and should never change. */
154extern LispObj ret1valn;
155extern LispObj nvalret;
156extern LispObj popj;
157
158LispObj text_start = 0;
159
160/* A pointer to some of the kernel's own data; also persistent. */
161
162extern LispObj import_ptrs_base;
163
164/* The highest heap address that's (probably) been written to. */
165BytePtr heap_dirty_limit = NULL;
166
167
168
169void
170make_dynamic_heap_executable(void *p, void *q)
171{
172  void * cache_start = (void *) p;
173  natural ncacheflush = (natural) q - (natural) p;
174
175  xMakeDataExecutable(cache_start, ncacheflush); 
176}
177     
178size_t
179ensure_stack_limit(size_t stack_size)
180{
181#ifdef WINDOWS
182  extern void os_get_current_thread_stack_bounds(void **, natural*);
183  natural totalsize;
184  void *ignored;
185 
186  os_get_current_thread_stack_bounds(&ignored, &totalsize);
187
188  return (size_t)totalsize-(size_t)(CSTACK_HARDPROT+CSTACK_SOFTPROT);
189
190#else
191  struct rlimit limits;
192  rlim_t cur_stack_limit, max_stack_limit;
193 
194  stack_size += (CSTACK_HARDPROT+CSTACK_SOFTPROT);
195  getrlimit(RLIMIT_STACK, &limits);
196  cur_stack_limit = limits.rlim_cur;
197  max_stack_limit = limits.rlim_max;
198  if (stack_size > max_stack_limit) {
199    stack_size = max_stack_limit;
200  }
201  if (cur_stack_limit < stack_size) {
202    limits.rlim_cur = stack_size;
203    errno = 0;
204    if (setrlimit(RLIMIT_STACK, &limits)) {
205      int e = errno;
206      fprintf(dbgout, "errno = %d\n", e);
207      Fatal(": Stack resource limit too small", "");
208    }
209  }
210#endif
211  return stack_size;
212}
213
214
215/* This should write-protect the bottom of the stack.
216   Doing so reliably involves ensuring that everything's unprotected on exit.
217*/
218
219BytePtr
220allocate_lisp_stack(natural useable,
221                    unsigned softsize,
222                    unsigned hardsize,
223                    lisp_protection_kind softkind,
224                    lisp_protection_kind hardkind,
225                    Ptr *h_p,
226                    BytePtr *base_p,
227                    protected_area_ptr *softp,
228                    protected_area_ptr *hardp)
229{
230  void *allocate_stack(natural);
231  void free_stack(void *);
232  natural size = useable+softsize+hardsize;
233  natural overhead;
234  BytePtr base, softlimit, hardlimit;
235  Ptr h = allocate_stack(size+4095);
236  protected_area_ptr hprotp = NULL, sprotp;
237
238  if (h == NULL) {
239    return NULL;
240  }
241  if (h_p) *h_p = h;
242  base = (BytePtr) align_to_power_of_2( h, log2_page_size);
243  hardlimit = (BytePtr) (base+hardsize);
244  softlimit = hardlimit+softsize;
245
246  overhead = (base - (BytePtr) h);
247  if (hardsize) {
248    hprotp = new_protected_area((BytePtr)base,hardlimit,hardkind, hardsize, true);
249    if (hprotp == NULL) {
250      if (base_p) *base_p = NULL;
251      if (h_p) *h_p = NULL;
252      free(h);
253      return NULL;
254    }
255    if (hardp) *hardp = hprotp;
256  }
257  if (softsize) {
258    sprotp = new_protected_area(hardlimit,softlimit, softkind, softsize, true);
259    if (sprotp == NULL) {
260      if (base_p) *base_p = NULL;
261      if (h_p) *h_p = NULL;
262      if (hardp) *hardp = NULL;
263      if (hprotp) delete_protected_area(hprotp);
264      free_stack(h);
265      return NULL;
266    }
267    if (softp) *softp = sprotp;
268  }
269  if (base_p) *base_p = base;
270  return (BytePtr) ((natural)(base+size));
271}
272
273/*
274  This should only called by something that owns the area_lock, or
275  by the initial thread before other threads exist.
276*/
277area *
278allocate_lisp_stack_area(area_code stack_type,
279                         natural usable,
280                         unsigned softsize, 
281                         unsigned hardsize, 
282                         lisp_protection_kind softkind, 
283                         lisp_protection_kind hardkind)
284
285{
286  BytePtr base, bottom;
287  Ptr h;
288  area *a = NULL;
289  protected_area_ptr soft_area=NULL, hard_area=NULL;
290
291  bottom = allocate_lisp_stack(usable, 
292                               softsize, 
293                               hardsize, 
294                               softkind, 
295                               hardkind, 
296                               &h, 
297                               &base,
298                               &soft_area, 
299                               &hard_area);
300
301  if (bottom) {
302    a = new_area(base, bottom, stack_type);
303    a->h = h;
304    a->hardlimit = base+hardsize;
305    a->softlimit = base+hardsize+softsize;
306    a->softprot = soft_area;
307    a->hardprot = hard_area;
308    add_area_holding_area_lock(a);
309  }
310  return a;
311}
312
313/*
314  Also assumes ownership of the area_lock
315*/
316area*
317register_cstack_holding_area_lock(BytePtr bottom, natural size)
318{
319  BytePtr lowlimit = (BytePtr) (((((natural)bottom)-size)+4095)&~4095);
320  area *a = new_area((BytePtr) bottom-size, bottom, AREA_CSTACK);
321  if (size > (CSTACK_HARDPROT + CSTACK_SOFTPROT)) {
322    a->hardlimit = lowlimit+CSTACK_HARDPROT;
323    a->softlimit = a->hardlimit+CSTACK_SOFTPROT;
324  } else {
325    a->softlimit = a->hardlimit = lowlimit;
326  }
327#ifdef USE_SIGALTSTACK
328  setup_sigaltstack(a);
329#endif
330#ifdef PROTECT_CSTACK
331  if (a->softlimit != a->hardlimit) {
332    a->softprot=new_protected_area(a->hardlimit,a->softlimit,kSPsoftguard,CSTACK_SOFTPROT,true);
333    a->hardprot=new_protected_area(lowlimit,a->hardlimit,kSPhardguard,CSTACK_HARDPROT,true);
334  }
335#endif
336  add_area_holding_area_lock(a);
337  return a;
338}
339 
340
341area*
342allocate_vstack_holding_area_lock(natural usable)
343{
344  return allocate_lisp_stack_area(AREA_VSTACK, 
345                                  usable > MIN_VSTACK_SIZE ?
346                                  usable : MIN_VSTACK_SIZE,
347                                  VSTACK_SOFTPROT,
348                                  VSTACK_HARDPROT,
349                                  kVSPsoftguard,
350                                  kVSPhardguard);
351}
352
353area *
354allocate_tstack_holding_area_lock(natural usable)
355{
356  return allocate_lisp_stack_area(AREA_TSTACK, 
357                                  usable > MIN_TSTACK_SIZE ?
358                                  usable : MIN_TSTACK_SIZE,
359                                  TSTACK_SOFTPROT,
360                                  TSTACK_HARDPROT,
361                                  kTSPsoftguard,
362                                  kTSPhardguard);
363}
364
365
366/* It's hard to believe that max & min don't exist already */
367unsigned unsigned_min(unsigned x, unsigned y)
368{
369  if (x <= y) {
370    return x;
371  } else {
372    return y;
373  }
374}
375
376unsigned unsigned_max(unsigned x, unsigned y)
377{
378  if (x >= y) {
379    return x;
380  } else {
381    return y;
382  }
383}
384
385natural
386reserved_area_size = MAXIMUM_MAPPABLE_MEMORY;
387
388BytePtr reserved_region_end = NULL;
389
390area
391  *nilreg_area=NULL,
392  *tenured_area=NULL, 
393  *g2_area=NULL, 
394  *g1_area=NULL,
395  *managed_static_area=NULL,
396  *static_cons_area=NULL,
397  *readonly_area=NULL;
398
399area *all_areas=NULL;
400int cache_block_size=32;
401
402
403#if WORD_SIZE == 64
404#define DEFAULT_LISP_HEAP_GC_THRESHOLD (32<<20)
405#define G2_AREA_THRESHOLD (8<<20)
406#define G1_AREA_THRESHOLD (4<<20)
407#define G0_AREA_THRESHOLD (2<<20)
408#else
409#define DEFAULT_LISP_HEAP_GC_THRESHOLD (16<<20)
410#define G2_AREA_THRESHOLD (4<<20)
411#define G1_AREA_THRESHOLD (2<<20)
412#define G0_AREA_THRESHOLD (1<<20)
413#endif
414
415#define MIN_DYNAMIC_SIZE (DEFAULT_LISP_HEAP_GC_THRESHOLD *2)
416
417#if (WORD_SIZE == 32)
418#define DEFAULT_INITIAL_STACK_SIZE (1<<20)
419#else
420#define DEFAULT_INITIAL_STACK_SIZE (2<<20)
421#endif
422
423natural
424lisp_heap_gc_threshold = DEFAULT_LISP_HEAP_GC_THRESHOLD;
425
426natural
427lisp_heap_notify_threshold = 0;
428
429natural
430initial_stack_size = DEFAULT_INITIAL_STACK_SIZE;
431
432natural
433thread_stack_size = 0;
434
435
436/*
437  'start' should be on a segment boundary; 'len' should be
438  an integral number of segments.  remap the entire range.
439*/
440
441void 
442uncommit_pages(void *start, size_t len)
443{
444  UnCommitMemory(start, len);
445}
446
447#define TOUCH_PAGES_ON_COMMIT 0
448
449Boolean
450touch_all_pages(void *start, size_t len)
451{
452#if TOUCH_PAGES_ON_COMMIT
453  extern Boolean touch_page(void *);
454  char *p = (char *)start;
455
456  while (len) {
457    if (!touch_page(p)) {
458      return false;
459    }
460    len -= page_size;
461    p += page_size;
462  }
463#endif
464  return true;
465}
466
467Boolean
468commit_pages(void *start, size_t len)
469{
470  if (len != 0) {
471    if (!CommitMemory(start, len)) {
472      return false;
473    }
474    if (!touch_all_pages(start, len)) {
475      return false;
476    }
477  }
478  return true;
479}
480
481area *
482find_readonly_area()
483{
484  area *a;
485
486  for (a = active_dynamic_area->succ; a != all_areas; a = a->succ) {
487    if (a->code == AREA_READONLY) {
488      return a;
489    }
490  }
491  return NULL;
492}
493
494area *
495extend_readonly_area(natural more)
496{
497  area *a;
498  unsigned mask;
499  BytePtr new_start, new_end;
500
501  if ((a = find_readonly_area()) != NULL) {
502    if ((a->active + more) > a->high) {
503      return NULL;
504    }
505    mask = ((natural)a->active) & (page_size-1);
506    if (mask) {
507      UnProtectMemory(a->active-mask, page_size);
508    }
509    new_start = (BytePtr)(align_to_power_of_2(a->active,log2_page_size));
510    new_end = (BytePtr)(align_to_power_of_2(a->active+more,log2_page_size));
511    if (!CommitMemory(new_start, new_end-new_start)) {
512      return NULL;
513    }
514    return a;
515  }
516  return NULL;
517}
518
519LispObj image_base=0;
520BytePtr pure_space_start, pure_space_active, pure_space_limit;
521BytePtr static_space_start, static_space_active, static_space_limit;
522
523void
524raise_limit()
525{
526#ifdef RLIMIT_AS
527  struct rlimit r;
528  if (getrlimit(RLIMIT_AS, &r) == 0) {
529    r.rlim_cur = r.rlim_max;
530    setrlimit(RLIMIT_AS, &r);
531    /* Could limit heaplimit to rlim_max here if smaller? */
532  }
533#endif
534} 
535
536
537area *
538create_reserved_area(natural totalsize)
539{
540  Ptr h;
541  natural base, refbits_size;
542  BytePtr
543    end, 
544    lastbyte, 
545    start, 
546    want = (BytePtr)IMAGE_BASE_ADDRESS;
547  area *reserved;
548  Boolean fatal = false;
549
550  totalsize = align_to_power_of_2((void *)totalsize, log2_heap_segment_size);
551   
552  if (totalsize < (PURESPACE_RESERVE + MIN_DYNAMIC_SIZE)) {
553    totalsize = PURESPACE_RESERVE + MIN_DYNAMIC_SIZE;
554    fatal = true;
555  }
556
557  start = ReserveMemoryForHeap(want, totalsize);
558
559  if (start == NULL) {
560    if (fatal) {
561#ifdef WINDOWS
562      wperror("minimal initial mmap");
563#else
564      perror("minimal initial mmap");
565#endif
566      exit(1);
567    }
568    return NULL;
569  }
570
571  h = (Ptr) start;
572  base = (natural) start;
573  image_base = base;
574  lastbyte = (BytePtr) (start+totalsize);
575  static_space_start = static_space_active = (BytePtr)STATIC_BASE_ADDRESS;
576  static_space_limit = static_space_start + STATIC_RESERVE;
577  pure_space_start = pure_space_active = start;
578  pure_space_limit = start + PURESPACE_SIZE;
579  start += PURESPACE_RESERVE;
580
581  /*
582    Allocate mark bits here.  They need to be 1/64 the size of the
583     maximum useable area of the heap (+ 3 words for the EGC.)
584  */
585  end = lastbyte;
586  reserved_region_end = lastbyte;
587  refbits_size = ((totalsize+63)>>6); /* word size! */
588  end = (BytePtr) ((natural)((((natural)end) - refbits_size) & ~4095));
589
590  global_mark_ref_bits = (bitvector)end;
591  end  = (BytePtr) ((natural)((((natural)end) - ((refbits_size+255) >> 8)) & ~4095));
592  global_refidx = (bitvector)end;
593  /* Don't really want to commit so much so soon */
594  CommitMemory((BytePtr)global_refidx,(BytePtr)global_mark_ref_bits-(BytePtr)global_refidx);
595   
596  end = (BytePtr) ((natural)((((natural)end) - ((totalsize+63) >> 6)) & ~4095));
597  global_reloctab = (LispObj *) end;
598  reserved = new_area(start, end, AREA_VOID);
599  /* The root of all evil is initially linked to itself. */
600  reserved->pred = reserved->succ = reserved;
601  all_areas = reserved;
602#ifdef X86
603  {
604    managed_static_refbits = ReserveMemory((((MANAGED_STATIC_SIZE>>dnode_shift)+7)>>3));
605    if (managed_static_refbits == NULL) {
606#ifdef WINDOWS
607      wperror("allocate refbits for managed static area");
608#else
609      perror("allocate refbits for managed static area");
610#endif
611      exit(1);
612    }
613    managed_static_refidx = ReserveMemory(((((MANAGED_STATIC_SIZE>>dnode_shift)+255)>>8)+7)>>3);
614    if (managed_static_refidx == NULL) {
615#ifdef WINDOWS
616      wperror("allocate refidx for managed static area");
617#else
618      perror("allocate refidx for managed static area");
619#endif
620      exit(1);
621    }     
622  }
623#endif
624  return reserved;
625}
626
627void *
628allocate_from_reserved_area(natural size)
629{
630  area *reserved = reserved_area;
631  BytePtr low = reserved->low, high = reserved->high;
632  natural avail = high-low;
633 
634  size = align_to_power_of_2(size, log2_heap_segment_size);
635
636  if (size > avail) {
637    return NULL;
638  }
639  reserved->low += size;
640  reserved->active = reserved->low;
641  reserved->ndnodes -= (size>>dnode_shift);
642  return low;
643}
644
645
646
647BytePtr reloctab_limit = NULL, markbits_limit = NULL;
648BytePtr low_relocatable_address = NULL, high_relocatable_address = NULL,
649  low_markable_address = NULL, high_markable_address = NULL;
650
651void
652map_initial_reloctab(BytePtr low, BytePtr high) 
653{
654  natural ndnodes, reloctab_size;
655
656  low_relocatable_address = low; /* will never change */
657  high_relocatable_address = high;
658  ndnodes = area_dnode(high,low);
659  reloctab_size = (sizeof(LispObj)*(((ndnodes+((1<<bitmap_shift)-1))>>bitmap_shift)+1));
660 
661  reloctab_limit = (BytePtr)align_to_power_of_2(((natural)global_reloctab)+reloctab_size,log2_page_size);
662  CommitMemory(global_reloctab,reloctab_limit-(BytePtr)global_reloctab);
663}
664
665void
666map_initial_markbits(BytePtr low, BytePtr high)
667{
668  natural
669    prefix_dnodes = area_dnode(low, pure_space_limit),
670    ndnodes = area_dnode(high, low),
671    prefix_size = (prefix_dnodes+7)>>3,
672    markbits_size = (3*sizeof(LispObj))+((ndnodes+7)>>3),
673    prefix_index_bits,
674    n;
675  low_markable_address = low;
676  high_markable_address = high;
677  dynamic_mark_ref_bits = (bitvector)(((BytePtr)global_mark_ref_bits)+prefix_size);
678  if (prefix_dnodes & 255) {
679    fprintf(dbgout, "warning: prefix_dnodes not a multiple of 256\n");
680  }
681  prefix_index_bits = prefix_dnodes>>8;
682  if (prefix_index_bits & (WORD_SIZE-1)) {
683    fprintf(dbgout, "warning: prefix_index_bits not a multiple of %d\n", WORD_SIZE);
684  }
685  dynamic_refidx = (bitvector)(((BytePtr)global_refidx)+(prefix_index_bits>>3));
686  relocatable_mark_ref_bits = dynamic_mark_ref_bits;
687  n = align_to_power_of_2(markbits_size,log2_page_size);
688  markbits_limit = ((BytePtr)dynamic_mark_ref_bits)+n;
689  CommitMemory(dynamic_mark_ref_bits,n);
690}
691   
692void
693lower_heap_start(BytePtr new_low, area *a)
694{
695  natural new_dnodes = area_dnode(low_markable_address,new_low);
696
697  if (new_dnodes) {
698    natural n = (new_dnodes+7)>>3,
699      nidx = ((((new_dnodes+255)>>8)+7)>>3)>>node_shift;
700
701    BytePtr old_markbits = (BytePtr)dynamic_mark_ref_bits,
702      new_markbits = old_markbits-n;
703    CommitMemory(new_markbits,n);
704    dynamic_mark_ref_bits = (bitvector)new_markbits;
705    if (a) {
706      if (a->refbits) {
707      a->refbits= dynamic_mark_ref_bits;
708      }
709      a->static_dnodes += new_dnodes;
710      a->ndnodes += new_dnodes;
711      a->low = new_low;
712      a->refidx -= nidx;
713    }
714    low_markable_address = new_low;
715    lisp_global(HEAP_START) = (LispObj)new_low;
716    static_cons_area->ndnodes = area_dnode(static_cons_area->high,new_low);
717    ensure_gc_structures_writable();
718  }
719}
720
721void
722ensure_gc_structures_writable()
723{
724  natural
725    ndnodes = area_dnode(lisp_global(HEAP_END),tenured_area->low),
726    markbits_size = (3*sizeof(LispObj))+((ndnodes+7)>>3),
727    reloctab_size = (sizeof(LispObj)*(((ndnodes+((1<<bitmap_shift)-1))>>bitmap_shift)+1)),
728    n;
729  BytePtr
730    new_reloctab_limit = (BytePtr)align_to_power_of_2(((natural)global_reloctab)+reloctab_size,log2_page_size),
731    new_markbits_limit = (BytePtr)align_to_power_of_2(((natural)relocatable_mark_ref_bits)+markbits_size,log2_page_size);
732
733  if (new_reloctab_limit > reloctab_limit) {
734    n = new_reloctab_limit - reloctab_limit;
735    CommitMemory(reloctab_limit, n);
736    UnProtectMemory(reloctab_limit, n);
737    reloctab_limit = new_reloctab_limit;
738  }
739 
740  if (new_markbits_limit > markbits_limit) {
741    n = new_markbits_limit-markbits_limit;
742    CommitMemory(markbits_limit, n);
743    UnProtectMemory(markbits_limit, n);
744    markbits_limit = new_markbits_limit;
745  }
746}
747
748
749area *
750allocate_dynamic_area(natural initsize)
751{
752  natural totalsize = align_to_power_of_2(initsize, log2_heap_segment_size);
753  BytePtr start, end;
754  area *a;
755
756  start = allocate_from_reserved_area(totalsize);
757  if (start == NULL) {
758    fprintf(dbgout, "reserved area too small to load heap image\n");
759    exit(1);
760  }
761  end = start + totalsize;
762  a = new_area(start, end, AREA_DYNAMIC);
763  a->active = start+initsize;
764  add_area_holding_area_lock(a);
765  CommitMemory(start, end-start);
766  a->softprot = NULL;
767  a->hardprot = NULL;
768  map_initial_reloctab(a->low, a->high);
769  map_initial_markbits(a->low, a->high);
770  lisp_global(HEAP_START) = ptr_to_lispobj(a->low);
771  lisp_global(HEAP_END) = ptr_to_lispobj(a->high);
772  return a;
773 }
774
775
776Boolean
777grow_dynamic_area(natural delta)
778{
779  area *a = active_dynamic_area, *reserved = reserved_area;
780  natural avail = reserved->high - reserved->low;
781 
782  delta = align_to_power_of_2(delta, log2_heap_segment_size);
783  if (delta > avail) {
784    return false;
785  }
786
787  if (!commit_pages(a->high,delta)) {
788    return false;
789  }
790
791
792  if (!allocate_from_reserved_area(delta)) {
793    return false;
794  }
795
796
797  a->high += delta;
798  a->ndnodes = area_dnode(a->high, a->low);
799  lisp_global(HEAP_END) += delta;
800  ensure_gc_structures_writable();
801  return true;
802}
803
804/*
805  As above.  Pages that're returned to the reserved_area are
806  "condemned" (e.g, we try to convince the OS that they never
807  existed ...)
808*/
809Boolean
810shrink_dynamic_area(natural delta)
811{
812  area *a = active_dynamic_area, *reserved = reserved_area;
813 
814  delta = align_to_power_of_2(delta, log2_heap_segment_size);
815
816  a->high -= delta;
817  a->ndnodes = area_dnode(a->high, a->low);
818  if (heap_dirty_limit > a->high) {
819    heap_dirty_limit = a->high;
820  }
821  a->hardlimit = a->high;
822  uncommit_pages(a->high, delta);
823  reserved->low -= delta;
824  reserved->ndnodes += (delta>>dnode_shift);
825  lisp_global(HEAP_END) -= delta;
826  return true;
827}
828
829#ifndef WINDOWS
830natural user_signal_semaphores[NSIG];
831sigset_t user_signals_reserved;
832#endif
833
834
835#ifndef WINDOWS
836void
837user_signal_handler (int signum, siginfo_t *info, ExceptionInformation *context)
838{
839  SEMAPHORE s = (SEMAPHORE)user_signal_semaphores[signum];
840
841  if (s != 0) {
842    signal_semaphore(s);
843  }
844  else if (signum == SIGINT) {
845    lisp_global(INTFLAG) = (((signum<<8) + 1) << fixnumshift);
846  }
847  else if (signum == SIGTERM) {
848    lisp_global(INTFLAG) = (((signum<<8) + 2) << fixnumshift);
849  }
850  else if (signum == SIGQUIT) {
851    lisp_global(INTFLAG) = (((signum<<8) + 2) << fixnumshift);
852  }
853#ifdef DARWIN
854  DarwinSigReturn(context);
855#endif
856}
857
858#endif
859
860
861void
862register_user_signal_handler()
863{
864#ifdef WINDOWS
865  extern BOOL CALLBACK ControlEventHandler(DWORD);
866
867  signal(SIGINT, SIG_IGN);
868
869  SetConsoleCtrlHandler(ControlEventHandler,TRUE);
870#else
871  install_signal_handler(SIGINT, (void *)user_signal_handler, 0);
872  install_signal_handler(SIGTERM, (void *)user_signal_handler, 0);
873  install_signal_handler(SIGQUIT, (void *)user_signal_handler, 0);
874#endif
875}
876
877int
878wait_for_signal(int signo, int seconds, int milliseconds)
879{
880#ifdef WINDOWS
881  return EINVAL;
882#else
883  if ((signo <= 0) || (signo >= NSIG)) {
884    return EINVAL;
885  }
886  if (sigismember(&user_signals_reserved,signo)) {
887    return EINVAL;
888  }
889  if (user_signal_semaphores[signo] == 0) {
890    user_signal_semaphores[signo] = (natural)new_semaphore(0);
891    install_signal_handler(signo,(void *)user_signal_handler, 0);
892  }
893  return wait_on_semaphore((void *)user_signal_semaphores[signo],seconds,milliseconds);
894#endif
895}
896
897BytePtr
898initial_stack_bottom()
899{
900  extern void os_get_current_thread_stack_bounds(void **, natural*);
901  void *stack_bottom;
902  natural stack_size;
903 
904  os_get_current_thread_stack_bounds(&stack_bottom, &stack_size);
905  return (BytePtr)stack_bottom;
906}
907
908
909
910 
911Ptr fatal_spare_ptr = NULL;
912
913
914void
915Fatal(StringPtr param0, StringPtr param1)
916{
917
918  if (fatal_spare_ptr) {
919    free(fatal_spare_ptr);
920    fatal_spare_ptr = NULL;
921  }
922  fprintf(dbgout, "Fatal error: %s\n%s\n", param0, param1);
923  _exit(-1);
924}
925
926void
927fatal_oserr(StringPtr param, OSErr err)
928{
929  char buf[64];
930  sprintf(buf," - operating system error %d.", err);
931  Fatal(param, buf);
932}
933
934OSErr application_load_err = noErr;
935
936area *
937set_nil(LispObj);
938
939
940/* Check for the existence of a file named by 'path'; return true
941   if it seems to exist, without checking size, permissions, or
942   anything else. */
943Boolean
944probe_file(char *path)
945{
946  struct stat st;
947
948  return (stat(path,&st) == 0);
949}
950
951
952#ifdef WINDOWS
953/* Chop the trailing ".exe" from the kernel image name */
954wchar_t *
955chop_exe_suffix(wchar_t *path)
956{
957  int len = wcslen(path);
958  wchar_t *copy = malloc((len+1)*sizeof(wchar_t)), *tail;
959
960  wcscpy(copy,path);
961  tail = wcsrchr(copy, '.');
962  if (tail) {
963    *tail = 0;
964  }
965  return copy;
966}
967#endif
968
969#ifdef WINDOWS
970wchar_t *
971path_by_appending_image(wchar_t *path)
972{
973  int len = wcslen(path) + wcslen(L".image") + 1;
974  wchar_t *copy = (wchar_t *) malloc(len*sizeof(wchar_t));
975
976  if (copy) {
977    wcscpy(copy, path);
978    wcscat(copy, L".image");
979  }
980  return copy;
981}
982#else
983char *
984path_by_appending_image(char *path)
985{
986  int len = strlen(path) + strlen(".image") + 1;
987  char *copy = (char *) malloc(len);
988
989  if (copy) {
990    strcpy(copy, path);
991    strcat(copy, ".image");
992  }
993  return copy;
994}
995#endif
996
997#ifdef WINDOWS
998wchar_t *
999default_image_name(wchar_t *orig)
1000{
1001  wchar_t *path = chop_exe_suffix(orig);
1002  wchar_t *image_name = path_by_appending_image(path);
1003  return image_name;
1004}
1005#else
1006char *
1007default_image_name(char *orig)
1008{
1009  char *path = orig;
1010  char *image_name = path_by_appending_image(path);
1011  return image_name;
1012}
1013#endif
1014
1015#ifdef DARWIN
1016char *
1017bundle_image_name(char *orig)
1018{
1019  char *base = basename(orig);
1020  char *dir = dirname(orig);
1021  char path[MAXPATHLEN];
1022
1023  snprintf(path, MAXPATHLEN, "%s/../Resources/ccl/%s", dir, base);
1024  return path_by_appending_image(path);
1025}
1026#endif
1027
1028char *program_name = NULL;
1029#ifdef WINDOWS
1030wchar_t *real_executable_name = NULL;
1031#else
1032char *real_executable_name = NULL;
1033#endif
1034
1035#ifndef WINDOWS
1036
1037char *
1038ensure_real_path(char *path)
1039{
1040  char buf[PATH_MAX*2], *p, *q;
1041  int n;
1042
1043  p = realpath(path, buf);
1044 
1045  if (p == NULL) {
1046    return path;
1047  }
1048  n = strlen(p);
1049  q = malloc(n+1);
1050  strcpy(q,p);
1051  return q;
1052}
1053
1054char *
1055determine_executable_name(char *argv0)
1056{
1057#ifdef DARWIN
1058  uint32_t len = 1024;
1059  char exepath[1024], *p = NULL;
1060   
1061  if (_NSGetExecutablePath(exepath, &len) == 0) {
1062    p = malloc(len+1);
1063    memmove(p, exepath, len);
1064    p[len]=0;
1065    return ensure_real_path(p);
1066  } 
1067  return ensure_real_path(argv0);
1068#endif
1069#ifdef LINUX
1070  char exepath[PATH_MAX], *p;
1071  int n;
1072
1073  if ((n = readlink("/proc/self/exe", exepath, PATH_MAX)) > 0) {
1074    p = malloc(n+1);
1075    memmove(p,exepath,n);
1076    p[n]=0;
1077    return p;
1078  }
1079  return argv0;
1080#endif
1081#ifdef FREEBSD
1082  return ensure_real_path(argv0);
1083#endif
1084#ifdef SOLARIS
1085  char exepath[PATH_MAX], proc_path[PATH_MAX], *p;
1086  int n;
1087
1088  snprintf(proc_path,PATH_MAX-1,"/proc/%d/path/a.out",getpid());
1089
1090  if ((n = readlink(proc_path, exepath, PATH_MAX)) > 0) {
1091    p = malloc(n+1);
1092    memmove(p,exepath,n);
1093    p[n]=0;
1094    return p;
1095  }
1096  return ensure_real_path(argv0);
1097#endif
1098  return ensure_real_path(argv0);
1099}
1100#endif
1101
1102#ifdef WINDOWS
1103wchar_t *
1104determine_executable_name()
1105{
1106  DWORD nsize = 512, result;
1107  wchar_t *buf = malloc(nsize*sizeof(wchar_t));
1108
1109  do {
1110    result = GetModuleFileNameW(NULL, buf, nsize);
1111    if (result == nsize) {
1112      nsize *= 2;
1113      buf = realloc(buf,nsize*sizeof(wchar_t));
1114    } else {
1115      return buf;
1116    }
1117  } while (1);
1118}
1119
1120
1121wchar_t *
1122ensure_real_path(wchar_t *path)
1123{
1124  int bufsize = 256, n;
1125
1126  do {
1127    wchar_t buf[bufsize];
1128
1129    n = GetFullPathNameW(path,bufsize,buf,NULL);
1130    if (n == 0) {
1131      return path;
1132    }
1133
1134    if (n < bufsize) {
1135      int i;
1136      wchar_t *q = calloc(n+1,sizeof(wchar_t));
1137
1138      for (i = 0; i < n; i++) {
1139        q[i] = buf[i];
1140      }
1141      return q;
1142    }
1143    bufsize = n+1;
1144  } while (1);
1145}
1146#endif
1147
1148void
1149usage_exit(char *herald, int exit_status, char* other_args)
1150{
1151  if (herald && *herald) {
1152    fprintf(dbgout, "%s\n", herald);
1153  }
1154  fprintf(dbgout, "usage: %s <options>\n", program_name);
1155#ifdef SINGLE_ARG_SHORTHAND
1156  fprintf(dbgout, "\t or %s <image-name>\n", program_name);
1157#endif
1158  fprintf(dbgout, "\t where <options> are one or more of:\n");
1159  if (other_args && *other_args) {
1160    fputs(other_args, dbgout);
1161  }
1162  fprintf(dbgout, "\t-R, --heap-reserve <n>: reserve <n> (default: %lld)\n",
1163          (long long)reserved_area_size);
1164  fprintf(dbgout, "\t\t bytes for heap expansion\n");
1165  fprintf(dbgout, "\t-S, --stack-size <n>: set  size of initial thread's control stack to <n>\n");
1166  fprintf(dbgout, "\t-Z, --thread-stack-size <n>: set default size of first (listener)  thread's stacks based on <n>\n");
1167  fprintf(dbgout, "\t-b, --batch: exit when EOF on *STANDARD-INPUT*\n");
1168  fprintf(dbgout, "\t--no-sigtrap : obscure option for running under GDB\n");
1169  fprintf(dbgout, "\t--debug : try to ensure that kernel debugger uses a TTY for I/O\n");
1170  fprintf(dbgout, "\t-I, --image-name <image-name>\n");
1171#ifndef WINDOWS
1172  fprintf(dbgout, "\t and <image-name> defaults to %s\n", 
1173          default_image_name(program_name));
1174#endif
1175  fprintf(dbgout, "\n\tAny arguments following the pseudoargument \"--\" are\n");
1176  fprintf(dbgout, "\tnot processed and are available to the application as\n");
1177  fprintf(dbgout, "\tthe value of CCL:*UNPROCESSED-COMMAND-LINE-ARGUMENTS* .\n");
1178
1179  fprintf(dbgout, "\n");
1180  _exit(exit_status);
1181}
1182
1183int no_sigtrap = 0;
1184#ifdef WINDOWS
1185wchar_t *image_name = NULL;
1186#else
1187char *image_name = NULL;
1188#endif
1189int batch_flag = 0;
1190
1191
1192natural
1193parse_numeric_option(char *arg, char *argname, natural default_val)
1194{
1195  char *tail;
1196  natural val = 0;
1197
1198  val = strtoul(arg, &tail, 0);
1199  switch(*tail) {
1200  case '\0':
1201    break;
1202   
1203  case 'M':
1204  case 'm':
1205    val = val << 20;
1206    break;
1207   
1208  case 'K':
1209  case 'k':
1210    val = val << 10;
1211    break;
1212   
1213  case 'G':
1214  case 'g':
1215    val = val << 30;
1216    break;
1217   
1218  default:
1219    fprintf(dbgout, "couldn't parse %s argument %s", argname, arg);
1220    val = default_val;
1221    break;
1222  }
1223  return val;
1224}
1225 
1226
1227
1228/*
1229   The set of arguments recognized by the kernel is
1230   likely to remain pretty small and pretty simple.
1231   This removes everything it recognizes from argv;
1232   remaining args will be processed by lisp code.
1233*/
1234
1235void
1236process_options(int argc, char *argv[], wchar_t *shadow[])
1237{
1238  int i, j, k, num_elide, flag, arg_error;
1239  char *arg, *val;
1240  wchar_t *warg, *wval;
1241#ifdef DARWIN
1242  extern int NXArgc;
1243#endif
1244  dbgin = stdin;
1245  for (i = 1; i < argc;) {
1246    arg = argv[i];
1247    if (shadow) {
1248      warg = shadow[i];
1249    }
1250    arg_error = 0;
1251    if (*arg != '-') {
1252      i++;
1253    } else {
1254      num_elide = 0;
1255      val = NULL;
1256      if ((flag = (strncmp(arg, "-I", 2) == 0)) ||
1257          (strcmp (arg, "--image-name") == 0)) {
1258        if (flag && arg[2]) {
1259          val = arg+2;         
1260          if (shadow) {
1261            wval = warg+2;
1262          }
1263          num_elide = 1;
1264        } else {
1265          if ((i+1) < argc) {
1266            val = argv[i+1];
1267            if (shadow) {
1268              wval = shadow[i+1];
1269            }
1270            num_elide = 2;
1271          } else {
1272            arg_error = 1;
1273          }
1274        }
1275        if (val) {
1276#ifdef WINDOWS
1277          image_name = wval;
1278#else
1279          image_name = val;
1280#endif
1281        }
1282      } else if ((flag = (strncmp(arg, "-R", 2) == 0)) ||
1283                 (strcmp(arg, "--heap-reserve") == 0)) {
1284        natural reserved_size = reserved_area_size;
1285
1286        if (flag && arg[2]) {
1287          val = arg+2;
1288          num_elide = 1;
1289        } else {
1290          if ((i+1) < argc) {
1291            val = argv[i+1];
1292            num_elide = 2;
1293          } else {
1294            arg_error = 1;
1295          }
1296        }
1297
1298        if (val) {
1299          reserved_size = parse_numeric_option(val, 
1300                                               "-R/--heap-reserve", 
1301                                               reserved_area_size);
1302        }
1303
1304        if (reserved_size <= MAXIMUM_MAPPABLE_MEMORY) {
1305          reserved_area_size = reserved_size;
1306        }
1307
1308      } else if ((flag = (strncmp(arg, "-S", 2) == 0)) ||
1309                 (strcmp(arg, "--stack-size") == 0)) {
1310        natural stack_size;
1311
1312        if (flag && arg[2]) {
1313          val = arg+2;
1314          num_elide = 1;
1315        } else {
1316          if ((i+1) < argc) {
1317            val = argv[i+1];
1318            num_elide = 2;
1319          } else {
1320            arg_error = 1;
1321          }
1322        }
1323
1324        if (val) {
1325          stack_size = parse_numeric_option(val, 
1326                                            "-S/--stack-size", 
1327                                            initial_stack_size);
1328         
1329
1330          if (stack_size >= MIN_CSTACK_SIZE) {
1331            initial_stack_size = stack_size;
1332          }
1333        }
1334
1335      } else if ((flag = (strncmp(arg, "-Z", 2) == 0)) ||
1336                 (strcmp(arg, "--thread-stack-size") == 0)) {
1337        natural stack_size;
1338
1339        if (flag && arg[2]) {
1340          val = arg+2;
1341          num_elide = 1;
1342        } else {
1343          if ((i+1) < argc) {
1344            val = argv[i+1];
1345            num_elide = 2;
1346          } else {
1347            arg_error = 1;
1348          }
1349        }
1350
1351        if (val) {
1352          stack_size = parse_numeric_option(val, 
1353                                            "-Z/--thread-stack-size", 
1354                                            thread_stack_size);
1355         
1356
1357          if (stack_size >= MIN_CSTACK_SIZE) {
1358           thread_stack_size = stack_size;
1359          }
1360          if (thread_stack_size >= (1LL<<((WORD_SIZE-fixnumshift)-1))) {
1361            thread_stack_size = (1LL<<((WORD_SIZE-fixnumshift)-1))-1;
1362          }
1363         
1364        }
1365
1366      } else if (strcmp(arg, "--no-sigtrap") == 0) {
1367        no_sigtrap = 1;
1368        num_elide = 1;
1369      } else if ((strcmp(arg, "-b") == 0) ||
1370                 (strcmp(arg, "--batch") == 0)) {
1371        batch_flag = 1;
1372        num_elide = 1;
1373      } else if ((strcmp (arg, "-d") == 0) ||
1374                 (strcmp (arg, "--debug")  == 0)) {
1375        redirect_debugger_io();
1376        num_elide=1;
1377       
1378        } else if (strcmp(arg,"--") == 0) {
1379                     
1380        break;
1381      } else {
1382        i++;
1383      }
1384      if (arg_error) {
1385        usage_exit("error in program arguments", 1, "");
1386      }
1387      if (num_elide) {
1388        for (j = i+num_elide, k=i; j < argc; j++, k++) {
1389          argv[k] = argv[j];
1390          if (shadow) {
1391            shadow[k] = shadow[j];
1392          }
1393        }
1394        argc -= num_elide;
1395#ifdef DARWIN
1396        NXArgc -= num_elide;
1397#endif
1398        argv[argc] = NULL;
1399        if (shadow) {
1400          shadow[argc] = NULL;
1401        }
1402      }
1403    }
1404  }
1405  redirect_debugger_io();
1406#if 0
1407  fprintf(dbgout,"ccl pid = %d", getpid());
1408  sleep(20);
1409#endif
1410
1411
1412}
1413
1414#ifdef WINDOWS
1415void
1416terminate_lisp()
1417{
1418  _exit(EXIT_FAILURE);
1419}
1420#else
1421pid_t main_thread_pid = (pid_t)0;
1422
1423void
1424terminate_lisp()
1425{
1426  kill(main_thread_pid, SIGKILL);
1427  _exit(-1);
1428}
1429#endif
1430
1431#ifdef DARWIN
1432#define min_os_version "8.0"    /* aka Tiger */
1433#endif
1434#ifdef LINUX
1435#ifdef PPC
1436#define min_os_version "2.2"
1437#endif
1438#ifdef X86
1439#define min_os_version "2.6"
1440#endif
1441#ifdef ARM
1442#define min_os_version "2.6"
1443#endif
1444#endif
1445#ifdef FREEBSD
1446#define min_os_version "6.0"
1447#endif
1448#ifdef SOLARIS
1449#define min_os_version "5.10"
1450#endif
1451
1452#ifdef PPC
1453#if defined(PPC64) || !defined(DARWIN)
1454/* ld64 on Darwin doesn't offer anything close to reliable control
1455   over the layout of a program in memory.  About all that we can
1456   be assured of is that the canonical subprims jump table address
1457   (currently 0x5000) is unmapped.  Map that page, and copy the
1458   actual spjump table there. */
1459
1460
1461void
1462remap_spjump()
1463{
1464  extern opcode spjump_start, spjump_end;
1465  pc new,
1466    old = &spjump_start,
1467    limit = &spjump_end,
1468    work;
1469  opcode instr;
1470  void *target;
1471  int disp;
1472 
1473  if (old != (pc)SPJUMP_TARGET_ADDRESS) {
1474    new = mmap((pc) SPJUMP_TARGET_ADDRESS,
1475               0x1000,
1476               PROT_READ | PROT_WRITE | PROT_EXEC,
1477               MAP_PRIVATE | MAP_ANON | MAP_FIXED,
1478               -1,
1479               0);
1480    if (new != (pc) SPJUMP_TARGET_ADDRESS) {
1481      perror("remap spjump");
1482      _exit(1);
1483    }
1484   
1485    for (work = new; old < limit; work++, old++) {
1486      instr = *old;
1487      disp = instr & ((1<<26)-1);
1488      target = (void*)old+disp;
1489      disp = target-(void *)work;
1490      *work = ((instr >> 26) << 26) | disp;
1491    }
1492    xMakeDataExecutable((void *)new, (natural)work-(natural)new);
1493    ProtectMemory(new, 0x1000);
1494  }
1495}
1496#endif
1497#endif
1498
1499#ifdef X86
1500#ifdef WINDOWS
1501
1502/* By using linker tricks, we ensure there's memory between 0x11000
1503   and 0x21000, so we just need to fix permissions and copy the spjump
1504   table. */
1505
1506void
1507remap_spjump()
1508{
1509  extern opcode spjump_start;
1510  DWORD old_protect;
1511
1512  if ((void *)(&spjump_start) != (void *) SPJUMP_TARGET_ADDRESS) {
1513    if (!VirtualProtect((pc) SPJUMP_TARGET_ADDRESS,
1514                        0x1000,
1515                        PAGE_READWRITE,
1516                        &old_protect)) {
1517      wperror("VirtualProtect spjump");
1518      _exit(1);
1519    }
1520    memmove((pc) SPJUMP_TARGET_ADDRESS, &spjump_start, 0x1000);
1521  }
1522}
1523#else
1524void
1525remap_spjump()
1526{
1527  extern opcode spjump_start;
1528  pc new = mmap((pc) SPJUMP_TARGET_ADDRESS,
1529                0x1000,
1530                PROT_READ | PROT_WRITE,
1531                MAP_PRIVATE | MAP_ANON | MAP_FIXED,
1532                -1,
1533                0),
1534    old = &spjump_start;
1535  if (new == (pc)-1) {
1536    perror("remap spjump");
1537    _exit(1);
1538  }
1539  memmove(new, old, 0x1000);
1540}
1541#endif
1542#endif
1543
1544
1545void
1546check_os_version(char *progname)
1547{
1548#ifdef WINDOWS
1549  /* 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. */
1550#else
1551  struct utsname uts;
1552  long got, want;
1553  char *got_end,*want_end;
1554
1555  want = strtoul(min_os_version,&want_end,10);
1556
1557  uname(&uts);
1558  got = strtoul(uts.release,&got_end,10);
1559#if defined(X8632) && defined(FREEBSD)
1560  if (!strcmp(uts.machine,"amd64")) {
1561    extern Boolean rcontext_readonly;
1562
1563    rcontext_readonly = true;
1564  }
1565#endif
1566#ifdef WIN_32
1567  rcontext_readonly = true;
1568#endif
1569  while (got == want) {
1570    if (*want_end == '.') {
1571      want = strtoul(want_end+1,&want_end,10);
1572      got = 0;
1573      if (*got_end == '.') {
1574        got = strtoul(got_end+1,&got_end,10);
1575      } else {
1576        break;
1577      }
1578    } else {
1579      break;
1580    }
1581  }
1582
1583  if (got < want) {
1584    fprintf(dbgout, "\n%s requires %s version %s or later; the current version is %s.\n", progname, uts.sysname, min_os_version, uts.release);
1585    exit(1);
1586  }
1587#endif
1588}
1589
1590#ifdef X86
1591/*
1592  This should determine the cache block size.  It should also
1593  probably complain if we don't have (at least) SSE2.
1594*/
1595extern int cpuid(natural, natural*, natural*, natural*);
1596
1597#define X86_FEATURE_CMOV    (1<<15)
1598#define X86_FEATURE_CLFLUSH (1<<19)
1599#define X86_FEATURE_MMX     (1<<23)
1600#define X86_FEATURE_SSE     (1<<25)
1601#define X86_FEATURE_SSE2    (1<<26)
1602
1603#define X86_REQUIRED_FEATURES (X86_FEATURE_CMOV|X86_FEATURE_MMX|X86_FEATURE_SSE|X86_FEATURE_SSE2)
1604
1605Boolean
1606check_x86_cpu()
1607{
1608  natural eax, ebx, ecx, edx;
1609
1610  eax = cpuid(0, &ebx, &ecx, &edx);
1611
1612  if (eax >= 1) {
1613    eax = cpuid(1, &ebx, &ecx, &edx);
1614    cache_block_size = (ebx & 0xff00) >> 5;
1615    if ((X86_REQUIRED_FEATURES & edx) == X86_REQUIRED_FEATURES) {
1616      return true;
1617    }
1618    /* It's very unlikely that SSE2 would be present and other things
1619       that we want wouldn't.  If they don't have MMX or CMOV either,
1620       might as well tell them. */
1621    if ((edx & X86_FEATURE_SSE2) == 0) {
1622      fprintf(dbgout, "This CPU doesn't support the SSE2 instruction set\n");
1623    }
1624    if ((edx & X86_FEATURE_MMX) == 0) {
1625      fprintf(dbgout, "This CPU doesn't support the MMX instruction set\n");
1626    }
1627    if ((edx & X86_FEATURE_CMOV) == 0) {
1628      fprintf(dbgout, "This CPU doesn't support the CMOV instruction\n");
1629    }
1630   
1631  }
1632  return false;
1633}
1634#endif
1635
1636#ifdef ARM
1637int
1638arm_architecture_version = 7;
1639
1640Boolean
1641check_arm_cpu()
1642{
1643  Boolean win = false;
1644#ifdef LINUX
1645  extern void feature_check(), early_signal_handler();
1646
1647  install_signal_handler(SIGILL, (void *)early_signal_handler,0);
1648  feature_check();
1649  win = arm_architecture_version >= 6;
1650  install_signal_handler(SIGILL, NULL, 0);
1651
1652#endif
1653  return win;
1654}
1655#endif 
1656
1657void
1658lazarus()
1659{
1660  TCR *tcr = get_tcr(false);
1661  if (tcr) {
1662    /* Some threads may be dying; no threads should be created. */
1663    LOCK(lisp_global(TCR_AREA_LOCK),tcr);
1664    tcr->vs_area->active = tcr->vs_area->high - node_size;
1665    tcr->save_vsp = (LispObj *)(tcr->vs_area->active);
1666#ifndef ARM
1667    tcr->ts_area->active = tcr->ts_area->high;
1668    tcr->save_tsp = (LispObj *)(tcr->ts_area->active);
1669#endif
1670    tcr->catch_top = 0;
1671    tcr->db_link = 0;
1672    tcr->xframe = 0;
1673    start_lisp(tcr, 0);
1674  }
1675}
1676
1677#ifdef LINUX
1678#ifdef X8664
1679#include <asm/prctl.h>
1680#include <sys/prctl.h>
1681
1682void
1683ensure_gs_available(char *progname)
1684{
1685  LispObj fs_addr = 0L, gs_addr = 0L, cur_thread = (LispObj)pthread_self();
1686  char *gnu_get_libc_version(void);
1687 
1688  arch_prctl(ARCH_GET_GS, &gs_addr);
1689  arch_prctl(ARCH_GET_FS, &fs_addr);
1690  if ((gs_addr == cur_thread) && (fs_addr != cur_thread)) {
1691    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);
1692    _exit(1);
1693  }
1694}
1695#endif
1696#endif
1697
1698Boolean
1699bogus_fp_exceptions = false;
1700
1701typedef
1702float (*float_arg_returns_float)(float);
1703
1704float
1705fcallf(float_arg_returns_float fun, float arg)
1706{
1707  return fun(arg);
1708}
1709
1710void
1711check_bogus_fp_exceptions()
1712{
1713#ifdef X8664
1714  float asinf(float),result;
1715   
1716
1717  natural save_mxcsr = get_mxcsr(), post_mxcsr;
1718  set_mxcsr(0x1f80);
1719
1720  result = fcallf(asinf, 1.0);
1721  post_mxcsr = get_mxcsr();
1722  set_mxcsr(save_mxcsr);
1723  if (post_mxcsr & (FE_ALL_EXCEPT & (~FE_INEXACT))) {
1724    bogus_fp_exceptions = true;
1725  }
1726#endif
1727}
1728
1729#ifdef WINDOWS
1730char *
1731utf_16_to_utf_8(wchar_t *utf_16)
1732{
1733  int utf8len = WideCharToMultiByte(CP_UTF8,
1734                                    0,
1735                                    utf_16,
1736                                    -1,
1737                                    NULL,
1738                                    0,
1739                                    NULL,
1740                                    NULL);
1741
1742  char *utf_8 = malloc(utf8len);
1743
1744  WideCharToMultiByte(CP_UTF8,
1745                      0,
1746                      utf_16,
1747                      -1,
1748                      utf_8,
1749                      utf8len,
1750                      NULL,
1751                      NULL);
1752
1753  return utf_8;
1754}
1755
1756char **
1757wide_argv_to_utf_8(wchar_t *wide_argv[], int argc)
1758{
1759  char** argv = calloc(argc+1,sizeof(char *));
1760  int i;
1761
1762  for (i = 0; i < argc; i++) {
1763    if (wide_argv[i]) {
1764      argv[i] = utf_16_to_utf_8(wide_argv[i]);
1765    } else {
1766      argv[i] = NULL;
1767    }
1768  }
1769  return argv;
1770}
1771#endif
1772
1773natural default_g0_threshold = G0_AREA_THRESHOLD;
1774natural default_g1_threshold = G1_AREA_THRESHOLD;
1775natural default_g2_threshold = G2_AREA_THRESHOLD;
1776natural lisp_heap_threshold_from_image = 0;
1777
1778void
1779init_consing_areas()
1780{
1781  area *a;
1782  a = active_dynamic_area;
1783
1784  if (nilreg_area != NULL) {
1785    BytePtr lowptr = (BytePtr) a->low;
1786
1787    /* Create these areas as AREA_STATIC, change them to AREA_DYNAMIC */
1788    g1_area = new_area(lowptr, lowptr, AREA_STATIC);
1789    g2_area = new_area(lowptr, lowptr, AREA_STATIC);
1790    add_area_holding_area_lock(g2_area);
1791    add_area_holding_area_lock(g1_area);
1792    add_area_holding_area_lock(tenured_area);
1793    g1_area->code = AREA_DYNAMIC;
1794    g2_area->code = AREA_DYNAMIC;
1795    tenured_area->code = AREA_DYNAMIC;
1796
1797/*    a->older = g1_area; */ /* Not yet: this is what "enabling the EGC" does. */
1798    g1_area->younger = a;
1799    g1_area->older = g2_area;
1800    g2_area->younger = g1_area;
1801    g2_area->older = tenured_area;
1802    tenured_area->younger = g2_area;
1803    tenured_area->refbits = dynamic_mark_ref_bits;
1804    tenured_area->refidx = dynamic_refidx;
1805    managed_static_area->refbits = global_mark_ref_bits;
1806    managed_static_area->refidx = global_refidx;
1807    a->markbits = dynamic_mark_ref_bits;
1808    tenured_area->static_dnodes = a->static_dnodes;
1809    a->static_dnodes = 0;
1810    tenured_area->static_used = a->static_used;
1811    a->static_used = 0;
1812    lisp_global(TENURED_AREA) = ptr_to_lispobj(tenured_area);
1813    lisp_global(STATIC_CONS_AREA) = ptr_to_lispobj(static_cons_area);
1814    lisp_global(REFBITS) = ptr_to_lispobj(global_mark_ref_bits);
1815    lisp_global(EPHEMERAL_REFIDX) = ptr_to_lispobj(global_refidx);
1816    g2_area->threshold = default_g2_threshold;
1817    g1_area->threshold = default_g1_threshold;
1818    a->threshold = default_g0_threshold;
1819    if (static_cons_area && static_cons_area->ndnodes) {
1820      lower_heap_start(static_cons_area->low, tenured_area);
1821    }
1822  }
1823}
1824
1825int
1826#ifdef CCLSHARED
1827cclmain
1828#else
1829main
1830#endif
1831(int argc, char *argv[]
1832#if defined(PPC) && defined(LINUX)
1833, char *envp[], void *aux
1834#endif
1835)
1836{
1837  extern int page_size;
1838  Boolean egc_enabled =
1839#ifdef DISABLE_EGC
1840    false
1841#else
1842    true
1843#endif
1844    ;
1845  Boolean lisp_heap_threshold_set_from_command_line = false;
1846  wchar_t **utf_16_argv = NULL;
1847
1848#ifdef PPC
1849  extern int altivec_present;
1850#endif
1851#ifdef WINDOWS
1852  extern LispObj load_image(wchar_t *);
1853#else
1854  extern LispObj load_image(char *);
1855#endif
1856  area *a;
1857  BytePtr stack_base, current_sp = (BytePtr) current_stack_pointer();
1858  TCR *tcr;
1859
1860  dbgout = stderr;
1861
1862#ifdef WINDOWS
1863  {
1864    int wide_argc;
1865    extern void init_winsock(void);
1866    extern void init_windows_io(void);
1867    extern void reserve_tls_slots(void);
1868
1869    _fmode = O_BINARY;
1870    _setmode(1, O_BINARY);
1871    _setmode(2, O_BINARY);
1872    setvbuf(dbgout, NULL, _IONBF, 0);
1873    init_winsock();
1874    init_windows_io();
1875    reserve_tls_slots();
1876    utf_16_argv = CommandLineToArgvW(GetCommandLineW(),&wide_argc);
1877  }
1878#endif
1879
1880  check_os_version(argv[0]);
1881#ifdef WINDOWS
1882  real_executable_name = determine_executable_name();
1883#else
1884  real_executable_name = determine_executable_name(argv[0]);
1885#endif
1886  page_size = getpagesize(); /* Implement with GetSystemInfo on Windows w/o MinGW */
1887
1888  check_bogus_fp_exceptions();
1889#ifdef LINUX
1890#ifdef X8664
1891  ensure_gs_available(real_executable_name);
1892#endif
1893#endif
1894#if (defined(DARWIN) && defined(PPC64)) || (defined(LINUX) && defined(PPC))|| defined(X8664) || (defined(X8632) && !defined(DARWIN))
1895  remap_spjump();
1896#endif
1897
1898#ifdef PPC
1899#ifdef LINUX
1900  {
1901    ElfW(auxv_t) *av = aux;
1902    int hwcap, done = false;
1903   
1904    if (av) {
1905      do {
1906        switch (av->a_type) {
1907        case AT_DCACHEBSIZE:
1908          cache_block_size = av->a_un.a_val;
1909          break;
1910
1911        case AT_HWCAP:
1912          hwcap = av->a_un.a_val;
1913          altivec_present = ((hwcap & PPC_FEATURE_HAS_ALTIVEC) != 0);
1914          break;
1915
1916        case AT_NULL:
1917          done = true;
1918          break;
1919        }
1920        av++;
1921      } while (!done);
1922    }
1923  }
1924#endif
1925#ifdef DARWIN
1926  {
1927    unsigned value = 0;
1928    size_t len = sizeof(value);
1929    int mib[2];
1930   
1931    mib[0] = CTL_HW;
1932    mib[1] = HW_CACHELINE;
1933    if (sysctl(mib,2,&value,&len, NULL, 0) != -1) {
1934      if (len == sizeof(value)) {
1935        cache_block_size = value;
1936      }
1937    }
1938    mib[1] = HW_VECTORUNIT;
1939    value = 0;
1940    len = sizeof(value);
1941    if (sysctl(mib,2,&value,&len, NULL, 0) != -1) {
1942      if (len == sizeof(value)) {
1943        altivec_present = value;
1944      }
1945    }
1946  }
1947#endif
1948#endif
1949
1950#ifdef X86
1951  if (!check_x86_cpu()) {
1952    fprintf(dbgout, "CPU doesn't support required features\n");
1953    exit(1);
1954  }
1955#endif
1956
1957#ifdef ARM
1958  if (!check_arm_cpu()) {
1959    fprintf(dbgout, "CPU doesn't support required features\n");
1960    exit(1);
1961  }
1962#endif
1963
1964#ifdef SOLARIS
1965#ifdef X8632
1966  {
1967    extern void solaris_ldt_init(void);
1968    solaris_ldt_init();
1969  }
1970#endif
1971#endif
1972
1973#ifndef WINDOWS
1974  main_thread_pid = getpid();
1975#endif
1976  tcr_area_lock = (void *)new_recursive_lock();
1977
1978  program_name = argv[0];
1979#ifdef SINGLE_ARG_SHORTHAND
1980  if ((argc == 2) && (*argv[1] != '-')) {
1981#ifdef WINDOWS
1982    image_name = utf_16_argv[1];
1983#else
1984    image_name = argv[1];
1985#endif
1986    argv[1] = NULL;
1987#ifdef WINDOWS
1988    utf_16_argv[1] = NULL;
1989#endif
1990  } else {
1991#endif  /* SINGLE_ARG_SHORTHAND */
1992    process_options(argc,argv,utf_16_argv);
1993#ifdef SINGLE_ARG_SHORTHAND
1994  }
1995#endif
1996  if (lisp_heap_gc_threshold != DEFAULT_LISP_HEAP_GC_THRESHOLD) {
1997    lisp_heap_threshold_set_from_command_line = true;
1998  }
1999
2000  initial_stack_size = ensure_stack_limit(initial_stack_size);
2001  if (image_name == NULL) {
2002    if (check_for_embedded_image(real_executable_name)) {
2003      image_name = real_executable_name;
2004    } else {
2005      image_name = default_image_name(real_executable_name);
2006#ifdef DARWIN
2007      if (!probe_file(image_name)) {
2008        image_name = bundle_image_name(real_executable_name);
2009      }
2010#endif
2011    }
2012  }
2013
2014  while (1) {
2015    if (create_reserved_area(reserved_area_size)) {
2016      break;
2017    }
2018    reserved_area_size = reserved_area_size *.9;
2019  }
2020
2021  gc_init();
2022
2023  set_nil(load_image(image_name));
2024  lisp_heap_notify_threshold = lisp_global(GC_NOTIFY_THRESHOLD);
2025  lisp_heap_threshold_from_image = lisp_global(LISP_HEAP_THRESHOLD);
2026 
2027  if (lisp_heap_threshold_from_image) {
2028    if ((!lisp_heap_threshold_set_from_command_line) &&
2029        (lisp_heap_threshold_from_image != lisp_heap_gc_threshold)) {
2030      lisp_heap_gc_threshold = lisp_heap_threshold_from_image;
2031      resize_dynamic_heap(active_dynamic_area->active,lisp_heap_gc_threshold);
2032    }
2033    /* If lisp_heap_threshold_from_image was set, other image params are
2034       valid. */
2035    default_g0_threshold = lisp_global(G0_THRESHOLD);
2036    default_g1_threshold = lisp_global(G1_THRESHOLD);
2037    default_g2_threshold = lisp_global(G2_THRESHOLD);
2038    egc_enabled = lisp_global(EGC_ENABLED);
2039  }
2040
2041  lisp_global(TCR_AREA_LOCK) = ptr_to_lispobj(tcr_area_lock);
2042
2043#ifdef X86
2044  lisp_global(SUBPRIMS_BASE) = (LispObj)((1<<16)+(5<<10));
2045#endif
2046#ifdef PPC
2047  lisp_global(SUBPRIMS_BASE) = (LispObj)(5<<10);
2048#endif
2049#ifdef ARM
2050  lisp_global(SUBPRIMS_BASE) = (LispObj)(9<<12);
2051#endif
2052
2053  lisp_global(RET1VALN) = (LispObj)&ret1valn;
2054  lisp_global(LEXPR_RETURN) = (LispObj)&nvalret;
2055  lisp_global(LEXPR_RETURN1V) = (LispObj)&popj;
2056  lisp_global(ALL_AREAS) = ptr_to_lispobj(all_areas);
2057  lisp_global(DEFAULT_ALLOCATION_QUANTUM) = log2_heap_segment_size << fixnumshift;
2058  lisp_global(STACK_SIZE) = thread_stack_size<<fixnumshift;
2059
2060
2061  exception_init();
2062
2063 
2064
2065#ifdef WINDOWS
2066  lisp_global(IMAGE_NAME) = ptr_to_lispobj(utf_16_to_utf_8(ensure_real_path(image_name)));
2067  lisp_global(KERNEL_PATH) = ptr_to_lispobj(utf_16_to_utf_8(real_executable_name));
2068  lisp_global(ARGV) = ptr_to_lispobj(wide_argv_to_utf_8(utf_16_argv, argc));
2069#else
2070  lisp_global(IMAGE_NAME) = ptr_to_lispobj(ensure_real_path(image_name));
2071  lisp_global(KERNEL_PATH) = ptr_to_lispobj(real_executable_name);
2072  lisp_global(ARGV) = ptr_to_lispobj(argv);
2073#endif
2074  lisp_global(KERNEL_IMPORTS) = (LispObj)import_ptrs_base;
2075
2076  lisp_global(GET_TCR) = (LispObj) get_tcr;
2077  *(double *) &(lisp_global(DOUBLE_FLOAT_ONE)) = (double) 1.0;
2078
2079  lisp_global(HOST_PLATFORM) = (LispObj) PLATFORM << fixnumshift;
2080
2081  lisp_global(BATCH_FLAG) = (batch_flag << fixnumshift);
2082
2083  init_consing_areas();
2084  tcr = new_tcr(initial_stack_size, MIN_TSTACK_SIZE);
2085  stack_base = initial_stack_bottom()-xStackSpace();
2086  init_threads((void *)(stack_base), tcr);
2087  thread_init_tcr(tcr, current_sp, current_sp-stack_base);
2088
2089  if (lisp_global(STATIC_CONSES) == 0) {
2090    lisp_global(STATIC_CONSES) = lisp_nil;
2091  }
2092
2093  lisp_global(EXCEPTION_LOCK) = ptr_to_lispobj(new_recursive_lock());
2094  enable_fp_exceptions();
2095  register_user_signal_handler();
2096
2097#ifdef PPC
2098  lisp_global(ALTIVEC_PRESENT) = altivec_present << fixnumshift;
2099#endif
2100#ifdef ARM
2101#if defined (__ARM_PCS_VFP)
2102 /* would be nice if there was a way to test for this (armhf) at runtime */
2103  lisp_global(FLOAT_ABI) = 1 << fixnumshift;
2104#else
2105  fprintf(dbgout,"lisp kernel support for the ARM soft-float ABI has been deprecated\n");
2106#endif
2107#endif
2108#if STATIC
2109  lisp_global(STATICALLY_LINKED) = 1 << fixnumshift;
2110#endif
2111  TCR_AUX(tcr)->prev = TCR_AUX(tcr)->next = tcr;
2112#ifndef WINDOWS
2113  lisp_global(INTERRUPT_SIGNAL) = (LispObj) box_fixnum(SIGNAL_FOR_PROCESS_INTERRUPT);
2114#endif
2115  tcr->vs_area->active -= node_size;
2116  *(--tcr->save_vsp) = nrs_TOPLFUNC.vcell;
2117  nrs_TOPLFUNC.vcell = lisp_nil;
2118#ifdef GC_INTEGRITY_CHECKING
2119  (nrs_GC_EVENT_STATUS_BITS.vcell |= gc_integrity_check_bit);
2120#endif
2121  if (egc_enabled) {
2122    egc_control(true, NULL);
2123  } else {
2124    lisp_global(OLDSPACE_DNODE_COUNT) = 0;
2125  }
2126  heap_dirty_limit = active_dynamic_area->active;
2127  lisp_global(MANAGED_STATIC_REFBITS) = (LispObj)managed_static_refbits;
2128  lisp_global(MANAGED_STATIC_REFIDX) = (LispObj)managed_static_refidx;
2129  lisp_global(MANAGED_STATIC_DNODES) = (LispObj)managed_static_area->ndnodes;
2130#ifdef ANDROID
2131  /* In some versions of Android, atexit() generates a runtime warning
2132     about the dangers of using atexit() with shared libraries.
2133     Android is what it is.  It's a steaming pile of what it is, in fact.
2134  */
2135  {
2136    extern int __cxa_atexit(void (*) (void *), void *, void *);
2137    __cxa_atexit(lazarus, NULL, NULL);
2138  }
2139#else
2140  atexit(lazarus);
2141#endif
2142#ifdef ARM
2143#ifdef LINUX
2144#ifdef SET_INITIAL_THREAD_AFFINITY
2145  /* Maybe work around an apparent cache coherency problem */
2146  set_thread_affinity(tcr,0);
2147#endif
2148#endif
2149#endif
2150  start_lisp(TCR_TO_TSD(tcr), 0);
2151  _exit(0);
2152}
2153
2154area *
2155set_nil(LispObj r)
2156{
2157
2158  if (lisp_nil == (LispObj)NULL) {
2159
2160    lisp_nil = r;
2161  }
2162  return NULL;
2163}
2164
2165
2166void
2167xMakeDataExecutable(BytePtr start, natural nbytes)
2168{
2169#ifdef PPC
2170  extern void flush_cache_lines();
2171  natural ustart = (natural) start, base, end;
2172 
2173  base = (ustart) & ~(cache_block_size-1);
2174  end = (ustart + nbytes + cache_block_size - 1) & ~(cache_block_size-1);
2175  flush_cache_lines(base, (end-base)/cache_block_size, cache_block_size);
2176#endif
2177#ifdef ARM
2178  extern void flush_cache_lines(void *, size_t);
2179  flush_cache_lines(start,nbytes);
2180#endif
2181}
2182
2183natural
2184xStackSpace()
2185{
2186  return initial_stack_size+CSTACK_HARDPROT+CSTACK_SOFTPROT;
2187}
2188
2189#ifndef DARWIN
2190#ifdef WINDOWS
2191extern void *windows_open_shared_library(char *);
2192
2193void *
2194xGetSharedLibrary(char *path, int mode)
2195{
2196  return windows_open_shared_library(path);
2197}
2198#else
2199void *
2200xGetSharedLibrary(char *path, int mode)
2201{
2202  return dlopen(path, mode);
2203}
2204#endif
2205#else
2206void *
2207xGetSharedLibrary(char *path, int *resultType)
2208{
2209  const char *error;
2210  void *result;
2211
2212  result = dlopen(path, RTLD_NOW | RTLD_GLOBAL);
2213 
2214  if (result == NULL) {
2215    error = dlerror();
2216    *resultType = 0;
2217    return (void *)error;
2218  }
2219  *resultType = 1;
2220  return result;
2221}
2222#endif
2223
2224
2225
2226int
2227fd_setsize_bytes()
2228{
2229  return sizeof(fd_set);
2230}
2231
2232void
2233do_fd_set(int fd, fd_set *fdsetp)
2234{
2235  FD_SET(fd, fdsetp);
2236}
2237
2238void
2239do_fd_clr(int fd, fd_set *fdsetp)
2240{
2241  FD_CLR(fd, fdsetp);
2242}
2243
2244int
2245do_fd_is_set(int fd, fd_set *fdsetp)
2246{
2247  return FD_ISSET(fd,fdsetp);
2248}
2249
2250
2251void
2252do_fd_zero(fd_set *fdsetp)
2253{
2254  FD_ZERO(fdsetp);
2255}
2256
2257#include "image.h"
2258
2259
2260
2261Boolean
2262check_for_embedded_image (
2263#ifdef WINDOWS
2264                          wchar_t *path
2265#else
2266                          char *path
2267#endif
2268                          )
2269{
2270#ifdef WINDOWS
2271  int fd = wopen(path, O_RDONLY);
2272#else 
2273  int fd = open(path, O_RDONLY);
2274#endif
2275
2276  Boolean image_is_embedded = false;
2277
2278  if (fd >= 0) {
2279    openmcl_image_file_header h;
2280
2281    if (find_openmcl_image_file_header (fd, &h)) {
2282      image_is_embedded = true;
2283    }
2284    close (fd);
2285  }
2286  return image_is_embedded;
2287}
2288
2289LispObj
2290load_image(
2291#ifdef WINDOWS
2292           wchar_t * path
2293#else
2294           char *path
2295#endif
2296)
2297{
2298#ifdef WINDOWS
2299  int fd = wopen(path, O_RDONLY, 0666), err;
2300#else
2301  int fd = open(path, O_RDONLY, 0666), err;
2302#endif
2303  LispObj image_nil = 0;
2304
2305  if (fd > 0) {
2306    openmcl_image_file_header ih;
2307
2308    errno = 0;
2309    image_nil = load_openmcl_image(fd, &ih);
2310    /* We -were- using a duplicate fd to map the file; that
2311       seems to confuse Darwin (doesn't everything ?), so
2312       we'll instead keep the original file open.
2313    */
2314    err = errno;
2315    if (!image_nil) {
2316      close(fd);
2317    }
2318#ifdef WINDOWS
2319    /* We currently don't actually map the image, and leaving the file
2320       open seems to make it difficult to write to reliably. */
2321    if (image_nil) {
2322      close(fd);
2323    }
2324#endif
2325  } else {
2326    err = errno;
2327  }
2328#ifdef DARWIN
2329#ifdef X86
2330  if (image_nil == 0) {
2331    extern LispObj load_native_library(char *);
2332    image_nil = load_native_library(path);
2333  }
2334#endif
2335#endif
2336  if (image_nil == 0) {
2337#ifdef WINDOWS
2338    char *fmt = "Couldn't load lisp heap image from %ls";
2339#else
2340    char *fmt = "Couldn't load lisp heap image from %s";
2341#endif
2342
2343    fprintf(dbgout, fmt, path);
2344    if (err == 0) {
2345      fprintf(dbgout, "\n");
2346    } else {
2347      fprintf(dbgout, ": %s\n", strerror(err));
2348    }
2349    exit(-1);
2350  }
2351  return image_nil;
2352}
2353
2354int
2355set_errno(int val)
2356{
2357  errno = val;
2358  return -1;
2359}
2360
2361/* A horrible hack to allow us to initialize a JVM instance from lisp.
2362   On Darwin, creating a JVM instance clobbers the thread's existing
2363   Mach exception infrastructure, so we save and restore it here.
2364*/
2365
2366typedef int (*jvm_initfunc)(void*,void*,void*);
2367
2368int
2369jvm_init(jvm_initfunc f,void*arg0,void*arg1,void*arg2)
2370{
2371  int result = -1;
2372  TCR *tcr = get_tcr(1);
2373#ifdef DARWIN
2374  extern kern_return_t tcr_establish_lisp_exception_port(TCR *);
2375#endif
2376 
2377  result = f(arg0,arg1,arg2);
2378#ifdef DARWIN
2379  tcr_establish_lisp_exception_port(tcr);
2380#endif
2381  return result;
2382}
2383
2384
2385void *
2386xFindSymbol(void* handle, char *name)
2387{
2388#if defined(LINUX) || defined(FREEBSD) || defined(SOLARIS)
2389#ifdef ANDROID
2390  if (handle == NULL) {
2391    handle = RTLD_DEFAULT;
2392  }
2393#endif
2394  return dlsym(handle, name);
2395#endif
2396#ifdef DARWIN
2397  void *result;
2398
2399  if ((handle == NULL) || (handle == ((void *) -1))) {
2400    handle = RTLD_DEFAULT;
2401  }   
2402  result = dlsym(handle, name);
2403  if ((result == NULL) && (*name == '_')) {
2404    result = dlsym(handle, name+1);
2405  }
2406  return result;
2407#endif
2408#ifdef WINDOWS
2409  extern void *windows_find_symbol(void *, char *);
2410  return windows_find_symbol(handle, name);
2411#endif
2412}
2413#if defined(LINUX) || defined(FREEBSD) || defined(SOLARIS)
2414#if WORD_SIZE == 64
2415typedef Elf64_Dyn Elf_Dyn_thing;
2416typedef Elf64_Ehdr Elf_Ehdr_thing;
2417typedef Elf64_Shdr Elf_Shdr_thing;
2418#else
2419typedef Elf32_Dyn Elf_Dyn_thing;
2420typedef Elf32_Ehdr Elf_Ehdr_thing;
2421typedef Elf32_Shdr Elf_Shdr_thing;
2422#endif
2423
2424#ifdef ANDROID
2425extern Elf_Dyn_thing *android_executable_dynamic_section = NULL;
2426#endif
2427
2428
2429Elf_Dyn_thing *
2430get_executable_dynamic_entries()
2431{
2432#ifndef CCLSHARED
2433  extern Elf_Dyn_thing _DYNAMIC[];
2434  return _DYNAMIC;
2435#else
2436#ifdef ANDROID
2437  extern Elf_Dyn_thing *android_executable_dynamic_section;
2438
2439  Elf_Dyn_thing *result = android_executable_dynamic_section;
2440  return result;
2441#else
2442#error need implementation for get_executable_dynamic_entries from dso
2443#endif
2444#endif
2445}
2446
2447
2448void *cached_r_debug = NULL;
2449
2450void *
2451get_r_debug()
2452{
2453  int tag;
2454  Elf_Dyn_thing *dp;
2455
2456  if (cached_r_debug == NULL) {
2457    for (dp = get_executable_dynamic_entries(); (tag = dp->d_tag) != 0; dp++) {
2458      if (tag == DT_DEBUG) {
2459        cached_r_debug = (void *)(dp->d_un.d_ptr);
2460        break;
2461      }
2462    }
2463  }
2464  return cached_r_debug;
2465}
2466
2467#else
2468void *
2469get_r_debug()
2470{
2471  return NULL;
2472}
2473#endif
2474
2475#ifdef WINDOWS
2476void
2477sample_paging_info(paging_info *stats)
2478{
2479}
2480
2481void
2482report_paging_info_delta(FILE *out, paging_info *start, paging_info *stop)
2483{
2484}
2485#else
2486void
2487sample_paging_info(paging_info *stats)
2488{
2489  getrusage(RUSAGE_SELF, stats);
2490}
2491
2492void
2493report_paging_info_delta(FILE *out, paging_info *start, paging_info *stop)
2494{
2495  fprintf(out,";;; %ld soft faults, %ld faults, %ld pageins\n\n",
2496          stop->ru_minflt-start->ru_minflt,
2497          stop->ru_majflt-start->ru_majflt,
2498          stop->ru_nswap-start->ru_nswap);
2499}
2500
2501#endif
2502
2503void
2504allocate_static_conses(natural n)
2505{
2506  BytePtr old_low = static_cons_area->low,
2507    new_low = old_low - (n<<dnode_shift);
2508  cons *c;
2509  natural i;
2510  LispObj prev;
2511
2512  CommitMemory(new_low,old_low-new_low);
2513
2514  static_cons_area->low = new_low;
2515  lower_heap_start(new_low, tenured_area);
2516  /* what a mess this is ... */
2517  if (active_dynamic_area->low == old_low) {
2518    active_dynamic_area->low = new_low;
2519  }
2520  if (!active_dynamic_area->older) {
2521    active_dynamic_area->markbits = tenured_area->refbits;
2522  }
2523  if (g1_area->low == old_low) {
2524    g1_area->low = new_low;
2525  }
2526  if (g1_area->high == old_low) {
2527    g1_area->high = new_low;
2528  }
2529  if (g2_area->low == old_low) {
2530    g2_area->low = new_low;
2531  }
2532  if (g2_area->high == old_low) {
2533    g2_area->high = new_low;
2534  }
2535  for (i=0, prev=lisp_global(STATIC_CONSES), c=(cons *)new_low;
2536       i < n;
2537       i++, c++) {
2538    c->car = unbound;
2539    c->cdr = prev;
2540    prev = ((LispObj)c)+fulltag_cons;
2541  }
2542  lisp_global(STATIC_CONSES)=prev;
2543  lisp_global(FREE_STATIC_CONSES)+=(n<<fixnumshift);
2544}
2545
2546#ifdef X86
2547#define USE_GC_NOTIFICATION 1
2548#else
2549#undef USE_GC_NOTIFICATION
2550#endif
2551
2552void
2553ensure_static_conses(ExceptionInformation *xp, TCR *tcr, natural nconses)
2554{
2555  area *a = active_dynamic_area;
2556  natural nbytes = nconses>>dnode_shift, have;
2557  BytePtr p = a->high-nbytes;
2558#ifdef USE_GC_NOTIFICATION
2559  Boolean crossed_notify_threshold = false;
2560  LispObj before_shrink, after_shrink;
2561#endif
2562
2563  if (p < a->active) {
2564    untenure_from_area(tenured_area);
2565    gc_from_xp(xp, 0L);
2566#ifdef USE_GC_NOTIFICATION
2567    did_gc_notification_since_last_full_gc = false;
2568#endif
2569  }
2570
2571  have = unbox_fixnum(lisp_global(FREE_STATIC_CONSES));
2572  if (have < nconses) {
2573#ifdef USE_GC_NOTIFICATION
2574    before_shrink = a->high-a->active;
2575    if (before_shrink>nbytes) {
2576      shrink_dynamic_area(nbytes);
2577      after_shrink = a->high-a->active; 
2578      if ((before_shrink >= lisp_heap_notify_threshold) &&
2579          (after_shrink < lisp_heap_notify_threshold)) {
2580        crossed_notify_threshold = true;
2581      }
2582    }
2583#endif
2584    allocate_static_conses(nconses);
2585    TCR_AUX(tcr)->bytes_allocated += nbytes;
2586  }
2587#ifdef USE_GC_NOTIFICATION
2588  if (crossed_notify_threshold && !did_gc_notification_since_last_full_gc) {
2589    callback_for_gc_notification(xp,tcr);
2590  }
2591#endif
2592}
2593     
2594#ifdef ANDROID
2595#include <jni.h>
2596#include <android/log.h>
2597#include "android_native_app_glue.h"
2598
2599extern int init_lisp(TCR *);
2600
2601JavaVM *android_vm = NULL;
2602
2603void
2604wait_for_debugger()
2605{ 
2606  volatile Boolean ready = false;
2607
2608  __android_log_print(ANDROID_LOG_INFO,"nativeCCL","waiting for debugger");
2609  do {
2610    sleep(1);
2611  } while(!ready);
2612} 
2613 
2614
2615Boolean
2616init_ccl_for_android(ANativeActivity *activity)
2617{
2618  extern int page_size;
2619  Boolean egc_enabled =
2620#ifdef DISABLE_EGC
2621    false
2622#else
2623    true
2624#endif
2625    ;
2626  TCR *tcr;
2627  BytePtr stack_base, current_sp;
2628  char **argv;
2629
2630  wait_for_debugger();
2631  android_vm = activity->vm;
2632
2633  current_sp = (BytePtr) current_stack_pointer();
2634  page_size = getpagesize();
2635 
2636  if (!check_arm_cpu()) {
2637    __android_log_print(ANDROID_LOG_FATAL,"nativeCCL","CPU doesn't support required features");
2638    return false;
2639  }
2640  main_thread_pid = getpid();
2641  tcr_area_lock = (void *)new_recursive_lock();
2642  image_name = "/data/local/ccl/android.image"; /* need something better. */
2643  while (1) {
2644    if (create_reserved_area(reserved_area_size)) {
2645      break;
2646    }
2647    reserved_area_size = reserved_area_size *.9;
2648  }
2649
2650  gc_init();
2651
2652  set_nil(load_image(image_name));
2653  lisp_heap_notify_threshold = GC_NOTIFY_THRESHOLD;
2654  lisp_heap_threshold_from_image = lisp_global(LISP_HEAP_THRESHOLD);
2655 
2656  if (lisp_heap_threshold_from_image) {
2657    if (lisp_heap_threshold_from_image != lisp_heap_gc_threshold) {
2658      lisp_heap_gc_threshold = lisp_heap_threshold_from_image;
2659      resize_dynamic_heap(active_dynamic_area->active,lisp_heap_gc_threshold);
2660    }
2661    /* If lisp_heap_threshold_from_image was set, other image params are
2662       valid. */
2663    default_g0_threshold = lisp_global(G0_THRESHOLD);
2664    default_g1_threshold = lisp_global(G1_THRESHOLD);
2665    default_g2_threshold = lisp_global(G2_THRESHOLD);
2666    egc_enabled = lisp_global(EGC_ENABLED);
2667  }
2668  lisp_global(TCR_AREA_LOCK) = ptr_to_lispobj(tcr_area_lock);
2669#ifdef ARM
2670  lisp_global(SUBPRIMS_BASE) = (LispObj)(9<<12);
2671#endif
2672  lisp_global(RET1VALN) = (LispObj)&ret1valn;
2673  lisp_global(LEXPR_RETURN) = (LispObj)&nvalret;
2674  lisp_global(LEXPR_RETURN1V) = (LispObj)&popj;
2675  lisp_global(ALL_AREAS) = ptr_to_lispobj(all_areas);
2676  lisp_global(DEFAULT_ALLOCATION_QUANTUM) = log2_heap_segment_size << fixnumshift;
2677  lisp_global(STACK_SIZE) = thread_stack_size<<fixnumshift;
2678
2679
2680  exception_init();
2681  argv = (char**)(malloc (sizeof (char *)));
2682  argv[0] = NULL;
2683  lisp_global(IMAGE_NAME) = ptr_to_lispobj(ensure_real_path(image_name));
2684  lisp_global(KERNEL_PATH) = ptr_to_lispobj(real_executable_name);
2685  lisp_global(ARGV) = ptr_to_lispobj(argv);
2686  lisp_global(KERNEL_IMPORTS) = (LispObj)import_ptrs_base;
2687
2688  lisp_global(GET_TCR) = (LispObj) get_tcr;
2689  *(double *) &(lisp_global(DOUBLE_FLOAT_ONE)) = (double) 1.0;
2690
2691  lisp_global(HOST_PLATFORM) = (LispObj) PLATFORM << fixnumshift;
2692
2693  lisp_global(BATCH_FLAG) = (batch_flag << fixnumshift);
2694
2695  init_consing_areas();
2696  tcr = new_tcr(initial_stack_size, MIN_TSTACK_SIZE);
2697  stack_base = initial_stack_bottom()-xStackSpace();
2698  init_threads((void *)(stack_base), tcr);
2699  thread_init_tcr(tcr, current_sp, current_sp-stack_base);
2700
2701  if (lisp_global(STATIC_CONSES) == 0) {
2702    lisp_global(STATIC_CONSES) = lisp_nil;
2703  }
2704
2705
2706  lisp_global(EXCEPTION_LOCK) = ptr_to_lispobj(new_recursive_lock());
2707  enable_fp_exceptions();
2708  register_user_signal_handler();
2709  TCR_AUX(tcr)->prev = TCR_AUX(tcr)->next = tcr;
2710  lisp_global(INTERRUPT_SIGNAL) = (LispObj) box_fixnum(SIGNAL_FOR_PROCESS_INTERRUPT);
2711#ifdef GC_INTEGRITY_CHECKING
2712  (nrs_GC_EVENT_STATUS_BITS.vcell |= gc_integrity_check_bit);
2713#endif
2714  if (egc_enabled) {
2715    egc_control(true, NULL);
2716  } else {
2717    lisp_global(OLDSPACE_DNODE_COUNT) = 0;
2718  }
2719
2720  if (init_lisp(TCR_TO_TSD(tcr)) == 0) {
2721    return true;
2722  }
2723  return false;
2724}
2725
2726
2727/*
2728   This runs on a secondary thread that isn't bound to the JVM.
2729   Splitting the event loop in two like this is supposed to
2730   weaken timing constraints somehow.  It's not clear that it
2731   actually does so, but Android NDK examples generally use
2732   this mechanism.
2733*/
2734   
2735void 
2736android_main(struct android_app* state) 
2737{
2738  TCR *tcr;
2739  JNIEnv *env;
2740
2741  tcr = new_tcr(DEFAULT_INITIAL_STACK_SIZE, MIN_TSTACK_SIZE);
2742  thread_init_tcr(tcr, current_stack_pointer,DEFAULT_INITIAL_STACK_SIZE);
2743  (*android_vm)->AttachCurrentThread(android_vm, &env, NULL);
2744
2745  os_main(tcr, state);
2746  (*android_vm)->DetachCurrentThread(android_vm);
2747}
2748#endif
2749
Note: See TracBrowser for help on using the repository browser.