source: branches/gb-egc/lisp-kernel/pmcl-kernel.c @ 15831

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

Zero dnodes when allocating segments, not in GC.

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