source: release/1.9/source/lisp-kernel/pmcl-kernel.c @ 16083

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

Propagate r15802 from trunk. Fixes ticket:1190

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