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

Last change on this file since 15473 was 15473, checked in by gb, 7 years ago

Ensure that darwin_sigreturn() is prototyped on platforms where it's
used.

Remove some remaining Mach-isms (notably the paging info stuff used
by GC-VERBOSE; just use getrusage()).

Make sure that the right headers are included in threads.h, to support
the remaining Mach-ism (use of Mach semaphores. Apple still doesn't
implement POSIX semaphores, though the functions have been prototyped
for several years now.)

This builds without warnings or errors on 10.8.1 with Xcode 4.4's
toolchain. It -may- address the problems described in ticket:1019.

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