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

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

Still not working; may not be for another few days.
Will create a branch for this and revert trunk.

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