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

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

newfangled --debug option. Seems to work on Linux, untested elsewhere.

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