Ticket #1190: pmcl-kernel.c

File pmcl-kernel.c, 62.3 KB (added by MarkBrown667, 5 years ago)

pmcl-kernel.c with check_arm_cpu fixed to recognise later model Raspberry Pi

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 = 0;
1581
1582Boolean
1583check_arm_cpu()
1584{
1585  Boolean win = false;
1586#ifdef LINUX
1587/* It's hard to determine ARM features in general, and especially
1588   hard to do so from user mode.  Parse /proc/cpuinfo.
1589   According to Android's cpufeatures library, some ARMv6 chips
1590   are reported to have archutecture version 7; check the ELF
1591   architecture in this case.
1592
1593   (In other words, we assume that we're on ARMv7 or later if
1594   the reported architecture is > 7, or if it's = 7 and the
1595   ELF architecture is "v7l".)
1596*/
1597  FILE *f = fopen("/proc/cpuinfo", "r");
1598  const size_t buffsz = 129;
1599  char procline[buffsz], cpuline[buffsz], line[buffsz];
1600  size_t n;
1601
1602  procline[0] = '\0';
1603  cpuline[0]  = '\0';
1604
1605  if (f) {
1606    while (1) {
1607      if (fgets(line,buffsz-1,f)==NULL) {
1608        break;
1609      }
1610      n = strlen(line);
1611      if (strncasecmp(line,"Processor",sizeof("Processor")-1) == 0) {
1612        strcpy(procline,line);
1613        procline[n]='\0';
1614      } else if (strncasecmp(line, "CPU architecture",sizeof("CPU architecture")-1) == 0) {
1615        strcpy(cpuline,line);
1616        cpuline[n] = '\0';
1617      }
1618    }
1619    if ('\0' != procline[0]) {
1620      win = (strstr(procline, "v7l") != NULL);
1621      if (win) {
1622        arm_architecture_version = 7;
1623      } else {
1624        win = (strstr(procline, "v6l") != NULL);
1625        if (win) {
1626          arm_architecture_version = 6;
1627        } else {
1628          if ('\0' != cpuline[0]) {
1629            char *workline = index(cpuline,':');
1630            if (workline) {
1631              arm_architecture_version = strtol(workline+1,NULL,0);
1632              if (arm_architecture_version >= ARM_ARCHITECTURE_min) {
1633                win = true;
1634              }
1635            }
1636          }
1637        }
1638      }
1639    }
1640    fclose(f);
1641  }
1642#endif
1643  return win;
1644}
1645#endif 
1646
1647void
1648lazarus()
1649{
1650  TCR *tcr = get_tcr(false);
1651  if (tcr) {
1652    /* Some threads may be dying; no threads should be created. */
1653    LOCK(lisp_global(TCR_AREA_LOCK),tcr);
1654    tcr->vs_area->active = tcr->vs_area->high - node_size;
1655    tcr->save_vsp = (LispObj *)(tcr->vs_area->active);
1656#ifndef ARM
1657    tcr->ts_area->active = tcr->ts_area->high;
1658    tcr->save_tsp = (LispObj *)(tcr->ts_area->active);
1659#endif
1660    tcr->catch_top = 0;
1661    tcr->db_link = 0;
1662    tcr->xframe = 0;
1663    start_lisp(tcr, 0);
1664  }
1665}
1666
1667#ifdef LINUX
1668#ifdef X8664
1669#include <asm/prctl.h>
1670#include <sys/prctl.h>
1671
1672void
1673ensure_gs_available(char *progname)
1674{
1675  LispObj fs_addr = 0L, gs_addr = 0L, cur_thread = (LispObj)pthread_self();
1676  char *gnu_get_libc_version(void);
1677 
1678  arch_prctl(ARCH_GET_GS, &gs_addr);
1679  arch_prctl(ARCH_GET_FS, &fs_addr);
1680  if ((gs_addr == cur_thread) && (fs_addr != cur_thread)) {
1681    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);
1682    _exit(1);
1683  }
1684}
1685#endif
1686#endif
1687
1688Boolean
1689bogus_fp_exceptions = false;
1690
1691typedef
1692float (*float_arg_returns_float)(float);
1693
1694float
1695fcallf(float_arg_returns_float fun, float arg)
1696{
1697  return fun(arg);
1698}
1699
1700void
1701check_bogus_fp_exceptions()
1702{
1703#ifdef X8664
1704  float asinf(float),result;
1705   
1706
1707  natural save_mxcsr = get_mxcsr(), post_mxcsr;
1708  set_mxcsr(0x1f80);
1709
1710  result = fcallf(asinf, 1.0);
1711  post_mxcsr = get_mxcsr();
1712  set_mxcsr(save_mxcsr);
1713  if (post_mxcsr & (FE_ALL_EXCEPT & (~FE_INEXACT))) {
1714    bogus_fp_exceptions = true;
1715  }
1716#endif
1717}
1718
1719#ifdef WINDOWS
1720char *
1721utf_16_to_utf_8(wchar_t *utf_16)
1722{
1723  int utf8len = WideCharToMultiByte(CP_UTF8,
1724                                    0,
1725                                    utf_16,
1726                                    -1,
1727                                    NULL,
1728                                    0,
1729                                    NULL,
1730                                    NULL);
1731
1732  char *utf_8 = malloc(utf8len);
1733
1734  WideCharToMultiByte(CP_UTF8,
1735                      0,
1736                      utf_16,
1737                      -1,
1738                      utf_8,
1739                      utf8len,
1740                      NULL,
1741                      NULL);
1742
1743  return utf_8;
1744}
1745
1746char **
1747wide_argv_to_utf_8(wchar_t *wide_argv[], int argc)
1748{
1749  char** argv = calloc(argc+1,sizeof(char *));
1750  int i;
1751
1752  for (i = 0; i < argc; i++) {
1753    if (wide_argv[i]) {
1754      argv[i] = utf_16_to_utf_8(wide_argv[i]);
1755    } else {
1756      argv[i] = NULL;
1757    }
1758  }
1759  return argv;
1760}
1761#endif
1762
1763natural default_g0_threshold = G0_AREA_THRESHOLD;
1764natural default_g1_threshold = G1_AREA_THRESHOLD;
1765natural default_g2_threshold = G2_AREA_THRESHOLD;
1766natural lisp_heap_threshold_from_image = 0;
1767
1768void
1769init_consing_areas()
1770{
1771  area *a;
1772  a = active_dynamic_area;
1773
1774  if (nilreg_area != NULL) {
1775    BytePtr lowptr = (BytePtr) a->low;
1776
1777    /* Create these areas as AREA_STATIC, change them to AREA_DYNAMIC */
1778    g1_area = new_area(lowptr, lowptr, AREA_STATIC);
1779    g2_area = new_area(lowptr, lowptr, AREA_STATIC);
1780    tenured_area = new_area(lowptr, lowptr, AREA_STATIC);
1781    add_area_holding_area_lock(tenured_area);
1782    add_area_holding_area_lock(g2_area);
1783    add_area_holding_area_lock(g1_area);
1784
1785    g1_area->code = AREA_DYNAMIC;
1786    g2_area->code = AREA_DYNAMIC;
1787    tenured_area->code = AREA_DYNAMIC;
1788
1789/*    a->older = g1_area; */ /* Not yet: this is what "enabling the EGC" does. */
1790    g1_area->younger = a;
1791    g1_area->older = g2_area;
1792    g2_area->younger = g1_area;
1793    g2_area->older = tenured_area;
1794    tenured_area->younger = g2_area;
1795    tenured_area->refbits = dynamic_mark_ref_bits;
1796    managed_static_area->refbits = global_mark_ref_bits;
1797    a->markbits = dynamic_mark_ref_bits;
1798    tenured_area->static_dnodes = a->static_dnodes;
1799    a->static_dnodes = 0;
1800    tenured_area->static_used = a->static_used;
1801    a->static_used = 0;
1802    lisp_global(TENURED_AREA) = ptr_to_lispobj(tenured_area);
1803    lisp_global(STATIC_CONS_AREA) = ptr_to_lispobj(static_cons_area);
1804    lisp_global(REFBITS) = ptr_to_lispobj(global_mark_ref_bits);
1805    g2_area->threshold = default_g2_threshold;
1806    g1_area->threshold = default_g1_threshold;
1807    a->threshold = default_g0_threshold;
1808  }
1809}
1810
1811int
1812#ifdef CCLSHARED
1813cclmain
1814#else
1815main
1816#endif
1817(int argc, char *argv[]
1818#if defined(PPC) && defined(LINUX)
1819, char *envp[], void *aux
1820#endif
1821)
1822{
1823  extern int page_size;
1824  Boolean egc_enabled =
1825#ifdef DISABLE_EGC
1826    false
1827#else
1828    true
1829#endif
1830    ;
1831  Boolean lisp_heap_threshold_set_from_command_line = false;
1832  wchar_t **utf_16_argv = NULL;
1833
1834#ifdef PPC
1835  extern int altivec_present;
1836#endif
1837#ifdef WINDOWS
1838  extern LispObj load_image(wchar_t *);
1839#else
1840  extern LispObj load_image(char *);
1841#endif
1842  area *a;
1843  BytePtr stack_base, current_sp = (BytePtr) current_stack_pointer();
1844  TCR *tcr;
1845
1846  dbgout = stderr;
1847
1848#ifdef WINDOWS
1849  {
1850    int wide_argc;
1851    extern void init_winsock(void);
1852    extern void init_windows_io(void);
1853    extern void reserve_tls_slots(void);
1854
1855    _fmode = O_BINARY;
1856    _setmode(1, O_BINARY);
1857    _setmode(2, O_BINARY);
1858    setvbuf(dbgout, NULL, _IONBF, 0);
1859    init_winsock();
1860    init_windows_io();
1861    reserve_tls_slots();
1862    utf_16_argv = CommandLineToArgvW(GetCommandLineW(),&wide_argc);
1863  }
1864#endif
1865
1866  check_os_version(argv[0]);
1867#ifdef WINDOWS
1868  real_executable_name = determine_executable_name();
1869#else
1870  real_executable_name = determine_executable_name(argv[0]);
1871#endif
1872  page_size = getpagesize(); /* Implement with GetSystemInfo on Windows w/o MinGW */
1873
1874  check_bogus_fp_exceptions();
1875#ifdef LINUX
1876#ifdef X8664
1877  ensure_gs_available(real_executable_name);
1878#endif
1879#endif
1880#if (defined(DARWIN) && defined(PPC64)) || (defined(LINUX) && defined(PPC))|| defined(X8664) || (defined(X8632) && !defined(DARWIN))
1881  remap_spjump();
1882#endif
1883
1884#ifdef PPC
1885#ifdef LINUX
1886  {
1887    ElfW(auxv_t) *av = aux;
1888    int hwcap, done = false;
1889   
1890    if (av) {
1891      do {
1892        switch (av->a_type) {
1893        case AT_DCACHEBSIZE:
1894          cache_block_size = av->a_un.a_val;
1895          break;
1896
1897        case AT_HWCAP:
1898          hwcap = av->a_un.a_val;
1899          altivec_present = ((hwcap & PPC_FEATURE_HAS_ALTIVEC) != 0);
1900          break;
1901
1902        case AT_NULL:
1903          done = true;
1904          break;
1905        }
1906        av++;
1907      } while (!done);
1908    }
1909  }
1910#endif
1911#ifdef DARWIN
1912  {
1913    unsigned value = 0;
1914    size_t len = sizeof(value);
1915    int mib[2];
1916   
1917    mib[0] = CTL_HW;
1918    mib[1] = HW_CACHELINE;
1919    if (sysctl(mib,2,&value,&len, NULL, 0) != -1) {
1920      if (len == sizeof(value)) {
1921        cache_block_size = value;
1922      }
1923    }
1924    mib[1] = HW_VECTORUNIT;
1925    value = 0;
1926    len = sizeof(value);
1927    if (sysctl(mib,2,&value,&len, NULL, 0) != -1) {
1928      if (len == sizeof(value)) {
1929        altivec_present = value;
1930      }
1931    }
1932  }
1933#endif
1934#endif
1935
1936#ifdef X86
1937  if (!check_x86_cpu()) {
1938    fprintf(dbgout, "CPU doesn't support required features\n");
1939    exit(1);
1940  }
1941#endif
1942
1943#ifdef ARM
1944  if (!check_arm_cpu()) {
1945    fprintf(dbgout, "CPU doesn't support required features\n");
1946    exit(1);
1947  }
1948#endif
1949
1950#ifdef SOLARIS
1951#ifdef X8632
1952  {
1953    extern void solaris_ldt_init(void);
1954    solaris_ldt_init();
1955  }
1956#endif
1957#endif
1958
1959#ifndef WINDOWS
1960  main_thread_pid = getpid();
1961#endif
1962  tcr_area_lock = (void *)new_recursive_lock();
1963
1964  program_name = argv[0];
1965#ifdef SINGLE_ARG_SHORTHAND
1966  if ((argc == 2) && (*argv[1] != '-')) {
1967#ifdef WINDOWS
1968    image_name = utf_16_argv[1];
1969#else
1970    image_name = argv[1];
1971#endif
1972    argv[1] = NULL;
1973#ifdef WINDOWS
1974    utf_16_argv[1] = NULL;
1975#endif
1976  } else {
1977#endif  /* SINGLE_ARG_SHORTHAND */
1978    process_options(argc,argv,utf_16_argv);
1979#ifdef SINGLE_ARG_SHORTHAND
1980  }
1981#endif
1982  if (lisp_heap_gc_threshold != DEFAULT_LISP_HEAP_GC_THRESHOLD) {
1983    lisp_heap_threshold_set_from_command_line = true;
1984  }
1985
1986  initial_stack_size = ensure_stack_limit(initial_stack_size);
1987  if (image_name == NULL) {
1988    if (check_for_embedded_image(real_executable_name)) {
1989      image_name = real_executable_name;
1990    } else {
1991      image_name = default_image_name(real_executable_name);
1992#ifdef DARWIN
1993      if (!probe_file(image_name)) {
1994        image_name = bundle_image_name(real_executable_name);
1995      }
1996#endif
1997    }
1998  }
1999
2000  while (1) {
2001    if (create_reserved_area(reserved_area_size)) {
2002      break;
2003    }
2004    reserved_area_size = reserved_area_size *.9;
2005  }
2006
2007  gc_init();
2008
2009  set_nil(load_image(image_name));
2010  lisp_heap_notify_threshold = GC_NOTIFY_THRESHOLD;
2011  lisp_heap_threshold_from_image = lisp_global(LISP_HEAP_THRESHOLD);
2012 
2013  if (lisp_heap_threshold_from_image) {
2014    if ((!lisp_heap_threshold_set_from_command_line) &&
2015        (lisp_heap_threshold_from_image != lisp_heap_gc_threshold)) {
2016      lisp_heap_gc_threshold = lisp_heap_threshold_from_image;
2017      resize_dynamic_heap(active_dynamic_area->active,lisp_heap_gc_threshold);
2018    }
2019    /* If lisp_heap_threshold_from_image was set, other image params are
2020       valid. */
2021    default_g0_threshold = lisp_global(G0_THRESHOLD);
2022    default_g1_threshold = lisp_global(G1_THRESHOLD);
2023    default_g2_threshold = lisp_global(G2_THRESHOLD);
2024    egc_enabled = lisp_global(EGC_ENABLED);
2025  }
2026
2027  lisp_global(TCR_AREA_LOCK) = ptr_to_lispobj(tcr_area_lock);
2028
2029#ifdef X86
2030  lisp_global(SUBPRIMS_BASE) = (LispObj)((1<<16)+(5<<10));
2031#endif
2032#ifdef PPC
2033  lisp_global(SUBPRIMS_BASE) = (LispObj)(5<<10);
2034#endif
2035#ifdef ARM
2036  lisp_global(SUBPRIMS_BASE) = (LispObj)(9<<12);
2037#endif
2038
2039  lisp_global(RET1VALN) = (LispObj)&ret1valn;
2040  lisp_global(LEXPR_RETURN) = (LispObj)&nvalret;
2041  lisp_global(LEXPR_RETURN1V) = (LispObj)&popj;
2042  lisp_global(ALL_AREAS) = ptr_to_lispobj(all_areas);
2043  lisp_global(DEFAULT_ALLOCATION_QUANTUM) = log2_heap_segment_size << fixnumshift;
2044  lisp_global(STACK_SIZE) = thread_stack_size<<fixnumshift;
2045
2046
2047  exception_init();
2048
2049 
2050
2051#ifdef WINDOWS
2052  lisp_global(IMAGE_NAME) = ptr_to_lispobj(utf_16_to_utf_8(ensure_real_path(image_name)));
2053  lisp_global(KERNEL_PATH) = ptr_to_lispobj(utf_16_to_utf_8(real_executable_name));
2054  lisp_global(ARGV) = ptr_to_lispobj(wide_argv_to_utf_8(utf_16_argv, argc));
2055#else
2056  lisp_global(IMAGE_NAME) = ptr_to_lispobj(ensure_real_path(image_name));
2057  lisp_global(KERNEL_PATH) = ptr_to_lispobj(real_executable_name);
2058  lisp_global(ARGV) = ptr_to_lispobj(argv);
2059#endif
2060  lisp_global(KERNEL_IMPORTS) = (LispObj)import_ptrs_base;
2061
2062  lisp_global(GET_TCR) = (LispObj) get_tcr;
2063  *(double *) &(lisp_global(DOUBLE_FLOAT_ONE)) = (double) 1.0;
2064
2065  lisp_global(HOST_PLATFORM) = (LispObj) PLATFORM << fixnumshift;
2066
2067  lisp_global(BATCH_FLAG) = (batch_flag << fixnumshift);
2068
2069  init_consing_areas();
2070  tcr = new_tcr(initial_stack_size, MIN_TSTACK_SIZE);
2071  stack_base = initial_stack_bottom()-xStackSpace();
2072  init_threads((void *)(stack_base), tcr);
2073  thread_init_tcr(tcr, current_sp, current_sp-stack_base);
2074
2075  if (lisp_global(STATIC_CONSES) == 0) {
2076    lisp_global(STATIC_CONSES) = lisp_nil;
2077  }
2078
2079  lisp_global(EXCEPTION_LOCK) = ptr_to_lispobj(new_recursive_lock());
2080  enable_fp_exceptions();
2081  register_user_signal_handler();
2082
2083#ifdef PPC
2084  lisp_global(ALTIVEC_PRESENT) = altivec_present << fixnumshift;
2085#endif
2086#ifdef ARM
2087#if defined (__ARM_PCS_VFP)
2088 /* would be nice if there was a way to test for this (armhf) at runtime */
2089  lisp_global(FLOAT_ABI) = 1 << fixnumshift;
2090#endif
2091#endif
2092#if STATIC
2093  lisp_global(STATICALLY_LINKED) = 1 << fixnumshift;
2094#endif
2095  TCR_AUX(tcr)->prev = TCR_AUX(tcr)->next = tcr;
2096#ifndef WINDOWS
2097  lisp_global(INTERRUPT_SIGNAL) = (LispObj) box_fixnum(SIGNAL_FOR_PROCESS_INTERRUPT);
2098#endif
2099  tcr->vs_area->active -= node_size;
2100  *(--tcr->save_vsp) = nrs_TOPLFUNC.vcell;
2101  nrs_TOPLFUNC.vcell = lisp_nil;
2102#ifdef GC_INTEGRITY_CHECKING
2103  (nrs_GC_EVENT_STATUS_BITS.vcell |= gc_integrity_check_bit);
2104#endif
2105  if (egc_enabled) {
2106    egc_control(true, NULL);
2107  } else {
2108    lisp_global(OLDSPACE_DNODE_COUNT) = 0;
2109  }
2110  lisp_global(MANAGED_STATIC_REFBITS) = (LispObj)managed_static_refbits;
2111  lisp_global(MANAGED_STATIC_DNODES) = (LispObj)managed_static_area->ndnodes;
2112  atexit(lazarus);
2113#ifdef ARM
2114#ifdef LINUX
2115#ifdef SET_INITIAL_THREAD_AFFINITY
2116  /* Maybe work around an apparent cache coherency problem */
2117  set_thread_affinity(tcr,0);
2118#endif
2119#endif
2120#endif
2121  start_lisp(TCR_TO_TSD(tcr), 0);
2122  _exit(0);
2123}
2124
2125area *
2126set_nil(LispObj r)
2127{
2128
2129  if (lisp_nil == (LispObj)NULL) {
2130
2131    lisp_nil = r;
2132  }
2133  return NULL;
2134}
2135
2136
2137void
2138xMakeDataExecutable(BytePtr start, natural nbytes)
2139{
2140#ifdef PPC
2141  extern void flush_cache_lines();
2142  natural ustart = (natural) start, base, end;
2143 
2144  base = (ustart) & ~(cache_block_size-1);
2145  end = (ustart + nbytes + cache_block_size - 1) & ~(cache_block_size-1);
2146  flush_cache_lines(base, (end-base)/cache_block_size, cache_block_size);
2147#endif
2148#ifdef ARM
2149  extern void flush_cache_lines(void *, size_t);
2150  flush_cache_lines(start,nbytes);
2151#endif
2152}
2153
2154natural
2155xStackSpace()
2156{
2157  return initial_stack_size+CSTACK_HARDPROT+CSTACK_SOFTPROT;
2158}
2159
2160#ifndef DARWIN
2161#ifdef WINDOWS
2162extern void *windows_open_shared_library(char *);
2163
2164void *
2165xGetSharedLibrary(char *path, int mode)
2166{
2167  return windows_open_shared_library(path);
2168}
2169#else
2170void *
2171xGetSharedLibrary(char *path, int mode)
2172{
2173  return dlopen(path, mode);
2174}
2175#endif
2176#else
2177void *
2178xGetSharedLibrary(char *path, int *resultType)
2179{
2180  const char *error;
2181  void *result;
2182
2183  result = dlopen(path, RTLD_NOW | RTLD_GLOBAL);
2184 
2185  if (result == NULL) {
2186    error = dlerror();
2187    *resultType = 0;
2188    return (void *)error;
2189  }
2190  *resultType = 1;
2191  return result;
2192}
2193#endif
2194
2195
2196
2197int
2198fd_setsize_bytes()
2199{
2200  return sizeof(fd_set);
2201}
2202
2203void
2204do_fd_set(int fd, fd_set *fdsetp)
2205{
2206  FD_SET(fd, fdsetp);
2207}
2208
2209void
2210do_fd_clr(int fd, fd_set *fdsetp)
2211{
2212  FD_CLR(fd, fdsetp);
2213}
2214
2215int
2216do_fd_is_set(int fd, fd_set *fdsetp)
2217{
2218  return FD_ISSET(fd,fdsetp);
2219}
2220
2221
2222void
2223do_fd_zero(fd_set *fdsetp)
2224{
2225  FD_ZERO(fdsetp);
2226}
2227
2228#include "image.h"
2229
2230
2231
2232Boolean
2233check_for_embedded_image (
2234#ifdef WINDOWS
2235                          wchar_t *path
2236#else
2237                          char *path
2238#endif
2239                          )
2240{
2241#ifdef WINDOWS
2242  int fd = wopen(path, O_RDONLY);
2243#else 
2244  int fd = open(path, O_RDONLY);
2245#endif
2246
2247  Boolean image_is_embedded = false;
2248
2249  if (fd >= 0) {
2250    openmcl_image_file_header h;
2251
2252    if (find_openmcl_image_file_header (fd, &h)) {
2253      image_is_embedded = true;
2254    }
2255    close (fd);
2256  }
2257  return image_is_embedded;
2258}
2259
2260LispObj
2261load_image(
2262#ifdef WINDOWS
2263           wchar_t * path
2264#else
2265           char *path
2266#endif
2267)
2268{
2269#ifdef WINDOWS
2270  int fd = wopen(path, O_RDONLY, 0666), err;
2271#else
2272  int fd = open(path, O_RDONLY, 0666), err;
2273#endif
2274  LispObj image_nil = 0;
2275
2276  if (fd > 0) {
2277    openmcl_image_file_header ih;
2278
2279    errno = 0;
2280    image_nil = load_openmcl_image(fd, &ih);
2281    /* We -were- using a duplicate fd to map the file; that
2282       seems to confuse Darwin (doesn't everything ?), so
2283       we'll instead keep the original file open.
2284    */
2285    err = errno;
2286    if (!image_nil) {
2287      close(fd);
2288    }
2289#ifdef WINDOWS
2290    /* We currently don't actually map the image, and leaving the file
2291       open seems to make it difficult to write to reliably. */
2292    if (image_nil) {
2293      close(fd);
2294    }
2295#endif
2296  } else {
2297    err = errno;
2298  }
2299#ifdef DARWIN
2300#ifdef X86
2301  if (image_nil == 0) {
2302    extern LispObj load_native_library(char *);
2303    image_nil = load_native_library(path);
2304  }
2305#endif
2306#endif
2307  if (image_nil == 0) {
2308#ifdef WINDOWS
2309    char *fmt = "Couldn't load lisp heap image from %ls";
2310#else
2311    char *fmt = "Couldn't load lisp heap image from %s";
2312#endif
2313
2314    fprintf(dbgout, fmt, path);
2315    if (err == 0) {
2316      fprintf(dbgout, "\n");
2317    } else {
2318      fprintf(dbgout, ": %s\n", strerror(err));
2319    }
2320    exit(-1);
2321  }
2322  return image_nil;
2323}
2324
2325int
2326set_errno(int val)
2327{
2328  errno = val;
2329  return -1;
2330}
2331
2332/* A horrible hack to allow us to initialize a JVM instance from lisp.
2333   On Darwin, creating a JVM instance clobbers the thread's existing
2334   Mach exception infrastructure, so we save and restore it here.
2335*/
2336
2337typedef int (*jvm_initfunc)(void*,void*,void*);
2338
2339int
2340jvm_init(jvm_initfunc f,void*arg0,void*arg1,void*arg2)
2341{
2342  int result = -1;
2343  TCR *tcr = get_tcr(1);
2344 
2345  result = f(arg0,arg1,arg2);
2346  return result;
2347}
2348
2349
2350void *
2351xFindSymbol(void* handle, char *name)
2352{
2353#if defined(LINUX) || defined(FREEBSD) || defined(SOLARIS)
2354#ifdef ANDROID
2355  if (handle == NULL) {
2356    handle = RTLD_DEFAULT;
2357  }
2358#endif
2359  return dlsym(handle, name);
2360#endif
2361#ifdef DARWIN
2362  void *result;
2363
2364  if ((handle == NULL) || (handle == ((void *) -1))) {
2365    handle = RTLD_DEFAULT;
2366  }   
2367  result = dlsym(handle, name);
2368  if ((result == NULL) && (*name == '_')) {
2369    result = dlsym(handle, name+1);
2370  }
2371  return result;
2372#endif
2373#ifdef WINDOWS
2374  extern void *windows_find_symbol(void *, char *);
2375  return windows_find_symbol(handle, name);
2376#endif
2377}
2378#if defined(LINUX) || defined(FREEBSD) || defined(SOLARIS)
2379#if WORD_SIZE == 64
2380typedef Elf64_Dyn Elf_Dyn_thing;
2381typedef Elf64_Ehdr Elf_Ehdr_thing;
2382typedef Elf64_Shdr Elf_Shdr_thing;
2383#else
2384typedef Elf32_Dyn Elf_Dyn_thing;
2385typedef Elf32_Ehdr Elf_Ehdr_thing;
2386typedef Elf32_Shdr Elf_Shdr_thing;
2387#endif
2388
2389Elf_Dyn_thing *
2390get_executable_dynamic_entries()
2391{
2392#ifndef CCLSHARED
2393  extern Elf_Dyn_thing _DYNAMIC[];
2394  return _DYNAMIC;
2395#else
2396#ifdef ANDROID
2397  /* Deep, dark secret: the "handle" returned by dlopen() is
2398     a pointer to an soinfo structure, as defined in linker.h.
2399     We can get the link map from there ...
2400  */
2401 
2402
2403 
2404  /* Woe unto us - and lots of it - if the executable is mapped
2405     at an address other than 0x8000.  Todo: parse /proc/self/maps. */
2406  char *p;
2407  Elf_Ehdr_thing *elf_header;
2408  Elf_Shdr_thing *section_header;
2409  int i,fd;
2410  struct stat _stat;
2411  Elf_Dyn_thing *result = NULL;
2412 
2413  fd = open("/proc/self/exe",O_RDONLY);
2414  if (fd >= 0) {
2415    if (fstat(fd,&_stat) == 0) {
2416      p = (char *)mmap(NULL,_stat.st_size,PROT_READ,MAP_PRIVATE,fd,0);
2417      if (p != MAP_FAILED) {
2418        elf_header = (Elf_Ehdr_thing *)p;
2419        for (section_header = (Elf_Shdr_thing *)(p+elf_header->e_shoff),
2420               i = 0;
2421             i < elf_header->e_shnum;
2422             i++,section_header++) {
2423          if (section_header->sh_type == SHT_DYNAMIC) {
2424            result = (Elf_Dyn_thing *)section_header->sh_addr;
2425            break;
2426          }
2427        }
2428        munmap(p,_stat.st_size);
2429      }
2430    }
2431    close(fd);
2432  }
2433  return result;
2434#else
2435#error need implementation for get_executable_dynamic_entries from dso
2436#endif
2437#endif
2438}
2439
2440
2441void *cached_r_debug = NULL;
2442
2443void *
2444get_r_debug()
2445{
2446  int tag;
2447  Elf_Dyn_thing *dp;
2448
2449  if (cached_r_debug == NULL) {
2450    for (dp = get_executable_dynamic_entries(); (tag = dp->d_tag) != 0; dp++) {
2451      if (tag == DT_DEBUG) {
2452        cached_r_debug = (void *)(dp->d_un.d_ptr);
2453        break;
2454      }
2455    }
2456  }
2457  return cached_r_debug;
2458}
2459
2460#else
2461void *
2462get_r_debug()
2463{
2464  return NULL;
2465}
2466#endif
2467
2468#ifdef WINDOWS
2469void
2470sample_paging_info(paging_info *stats)
2471{
2472}
2473
2474void
2475report_paging_info_delta(FILE *out, paging_info *start, paging_info *stop)
2476{
2477}
2478#else
2479void
2480sample_paging_info(paging_info *stats)
2481{
2482  getrusage(RUSAGE_SELF, stats);
2483}
2484
2485void
2486report_paging_info_delta(FILE *out, paging_info *start, paging_info *stop)
2487{
2488  fprintf(out,";;; %ld soft faults, %ld faults, %ld pageins\n\n",
2489          stop->ru_minflt-start->ru_minflt,
2490          stop->ru_majflt-start->ru_majflt,
2491          stop->ru_nswap-start->ru_nswap);
2492}
2493
2494#endif
2495
2496void
2497allocate_static_conses(natural n)
2498{
2499  BytePtr old_low = static_cons_area->low,
2500    new_low = old_low - (n<<dnode_shift);
2501  cons *c;
2502  natural i;
2503  LispObj prev;
2504
2505  CommitMemory(new_low,old_low-new_low);
2506
2507  static_cons_area->low = new_low;
2508  lower_heap_start(new_low, tenured_area);
2509  /* what a mess this is ... */
2510  if (active_dynamic_area->low == old_low) {
2511    active_dynamic_area->low = new_low;
2512  }
2513  if (!active_dynamic_area->older) {
2514    active_dynamic_area->markbits = tenured_area->refbits;
2515  }
2516  if (g1_area->low == old_low) {
2517    g1_area->low = new_low;
2518  }
2519  if (g1_area->high == old_low) {
2520    g1_area->high = new_low;
2521  }
2522  if (g2_area->low == old_low) {
2523    g2_area->low = new_low;
2524  }
2525  if (g2_area->high == old_low) {
2526    g2_area->high = new_low;
2527  }
2528  for (i=0, prev=lisp_global(STATIC_CONSES), c=(cons *)new_low;
2529       i < n;
2530       i++, c++) {
2531    c->car = unbound;
2532    c->cdr = prev;
2533    prev = ((LispObj)c)+fulltag_cons;
2534  }
2535  lisp_global(STATIC_CONSES)=prev;
2536  lisp_global(FREE_STATIC_CONSES)+=(n<<fixnumshift);
2537}
2538
2539#ifdef X86
2540#define USE_GC_NOTIFICATION 1
2541#else
2542#undef USE_GC_NOTIFICATION
2543#endif
2544
2545void
2546ensure_static_conses(ExceptionInformation *xp, TCR *tcr, natural nconses)
2547{
2548  area *a = active_dynamic_area;
2549  natural nbytes = nconses>>dnode_shift, have;
2550  BytePtr p = a->high-nbytes;
2551#ifdef USE_GC_NOTIFICATION
2552  Boolean crossed_notify_threshold = false;
2553  LispObj before_shrink, after_shrink;
2554#endif
2555
2556  if (p < a->active) {
2557    untenure_from_area(tenured_area);
2558    gc_from_xp(xp, 0L);
2559#ifdef USE_GC_NOTIFICATION
2560    did_gc_notification_since_last_full_gc = false;
2561#endif
2562  }
2563
2564  have = unbox_fixnum(lisp_global(FREE_STATIC_CONSES));
2565  if (have < nconses) {
2566#ifdef USE_GC_NOTIFICATION
2567    before_shrink = a->high-a->active;
2568    if (before_shrink>nbytes) {
2569      shrink_dynamic_area(nbytes);
2570      after_shrink = a->high-a->active; 
2571      if ((before_shrink >= lisp_heap_notify_threshold) &&
2572          (after_shrink < lisp_heap_notify_threshold)) {
2573        crossed_notify_threshold = true;
2574      }
2575    }
2576#endif
2577    allocate_static_conses(nconses);
2578    TCR_AUX(tcr)->bytes_allocated += nbytes;
2579  }
2580#ifdef USE_GC_NOTIFICATION
2581  if (crossed_notify_threshold && !did_gc_notification_since_last_full_gc) {
2582    callback_for_gc_notification(xp,tcr);
2583  }
2584#endif
2585}
2586     
2587#ifdef ANDROID
2588#include <jni.h>
2589#include <android/log.h>
2590#include "android_native_app_glue.h"
2591
2592extern int init_lisp(TCR *);
2593
2594JavaVM *android_vm = NULL;
2595
2596void
2597wait_for_debugger()
2598{ 
2599  volatile Boolean ready = false;
2600
2601  __android_log_print(ANDROID_LOG_INFO,"nativeCCL","waiting for debugger");
2602  do {
2603    sleep(1);
2604  } while(!ready);
2605} 
2606 
2607
2608Boolean
2609init_ccl_for_android(ANativeActivity *activity)
2610{
2611  extern int page_size;
2612  Boolean egc_enabled =
2613#ifdef DISABLE_EGC
2614    false
2615#else
2616    true
2617#endif
2618    ;
2619  TCR *tcr;
2620  BytePtr stack_base, current_sp;
2621  char **argv;
2622
2623  wait_for_debugger();
2624  android_vm = activity->vm;
2625
2626  current_sp = (BytePtr) current_stack_pointer();
2627  page_size = getpagesize();
2628 
2629  if (!check_arm_cpu()) {
2630    __android_log_print(ANDROID_LOG_FATAL,"nativeCCL","CPU doesn't support required features");
2631    return false;
2632  }
2633  main_thread_pid = getpid();
2634  tcr_area_lock = (void *)new_recursive_lock();
2635  image_name = "/data/local/ccl/android.image"; /* need something better. */
2636  while (1) {
2637    if (create_reserved_area(reserved_area_size)) {
2638      break;
2639    }
2640    reserved_area_size = reserved_area_size *.9;
2641  }
2642
2643  gc_init();
2644
2645  set_nil(load_image(image_name));
2646  lisp_heap_notify_threshold = GC_NOTIFY_THRESHOLD;
2647  lisp_heap_threshold_from_image = lisp_global(LISP_HEAP_THRESHOLD);
2648 
2649  if (lisp_heap_threshold_from_image) {
2650    if (lisp_heap_threshold_from_image != lisp_heap_gc_threshold) {
2651      lisp_heap_gc_threshold = lisp_heap_threshold_from_image;
2652      resize_dynamic_heap(active_dynamic_area->active,lisp_heap_gc_threshold);
2653    }
2654    /* If lisp_heap_threshold_from_image was set, other image params are
2655       valid. */
2656    default_g0_threshold = lisp_global(G0_THRESHOLD);
2657    default_g1_threshold = lisp_global(G1_THRESHOLD);
2658    default_g2_threshold = lisp_global(G2_THRESHOLD);
2659    egc_enabled = lisp_global(EGC_ENABLED);
2660  }
2661  lisp_global(TCR_AREA_LOCK) = ptr_to_lispobj(tcr_area_lock);
2662#ifdef ARM
2663  lisp_global(SUBPRIMS_BASE) = (LispObj)(9<<12);
2664#endif
2665  lisp_global(RET1VALN) = (LispObj)&ret1valn;
2666  lisp_global(LEXPR_RETURN) = (LispObj)&nvalret;
2667  lisp_global(LEXPR_RETURN1V) = (LispObj)&popj;
2668  lisp_global(ALL_AREAS) = ptr_to_lispobj(all_areas);
2669  lisp_global(DEFAULT_ALLOCATION_QUANTUM) = log2_heap_segment_size << fixnumshift;
2670  lisp_global(STACK_SIZE) = thread_stack_size<<fixnumshift;
2671
2672
2673  exception_init();
2674  argv = (char**)(malloc (sizeof (char *)));
2675  argv[0] = NULL;
2676  lisp_global(IMAGE_NAME) = ptr_to_lispobj(ensure_real_path(image_name));
2677  lisp_global(KERNEL_PATH) = ptr_to_lispobj(real_executable_name);
2678  lisp_global(ARGV) = ptr_to_lispobj(argv);
2679  lisp_global(KERNEL_IMPORTS) = (LispObj)import_ptrs_base;
2680
2681  lisp_global(GET_TCR) = (LispObj) get_tcr;
2682  *(double *) &(lisp_global(DOUBLE_FLOAT_ONE)) = (double) 1.0;
2683
2684  lisp_global(HOST_PLATFORM) = (LispObj) PLATFORM << fixnumshift;
2685
2686  lisp_global(BATCH_FLAG) = (batch_flag << fixnumshift);
2687
2688  init_consing_areas();
2689  tcr = new_tcr(initial_stack_size, MIN_TSTACK_SIZE);
2690  stack_base = initial_stack_bottom()-xStackSpace();
2691  init_threads((void *)(stack_base), tcr);
2692  thread_init_tcr(tcr, current_sp, current_sp-stack_base);
2693
2694  if (lisp_global(STATIC_CONSES) == 0) {
2695    lisp_global(STATIC_CONSES) = lisp_nil;
2696  }
2697
2698
2699  lisp_global(EXCEPTION_LOCK) = ptr_to_lispobj(new_recursive_lock());
2700  enable_fp_exceptions();
2701  register_user_signal_handler();
2702  TCR_AUX(tcr)->prev = TCR_AUX(tcr)->next = tcr;
2703  lisp_global(INTERRUPT_SIGNAL) = (LispObj) box_fixnum(SIGNAL_FOR_PROCESS_INTERRUPT);
2704#ifdef GC_INTEGRITY_CHECKING
2705  (nrs_GC_EVENT_STATUS_BITS.vcell |= gc_integrity_check_bit);
2706#endif
2707  if (egc_enabled) {
2708    egc_control(true, NULL);
2709  } else {
2710    lisp_global(OLDSPACE_DNODE_COUNT) = 0;
2711  }
2712
2713  if (init_lisp(TCR_TO_TSD(tcr)) == 0) {
2714    return true;
2715  }
2716  return false;
2717}
2718
2719
2720/*
2721   This runs on a secondary thread that isn't bound to the JVM.
2722   Splitting the event loop in two like this is supposed to
2723   weaken timing constraints somehow.  It's not clear that it
2724   actually does so, but Android NDK examples generally use
2725   this mechanism.
2726*/
2727   
2728void 
2729android_main(struct android_app* state) 
2730{
2731  TCR *tcr;
2732  JNIEnv *env;
2733
2734  tcr = new_tcr(DEFAULT_INITIAL_STACK_SIZE, MIN_TSTACK_SIZE);
2735  thread_init_tcr(tcr, current_stack_pointer,DEFAULT_INITIAL_STACK_SIZE);
2736  (*android_vm)->AttachCurrentThread(android_vm, &env, NULL);
2737
2738  os_main(tcr, state);
2739  (*android_vm)->DetachCurrentThread(android_vm);
2740}
2741#endif
2742