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

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

Defer all aspects of gcable-pointer termination until after other
threads have been resumed. This is necessary because some things
that we were doing earlier (sem_destroy, for instance) may try to
do memory operations that may require ownership of a lock owned
by some other thread.

There are some (hopefully minor) consequences of this change: the
GC has to retain an otherwise unreachable lisp XMACPTR object until
the next GC, and some foreign resources might by tied up slightly
longer than they had been in the old scheme.

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