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

Last change on this file since 14873 was 14873, checked in by rme, 8 years ago

Change signature of install_signal_handler() and update
callers.

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