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

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

Conditionalize out support for treating a single command-line
argument as an image name. This is a minor incompatible change,
but relieves some users of the stigma and shame of writing shell
script wrappers.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 56.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#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#ifdef SINGLE_ARG_SHORTHAND
1090  fprintf(dbgout, "\t or %s <image-name>\n", program_name);
1091#endif
1092  fprintf(dbgout, "\t where <options> are one or more of:\n");
1093  if (other_args && *other_args) {
1094    fputs(other_args, dbgout);
1095  }
1096  fprintf(dbgout, "\t-R, --heap-reserve <n>: reserve <n> (default: %lld)\n",
1097          (u64_t) reserved_area_size);
1098  fprintf(dbgout, "\t\t bytes for heap expansion\n");
1099  fprintf(dbgout, "\t-S, --stack-size <n>: set  size of initial thread's control stack to <n>\n");
1100  fprintf(dbgout, "\t-Z, --thread-stack-size <n>: set default size of first (listener)  thread's stacks based on <n>\n");
1101  fprintf(dbgout, "\t-b, --batch: exit when EOF on *STANDARD-INPUT*\n");
1102  fprintf(dbgout, "\t--no-sigtrap : obscure option for running under GDB\n");
1103  fprintf(dbgout, "\t-I, --image-name <image-name>\n");
1104#ifndef WINDOWS
1105  fprintf(dbgout, "\t and <image-name> defaults to %s\n", 
1106          default_image_name(program_name));
1107#endif
1108  fprintf(dbgout, "\n\tAny arguments following the pseudoargument \"--\" are\n");
1109  fprintf(dbgout, "\tnot processed and are available to the application as\n");
1110  fprintf(dbgout, "\tthe value of CCL:*UNPROCESSED-COMMAND-LINE-ARGUMENTS* .\n");
1111
1112  fprintf(dbgout, "\n");
1113  _exit(exit_status);
1114}
1115
1116int no_sigtrap = 0;
1117#ifdef WINDOWS
1118wchar_t *image_name = NULL;
1119#else
1120char *image_name = NULL;
1121#endif
1122int batch_flag = 0;
1123
1124
1125natural
1126parse_numeric_option(char *arg, char *argname, natural default_val)
1127{
1128  char *tail;
1129  natural val = 0;
1130
1131  val = strtoul(arg, &tail, 0);
1132  switch(*tail) {
1133  case '\0':
1134    break;
1135   
1136  case 'M':
1137  case 'm':
1138    val = val << 20;
1139    break;
1140   
1141  case 'K':
1142  case 'k':
1143    val = val << 10;
1144    break;
1145   
1146  case 'G':
1147  case 'g':
1148    val = val << 30;
1149    break;
1150   
1151  default:
1152    fprintf(dbgout, "couldn't parse %s argument %s", argname, arg);
1153    val = default_val;
1154    break;
1155  }
1156  return val;
1157}
1158 
1159
1160
1161/*
1162   The set of arguments recognized by the kernel is
1163   likely to remain pretty small and pretty simple.
1164   This removes everything it recognizes from argv;
1165   remaining args will be processed by lisp code.
1166*/
1167
1168void
1169process_options(int argc, char *argv[], wchar_t *shadow[])
1170{
1171  int i, j, k, num_elide, flag, arg_error;
1172  char *arg, *val;
1173  wchar_t *warg, *wval;
1174#ifdef DARWIN
1175  extern int NXArgc;
1176#endif
1177
1178  for (i = 1; i < argc;) {
1179    arg = argv[i];
1180    if (shadow) {
1181      warg = shadow[i];
1182    }
1183    arg_error = 0;
1184    if (*arg != '-') {
1185      i++;
1186    } else {
1187      num_elide = 0;
1188      val = NULL;
1189      if ((flag = (strncmp(arg, "-I", 2) == 0)) ||
1190          (strcmp (arg, "--image-name") == 0)) {
1191        if (flag && arg[2]) {
1192          val = arg+2;         
1193          if (shadow) {
1194            wval = warg+2;
1195          }
1196          num_elide = 1;
1197        } else {
1198          if ((i+1) < argc) {
1199            val = argv[i+1];
1200            if (shadow) {
1201              wval = shadow[i+1];
1202            }
1203            num_elide = 2;
1204          } else {
1205            arg_error = 1;
1206          }
1207        }
1208        if (val) {
1209#ifdef WINDOWS
1210          image_name = wval;
1211#else
1212          image_name = val;
1213#endif
1214        }
1215      } else if ((flag = (strncmp(arg, "-R", 2) == 0)) ||
1216                 (strcmp(arg, "--heap-reserve") == 0)) {
1217        natural reserved_size = reserved_area_size;
1218
1219        if (flag && arg[2]) {
1220          val = arg+2;
1221          num_elide = 1;
1222        } else {
1223          if ((i+1) < argc) {
1224            val = argv[i+1];
1225            num_elide = 2;
1226          } else {
1227            arg_error = 1;
1228          }
1229        }
1230
1231        if (val) {
1232          reserved_size = parse_numeric_option(val, 
1233                                               "-R/--heap-reserve", 
1234                                               reserved_area_size);
1235        }
1236
1237        if (reserved_size <= MAXIMUM_MAPPABLE_MEMORY) {
1238          reserved_area_size = reserved_size;
1239        }
1240
1241      } else if ((flag = (strncmp(arg, "-S", 2) == 0)) ||
1242                 (strcmp(arg, "--stack-size") == 0)) {
1243        natural stack_size;
1244
1245        if (flag && arg[2]) {
1246          val = arg+2;
1247          num_elide = 1;
1248        } else {
1249          if ((i+1) < argc) {
1250            val = argv[i+1];
1251            num_elide = 2;
1252          } else {
1253            arg_error = 1;
1254          }
1255        }
1256
1257        if (val) {
1258          stack_size = parse_numeric_option(val, 
1259                                            "-S/--stack-size", 
1260                                            initial_stack_size);
1261         
1262
1263          if (stack_size >= MIN_CSTACK_SIZE) {
1264            initial_stack_size = stack_size;
1265          }
1266        }
1267
1268      } else if ((flag = (strncmp(arg, "-Z", 2) == 0)) ||
1269                 (strcmp(arg, "--thread-stack-size") == 0)) {
1270        natural stack_size;
1271
1272        if (flag && arg[2]) {
1273          val = arg+2;
1274          num_elide = 1;
1275        } else {
1276          if ((i+1) < argc) {
1277            val = argv[i+1];
1278            num_elide = 2;
1279          } else {
1280            arg_error = 1;
1281          }
1282        }
1283
1284        if (val) {
1285          stack_size = parse_numeric_option(val, 
1286                                            "-Z/--thread-stack-size", 
1287                                            thread_stack_size);
1288         
1289
1290          if (stack_size >= MIN_CSTACK_SIZE) {
1291           thread_stack_size = stack_size;
1292          }
1293          if (thread_stack_size >= (1LL<<((WORD_SIZE-fixnumshift)-1))) {
1294            thread_stack_size = (1LL<<((WORD_SIZE-fixnumshift)-1))-1;
1295          }
1296         
1297        }
1298
1299      } else if (strcmp(arg, "--no-sigtrap") == 0) {
1300        no_sigtrap = 1;
1301        num_elide = 1;
1302      } else if ((strcmp(arg, "-b") == 0) ||
1303                 (strcmp(arg, "--batch") == 0)) {
1304        batch_flag = 1;
1305        num_elide = 1;
1306      } else if (strcmp(arg,"--") == 0) {
1307        break;
1308      } else {
1309        i++;
1310      }
1311      if (arg_error) {
1312        usage_exit("error in program arguments", 1, "");
1313      }
1314      if (num_elide) {
1315        for (j = i+num_elide, k=i; j < argc; j++, k++) {
1316          argv[k] = argv[j];
1317          if (shadow) {
1318            shadow[k] = shadow[j];
1319          }
1320        }
1321        argc -= num_elide;
1322#ifdef DARWIN
1323        NXArgc -= num_elide;
1324#endif
1325        argv[argc] = NULL;
1326        if (shadow) {
1327          shadow[argc] = NULL;
1328        }
1329      }
1330    }
1331  }
1332}
1333
1334#ifdef WINDOWS
1335void
1336terminate_lisp()
1337{
1338  _exit(EXIT_FAILURE);
1339}
1340#else
1341pid_t main_thread_pid = (pid_t)0;
1342
1343void
1344terminate_lisp()
1345{
1346  kill(main_thread_pid, SIGKILL);
1347  _exit(-1);
1348}
1349#endif
1350
1351#ifdef DARWIN
1352#define min_os_version "8.0"    /* aka Tiger */
1353#endif
1354#ifdef LINUX
1355#ifdef PPC
1356#define min_os_version "2.2"
1357#endif
1358#ifdef X86
1359#define min_os_version "2.6"
1360#endif
1361#ifdef ARM
1362#define min_os_version "2.6"
1363#endif
1364#endif
1365#ifdef FREEBSD
1366#define min_os_version "6.0"
1367#endif
1368#ifdef SOLARIS
1369#define min_os_version "5.10"
1370#endif
1371
1372#ifdef PPC
1373#if defined(PPC64) || !defined(DARWIN)
1374/* ld64 on Darwin doesn't offer anything close to reliable control
1375   over the layout of a program in memory.  About all that we can
1376   be assured of is that the canonical subprims jump table address
1377   (currently 0x5000) is unmapped.  Map that page, and copy the
1378   actual spjump table there. */
1379
1380
1381void
1382remap_spjump()
1383{
1384  extern opcode spjump_start, spjump_end;
1385  pc new,
1386    old = &spjump_start,
1387    limit = &spjump_end,
1388    work;
1389  opcode instr;
1390  void *target;
1391  int disp;
1392 
1393  if (old != (pc)SPJUMP_TARGET_ADDRESS) {
1394    new = mmap((pc) SPJUMP_TARGET_ADDRESS,
1395               0x1000,
1396               PROT_READ | PROT_WRITE | PROT_EXEC,
1397               MAP_PRIVATE | MAP_ANON | MAP_FIXED,
1398               -1,
1399               0);
1400    if (new != (pc) SPJUMP_TARGET_ADDRESS) {
1401      perror("remap spjump");
1402      _exit(1);
1403    }
1404   
1405    for (work = new; old < limit; work++, old++) {
1406      instr = *old;
1407      disp = instr & ((1<<26)-1);
1408      target = (void*)old+disp;
1409      disp = target-(void *)work;
1410      *work = ((instr >> 26) << 26) | disp;
1411    }
1412    xMakeDataExecutable(new, (void*)work-(void*)new);
1413    ProtectMemory(new, 0x1000);
1414  }
1415}
1416#endif
1417#endif
1418
1419#ifdef X86
1420#ifdef WINDOWS
1421
1422/* By using linker tricks, we ensure there's memory between 0x11000
1423   and 0x21000, so we just need to fix permissions and copy the spjump
1424   table. */
1425
1426void
1427remap_spjump()
1428{
1429  extern opcode spjump_start;
1430  DWORD old_protect;
1431
1432  if ((void *)(&spjump_start) != (void *) SPJUMP_TARGET_ADDRESS) {
1433    if (!VirtualProtect((pc) SPJUMP_TARGET_ADDRESS,
1434                        0x1000,
1435                        PAGE_READWRITE,
1436                        &old_protect)) {
1437      wperror("VirtualProtect spjump");
1438      _exit(1);
1439    }
1440    memmove((pc) SPJUMP_TARGET_ADDRESS, &spjump_start, 0x1000);
1441  }
1442}
1443#else
1444void
1445remap_spjump()
1446{
1447  extern opcode spjump_start;
1448  pc new = mmap((pc) SPJUMP_TARGET_ADDRESS,
1449                0x1000,
1450                PROT_READ | PROT_WRITE,
1451                MAP_PRIVATE | MAP_ANON | MAP_FIXED,
1452                -1,
1453                0),
1454    old = &spjump_start;
1455  if (new == (pc)-1) {
1456    perror("remap spjump");
1457    _exit(1);
1458  }
1459  memmove(new, old, 0x1000);
1460}
1461#endif
1462#endif
1463
1464
1465void
1466check_os_version(char *progname)
1467{
1468#ifdef WINDOWS
1469  /* 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. */
1470#else
1471  struct utsname uts;
1472  long got, want;
1473  char *got_end,*want_end;
1474
1475  want = strtoul(min_os_version,&want_end,10);
1476
1477  uname(&uts);
1478  got = strtoul(uts.release,&got_end,10);
1479#if defined(X8632) && defined(FREEBSD)
1480  if (!strcmp(uts.machine,"amd64")) {
1481    extern Boolean rcontext_readonly;
1482
1483    rcontext_readonly = true;
1484  }
1485#endif
1486#ifdef WIN_32
1487  rcontext_readonly = true;
1488#endif
1489  while (got == want) {
1490    if (*want_end == '.') {
1491      want = strtoul(want_end+1,&want_end,10);
1492      got = 0;
1493      if (*got_end == '.') {
1494        got = strtoul(got_end+1,&got_end,10);
1495      } else {
1496        break;
1497      }
1498    } else {
1499      break;
1500    }
1501  }
1502
1503  if (got < want) {
1504    fprintf(dbgout, "\n%s requires %s version %s or later; the current version is %s.\n", progname, uts.sysname, min_os_version, uts.release);
1505    exit(1);
1506  }
1507#endif
1508}
1509
1510#ifdef X86
1511/*
1512  This should determine the cache block size.  It should also
1513  probably complain if we don't have (at least) SSE2.
1514*/
1515extern int cpuid(natural, natural*, natural*, natural*);
1516
1517#define X86_FEATURE_CMOV    (1<<15)
1518#define X86_FEATURE_CLFLUSH (1<<19)
1519#define X86_FEATURE_MMX     (1<<23)
1520#define X86_FEATURE_SSE     (1<<25)
1521#define X86_FEATURE_SSE2    (1<<26)
1522
1523#define X86_REQUIRED_FEATURES (X86_FEATURE_CMOV|X86_FEATURE_MMX|X86_FEATURE_SSE|X86_FEATURE_SSE2)
1524
1525Boolean
1526check_x86_cpu()
1527{
1528  natural eax, ebx, ecx, edx;
1529
1530  eax = cpuid(0, &ebx, &ecx, &edx);
1531
1532  if (eax >= 1) {
1533    eax = cpuid(1, &ebx, &ecx, &edx);
1534    cache_block_size = (ebx & 0xff00) >> 5;
1535    if ((X86_REQUIRED_FEATURES & edx) == X86_REQUIRED_FEATURES) {
1536      return true;
1537    }
1538    /* It's very unlikely that SSE2 would be present and other things
1539       that we want wouldn't.  If they don't have MMX or CMOV either,
1540       might as well tell them. */
1541    if ((edx & X86_FEATURE_SSE2) == 0) {
1542      fprintf(dbgout, "This CPU doesn't support the SSE2 instruction set\n");
1543    }
1544    if ((edx & X86_FEATURE_MMX) == 0) {
1545      fprintf(dbgout, "This CPU doesn't support the MMX instruction set\n");
1546    }
1547    if ((edx & X86_FEATURE_CMOV) == 0) {
1548      fprintf(dbgout, "This CPU doesn't support the CMOV instruction\n");
1549    }
1550   
1551  }
1552  return false;
1553}
1554#endif
1555
1556#ifdef ARM
1557Boolean
1558check_arm_cpu()
1559{
1560  Boolean win = false;
1561#ifdef LINUX
1562/* It's hard to determine ARM features in general, and especially
1563   hard to do so from user mode.  Parse /proc/cpuinfo.
1564   According to Android's cpufeatures library, some ARMv6 chips
1565   are reported to have archutecture version 7; check the ELF
1566   architecture in this case.
1567
1568   (In other words, we assume that we're on ARMv7 or later if
1569   the reported architecture is > 7, or if it's = 7 and the
1570   ELF architecture is "v7l".)
1571*/
1572  FILE *f = fopen("/proc/cpuinfo", "r");
1573  char *procline = NULL, *cpuline = NULL, line[129], *workline;
1574  size_t n;
1575
1576  if (f) {
1577    while (1) {
1578      if (fgets(line,128,f)==NULL) {
1579        break;
1580      }
1581      n = strlen(line);
1582      if (strncmp(line,"Processor",sizeof("Processor")-1) == 0) {
1583        procline = malloc(n+1);
1584        strcpy(procline,line);
1585        procline[n]='\0';
1586      } else if (strncmp(line, "CPU architecture",sizeof("CPU architecture")-1) == 0) {
1587        cpuline = malloc(n+1);
1588        strcpy(cpuline,line);
1589        cpuline[n] = '\0';
1590      }
1591    }
1592    if (cpuline) {
1593      workline = index(cpuline,':');
1594      if (workline) {
1595        n = strtol(workline+1,NULL,0);
1596        if (n >= 7) {
1597          if (n == 7) {
1598            if (procline) {
1599              win = (strstr(procline, "v7l") != NULL);
1600            }
1601          } else {
1602            win = true;
1603          }
1604        }
1605      }
1606    }
1607    if (procline) {
1608      free(procline);
1609    }
1610    if (cpuline) {
1611      free(cpuline);
1612    }
1613    fclose(f);
1614  }
1615#endif
1616  return win;
1617}
1618#endif 
1619
1620void
1621lazarus()
1622{
1623  TCR *tcr = get_tcr(false);
1624  if (tcr) {
1625    /* Some threads may be dying; no threads should be created. */
1626    LOCK(lisp_global(TCR_AREA_LOCK),tcr);
1627    tcr->vs_area->active = tcr->vs_area->high - node_size;
1628    tcr->save_vsp = (LispObj *)(tcr->vs_area->active);
1629#ifndef ARM
1630    tcr->ts_area->active = tcr->ts_area->high;
1631    tcr->save_tsp = (LispObj *)(tcr->ts_area->active);
1632#endif
1633    tcr->catch_top = 0;
1634    tcr->db_link = 0;
1635    tcr->xframe = 0;
1636    start_lisp(tcr, 0);
1637  }
1638}
1639
1640#ifdef LINUX
1641#ifdef X8664
1642#include <asm/prctl.h>
1643#include <sys/prctl.h>
1644
1645void
1646ensure_gs_available(char *progname)
1647{
1648  LispObj fs_addr = 0L, gs_addr = 0L, cur_thread = (LispObj)pthread_self();
1649  char *gnu_get_libc_version(void);
1650 
1651  arch_prctl(ARCH_GET_GS, &gs_addr);
1652  arch_prctl(ARCH_GET_FS, &fs_addr);
1653  if ((gs_addr == cur_thread) && (fs_addr != cur_thread)) {
1654    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);
1655    _exit(1);
1656  }
1657}
1658#endif
1659#endif
1660
1661Boolean
1662bogus_fp_exceptions = false;
1663
1664typedef
1665float (*float_arg_returns_float)(float);
1666
1667float
1668fcallf(float_arg_returns_float fun, float arg)
1669{
1670  return fun(arg);
1671}
1672
1673void
1674check_bogus_fp_exceptions()
1675{
1676#ifdef X8664
1677  float asinf(float),result;
1678   
1679
1680  natural save_mxcsr = get_mxcsr(), post_mxcsr;
1681  set_mxcsr(0x1f80);
1682
1683  result = fcallf(asinf, 1.0);
1684  post_mxcsr = get_mxcsr();
1685  set_mxcsr(save_mxcsr);
1686  if (post_mxcsr & (FE_ALL_EXCEPT & (~FE_INEXACT))) {
1687    bogus_fp_exceptions = true;
1688  }
1689#endif
1690}
1691
1692#ifdef WINDOWS
1693char *
1694utf_16_to_utf_8(wchar_t *utf_16)
1695{
1696  int utf8len = WideCharToMultiByte(CP_UTF8,
1697                                    0,
1698                                    utf_16,
1699                                    -1,
1700                                    NULL,
1701                                    0,
1702                                    NULL,
1703                                    NULL);
1704
1705  char *utf_8 = malloc(utf8len);
1706
1707  WideCharToMultiByte(CP_UTF8,
1708                      0,
1709                      utf_16,
1710                      -1,
1711                      utf_8,
1712                      utf8len,
1713                      NULL,
1714                      NULL);
1715
1716  return utf_8;
1717}
1718
1719char **
1720wide_argv_to_utf_8(wchar_t *wide_argv[], int argc)
1721{
1722  char** argv = calloc(argc+1,sizeof(char *));
1723  int i;
1724
1725  for (i = 0; i < argc; i++) {
1726    if (wide_argv[i]) {
1727      argv[i] = utf_16_to_utf_8(wide_argv[i]);
1728    } else {
1729      argv[i] = NULL;
1730    }
1731  }
1732  return argv;
1733}
1734#endif
1735
1736
1737
1738
1739int
1740#ifdef CCLSHARED
1741cclmain
1742#else
1743main
1744#endif
1745(int argc, char *argv[]
1746#if defined(PPC) && defined(LINUX)
1747, char *envp[], void *aux
1748#endif
1749)
1750{
1751  extern int page_size;
1752  natural default_g0_threshold = G0_AREA_THRESHOLD,
1753    default_g1_threshold = G1_AREA_THRESHOLD,
1754    default_g2_threshold = G2_AREA_THRESHOLD,
1755    lisp_heap_threshold_from_image = 0;
1756  Boolean egc_enabled =
1757#ifdef DISABLE_EGC
1758    false
1759#else
1760    true
1761#endif
1762    ;
1763  Boolean lisp_heap_threshold_set_from_command_line = false;
1764  wchar_t **utf_16_argv = NULL;
1765
1766#ifdef PPC
1767  extern int altivec_present;
1768#endif
1769#ifdef WINDOWS
1770  extern LispObj load_image(wchar_t *);
1771#else
1772  extern LispObj load_image(char *);
1773#endif
1774  area *a;
1775  BytePtr stack_base, current_sp = (BytePtr) current_stack_pointer();
1776  TCR *tcr;
1777
1778  dbgout = stderr;
1779
1780#ifdef WINDOWS
1781  {
1782    int wide_argc;
1783    extern void init_winsock(void);
1784    extern void init_windows_io(void);
1785    extern void reserve_tls_slots(void);
1786
1787    _fmode = O_BINARY;
1788    _setmode(1, O_BINARY);
1789    _setmode(2, O_BINARY);
1790    setvbuf(dbgout, NULL, _IONBF, 0);
1791    init_winsock();
1792    init_windows_io();
1793    reserve_tls_slots();
1794    utf_16_argv = CommandLineToArgvW(GetCommandLineW(),&wide_argc);
1795  }
1796#endif
1797
1798  check_os_version(argv[0]);
1799#ifdef WINDOWS
1800  real_executable_name = determine_executable_name();
1801#else
1802  real_executable_name = determine_executable_name(argv[0]);
1803#endif
1804  page_size = getpagesize(); /* Implement with GetSystemInfo on Windows w/o MinGW */
1805
1806  check_bogus_fp_exceptions();
1807#ifdef LINUX
1808#ifdef X8664
1809  ensure_gs_available(real_executable_name);
1810#endif
1811#endif
1812#if (defined(DARWIN) && defined(PPC64)) || (defined(LINUX) && defined(PPC))|| defined(X8664) || (defined(X8632) && !defined(DARWIN))
1813  remap_spjump();
1814#endif
1815
1816#ifdef PPC
1817#ifdef LINUX
1818  {
1819    ElfW(auxv_t) *av = aux;
1820    int hwcap, done = false;
1821   
1822    if (av) {
1823      do {
1824        switch (av->a_type) {
1825        case AT_DCACHEBSIZE:
1826          cache_block_size = av->a_un.a_val;
1827          break;
1828
1829        case AT_HWCAP:
1830          hwcap = av->a_un.a_val;
1831          altivec_present = ((hwcap & PPC_FEATURE_HAS_ALTIVEC) != 0);
1832          break;
1833
1834        case AT_NULL:
1835          done = true;
1836          break;
1837        }
1838        av++;
1839      } while (!done);
1840    }
1841  }
1842#endif
1843#ifdef DARWIN
1844  {
1845    unsigned value = 0;
1846    size_t len = sizeof(value);
1847    int mib[2];
1848   
1849    mib[0] = CTL_HW;
1850    mib[1] = HW_CACHELINE;
1851    if (sysctl(mib,2,&value,&len, NULL, 0) != -1) {
1852      if (len == sizeof(value)) {
1853        cache_block_size = value;
1854      }
1855    }
1856    mib[1] = HW_VECTORUNIT;
1857    value = 0;
1858    len = sizeof(value);
1859    if (sysctl(mib,2,&value,&len, NULL, 0) != -1) {
1860      if (len == sizeof(value)) {
1861        altivec_present = value;
1862      }
1863    }
1864  }
1865#endif
1866#endif
1867
1868#ifdef X86
1869  if (!check_x86_cpu()) {
1870    fprintf(dbgout, "CPU doesn't support required features\n");
1871    exit(1);
1872  }
1873#endif
1874
1875#ifdef ARM
1876  if (!check_arm_cpu()) {
1877    fprintf(dbgout, "CPU doesn't support required features\n");
1878    exit(1);
1879  }
1880#endif
1881
1882#ifdef SOLARIS
1883#ifdef X8632
1884  {
1885    extern void solaris_ldt_init(void);
1886    solaris_ldt_init();
1887  }
1888#endif
1889#endif
1890
1891#ifndef WINDOWS
1892  main_thread_pid = getpid();
1893#endif
1894  tcr_area_lock = (void *)new_recursive_lock();
1895
1896  program_name = argv[0];
1897#ifdef SINGLE_ARG_SHORTHAND
1898  if ((argc == 2) && (*argv[1] != '-')) {
1899#ifdef WINDOWS
1900    image_name = utf_16_argv[1];
1901#else
1902    image_name = argv[1];
1903#endif
1904    argv[1] = NULL;
1905#ifdef WINDOWS
1906    utf_16_argv[1] = NULL;
1907#endif
1908  } else {
1909#endif  /* SINGLE_ARG_SHORTHAND */
1910    process_options(argc,argv,utf_16_argv);
1911#ifdef SINGLE_ARG_SHORTHAND
1912  }
1913#endif
1914  if (lisp_heap_gc_threshold != DEFAULT_LISP_HEAP_GC_THRESHOLD) {
1915    lisp_heap_threshold_set_from_command_line = true;
1916  }
1917
1918  initial_stack_size = ensure_stack_limit(initial_stack_size);
1919  if (image_name == NULL) {
1920    if (check_for_embedded_image(real_executable_name)) {
1921      image_name = real_executable_name;
1922    } else {
1923      image_name = default_image_name(real_executable_name);
1924    }
1925  }
1926
1927  while (1) {
1928    if (create_reserved_area(reserved_area_size)) {
1929      break;
1930    }
1931    reserved_area_size = reserved_area_size *.9;
1932  }
1933
1934  gc_init();
1935
1936  set_nil(load_image(image_name));
1937  lisp_heap_notify_threshold = GC_NOTIFY_THRESHOLD;
1938  lisp_heap_threshold_from_image = lisp_global(LISP_HEAP_THRESHOLD);
1939 
1940  if (lisp_heap_threshold_from_image) {
1941    if ((!lisp_heap_threshold_set_from_command_line) &&
1942        (lisp_heap_threshold_from_image != lisp_heap_gc_threshold)) {
1943      lisp_heap_gc_threshold = lisp_heap_threshold_from_image;
1944      resize_dynamic_heap(active_dynamic_area->active,lisp_heap_gc_threshold);
1945    }
1946    /* If lisp_heap_threshold_from_image was set, other image params are
1947       valid. */
1948    default_g0_threshold = lisp_global(G0_THRESHOLD);
1949    default_g1_threshold = lisp_global(G1_THRESHOLD);
1950    default_g2_threshold = lisp_global(G2_THRESHOLD);
1951    egc_enabled = lisp_global(EGC_ENABLED);
1952  }
1953
1954  lisp_global(TCR_AREA_LOCK) = ptr_to_lispobj(tcr_area_lock);
1955
1956#ifdef X86
1957  lisp_global(SUBPRIMS_BASE) = (LispObj)((1<<16)+(5<<10));
1958#endif
1959#ifdef PPC
1960  lisp_global(SUBPRIMS_BASE) = (LispObj)(5<<10);
1961#endif
1962#ifdef ARM
1963  lisp_global(SUBPRIMS_BASE) = (LispObj)(9<<12);
1964#endif
1965
1966  lisp_global(RET1VALN) = (LispObj)&ret1valn;
1967  lisp_global(LEXPR_RETURN) = (LispObj)&nvalret;
1968  lisp_global(LEXPR_RETURN1V) = (LispObj)&popj;
1969  lisp_global(ALL_AREAS) = ptr_to_lispobj(all_areas);
1970  lisp_global(DEFAULT_ALLOCATION_QUANTUM) = log2_heap_segment_size << fixnumshift;
1971  lisp_global(STACK_SIZE) = thread_stack_size<<fixnumshift;
1972
1973
1974  exception_init();
1975
1976 
1977
1978#ifdef WINDOWS
1979  lisp_global(IMAGE_NAME) = ptr_to_lispobj(utf_16_to_utf_8(ensure_real_path(image_name)));
1980  lisp_global(KERNEL_PATH) = ptr_to_lispobj(utf_16_to_utf_8(real_executable_name));
1981  lisp_global(ARGV) = ptr_to_lispobj(wide_argv_to_utf_8(utf_16_argv, argc));
1982#else
1983  lisp_global(IMAGE_NAME) = ptr_to_lispobj(ensure_real_path(image_name));
1984  lisp_global(KERNEL_PATH) = ptr_to_lispobj(real_executable_name);
1985  lisp_global(ARGV) = ptr_to_lispobj(argv);
1986#endif
1987  lisp_global(KERNEL_IMPORTS) = (LispObj)import_ptrs_base;
1988
1989  lisp_global(GET_TCR) = (LispObj) get_tcr;
1990  *(double *) &(lisp_global(DOUBLE_FLOAT_ONE)) = (double) 1.0;
1991
1992  lisp_global(HOST_PLATFORM) = (LispObj) PLATFORM << fixnumshift;
1993
1994  lisp_global(BATCH_FLAG) = (batch_flag << fixnumshift);
1995
1996  a = active_dynamic_area;
1997
1998  if (nilreg_area != NULL) {
1999    BytePtr lowptr = (BytePtr) a->low;
2000
2001    /* Create these areas as AREA_STATIC, change them to AREA_DYNAMIC */
2002    g1_area = new_area(lowptr, lowptr, AREA_STATIC);
2003    g2_area = new_area(lowptr, lowptr, AREA_STATIC);
2004    tenured_area = new_area(lowptr, lowptr, AREA_STATIC);
2005    add_area_holding_area_lock(tenured_area);
2006    add_area_holding_area_lock(g2_area);
2007    add_area_holding_area_lock(g1_area);
2008
2009    g1_area->code = AREA_DYNAMIC;
2010    g2_area->code = AREA_DYNAMIC;
2011    tenured_area->code = AREA_DYNAMIC;
2012
2013/*    a->older = g1_area; */ /* Not yet: this is what "enabling the EGC" does. */
2014    g1_area->younger = a;
2015    g1_area->older = g2_area;
2016    g2_area->younger = g1_area;
2017    g2_area->older = tenured_area;
2018    tenured_area->younger = g2_area;
2019    tenured_area->refbits = dynamic_mark_ref_bits;
2020    managed_static_area->refbits = global_mark_ref_bits;
2021    a->markbits = dynamic_mark_ref_bits;
2022    tenured_area->static_dnodes = a->static_dnodes;
2023    a->static_dnodes = 0;
2024    tenured_area->static_used = a->static_used;
2025    a->static_used = 0;
2026    lisp_global(TENURED_AREA) = ptr_to_lispobj(tenured_area);
2027    lisp_global(STATIC_CONS_AREA) = ptr_to_lispobj(static_cons_area);
2028    lisp_global(REFBITS) = ptr_to_lispobj(global_mark_ref_bits);
2029    g2_area->threshold = default_g2_threshold;
2030    g1_area->threshold = default_g1_threshold;
2031    a->threshold = default_g0_threshold;
2032  }
2033
2034  tcr = new_tcr(initial_stack_size, MIN_TSTACK_SIZE);
2035  stack_base = initial_stack_bottom()-xStackSpace();
2036  init_threads((void *)(stack_base), tcr);
2037  thread_init_tcr(tcr, current_sp, current_sp-stack_base);
2038
2039  if (lisp_global(STATIC_CONSES) == 0) {
2040    lisp_global(STATIC_CONSES) = lisp_nil;
2041  }
2042
2043  lisp_global(EXCEPTION_LOCK) = ptr_to_lispobj(new_recursive_lock());
2044  enable_fp_exceptions();
2045  register_user_signal_handler();
2046
2047#ifdef PPC
2048  lisp_global(ALTIVEC_PRESENT) = altivec_present << fixnumshift;
2049#endif
2050#if STATIC
2051  lisp_global(STATICALLY_LINKED) = 1 << fixnumshift;
2052#endif
2053  TCR_AUX(tcr)->prev = TCR_AUX(tcr)->next = tcr;
2054#ifndef WINDOWS
2055  lisp_global(INTERRUPT_SIGNAL) = (LispObj) box_fixnum(SIGNAL_FOR_PROCESS_INTERRUPT);
2056#endif
2057  tcr->vs_area->active -= node_size;
2058  *(--tcr->save_vsp) = nrs_TOPLFUNC.vcell;
2059  nrs_TOPLFUNC.vcell = lisp_nil;
2060#ifdef GC_INTEGRITY_CHECKING
2061  (nrs_GC_EVENT_STATUS_BITS.vcell |= gc_integrity_check_bit);
2062#endif
2063  if (egc_enabled) {
2064    egc_control(true, NULL);
2065  } else {
2066    lisp_global(OLDSPACE_DNODE_COUNT) = area_dnode(managed_static_area->active,managed_static_area->low);
2067  }
2068  atexit(lazarus);
2069#ifdef ARM
2070#ifdef LINUX
2071#ifdef SET_INITIAL_THREAD_AFFINITY
2072  /* Maybe work around an apparent cache coherency problem */
2073  set_thread_affinity(tcr,0);
2074#endif
2075#endif
2076#endif
2077  start_lisp(TCR_TO_TSD(tcr), 0);
2078  _exit(0);
2079}
2080
2081area *
2082set_nil(LispObj r)
2083{
2084
2085  if (lisp_nil == (LispObj)NULL) {
2086
2087    lisp_nil = r;
2088  }
2089  return NULL;
2090}
2091
2092
2093void
2094xMakeDataExecutable(void *start, unsigned long nbytes)
2095{
2096#ifdef PPC
2097  extern void flush_cache_lines();
2098  natural ustart = (natural) start, base, end;
2099 
2100  base = (ustart) & ~(cache_block_size-1);
2101  end = (ustart + nbytes + cache_block_size - 1) & ~(cache_block_size-1);
2102  flush_cache_lines(base, (end-base)/cache_block_size, cache_block_size);
2103#endif
2104#ifdef ARM
2105  extern void flush_cache_lines(void *, size_t);
2106  flush_cache_lines(start,nbytes);
2107#endif
2108}
2109
2110natural
2111xStackSpace()
2112{
2113  return initial_stack_size+CSTACK_HARDPROT+CSTACK_SOFTPROT;
2114}
2115
2116#ifndef DARWIN
2117#ifdef WINDOWS
2118extern void *windows_open_shared_library(char *);
2119
2120void *
2121xGetSharedLibrary(char *path, int mode)
2122{
2123  return windows_open_shared_library(path);
2124}
2125#else
2126void *
2127xGetSharedLibrary(char *path, int mode)
2128{
2129  return dlopen(path, mode);
2130}
2131#endif
2132#else
2133void *
2134xGetSharedLibrary(char *path, int *resultType)
2135{
2136  const char *error;
2137  void *result;
2138
2139  result = dlopen(path, RTLD_NOW | RTLD_GLOBAL);
2140 
2141  if (result == NULL) {
2142    error = dlerror();
2143    *resultType = 0;
2144    return (void *)error;
2145  }
2146  *resultType = 1;
2147  return result;
2148}
2149#endif
2150
2151
2152
2153int
2154fd_setsize_bytes()
2155{
2156  return sizeof(fd_set);
2157}
2158
2159void
2160do_fd_set(int fd, fd_set *fdsetp)
2161{
2162  FD_SET(fd, fdsetp);
2163}
2164
2165void
2166do_fd_clr(int fd, fd_set *fdsetp)
2167{
2168  FD_CLR(fd, fdsetp);
2169}
2170
2171int
2172do_fd_is_set(int fd, fd_set *fdsetp)
2173{
2174  return FD_ISSET(fd,fdsetp);
2175}
2176
2177
2178void
2179do_fd_zero(fd_set *fdsetp)
2180{
2181  FD_ZERO(fdsetp);
2182}
2183
2184#include "image.h"
2185
2186
2187
2188Boolean
2189check_for_embedded_image (
2190#ifdef WINDOWS
2191                          wchar_t *path
2192#else
2193                          char *path
2194#endif
2195                          )
2196{
2197#ifdef WINDOWS
2198  int fd = wopen(path, O_RDONLY);
2199#else 
2200  int fd = open(path, O_RDONLY);
2201#endif
2202
2203  Boolean image_is_embedded = false;
2204
2205  if (fd >= 0) {
2206    openmcl_image_file_header h;
2207
2208    if (find_openmcl_image_file_header (fd, &h)) {
2209      image_is_embedded = true;
2210    }
2211    close (fd);
2212  }
2213  return image_is_embedded;
2214}
2215
2216LispObj
2217load_image(
2218#ifdef WINDOWS
2219           wchar_t * path
2220#else
2221           char *path
2222#endif
2223)
2224{
2225#ifdef WINDOWS
2226  int fd = wopen(path, O_RDONLY, 0666), err;
2227#else
2228  int fd = open(path, O_RDONLY, 0666), err;
2229#endif
2230  LispObj image_nil = 0;
2231
2232  if (fd > 0) {
2233    openmcl_image_file_header ih;
2234
2235    errno = 0;
2236    image_nil = load_openmcl_image(fd, &ih);
2237    /* We -were- using a duplicate fd to map the file; that
2238       seems to confuse Darwin (doesn't everything ?), so
2239       we'll instead keep the original file open.
2240    */
2241    err = errno;
2242    if (!image_nil) {
2243      close(fd);
2244    }
2245#ifdef WINDOWS
2246    /* We currently don't actually map the image, and leaving the file
2247       open seems to make it difficult to write to reliably. */
2248    if (image_nil) {
2249      close(fd);
2250    }
2251#endif
2252  } else {
2253    err = errno;
2254  }
2255#ifdef DARWIN
2256#ifdef X86
2257  if (image_nil == 0) {
2258    extern LispObj load_native_library(char *);
2259    image_nil = load_native_library(path);
2260  }
2261#endif
2262#endif
2263  if (image_nil == 0) {
2264#ifdef WINDOWS
2265    char *fmt = "Couldn't load lisp heap image from %ls";
2266#else
2267    char *fmt = "Couldn't load lisp heap image from %s";
2268#endif
2269
2270    fprintf(dbgout, fmt, path);
2271    if (err == 0) {
2272      fprintf(dbgout, "\n");
2273    } else {
2274      fprintf(dbgout, ": %s\n", strerror(err));
2275    }
2276    exit(-1);
2277  }
2278  return image_nil;
2279}
2280
2281int
2282set_errno(int val)
2283{
2284  errno = val;
2285  return -1;
2286}
2287
2288
2289
2290
2291void *
2292xFindSymbol(void* handle, char *name)
2293{
2294#if defined(LINUX) || defined(FREEBSD) || defined(SOLARIS)
2295#ifdef ANDROID
2296  if (handle == NULL) {
2297    handle = RTLD_DEFAULT;
2298  }
2299#endif
2300  return dlsym(handle, name);
2301#endif
2302#ifdef DARWIN
2303  void *result;
2304
2305  if ((handle == NULL) || (handle == ((void *) -1))) {
2306    handle = RTLD_DEFAULT;
2307  }   
2308  result = dlsym(handle, name);
2309  if ((result == NULL) && (*name == '_')) {
2310    result = dlsym(handle, name+1);
2311  }
2312  return result;
2313#endif
2314#ifdef WINDOWS
2315  extern void *windows_find_symbol(void *, char *);
2316  return windows_find_symbol(handle, name);
2317#endif
2318}
2319#if defined(LINUX) || defined(FREEBSD) || defined(SOLARIS)
2320#if WORD_SIZE == 64
2321typedef Elf64_Dyn Elf_Dyn;
2322typedef Elf64_Ehdr Elf_Ehdr;
2323typedef Elf64_Shdr Elf_Shdr;
2324#else
2325typedef Elf32_Dyn Elf_Dyn;
2326typedef Elf32_Ehdr Elf_Ehdr;
2327typedef Elf32_Shdr Elf_Shdr;
2328#endif
2329
2330Elf_Dyn *
2331get_executable_dynamic_entries()
2332{
2333#ifndef CCLSHARED
2334  extern Elf_Dyn _DYNAMIC[];
2335  return _DYNAMIC;
2336#else
2337#ifdef ANDROID
2338  /* Deep, dark secret: the "handle" returned by dlopen() is
2339     a pointer to an soinfo structure, as defined in linker.h.
2340     We can get the link map from there ...
2341  */
2342 
2343
2344 
2345  /* Woe unto us - and lots of it - if the executable is mapped
2346     at an address other than 0x8000.  Todo: parse /proc/self/maps. */
2347  char *p;
2348  Elf_Ehdr *elf_header;
2349  Elf_Shdr *section_header;
2350  int i,fd;
2351  struct stat _stat;
2352  Elf_Dyn *result = NULL;
2353 
2354  fd = open("/proc/self/exe",O_RDONLY);
2355  if (fd >= 0) {
2356    if (fstat(fd,&_stat) == 0) {
2357      p = (char *)mmap(NULL,_stat.st_size,PROT_READ,MAP_PRIVATE,fd,0);
2358      if (p != MAP_FAILED) {
2359        elf_header = (Elf_Ehdr *)p;
2360        for (section_header = (Elf_Shdr *)(p+elf_header->e_shoff),
2361               i = 0;
2362             i < elf_header->e_shnum;
2363             i++,section_header++) {
2364          if (section_header->sh_type == SHT_DYNAMIC) {
2365            result = (Elf_Dyn *)section_header->sh_addr;
2366            break;
2367          }
2368        }
2369        munmap(p,_stat.st_size);
2370      }
2371    }
2372    close(fd);
2373  }
2374  return result;
2375#else
2376#error need implementation for get_executable_dynamic_entries from dso
2377#endif
2378#endif
2379}
2380
2381
2382void *cached_r_debug = NULL;
2383
2384void *
2385get_r_debug()
2386{
2387  int tag;
2388  Elf_Dyn *dp;
2389
2390  if (cached_r_debug == NULL) {
2391    for (dp = get_executable_dynamic_entries(); (tag = dp->d_tag) != 0; dp++) {
2392      if (tag == DT_DEBUG) {
2393        cached_r_debug = (void *)(dp->d_un.d_ptr);
2394        break;
2395      }
2396    }
2397  }
2398  return cached_r_debug;
2399}
2400
2401#else
2402void *
2403get_r_debug()
2404{
2405  return NULL;
2406}
2407#endif
2408
2409#ifdef DARWIN
2410void
2411sample_paging_info(paging_info *stats)
2412{
2413  mach_msg_type_number_t count = TASK_EVENTS_INFO_COUNT;
2414
2415  task_info(mach_task_self(),
2416            TASK_EVENTS_INFO,
2417            (task_info_t)stats,
2418            &count);
2419}
2420
2421void
2422report_paging_info_delta(FILE *out, paging_info *start, paging_info *stop)
2423{
2424  fprintf(out,";;; %d soft faults, %d faults, %d pageins\n\n",
2425          stop->cow_faults-start->cow_faults,
2426          stop->faults-start->faults,
2427          stop->pageins-start->pageins);
2428}
2429
2430#else
2431#ifdef WINDOWS
2432void
2433sample_paging_info(paging_info *stats)
2434{
2435}
2436
2437void
2438report_paging_info_delta(FILE *out, paging_info *start, paging_info *stop)
2439{
2440}
2441#else
2442void
2443sample_paging_info(paging_info *stats)
2444{
2445  getrusage(RUSAGE_SELF, stats);
2446}
2447
2448void
2449report_paging_info_delta(FILE *out, paging_info *start, paging_info *stop)
2450{
2451  fprintf(out,";;; %ld soft faults, %ld faults, %ld pageins\n\n",
2452          stop->ru_minflt-start->ru_minflt,
2453          stop->ru_majflt-start->ru_majflt,
2454          stop->ru_nswap-start->ru_nswap);
2455}
2456
2457#endif
2458#endif
2459
2460void
2461allocate_static_conses(natural n)
2462{
2463  BytePtr old_low = static_cons_area->low,
2464    new_low = old_low - (n<<dnode_shift);
2465  cons *c;
2466  natural i;
2467  LispObj prev;
2468
2469  CommitMemory(new_low,old_low-new_low);
2470
2471  static_cons_area->low = new_low;
2472  lower_heap_start(new_low, tenured_area);
2473  /* what a mess this is ... */
2474  if (active_dynamic_area->low == old_low) {
2475    active_dynamic_area->low = new_low;
2476  }
2477  if (!active_dynamic_area->older) {
2478    active_dynamic_area->markbits = tenured_area->refbits;
2479  }
2480  if (g1_area->low == old_low) {
2481    g1_area->low = new_low;
2482  }
2483  if (g1_area->high == old_low) {
2484    g1_area->high = new_low;
2485  }
2486  if (g2_area->low == old_low) {
2487    g2_area->low = new_low;
2488  }
2489  if (g2_area->high == old_low) {
2490    g2_area->high = new_low;
2491  }
2492  for (i=0, prev=lisp_global(STATIC_CONSES), c=(cons *)new_low;
2493       i < n;
2494       i++, c++) {
2495    c->car = unbound;
2496    c->cdr = prev;
2497    prev = ((LispObj)c)+fulltag_cons;
2498  }
2499  lisp_global(STATIC_CONSES)=prev;
2500  lisp_global(FREE_STATIC_CONSES)+=(n<<fixnumshift);
2501}
2502
2503#ifdef X86
2504#define USE_GC_NOTIFICATION 1
2505#else
2506#undef USE_GC_NOTIFICATION
2507#endif
2508
2509void
2510ensure_static_conses(ExceptionInformation *xp, TCR *tcr, natural nconses)
2511{
2512  area *a = active_dynamic_area;
2513  natural nbytes = nconses>>dnode_shift, have;
2514  BytePtr p = a->high-nbytes;
2515#ifdef USE_GC_NOTIFICATION
2516  Boolean crossed_notify_threshold = false;
2517  LispObj before_shrink, after_shrink;
2518#endif
2519
2520  if (p < a->active) {
2521    untenure_from_area(tenured_area);
2522    gc_from_xp(xp, 0L);
2523#ifdef USE_GC_NOTIFICATION
2524    did_gc_notification_since_last_full_gc = false;
2525#endif
2526  }
2527
2528  have = unbox_fixnum(lisp_global(FREE_STATIC_CONSES));
2529  if (have < nconses) {
2530#ifdef USE_GC_NOTIFICATION
2531    before_shrink = a->high-a->active;
2532    if (before_shrink>nbytes) {
2533      shrink_dynamic_area(nbytes);
2534      after_shrink = a->high-a->active; 
2535      if ((before_shrink >= lisp_heap_notify_threshold) &&
2536          (after_shrink < lisp_heap_notify_threshold)) {
2537        crossed_notify_threshold = true;
2538      }
2539    }
2540#endif
2541    allocate_static_conses(nconses);
2542    TCR_AUX(tcr)->bytes_allocated += nbytes;
2543  }
2544#ifdef USE_GC_NOTIFICATION
2545  if (crossed_notify_threshold && !did_gc_notification_since_last_full_gc) {
2546    callback_for_gc_notification(xp,tcr);
2547  }
2548#endif
2549}
2550     
Note: See TracBrowser for help on using the repository browser.