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

Last change on this file since 13602 was 13592, checked in by rme, 10 years ago

The function default_image_name() now simply returns the lisp kernel
name plus a ".image" suffix.

Delete now-unused function case_inverted_path().

We formerly would case-invert the lisp kernel's name and use that as
the name of the default image. For example, for lx86cl64, the default
image name was LX86CL64.

This was probably always stylistically questionable, but it became a
problem on ports to systems with case-insensitive file systems (e.g.,
HFS on the Macintosh). On those systems, we used the lisp kernel name
plus a ".image" suffix as the default image name.

A couple of releases ago, we started using the ".image" suffix on all
systems, but would look for the case-inverted name as a fallback.
We no longer look for the case-inverted name at all.

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