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

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

Someone got paid to develop Android's C library.

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