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

Last change on this file since 14206 was 14206, checked in by rme, 9 years ago

Rename lisp kernel functions allocate() and deallocate() to
lisp_malloc() and lisp_free() to make it clearer that they are
kernel imports.

Use regular C library functions (malloc/calloc/free) instead of
allocate/deallocate in other lisp kernel C files.

  • 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#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#ifndef WINDOWS
832  extern char **environ;
833  char *p = *environ;
834  while (*p) {
835    p += (1+strlen(p));
836  }
837  return (BytePtr)((((natural) p) +4095) & ~4095);
838#endif
839#ifdef WINDOWS
840  return (BytePtr)((current_stack_pointer() + 4095) & ~ 4095);
841#endif
842}
843
844
845 
846Ptr fatal_spare_ptr = NULL;
847
848
849void
850Fatal(StringPtr param0, StringPtr param1)
851{
852
853  if (fatal_spare_ptr) {
854    free(fatal_spare_ptr);
855    fatal_spare_ptr = NULL;
856  }
857  fprintf(dbgout, "Fatal error: %s\n%s\n", param0, param1);
858  _exit(-1);
859}
860
861OSErr application_load_err = noErr;
862
863area *
864set_nil(LispObj);
865
866
867/* Check for the existence of a file named by 'path'; return true
868   if it seems to exist, without checking size, permissions, or
869   anything else. */
870Boolean
871probe_file(char *path)
872{
873  struct stat st;
874
875  return (stat(path,&st) == 0);
876}
877
878
879#ifdef WINDOWS
880/* Chop the trailing ".exe" from the kernel image name */
881wchar_t *
882chop_exe_suffix(wchar_t *path)
883{
884  int len = wcslen(path);
885  wchar_t *copy = malloc((len+1)*sizeof(wchar_t)), *tail;
886
887  wcscpy(copy,path);
888  tail = wcsrchr(copy, '.');
889  if (tail) {
890    *tail = 0;
891  }
892  return copy;
893}
894#endif
895
896#ifdef WINDOWS
897wchar_t *
898path_by_appending_image(wchar_t *path)
899{
900  int len = wcslen(path) + wcslen(L".image") + 1;
901  wchar_t *copy = (wchar_t *) malloc(len*sizeof(wchar_t));
902
903  if (copy) {
904    wcscpy(copy, path);
905    wcscat(copy, L".image");
906  }
907  return copy;
908}
909#else
910char *
911path_by_appending_image(char *path)
912{
913  int len = strlen(path) + strlen(".image") + 1;
914  char *copy = (char *) malloc(len);
915
916  if (copy) {
917    strcpy(copy, path);
918    strcat(copy, ".image");
919  }
920  return copy;
921}
922#endif
923
924#ifdef WINDOWS
925wchar_t *
926default_image_name(wchar_t *orig)
927{
928  wchar_t *path = chop_exe_suffix(orig);
929  wchar_t *image_name = path_by_appending_image(path);
930  return image_name;
931}
932#else
933char *
934default_image_name(char *orig)
935{
936  char *path = orig;
937  char *image_name = path_by_appending_image(path);
938  return image_name;
939}
940#endif
941
942
943
944char *program_name = NULL;
945#ifdef WINDOWS
946wchar_t *real_executable_name = NULL;
947#else
948char *real_executable_name = NULL;
949#endif
950
951#ifndef WINDOWS
952
953char *
954ensure_real_path(char *path)
955{
956  char buf[PATH_MAX*2], *p, *q;
957  int n;
958
959  p = realpath(path, buf);
960 
961  if (p == NULL) {
962    return path;
963  }
964  n = strlen(p);
965  q = malloc(n+1);
966  strcpy(q,p);
967  return q;
968}
969
970char *
971determine_executable_name(char *argv0)
972{
973#ifdef DARWIN
974  uint32_t len = 1024;
975  char exepath[1024], *p = NULL;
976   
977  if (_NSGetExecutablePath(exepath, &len) == 0) {
978    p = malloc(len+1);
979    memmove(p, exepath, len);
980    p[len]=0;
981    return ensure_real_path(p);
982  } 
983  return ensure_real_path(argv0);
984#endif
985#ifdef LINUX
986  char exepath[PATH_MAX], *p;
987  int n;
988
989  if ((n = readlink("/proc/self/exe", exepath, PATH_MAX)) > 0) {
990    p = malloc(n+1);
991    memmove(p,exepath,n);
992    p[n]=0;
993    return p;
994  }
995  return argv0;
996#endif
997#ifdef FREEBSD
998  return ensure_real_path(argv0);
999#endif
1000#ifdef SOLARIS
1001  char exepath[PATH_MAX], proc_path[PATH_MAX], *p;
1002  int n;
1003
1004  snprintf(proc_path,PATH_MAX-1,"/proc/%d/path/a.out",getpid());
1005
1006  if ((n = readlink(proc_path, exepath, PATH_MAX)) > 0) {
1007    p = malloc(n+1);
1008    memmove(p,exepath,n);
1009    p[n]=0;
1010    return p;
1011  }
1012  return ensure_real_path(argv0);
1013#endif
1014  return ensure_real_path(argv0);
1015}
1016#endif
1017
1018#ifdef WINDOWS
1019wchar_t *
1020determine_executable_name()
1021{
1022  DWORD nsize = 512, result;
1023  wchar_t *buf = malloc(nsize*sizeof(wchar_t));
1024
1025  do {
1026    result = GetModuleFileNameW(NULL, buf, nsize);
1027    if (result == nsize) {
1028      nsize *= 2;
1029      buf = realloc(buf,nsize*sizeof(wchar_t));
1030    } else {
1031      return buf;
1032    }
1033  } while (1);
1034}
1035
1036
1037wchar_t *
1038ensure_real_path(wchar_t *path)
1039{
1040  int bufsize = 256, n;
1041
1042  do {
1043    wchar_t buf[bufsize];
1044
1045    n = GetFullPathNameW(path,bufsize,buf,NULL);
1046    if (n == 0) {
1047      return path;
1048    }
1049
1050    if (n < bufsize) {
1051      int i;
1052      wchar_t *q = calloc(n+1,sizeof(wchar_t));
1053
1054      for (i = 0; i < n; i++) {
1055        q[i] = buf[i];
1056      }
1057      return q;
1058    }
1059    bufsize = n+1;
1060  } while (1);
1061}
1062#endif
1063
1064void
1065usage_exit(char *herald, int exit_status, char* other_args)
1066{
1067  if (herald && *herald) {
1068    fprintf(dbgout, "%s\n", herald);
1069  }
1070  fprintf(dbgout, "usage: %s <options>\n", program_name);
1071  fprintf(dbgout, "\t or %s <image-name>\n", program_name);
1072  fprintf(dbgout, "\t where <options> are one or more of:\n");
1073  if (other_args && *other_args) {
1074    fputs(other_args, dbgout);
1075  }
1076  fprintf(dbgout, "\t-R, --heap-reserve <n>: reserve <n> (default: %lld)\n",
1077          (u64_t) reserved_area_size);
1078  fprintf(dbgout, "\t\t bytes for heap expansion\n");
1079  fprintf(dbgout, "\t-S, --stack-size <n>: set  size of initial thread's control stack to <n>\n");
1080  fprintf(dbgout, "\t-Z, --thread-stack-size <n>: set default size of first (listener)  thread's stacks based on <n>\n");
1081  fprintf(dbgout, "\t-b, --batch: exit when EOF on *STANDARD-INPUT*\n");
1082  fprintf(dbgout, "\t--no-sigtrap : obscure option for running under GDB\n");
1083  fprintf(dbgout, "\t-I, --image-name <image-name>\n");
1084#ifndef WINDOWS
1085  fprintf(dbgout, "\t and <image-name> defaults to %s\n", 
1086          default_image_name(program_name));
1087#endif
1088  fprintf(dbgout, "\n");
1089  _exit(exit_status);
1090}
1091
1092int no_sigtrap = 0;
1093#ifdef WINDOWS
1094wchar_t *image_name = NULL;
1095#else
1096char *image_name = NULL;
1097#endif
1098int batch_flag = 0;
1099
1100
1101natural
1102parse_numeric_option(char *arg, char *argname, natural default_val)
1103{
1104  char *tail;
1105  natural val = 0;
1106
1107  val = strtoul(arg, &tail, 0);
1108  switch(*tail) {
1109  case '\0':
1110    break;
1111   
1112  case 'M':
1113  case 'm':
1114    val = val << 20;
1115    break;
1116   
1117  case 'K':
1118  case 'k':
1119    val = val << 10;
1120    break;
1121   
1122  case 'G':
1123  case 'g':
1124    val = val << 30;
1125    break;
1126   
1127  default:
1128    fprintf(dbgout, "couldn't parse %s argument %s", argname, arg);
1129    val = default_val;
1130    break;
1131  }
1132  return val;
1133}
1134 
1135
1136
1137/*
1138   The set of arguments recognized by the kernel is
1139   likely to remain pretty small and pretty simple.
1140   This removes everything it recognizes from argv;
1141   remaining args will be processed by lisp code.
1142*/
1143
1144void
1145process_options(int argc, char *argv[], wchar_t *shadow[])
1146{
1147  int i, j, k, num_elide, flag, arg_error;
1148  char *arg, *val;
1149  wchar_t *warg, *wval;
1150#ifdef DARWIN
1151  extern int NXArgc;
1152#endif
1153
1154  for (i = 1; i < argc;) {
1155    arg = argv[i];
1156    if (shadow) {
1157      warg = shadow[i];
1158    }
1159    arg_error = 0;
1160    if (*arg != '-') {
1161      i++;
1162    } else {
1163      num_elide = 0;
1164      val = NULL;
1165      if ((flag = (strncmp(arg, "-I", 2) == 0)) ||
1166          (strcmp (arg, "--image-name") == 0)) {
1167        if (flag && arg[2]) {
1168          val = arg+2;         
1169          if (shadow) {
1170            wval = warg+2;
1171          }
1172          num_elide = 1;
1173        } else {
1174          if ((i+1) < argc) {
1175            val = argv[i+1];
1176            if (shadow) {
1177              wval = shadow[i+1];
1178            }
1179            num_elide = 2;
1180          } else {
1181            arg_error = 1;
1182          }
1183        }
1184        if (val) {
1185#ifdef WINDOWS
1186          image_name = wval;
1187#else
1188          image_name = val;
1189#endif
1190        }
1191      } else if ((flag = (strncmp(arg, "-R", 2) == 0)) ||
1192                 (strcmp(arg, "--heap-reserve") == 0)) {
1193        natural reserved_size = reserved_area_size;
1194
1195        if (flag && arg[2]) {
1196          val = arg+2;
1197          num_elide = 1;
1198        } else {
1199          if ((i+1) < argc) {
1200            val = argv[i+1];
1201            num_elide = 2;
1202          } else {
1203            arg_error = 1;
1204          }
1205        }
1206
1207        if (val) {
1208          reserved_size = parse_numeric_option(val, 
1209                                               "-R/--heap-reserve", 
1210                                               reserved_area_size);
1211        }
1212
1213        if (reserved_size <= MAXIMUM_MAPPABLE_MEMORY) {
1214          reserved_area_size = reserved_size;
1215        }
1216
1217      } else if ((flag = (strncmp(arg, "-S", 2) == 0)) ||
1218                 (strcmp(arg, "--stack-size") == 0)) {
1219        natural stack_size;
1220
1221        if (flag && arg[2]) {
1222          val = arg+2;
1223          num_elide = 1;
1224        } else {
1225          if ((i+1) < argc) {
1226            val = argv[i+1];
1227            num_elide = 2;
1228          } else {
1229            arg_error = 1;
1230          }
1231        }
1232
1233        if (val) {
1234          stack_size = parse_numeric_option(val, 
1235                                            "-S/--stack-size", 
1236                                            initial_stack_size);
1237         
1238
1239          if (stack_size >= MIN_CSTACK_SIZE) {
1240            initial_stack_size = stack_size;
1241          }
1242        }
1243
1244      } else if ((flag = (strncmp(arg, "-Z", 2) == 0)) ||
1245                 (strcmp(arg, "--thread-stack-size") == 0)) {
1246        natural stack_size;
1247
1248        if (flag && arg[2]) {
1249          val = arg+2;
1250          num_elide = 1;
1251        } else {
1252          if ((i+1) < argc) {
1253            val = argv[i+1];
1254            num_elide = 2;
1255          } else {
1256            arg_error = 1;
1257          }
1258        }
1259
1260        if (val) {
1261          stack_size = parse_numeric_option(val, 
1262                                            "-Z/--thread-stack-size", 
1263                                            thread_stack_size);
1264         
1265
1266          if (stack_size >= MIN_CSTACK_SIZE) {
1267           thread_stack_size = stack_size;
1268          }
1269          if (thread_stack_size >= (1LL<<((WORD_SIZE-fixnumshift)-1))) {
1270            thread_stack_size = (1LL<<((WORD_SIZE-fixnumshift)-1))-1;
1271          }
1272         
1273        }
1274
1275      } else if (strcmp(arg, "--no-sigtrap") == 0) {
1276        no_sigtrap = 1;
1277        num_elide = 1;
1278      } else if ((strcmp(arg, "-b") == 0) ||
1279                 (strcmp(arg, "--batch") == 0)) {
1280        batch_flag = 1;
1281        num_elide = 1;
1282      } else if (strcmp(arg,"--") == 0) {
1283        break;
1284      } else {
1285        i++;
1286      }
1287      if (arg_error) {
1288        usage_exit("error in program arguments", 1, "");
1289      }
1290      if (num_elide) {
1291        for (j = i+num_elide, k=i; j < argc; j++, k++) {
1292          argv[k] = argv[j];
1293          if (shadow) {
1294            shadow[k] = shadow[j];
1295          }
1296        }
1297        argc -= num_elide;
1298#ifdef DARWIN
1299        NXArgc -= num_elide;
1300#endif
1301        argv[argc] = NULL;
1302        if (shadow) {
1303          shadow[argc] = NULL;
1304        }
1305      }
1306    }
1307  }
1308}
1309
1310#ifdef WINDOWS
1311void
1312terminate_lisp()
1313{
1314  _exit(EXIT_FAILURE);
1315}
1316#else
1317pid_t main_thread_pid = (pid_t)0;
1318
1319void
1320terminate_lisp()
1321{
1322  kill(main_thread_pid, SIGKILL);
1323  _exit(-1);
1324}
1325#endif
1326
1327#ifdef DARWIN
1328#define min_os_version "8.0"    /* aka Tiger */
1329#endif
1330#ifdef LINUX
1331#ifdef PPC
1332#define min_os_version "2.2"
1333#endif
1334#ifdef X86
1335#define min_os_version "2.6"
1336#endif
1337#ifdef ARM
1338#define min_os_version "2.6"
1339#endif
1340#endif
1341#ifdef FREEBSD
1342#define min_os_version "6.0"
1343#endif
1344#ifdef SOLARIS
1345#define min_os_version "5.10"
1346#endif
1347
1348#ifdef PPC
1349#if defined(PPC64) || !defined(DARWIN)
1350/* ld64 on Darwin doesn't offer anything close to reliable control
1351   over the layout of a program in memory.  About all that we can
1352   be assured of is that the canonical subprims jump table address
1353   (currently 0x5000) is unmapped.  Map that page, and copy the
1354   actual spjump table there. */
1355
1356
1357void
1358remap_spjump()
1359{
1360  extern opcode spjump_start, spjump_end;
1361  pc new,
1362    old = &spjump_start,
1363    limit = &spjump_end,
1364    work;
1365  opcode instr;
1366  void *target;
1367  int disp;
1368 
1369  if (old != (pc)SPJUMP_TARGET_ADDRESS) {
1370    new = mmap((pc) SPJUMP_TARGET_ADDRESS,
1371               0x1000,
1372               PROT_READ | PROT_WRITE | PROT_EXEC,
1373               MAP_PRIVATE | MAP_ANON | MAP_FIXED,
1374               -1,
1375               0);
1376    if (new != (pc) SPJUMP_TARGET_ADDRESS) {
1377      perror("remap spjump");
1378      _exit(1);
1379    }
1380   
1381    for (work = new; old < limit; work++, old++) {
1382      instr = *old;
1383      disp = instr & ((1<<26)-1);
1384      target = (void*)old+disp;
1385      disp = target-(void *)work;
1386      *work = ((instr >> 26) << 26) | disp;
1387    }
1388    xMakeDataExecutable(new, (void*)work-(void*)new);
1389    ProtectMemory(new, 0x1000);
1390  }
1391}
1392#endif
1393#endif
1394
1395#ifdef X86
1396#ifdef WINDOWS
1397
1398/* By using linker tricks, we ensure there's memory between 0x11000
1399   and 0x21000, so we just need to fix permissions and copy the spjump
1400   table. */
1401
1402void
1403remap_spjump()
1404{
1405  extern opcode spjump_start;
1406  DWORD old_protect;
1407
1408  if ((void *)(&spjump_start) != (void *) SPJUMP_TARGET_ADDRESS) {
1409    if (!VirtualProtect((pc) SPJUMP_TARGET_ADDRESS,
1410                        0x1000,
1411                        PAGE_EXECUTE_READWRITE,
1412                        &old_protect)) {
1413      wperror("VirtualProtect spjump");
1414      _exit(1);
1415    }
1416    memmove((pc) SPJUMP_TARGET_ADDRESS, &spjump_start, 0x1000);
1417  }
1418}
1419#else
1420void
1421remap_spjump()
1422{
1423  extern opcode spjump_start;
1424  pc new = mmap((pc) SPJUMP_TARGET_ADDRESS,
1425                0x1000,
1426                PROT_READ | PROT_WRITE | PROT_EXEC,
1427                MAP_PRIVATE | MAP_ANON | MAP_FIXED,
1428                -1,
1429                0),
1430    old = &spjump_start;
1431  if (new == (pc)-1) {
1432    perror("remap spjump");
1433    _exit(1);
1434  }
1435  memmove(new, old, 0x1000);
1436}
1437#endif
1438#endif
1439
1440
1441void
1442check_os_version(char *progname)
1443{
1444#ifdef WINDOWS
1445  /* 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. */
1446#else
1447  struct utsname uts;
1448  long got, want;
1449  char *got_end,*want_end;
1450#ifdef X8632
1451  extern Boolean rcontext_readonly;
1452#endif
1453
1454  want = strtoul(min_os_version,&want_end,10);
1455
1456  uname(&uts);
1457  got = strtoul(uts.release,&got_end,10);
1458#ifdef X8632
1459#ifdef FREEBSD
1460  if (!strcmp(uts.machine,"amd64")) {
1461    rcontext_readonly = true;
1462  }
1463#endif
1464#endif
1465  while (got == want) {
1466    if (*want_end == '.') {
1467      want = strtoul(want_end+1,&want_end,10);
1468      got = 0;
1469      if (*got_end == '.') {
1470        got = strtoul(got_end+1,&got_end,10);
1471      } else {
1472        break;
1473      }
1474    } else {
1475      break;
1476    }
1477  }
1478
1479  if (got < want) {
1480    fprintf(dbgout, "\n%s requires %s version %s or later; the current version is %s.\n", progname, uts.sysname, min_os_version, uts.release);
1481    exit(1);
1482  }
1483#endif
1484}
1485
1486#ifdef X86
1487/*
1488  This should determine the cache block size.  It should also
1489  probably complain if we don't have (at least) SSE2.
1490*/
1491extern int cpuid(natural, natural*, natural*, natural*);
1492
1493#define X86_FEATURE_CMOV    (1<<15)
1494#define X86_FEATURE_CLFLUSH (1<<19)
1495#define X86_FEATURE_MMX     (1<<23)
1496#define X86_FEATURE_SSE     (1<<25)
1497#define X86_FEATURE_SSE2    (1<<26)
1498
1499#define X86_REQUIRED_FEATURES (X86_FEATURE_CMOV|X86_FEATURE_MMX|X86_FEATURE_SSE|X86_FEATURE_SSE2)
1500
1501Boolean
1502check_x86_cpu()
1503{
1504  natural eax, ebx, ecx, edx;
1505
1506  eax = cpuid(0, &ebx, &ecx, &edx);
1507
1508  if (eax >= 1) {
1509    eax = cpuid(1, &ebx, &ecx, &edx);
1510    cache_block_size = (ebx & 0xff00) >> 5;
1511    if ((X86_REQUIRED_FEATURES & edx) == X86_REQUIRED_FEATURES) {
1512      return true;
1513    }
1514    /* It's very unlikely that SSE2 would be present and other things
1515       that we want wouldn't.  If they don't have MMX or CMOV either,
1516       might as well tell them. */
1517    if ((edx & X86_FEATURE_SSE2) == 0) {
1518      fprintf(dbgout, "This CPU doesn't support the SSE2 instruction set\n");
1519    }
1520    if ((edx & X86_FEATURE_MMX) == 0) {
1521      fprintf(dbgout, "This CPU doesn't support the MMX instruction set\n");
1522    }
1523    if ((edx & X86_FEATURE_CMOV) == 0) {
1524      fprintf(dbgout, "This CPU doesn't support the CMOV instruction\n");
1525    }
1526   
1527  }
1528  return false;
1529}
1530#endif
1531
1532void
1533lazarus()
1534{
1535  TCR *tcr = get_tcr(false);
1536  if (tcr) {
1537    /* Some threads may be dying; no threads should be created. */
1538    LOCK(lisp_global(TCR_AREA_LOCK),tcr);
1539    tcr->vs_area->active = tcr->vs_area->high - node_size;
1540    tcr->save_vsp = (LispObj *)(tcr->vs_area->active);
1541#ifndef ARM
1542    tcr->ts_area->active = tcr->ts_area->high;
1543    tcr->save_tsp = (LispObj *)(tcr->ts_area->active);
1544#endif
1545    tcr->catch_top = 0;
1546    tcr->db_link = 0;
1547    tcr->xframe = 0;
1548    start_lisp(tcr, 0);
1549  }
1550}
1551
1552#ifdef LINUX
1553#ifdef X8664
1554#include <asm/prctl.h>
1555#include <sys/prctl.h>
1556
1557void
1558ensure_gs_available(char *progname)
1559{
1560  LispObj fs_addr = 0L, gs_addr = 0L, cur_thread = (LispObj)pthread_self();
1561  char *gnu_get_libc_version(void);
1562 
1563  arch_prctl(ARCH_GET_GS, &gs_addr);
1564  arch_prctl(ARCH_GET_FS, &fs_addr);
1565  if ((gs_addr == cur_thread) && (fs_addr != cur_thread)) {
1566    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);
1567    _exit(1);
1568  }
1569}
1570#endif
1571#endif
1572
1573Boolean
1574bogus_fp_exceptions = false;
1575
1576typedef
1577float (*float_arg_returns_float)(float);
1578
1579float
1580fcallf(float_arg_returns_float fun, float arg)
1581{
1582  return fun(arg);
1583}
1584
1585void
1586check_bogus_fp_exceptions()
1587{
1588#ifdef X8664
1589  float asinf(float),result;
1590   
1591
1592  natural save_mxcsr = get_mxcsr(), post_mxcsr;
1593  set_mxcsr(0x1f80);
1594
1595  result = fcallf(asinf, 1.0);
1596  post_mxcsr = get_mxcsr();
1597  set_mxcsr(save_mxcsr);
1598  if (post_mxcsr & (FE_ALL_EXCEPT & (~FE_INEXACT))) {
1599    bogus_fp_exceptions = true;
1600  }
1601#endif
1602}
1603
1604#ifdef WINDOWS
1605char *
1606utf_16_to_utf_8(wchar_t *utf_16)
1607{
1608  int utf8len = WideCharToMultiByte(CP_UTF8,
1609                                    0,
1610                                    utf_16,
1611                                    -1,
1612                                    NULL,
1613                                    0,
1614                                    NULL,
1615                                    NULL);
1616
1617  char *utf_8 = malloc(utf8len);
1618
1619  WideCharToMultiByte(CP_UTF8,
1620                      0,
1621                      utf_16,
1622                      -1,
1623                      utf_8,
1624                      utf8len,
1625                      NULL,
1626                      NULL);
1627
1628  return utf_8;
1629}
1630
1631char **
1632wide_argv_to_utf_8(wchar_t *wide_argv[], int argc)
1633{
1634  char** argv = calloc(argc+1,sizeof(char *));
1635  int i;
1636
1637  for (i = 0; i < argc; i++) {
1638    if (wide_argv[i]) {
1639      argv[i] = utf_16_to_utf_8(wide_argv[i]);
1640    } else {
1641      argv[i] = NULL;
1642    }
1643  }
1644  return argv;
1645}
1646#endif
1647
1648
1649 
1650
1651
1652int
1653main(int argc, char *argv[]
1654#ifndef WINDOWS
1655, char *envp[], void *aux
1656#endif
1657)
1658{
1659  extern int page_size;
1660  natural default_g0_threshold = G0_AREA_THRESHOLD,
1661    default_g1_threshold = G1_AREA_THRESHOLD,
1662    default_g2_threshold = G2_AREA_THRESHOLD,
1663    lisp_heap_threshold_from_image = 0;
1664  Boolean egc_enabled =
1665#ifdef DISABLE_EGC
1666    false
1667#else
1668    true
1669#endif
1670    ;
1671  Boolean lisp_heap_threshold_set_from_command_line = false;
1672  wchar_t **utf_16_argv = NULL;
1673
1674#ifdef PPC
1675  extern int altivec_present;
1676#endif
1677#ifdef WINDOWS
1678  extern LispObj load_image(wchar_t *);
1679#else
1680  extern LispObj load_image(char *);
1681#endif
1682  area *a;
1683  BytePtr stack_base, current_sp = (BytePtr) current_stack_pointer();
1684  TCR *tcr;
1685
1686  dbgout = stderr;
1687
1688#ifdef WINDOWS
1689  {
1690    int wide_argc;
1691    extern void init_winsock(void);
1692    extern void init_windows_io(void);
1693
1694    _fmode = O_BINARY;
1695    _setmode(1, O_BINARY);
1696    _setmode(2, O_BINARY);
1697    setvbuf(dbgout, NULL, _IONBF, 0);
1698    init_winsock();
1699    init_windows_io();
1700    utf_16_argv = CommandLineToArgvW(GetCommandLineW(),&wide_argc);
1701  }
1702#endif
1703
1704  check_os_version(argv[0]);
1705#ifdef WINDOWS
1706  real_executable_name = determine_executable_name();
1707#else
1708  real_executable_name = determine_executable_name(argv[0]);
1709#endif
1710  page_size = getpagesize(); /* Implement with GetSystemInfo on Windows w/o MinGW */
1711
1712  check_bogus_fp_exceptions();
1713#ifdef LINUX
1714#ifdef X8664
1715  ensure_gs_available(real_executable_name);
1716#endif
1717#endif
1718#if (defined(DARWIN) && defined(PPC64)) || (defined(LINUX) && defined(PPC))|| defined(X8664) || (defined(X8632) && !defined(DARWIN))
1719  remap_spjump();
1720#endif
1721
1722#ifdef PPC
1723#ifdef LINUX
1724  {
1725    ElfW(auxv_t) *av = aux;
1726    int hwcap, done = false;
1727   
1728    if (av) {
1729      do {
1730        switch (av->a_type) {
1731        case AT_DCACHEBSIZE:
1732          cache_block_size = av->a_un.a_val;
1733          break;
1734
1735        case AT_HWCAP:
1736          hwcap = av->a_un.a_val;
1737          altivec_present = ((hwcap & PPC_FEATURE_HAS_ALTIVEC) != 0);
1738          break;
1739
1740        case AT_NULL:
1741          done = true;
1742          break;
1743        }
1744        av++;
1745      } while (!done);
1746    }
1747  }
1748#endif
1749#ifdef DARWIN
1750  {
1751    unsigned value = 0;
1752    size_t len = sizeof(value);
1753    int mib[2];
1754   
1755    mib[0] = CTL_HW;
1756    mib[1] = HW_CACHELINE;
1757    if (sysctl(mib,2,&value,&len, NULL, 0) != -1) {
1758      if (len == sizeof(value)) {
1759        cache_block_size = value;
1760      }
1761    }
1762    mib[1] = HW_VECTORUNIT;
1763    value = 0;
1764    len = sizeof(value);
1765    if (sysctl(mib,2,&value,&len, NULL, 0) != -1) {
1766      if (len == sizeof(value)) {
1767        altivec_present = value;
1768      }
1769    }
1770  }
1771#endif
1772#endif
1773
1774#ifdef X86
1775  if (!check_x86_cpu()) {
1776    fprintf(dbgout, "CPU doesn't support required features\n");
1777    exit(1);
1778  }
1779#endif
1780
1781#ifdef SOLARIS
1782#ifdef X8632
1783  {
1784    extern void solaris_ldt_init(void);
1785    solaris_ldt_init();
1786  }
1787#endif
1788#endif
1789
1790#ifndef WINDOWS
1791  main_thread_pid = getpid();
1792#endif
1793  tcr_area_lock = (void *)new_recursive_lock();
1794
1795  program_name = argv[0];
1796  if ((argc == 2) && (*argv[1] != '-')) {
1797#ifdef WINDOWS
1798    image_name = utf_16_argv[1];
1799#else
1800    image_name = argv[1];
1801#endif
1802    argv[1] = NULL;
1803#ifdef WINDOWS
1804    utf_16_argv[1] = NULL;
1805#endif
1806  } else {
1807    process_options(argc,argv,utf_16_argv);
1808  }
1809  if (lisp_heap_gc_threshold != DEFAULT_LISP_HEAP_GC_THRESHOLD) {
1810    lisp_heap_threshold_set_from_command_line = true;
1811  }
1812
1813  initial_stack_size = ensure_stack_limit(initial_stack_size);
1814  if (image_name == NULL) {
1815    if (check_for_embedded_image(real_executable_name)) {
1816      image_name = real_executable_name;
1817    } else {
1818      image_name = default_image_name(real_executable_name);
1819    }
1820  }
1821
1822  while (1) {
1823    if (create_reserved_area(reserved_area_size)) {
1824      break;
1825    }
1826    reserved_area_size = reserved_area_size *.9;
1827  }
1828
1829  gc_init();
1830
1831  set_nil(load_image(image_name));
1832  lisp_heap_notify_threshold = GC_NOTIFY_THRESHOLD;
1833  lisp_heap_threshold_from_image = lisp_global(LISP_HEAP_THRESHOLD);
1834 
1835  if (lisp_heap_threshold_from_image) {
1836    if ((!lisp_heap_threshold_set_from_command_line) &&
1837        (lisp_heap_threshold_from_image != lisp_heap_gc_threshold)) {
1838      lisp_heap_gc_threshold = lisp_heap_threshold_from_image;
1839      resize_dynamic_heap(active_dynamic_area->active,lisp_heap_gc_threshold);
1840    }
1841    /* If lisp_heap_threshold_from_image was set, other image params are
1842       valid. */
1843    default_g0_threshold = lisp_global(G0_THRESHOLD);
1844    default_g1_threshold = lisp_global(G1_THRESHOLD);
1845    default_g2_threshold = lisp_global(G2_THRESHOLD);
1846    egc_enabled = lisp_global(EGC_ENABLED);
1847  }
1848
1849  lisp_global(TCR_AREA_LOCK) = ptr_to_lispobj(tcr_area_lock);
1850
1851#ifdef X86
1852  lisp_global(SUBPRIMS_BASE) = (LispObj)((1<<16)+(5<<10));
1853#endif
1854#ifdef PPC
1855  lisp_global(SUBPRIMS_BASE) = (LispObj)(5<<10);
1856#endif
1857#ifdef ARM
1858  lisp_global(SUBPRIMS_BASE) = (LispObj)(9<<12);
1859#endif
1860
1861  lisp_global(RET1VALN) = (LispObj)&ret1valn;
1862  lisp_global(LEXPR_RETURN) = (LispObj)&nvalret;
1863  lisp_global(LEXPR_RETURN1V) = (LispObj)&popj;
1864  lisp_global(ALL_AREAS) = ptr_to_lispobj(all_areas);
1865  lisp_global(DEFAULT_ALLOCATION_QUANTUM) = log2_heap_segment_size << fixnumshift;
1866  lisp_global(STACK_SIZE) = thread_stack_size<<fixnumshift;
1867
1868
1869  exception_init();
1870
1871 
1872
1873#ifdef WINDOWS
1874  lisp_global(IMAGE_NAME) = ptr_to_lispobj(utf_16_to_utf_8(ensure_real_path(image_name)));
1875  lisp_global(KERNEL_PATH) = ptr_to_lispobj(utf_16_to_utf_8(real_executable_name));
1876  lisp_global(ARGV) = ptr_to_lispobj(wide_argv_to_utf_8(utf_16_argv, argc));
1877#else
1878  lisp_global(IMAGE_NAME) = ptr_to_lispobj(ensure_real_path(image_name));
1879  lisp_global(KERNEL_PATH) = ptr_to_lispobj(real_executable_name);
1880  lisp_global(ARGV) = ptr_to_lispobj(argv);
1881#endif
1882  lisp_global(KERNEL_IMPORTS) = (LispObj)import_ptrs_base;
1883
1884  lisp_global(GET_TCR) = (LispObj) get_tcr;
1885  *(double *) &(lisp_global(DOUBLE_FLOAT_ONE)) = (double) 1.0;
1886
1887  lisp_global(HOST_PLATFORM) = (LispObj) PLATFORM << fixnumshift;
1888
1889  lisp_global(BATCH_FLAG) = (batch_flag << fixnumshift);
1890
1891  a = active_dynamic_area;
1892
1893  if (nilreg_area != NULL) {
1894    BytePtr lowptr = (BytePtr) a->low;
1895
1896    /* Create these areas as AREA_STATIC, change them to AREA_DYNAMIC */
1897    g1_area = new_area(lowptr, lowptr, AREA_STATIC);
1898    g2_area = new_area(lowptr, lowptr, AREA_STATIC);
1899    tenured_area = new_area(lowptr, lowptr, AREA_STATIC);
1900    add_area_holding_area_lock(tenured_area);
1901    add_area_holding_area_lock(g2_area);
1902    add_area_holding_area_lock(g1_area);
1903
1904    g1_area->code = AREA_DYNAMIC;
1905    g2_area->code = AREA_DYNAMIC;
1906    tenured_area->code = AREA_DYNAMIC;
1907
1908/*    a->older = g1_area; */ /* Not yet: this is what "enabling the EGC" does. */
1909    g1_area->younger = a;
1910    g1_area->older = g2_area;
1911    g2_area->younger = g1_area;
1912    g2_area->older = tenured_area;
1913    tenured_area->younger = g2_area;
1914    tenured_area->refbits = dynamic_mark_ref_bits;
1915    managed_static_area->refbits = global_mark_ref_bits;
1916    a->markbits = dynamic_mark_ref_bits;
1917    tenured_area->static_dnodes = a->static_dnodes;
1918    a->static_dnodes = 0;
1919    tenured_area->static_used = a->static_used;
1920    a->static_used = 0;
1921    lisp_global(TENURED_AREA) = ptr_to_lispobj(tenured_area);
1922    lisp_global(STATIC_CONS_AREA) = ptr_to_lispobj(static_cons_area);
1923    lisp_global(REFBITS) = ptr_to_lispobj(global_mark_ref_bits);
1924    g2_area->threshold = default_g2_threshold;
1925    g1_area->threshold = default_g1_threshold;
1926    a->threshold = default_g0_threshold;
1927  }
1928
1929  tcr = new_tcr(initial_stack_size, MIN_TSTACK_SIZE);
1930  stack_base = initial_stack_bottom()-xStackSpace();
1931  init_threads((void *)(stack_base), tcr);
1932  thread_init_tcr(tcr, current_sp, current_sp-stack_base);
1933
1934  if (lisp_global(STATIC_CONSES) == 0) {
1935    lisp_global(STATIC_CONSES) = lisp_nil;
1936  }
1937
1938  lisp_global(EXCEPTION_LOCK) = ptr_to_lispobj(new_recursive_lock());
1939  enable_fp_exceptions();
1940  register_user_signal_handler();
1941
1942#ifdef PPC
1943  lisp_global(ALTIVEC_PRESENT) = altivec_present << fixnumshift;
1944#endif
1945#if STATIC
1946  lisp_global(STATICALLY_LINKED) = 1 << fixnumshift;
1947#endif
1948  tcr->prev = tcr->next = tcr;
1949#ifndef WINDOWS
1950  lisp_global(INTERRUPT_SIGNAL) = (LispObj) box_fixnum(SIGNAL_FOR_PROCESS_INTERRUPT);
1951#endif
1952  tcr->vs_area->active -= node_size;
1953  *(--tcr->save_vsp) = nrs_TOPLFUNC.vcell;
1954  nrs_TOPLFUNC.vcell = lisp_nil;
1955#ifdef GC_INTEGRITY_CHECKING
1956  (nrs_GC_EVENT_STATUS_BITS.vcell |= gc_integrity_check_bit);
1957#endif
1958  if (egc_enabled) {
1959    egc_control(true, NULL);
1960  } else {
1961    lisp_global(OLDSPACE_DNODE_COUNT) = area_dnode(managed_static_area->active,managed_static_area->low);
1962  }
1963  atexit(lazarus);
1964  start_lisp(TCR_TO_TSD(tcr), 0);
1965  _exit(0);
1966}
1967
1968area *
1969set_nil(LispObj r)
1970{
1971
1972  if (lisp_nil == (LispObj)NULL) {
1973
1974    lisp_nil = r;
1975  }
1976  return NULL;
1977}
1978
1979
1980void
1981xMakeDataExecutable(void *start, unsigned long nbytes)
1982{
1983#ifdef PPC
1984  extern void flush_cache_lines();
1985  natural ustart = (natural) start, base, end;
1986 
1987  base = (ustart) & ~(cache_block_size-1);
1988  end = (ustart + nbytes + cache_block_size - 1) & ~(cache_block_size-1);
1989  flush_cache_lines(base, (end-base)/cache_block_size, cache_block_size);
1990#endif
1991#ifdef ARM
1992  extern void flush_cache_lines(void *, size_t);
1993  flush_cache_lines(start,nbytes);
1994#endif
1995}
1996
1997natural
1998xStackSpace()
1999{
2000  return initial_stack_size+CSTACK_HARDPROT+CSTACK_SOFTPROT;
2001}
2002
2003#ifndef DARWIN
2004#ifdef WINDOWS
2005extern void *windows_open_shared_library(char *);
2006
2007void *
2008xGetSharedLibrary(char *path, int mode)
2009{
2010  return windows_open_shared_library(path);
2011}
2012#else
2013void *
2014xGetSharedLibrary(char *path, int mode)
2015{
2016  return dlopen(path, mode);
2017}
2018#endif
2019#else
2020void *
2021xGetSharedLibrary(char *path, int *resultType)
2022{
2023  const char *error;
2024  void *result;
2025
2026  result = dlopen(path, RTLD_NOW | RTLD_GLOBAL);
2027 
2028  if (result == NULL) {
2029    error = dlerror();
2030    *resultType = 0;
2031    return (void *)error;
2032  }
2033  *resultType = 1;
2034  return result;
2035}
2036#endif
2037
2038
2039
2040int
2041fd_setsize_bytes()
2042{
2043  return FD_SETSIZE/8;
2044}
2045
2046void
2047do_fd_set(int fd, fd_set *fdsetp)
2048{
2049  FD_SET(fd, fdsetp);
2050}
2051
2052void
2053do_fd_clr(int fd, fd_set *fdsetp)
2054{
2055  FD_CLR(fd, fdsetp);
2056}
2057
2058int
2059do_fd_is_set(int fd, fd_set *fdsetp)
2060{
2061  return FD_ISSET(fd,fdsetp);
2062}
2063
2064
2065void
2066do_fd_zero(fd_set *fdsetp)
2067{
2068  FD_ZERO(fdsetp);
2069}
2070
2071#include "image.h"
2072
2073
2074
2075Boolean
2076check_for_embedded_image (
2077#ifdef WINDOWS
2078                          wchar_t *path
2079#else
2080                          char *path
2081#endif
2082                          )
2083{
2084#ifdef WINDOWS
2085  int fd = wopen(path, O_RDONLY);
2086#else 
2087  int fd = open(path, O_RDONLY);
2088#endif
2089
2090  Boolean image_is_embedded = false;
2091
2092  if (fd >= 0) {
2093    openmcl_image_file_header h;
2094
2095    if (find_openmcl_image_file_header (fd, &h)) {
2096      image_is_embedded = true;
2097    }
2098    close (fd);
2099  }
2100  return image_is_embedded;
2101}
2102
2103LispObj
2104load_image(
2105#ifdef WINDOWS
2106           wchar_t * path
2107#else
2108           char *path
2109#endif
2110)
2111{
2112#ifdef WINDOWS
2113  int fd = wopen(path, O_RDONLY, 0666), err;
2114#else
2115  int fd = open(path, O_RDONLY, 0666), err;
2116#endif
2117  LispObj image_nil = 0;
2118
2119  if (fd > 0) {
2120    openmcl_image_file_header ih;
2121
2122    errno = 0;
2123    image_nil = load_openmcl_image(fd, &ih);
2124    /* We -were- using a duplicate fd to map the file; that
2125       seems to confuse Darwin (doesn't everything ?), so
2126       we'll instead keep the original file open.
2127    */
2128    err = errno;
2129    if (!image_nil) {
2130      close(fd);
2131    }
2132#ifdef WINDOWS
2133    /* We currently don't actually map the image, and leaving the file
2134       open seems to make it difficult to write to reliably. */
2135    if (image_nil) {
2136      close(fd);
2137    }
2138#endif
2139  } else {
2140    err = errno;
2141  }
2142  if (image_nil == 0) {
2143#ifdef WINDOWS
2144    char *fmt = "Couldn't load lisp heap image from %ls";
2145#else
2146    char *fmt = "Couldn't load lisp heap image from %s";
2147#endif
2148
2149    fprintf(dbgout, fmt, path);
2150    if (err == 0) {
2151      fprintf(dbgout, "\n");
2152    } else {
2153      fprintf(dbgout, ": %s\n", strerror(err));
2154    }
2155    exit(-1);
2156  }
2157  return image_nil;
2158}
2159
2160int
2161set_errno(int val)
2162{
2163  errno = val;
2164  return -1;
2165}
2166
2167
2168
2169
2170void *
2171xFindSymbol(void* handle, char *name)
2172{
2173#if defined(LINUX) || defined(FREEBSD) || defined(SOLARIS)
2174  return dlsym(handle, name);
2175#endif
2176#ifdef DARWIN
2177  void *result;
2178
2179  if ((handle == NULL) || (handle == ((void *) -1))) {
2180    handle = RTLD_DEFAULT;
2181  }   
2182  result = dlsym(handle, name);
2183  if ((result == NULL) && (*name == '_')) {
2184    result = dlsym(handle, name+1);
2185  }
2186  return result;
2187#endif
2188#ifdef WINDOWS
2189  extern void *windows_find_symbol(void *, char *);
2190  return windows_find_symbol(handle, name);
2191#endif
2192}
2193
2194void *
2195get_r_debug()
2196{
2197#if defined(LINUX) || defined(FREEBSD) || defined(SOLARIS)
2198#if WORD_SIZE == 64
2199  extern Elf64_Dyn _DYNAMIC[];
2200  Elf64_Dyn *dp;
2201#else
2202  extern Elf32_Dyn _DYNAMIC[];
2203  Elf32_Dyn *dp;
2204#endif
2205  int tag;
2206
2207  for (dp = _DYNAMIC; (tag = dp->d_tag) != 0; dp++) {
2208    if (tag == DT_DEBUG) {
2209      return (void *)(dp->d_un.d_ptr);
2210    }
2211  }
2212#endif
2213  return NULL;
2214}
2215
2216
2217#ifdef DARWIN
2218void
2219sample_paging_info(paging_info *stats)
2220{
2221  mach_msg_type_number_t count = TASK_EVENTS_INFO_COUNT;
2222
2223  task_info(mach_task_self(),
2224            TASK_EVENTS_INFO,
2225            (task_info_t)stats,
2226            &count);
2227}
2228
2229void
2230report_paging_info_delta(FILE *out, paging_info *start, paging_info *stop)
2231{
2232  fprintf(out,";;; %d soft faults, %d faults, %d pageins\n\n",
2233          stop->cow_faults-start->cow_faults,
2234          stop->faults-start->faults,
2235          stop->pageins-start->pageins);
2236}
2237
2238#else
2239#ifdef WINDOWS
2240void
2241sample_paging_info(paging_info *stats)
2242{
2243}
2244
2245void
2246report_paging_info_delta(FILE *out, paging_info *start, paging_info *stop)
2247{
2248}
2249#else
2250void
2251sample_paging_info(paging_info *stats)
2252{
2253  getrusage(RUSAGE_SELF, stats);
2254}
2255
2256void
2257report_paging_info_delta(FILE *out, paging_info *start, paging_info *stop)
2258{
2259  fprintf(out,";;; %ld soft faults, %ld faults, %ld pageins\n\n",
2260          stop->ru_minflt-start->ru_minflt,
2261          stop->ru_majflt-start->ru_majflt,
2262          stop->ru_nswap-start->ru_nswap);
2263}
2264
2265#endif
2266#endif
2267
2268void
2269allocate_static_conses(natural n)
2270{
2271  BytePtr old_low = static_cons_area->low,
2272    new_low = old_low - (n<<dnode_shift);
2273  cons *c;
2274  natural i;
2275  LispObj prev;
2276
2277  CommitMemory(new_low,old_low-new_low);
2278
2279  static_cons_area->low = new_low;
2280  lower_heap_start(new_low, tenured_area);
2281  /* what a mess this is ... */
2282  if (active_dynamic_area->low == old_low) {
2283    active_dynamic_area->low = new_low;
2284  }
2285  if (!active_dynamic_area->older) {
2286    active_dynamic_area->markbits = tenured_area->refbits;
2287  }
2288  if (g1_area->low == old_low) {
2289    g1_area->low = new_low;
2290  }
2291  if (g1_area->high == old_low) {
2292    g1_area->high = new_low;
2293  }
2294  if (g2_area->low == old_low) {
2295    g2_area->low = new_low;
2296  }
2297  if (g2_area->high == old_low) {
2298    g2_area->high = new_low;
2299  }
2300  for (i=0, prev=lisp_global(STATIC_CONSES), c=(cons *)new_low;
2301       i < n;
2302       i++, c++) {
2303    c->car = unbound;
2304    c->cdr = prev;
2305    prev = ((LispObj)c)+fulltag_cons;
2306  }
2307  lisp_global(STATIC_CONSES)=prev;
2308  lisp_global(FREE_STATIC_CONSES)+=(n<<fixnumshift);
2309}
2310
2311#ifdef X86
2312#define USE_GC_NOTIFICATION 1
2313#else
2314#undef USE_GC_NOTIFICATION
2315#endif
2316
2317void
2318ensure_static_conses(ExceptionInformation *xp, TCR *tcr, natural nconses)
2319{
2320  area *a = active_dynamic_area;
2321  natural nbytes = nconses>>dnode_shift, have;
2322  BytePtr p = a->high-nbytes;
2323#ifdef USE_GC_NOTIFICATION
2324  Boolean crossed_notify_threshold = false;
2325  LispObj before_shrink, after_shrink;
2326#endif
2327
2328  if (p < a->active) {
2329    untenure_from_area(tenured_area);
2330    gc_from_xp(xp, 0L);
2331#ifdef USE_GC_NOTIFICATION
2332    did_gc_notification_since_last_full_gc = false;
2333#endif
2334  }
2335
2336  have = unbox_fixnum(lisp_global(FREE_STATIC_CONSES));
2337  if (have < nconses) {
2338#ifdef USE_GC_NOTIFICATION
2339    before_shrink = a->high-a->active;
2340    if (before_shrink>nbytes) {
2341      shrink_dynamic_area(nbytes);
2342      after_shrink = a->high-a->active; 
2343      if ((before_shrink >= lisp_heap_notify_threshold) &&
2344          (after_shrink < lisp_heap_notify_threshold)) {
2345        crossed_notify_threshold = true;
2346      }
2347    }
2348#endif
2349    allocate_static_conses(nconses);
2350    tcr->bytes_allocated += nbytes;
2351  }
2352#ifdef USE_GC_NOTIFICATION
2353  if (crossed_notify_threshold && !did_gc_notification_since_last_full_gc) {
2354    callback_for_gc_notification(xp,tcr);
2355  }
2356#endif
2357}
2358     
Note: See TracBrowser for help on using the repository browser.