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

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

Eliminate some (but not all) warnings produced when building with
"-Wall -Wno-format". Also a couple of minor changes that enable
clang to build the lisp kernel (at least on x8632 and x8664).

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