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

Last change on this file since 15451 was 15451, checked in by gb, 8 years ago

pmcl-kernel.c: In register_cstack_holding_area_lock(), if stack is too

small for soft/hard protected areas, just set hard/soft limits to
physical limits and don't write-protect any regions (on architectures
that want to do this.)

thread_manager.c: even foreign TCR's need to set tcr->cs_limit, so that

rmark() doesn't exhaust the stack.

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