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

Last change on this file since 14232 was 14232, checked in by gb, 9 years ago

In initial_stack_bottom(), don't assume that stack bounds have
anything to do with the address of the environment strings. (There's
traditionally often a relationship between the address of the bottom
of the initial thread's stack and the environment area, but I don't
know that that relationship's guaranteed to hold in all cases.)

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