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

Last change on this file since 16685 was 16685, checked in by rme, 4 years ago

Update copyright/license headers in files.

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