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

Last change on this file since 10928 was 10928, checked in by gb, 11 years ago

Need to remap_spjump() on win32, too.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 44.0 KB
Line 
1/*
2   Copyright (C) 1994-2001 Digitool, Inc
3   This file is part of OpenMCL. 
4
5   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
6   License , known as the LLGPL and distributed with OpenMCL as the
7   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
8   which is distributed with OpenMCL as the file "LGPL".  Where these
9   conflict, the preamble takes precedence. 
10
11   OpenMCL is referenced in the preamble as the "LIBRARY."
12
13   The LLGPL is also available online at
14   http://opensource.franz.com/preamble.html
15*/
16
17#ifdef DARWIN
18/*      dyld.h included here because something in "lisp.h" causes
19    a conflict (actually I think the problem is in "constants.h")
20*/
21#include <mach-o/dyld.h>
22
23#endif
24#include "lisp.h"
25#include "lisp_globals.h"
26#include "gc.h"
27#include "area.h"
28#include <stdlib.h>
29#include <string.h>
30#include "lisp-exceptions.h"
31#include <stdio.h>
32#include <stdlib.h>
33#ifndef WINDOWS
34#include <sys/mman.h>
35#endif
36#include <fcntl.h>
37#include <signal.h>
38#include <errno.h>
39#ifndef WINDOWS
40#include <sys/utsname.h>
41#include <unistd.h>
42#endif
43
44#ifdef LINUX
45#include <mcheck.h>
46#include <dirent.h>
47#include <dlfcn.h>
48#include <sys/time.h>
49#include <sys/resource.h>
50#include <link.h>
51#include <elf.h>
52
53/*
54   The version of <asm/cputable.h> provided by some distributions will
55   claim that <asm-ppc64/cputable.h> doesn't exist.  It may be present
56   in the Linux kernel source tree even if it's not copied to
57   /usr/include/asm-ppc64.  Hopefully, this will be straightened out
58   soon (and/or the PPC_FEATURE_HAS_ALTIVEC constant will be defined
59   in a less volatile place.)  Until that's straightened out, it may
60   be necessary to install a copy of the kernel header in the right
61   place and/or persuade <asm/cputable> to lighten up a bit.
62*/
63
64#ifdef PPC
65#ifndef PPC64
66#include <asm/cputable.h>
67#endif
68#ifndef PPC_FEATURE_HAS_ALTIVEC
69#define PPC_FEATURE_HAS_ALTIVEC 0x10000000
70#endif
71#endif
72#endif
73
74Boolean use_mach_exception_handling = 
75#ifdef DARWIN
76  true
77#else
78  false
79#endif
80;
81
82#ifdef DARWIN
83#include <sys/types.h>
84#include <sys/time.h>
85#include <sys/mman.h>
86#include <sys/resource.h>
87#include <mach/mach_types.h>
88#include <mach/message.h>
89#include <mach/vm_region.h>
90#include <mach/port.h>
91#include <sys/sysctl.h>
92
93Boolean running_under_rosetta = false;
94
95#if WORD_SIZE == 64 || defined(X8632)
96/* Assume that if the OS is new enough to support PPC64/X8664, it has
97   a reasonable dlfcn.h
98*/
99#include <dlfcn.h>
100#endif
101#endif
102
103#if defined(FREEBSD) || defined(SOLARIS)
104#include <sys/time.h>
105#include <sys/resource.h>
106#include <dlfcn.h>
107#include <elf.h> 
108#include <link.h>
109#endif
110
111#include <ctype.h>
112#ifndef WINDOWS
113#include <sys/select.h>
114#endif
115#include "Threads.h"
116
117#include <fenv.h>
118
119#ifndef MAP_NORESERVE
120#define MAP_NORESERVE (0)
121#endif
122
123#ifdef WINDOWS
124#include <windows.h>
125#include <stdio.h>
126void
127wperror(char* message)
128{
129  char* buffer;
130  DWORD last_error = GetLastError();
131 
132  FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER|
133                FORMAT_MESSAGE_FROM_SYSTEM|
134                FORMAT_MESSAGE_IGNORE_INSERTS,
135                NULL,
136                last_error,
137                MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
138                (LPTSTR)&buffer,
139                0, NULL);
140  fprintf(stderr, "%s: 0x%x %s\n", message, (unsigned) last_error, buffer);
141  LocalFree(buffer);
142}
143#endif
144
145LispObj lisp_nil = (LispObj) 0;
146bitvector global_mark_ref_bits = NULL;
147
148
149/* These are all "persistent" : they're initialized when
150   subprims are first loaded and should never change. */
151extern LispObj ret1valn;
152extern LispObj nvalret;
153extern LispObj popj;
154#ifdef X86
155extern LispObj bad_funcall;
156#endif
157
158LispObj text_start = 0;
159
160/* A pointer to some of the kernel's own data; also persistent. */
161
162extern LispObj import_ptrs_base;
163
164
165
166void
167xMakeDataExecutable(void *, unsigned long);
168
169void
170make_dynamic_heap_executable(LispObj *p, LispObj *q)
171{
172  void * cache_start = (void *) p;
173  natural ncacheflush = (natural) q - (natural) p;
174
175  xMakeDataExecutable(cache_start, ncacheflush); 
176}
177     
178size_t
179ensure_stack_limit(size_t stack_size)
180{
181#ifdef WINDOWS
182
183  /* On Windows, the stack is allocated on thread creation.  For the
184     initial thread, the loader does that, and we cannot change the
185     stack size after the fact.  For threads we create, we can set the
186     stack size.  A possible solution is putting the initial thread
187     asleep and using only runtime-created threads.
188
189     For now, just refuse any attempt to set another stack size, and
190     return the linker default. */
191
192  return 0x200000;
193
194#else
195  struct rlimit limits;
196  rlim_t cur_stack_limit, max_stack_limit;
197 
198  stack_size += (CSTACK_HARDPROT+CSTACK_SOFTPROT);
199  getrlimit(RLIMIT_STACK, &limits);
200  cur_stack_limit = limits.rlim_cur;
201  max_stack_limit = limits.rlim_max;
202  if (stack_size > max_stack_limit) {
203    stack_size = max_stack_limit;
204  }
205  if (cur_stack_limit < stack_size) {
206    limits.rlim_cur = stack_size;
207    errno = 0;
208    if (setrlimit(RLIMIT_STACK, &limits)) {
209      int e = errno;
210      fprintf(stderr, "errno = %d\n", e);
211      Fatal(": Stack resource limit too small", "");
212    }
213  }
214#endif
215  return stack_size;
216}
217
218
219/* This should write-protect the bottom of the stack.
220   Doing so reliably involves ensuring that everything's unprotected on exit.
221*/
222
223BytePtr
224allocate_lisp_stack(natural useable,
225                    unsigned softsize,
226                    unsigned hardsize,
227                    lisp_protection_kind softkind,
228                    lisp_protection_kind hardkind,
229                    Ptr *h_p,
230                    BytePtr *base_p,
231                    protected_area_ptr *softp,
232                    protected_area_ptr *hardp)
233{
234  void *allocate_stack(natural);
235  void free_stack(void *);
236  natural size = useable+softsize+hardsize;
237  natural overhead;
238  BytePtr base, softlimit, hardlimit;
239  Ptr h = allocate_stack(size+4095);
240  protected_area_ptr hprotp = NULL, sprotp;
241
242  if (h == NULL) {
243    return NULL;
244  }
245  if (h_p) *h_p = h;
246  base = (BytePtr) align_to_power_of_2( h, log2_page_size);
247  hardlimit = (BytePtr) (base+hardsize);
248  softlimit = hardlimit+softsize;
249
250  overhead = (base - (BytePtr) h);
251  if (hardsize) {
252    hprotp = new_protected_area((BytePtr)base,hardlimit,hardkind, hardsize, true);
253    if (hprotp == NULL) {
254      if (base_p) *base_p = NULL;
255      if (h_p) *h_p = NULL;
256      deallocate(h);
257      return NULL;
258    }
259    if (hardp) *hardp = hprotp;
260  }
261  if (softsize) {
262    sprotp = new_protected_area(hardlimit,softlimit, softkind, softsize, true);
263    if (sprotp == NULL) {
264      if (base_p) *base_p = NULL;
265      if (h_p) *h_p = NULL;
266      if (hardp) *hardp = NULL;
267      if (hprotp) delete_protected_area(hprotp);
268      free_stack(h);
269      return NULL;
270    }
271    if (softp) *softp = sprotp;
272  }
273  if (base_p) *base_p = base;
274  return (BytePtr) ((natural)(base+size));
275}
276
277/*
278  This should only called by something that owns the area_lock, or
279  by the initial thread before other threads exist.
280*/
281area *
282allocate_lisp_stack_area(area_code stack_type,
283                         natural usable,
284                         unsigned softsize, 
285                         unsigned hardsize, 
286                         lisp_protection_kind softkind, 
287                         lisp_protection_kind hardkind)
288
289{
290  BytePtr base, bottom;
291  Ptr h;
292  area *a = NULL;
293  protected_area_ptr soft_area=NULL, hard_area=NULL;
294
295  bottom = allocate_lisp_stack(usable, 
296                               softsize, 
297                               hardsize, 
298                               softkind, 
299                               hardkind, 
300                               &h, 
301                               &base,
302                               &soft_area, 
303                               &hard_area);
304
305  if (bottom) {
306    a = new_area(base, bottom, stack_type);
307    a->hardlimit = base+hardsize;
308    a->softlimit = base+hardsize+softsize;
309    a->h = h;
310    a->softprot = soft_area;
311    a->hardprot = hard_area;
312    add_area_holding_area_lock(a);
313  }
314  return a;
315}
316
317/*
318  Also assumes ownership of the area_lock
319*/
320area*
321register_cstack_holding_area_lock(BytePtr bottom, natural size)
322{
323  BytePtr lowlimit = (BytePtr) (((((natural)bottom)-size)+4095)&~4095);
324  area *a = new_area((BytePtr) bottom-size, bottom, AREA_CSTACK);
325  a->hardlimit = lowlimit+CSTACK_HARDPROT;
326  a->softlimit = a->hardlimit+CSTACK_SOFTPROT;
327#ifdef USE_SIGALTSTACK
328  setup_sigaltstack(a);
329#endif
330  add_area_holding_area_lock(a);
331  return a;
332}
333 
334
335area*
336allocate_vstack_holding_area_lock(natural usable)
337{
338  return allocate_lisp_stack_area(AREA_VSTACK, 
339                                  usable > MIN_VSTACK_SIZE ?
340                                  usable : MIN_VSTACK_SIZE,
341                                  VSTACK_SOFTPROT,
342                                  VSTACK_HARDPROT,
343                                  kVSPsoftguard,
344                                  kVSPhardguard);
345}
346
347area *
348allocate_tstack_holding_area_lock(natural usable)
349{
350  return allocate_lisp_stack_area(AREA_TSTACK, 
351                                  usable > MIN_TSTACK_SIZE ?
352                                  usable : MIN_TSTACK_SIZE,
353                                  TSTACK_SOFTPROT,
354                                  TSTACK_HARDPROT,
355                                  kTSPsoftguard,
356                                  kTSPhardguard);
357}
358
359
360/* It's hard to believe that max & min don't exist already */
361unsigned unsigned_min(unsigned x, unsigned y)
362{
363  if (x <= y) {
364    return x;
365  } else {
366    return y;
367  }
368}
369
370unsigned unsigned_max(unsigned x, unsigned y)
371{
372  if (x >= y) {
373    return x;
374  } else {
375    return y;
376  }
377}
378
379#if WORD_SIZE == 64
380#ifdef DARWIN
381#define MAXIMUM_MAPPABLE_MEMORY (512L<<30L)
382#endif
383#ifdef FREEBSD
384#define MAXIMUM_MAPPABLE_MEMORY (512L<<30L)
385#endif
386#ifdef SOLARIS
387#define MAXIMUM_MAPPABLE_MEMORY (128L<<30L)
388#endif
389#ifdef LINUX
390#ifdef X8664
391#define MAXIMUM_MAPPABLE_MEMORY (512L<<30L)
392#endif
393#ifdef PPC
394#define MAXIMUM_MAPPABLE_MEMORY (128L<<30L)
395#endif
396#endif
397#ifdef WINDOWS
398/* Supposedly, the high-end version of Vista allow 128GB of pageable memory */
399#define MAXIMUM_MAPPABLE_MEMORY (120LL<<30LL)
400#endif
401#else
402#ifdef DARWIN
403#define MAXIMUM_MAPPABLE_MEMORY ((1U<<31)-2*heap_segment_size)
404#endif
405#ifdef LINUX
406#define MAXIMUM_MAPPABLE_MEMORY (1U<<30)
407#endif
408#ifdef WINDOWS
409#define MAXIMUM_MAPPABLE_MEMORY (1U<<30)
410#endif
411#endif
412
413natural
414reserved_area_size = MAXIMUM_MAPPABLE_MEMORY;
415
416area
417  *nilreg_area=NULL,
418  *tenured_area=NULL, 
419  *g2_area=NULL, 
420  *g1_area=NULL,
421  *managed_static_area=NULL,
422  *readonly_area=NULL;
423
424area *all_areas=NULL;
425int cache_block_size=32;
426
427
428#if WORD_SIZE == 64
429#define DEFAULT_LISP_HEAP_GC_THRESHOLD (32<<20)
430#define G2_AREA_THRESHOLD (8<<20)
431#define G1_AREA_THRESHOLD (4<<20)
432#define G0_AREA_THRESHOLD (2<<20)
433#else
434#define DEFAULT_LISP_HEAP_GC_THRESHOLD (16<<20)
435#define G2_AREA_THRESHOLD (4<<20)
436#define G1_AREA_THRESHOLD (2<<20)
437#define G0_AREA_THRESHOLD (1<<20)
438#endif
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(unsigned 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
568  totalsize = align_to_power_of_2((void *)totalsize, log2_heap_segment_size);
569
570  start = ReserveMemoryForHeap(want, totalsize);
571
572  h = (Ptr) start;
573  base = (natural) start;
574  image_base = base;
575  lastbyte = (BytePtr) (start+totalsize);
576  static_space_start = static_space_active = (BytePtr)STATIC_BASE_ADDRESS;
577  static_space_limit = static_space_start + STATIC_RESERVE;
578  pure_space_start = pure_space_active = start;
579  pure_space_limit = start + PURESPACE_RESERVE;
580  start = pure_space_limit;
581
582  /*
583    Allocate mark bits here.  They need to be 1/64 the size of the
584     maximum useable area of the heap (+ 3 words for the EGC.)
585  */
586  end = lastbyte;
587  end = (BytePtr) ((natural)((((natural)end) - ((totalsize+63)>>6)) & ~4095));
588
589  global_mark_ref_bits = (bitvector)end;
590  end = (BytePtr) ((natural)((((natural)end) - ((totalsize+63) >> 6)) & ~4095));
591  global_reloctab = (LispObj *) end;
592  reserved = new_area(start, end, AREA_VOID);
593  /* The root of all evil is initially linked to itself. */
594  reserved->pred = reserved->succ = reserved;
595  all_areas = reserved;
596  reserved->markbits = global_mark_ref_bits;
597  return reserved;
598}
599
600void *
601allocate_from_reserved_area(natural size)
602{
603  area *reserved = reserved_area;
604  BytePtr low = reserved->low, high = reserved->high;
605  natural avail = high-low;
606 
607  size = align_to_power_of_2(size, log2_heap_segment_size);
608
609  if (size > avail) {
610    return NULL;
611  }
612  reserved->low += size;
613  reserved->active = reserved->low;
614  reserved->ndnodes -= (size>>dnode_shift);
615  return low;
616}
617
618
619
620BytePtr reloctab_limit = NULL, markbits_limit = NULL;
621
622void
623ensure_gc_structures_writable()
624{
625  natural
626    ndnodes = area_dnode(lisp_global(HEAP_END),lisp_global(HEAP_START)),
627    markbits_size = (3*sizeof(LispObj))+((ndnodes+7)>>3),
628    reloctab_size = (sizeof(LispObj)*(((ndnodes+((1<<bitmap_shift)-1))>>bitmap_shift)+1));
629  BytePtr
630    new_reloctab_limit = ((BytePtr)global_reloctab)+reloctab_size,
631    new_markbits_limit = ((BytePtr)global_mark_ref_bits)+markbits_size;
632
633  if (new_reloctab_limit > reloctab_limit) {
634    CommitMemory(global_reloctab, reloctab_size);
635    UnProtectMemory(global_reloctab, reloctab_size);
636    reloctab_limit = new_reloctab_limit;
637  }
638 
639  if (new_markbits_limit > markbits_limit) {
640    CommitMemory(global_mark_ref_bits, markbits_size);
641    UnProtectMemory(global_mark_ref_bits, markbits_size);
642    markbits_limit = new_markbits_limit;
643  }
644}
645
646
647area *
648allocate_dynamic_area(natural initsize)
649{
650  natural totalsize = align_to_power_of_2(initsize, log2_heap_segment_size);
651  BytePtr start, end;
652  area *a;
653
654  start = allocate_from_reserved_area(totalsize);
655  if (start == NULL) {
656    return NULL;
657  }
658  end = start + totalsize;
659  a = new_area(start, end, AREA_DYNAMIC);
660  a->active = start+initsize;
661  add_area_holding_area_lock(a);
662  a->markbits = reserved_area->markbits;
663  reserved_area->markbits = NULL;
664  CommitMemory(start, end-start);
665  a->h = start;
666  a->softprot = NULL;
667  a->hardprot = NULL;
668  lisp_global(HEAP_START) = ptr_to_lispobj(a->low);
669  lisp_global(HEAP_END) = ptr_to_lispobj(a->high);
670  ensure_gc_structures_writable();
671  return a;
672 }
673
674
675Boolean
676grow_dynamic_area(natural delta)
677{
678  area *a = active_dynamic_area, *reserved = reserved_area;
679  natural avail = reserved->high - reserved->low;
680 
681  delta = align_to_power_of_2(delta, log2_heap_segment_size);
682  if (delta > avail) {
683    return false;
684  }
685
686  if (!commit_pages(a->high,delta)) {
687    return false;
688  }
689
690
691  if (!allocate_from_reserved_area(delta)) {
692    return false;
693  }
694
695
696  a->high += delta;
697  a->ndnodes = area_dnode(a->high, a->low);
698  lisp_global(HEAP_END) += delta;
699  ensure_gc_structures_writable();
700  return true;
701}
702
703/*
704  As above.  Pages that're returned to the reserved_area are
705  "condemned" (e.g, we try to convince the OS that they never
706  existed ...)
707*/
708Boolean
709shrink_dynamic_area(natural delta)
710{
711  area *a = active_dynamic_area, *reserved = reserved_area;
712 
713  delta = align_to_power_of_2(delta, log2_heap_segment_size);
714
715  a->high -= delta;
716  a->ndnodes = area_dnode(a->high, a->low);
717  a->hardlimit = a->high;
718  uncommit_pages(a->high, delta);
719  reserved->low -= delta;
720  reserved->ndnodes += (delta>>dnode_shift);
721  lisp_global(HEAP_END) -= delta;
722  return true;
723}
724
725
726
727void
728sigint_handler (int signum, siginfo_t *info, ExceptionInformation *context)
729{
730  if (signum == SIGINT) {
731    lisp_global(INTFLAG) = (1 << fixnumshift);
732  }
733#ifdef DARWIN
734  DarwinSigReturn(context);
735#endif
736}
737
738
739void
740register_sigint_handler()
741{
742#ifdef WINDOWS
743  extern BOOL CALLBACK ControlEventHandler(DWORD);
744
745  signal(SIGINT, SIG_IGN);
746
747  SetConsoleCtrlHandler(ControlEventHandler,TRUE);
748#else
749  install_signal_handler(SIGINT, (void *)sigint_handler);
750#endif
751}
752
753
754
755BytePtr
756initial_stack_bottom()
757{
758#ifndef WINDOWS
759  extern char **environ;
760  char *p = *environ;
761  while (*p) {
762    p += (1+strlen(p));
763  }
764  return (BytePtr)((((natural) p) +4095) & ~4095);
765#endif
766#ifdef WINDOWS
767  return (BytePtr)((current_stack_pointer() + 4095) & ~ 4095);
768#endif
769}
770
771
772 
773Ptr fatal_spare_ptr = NULL;
774
775
776void
777Fatal(StringPtr param0, StringPtr param1)
778{
779
780  if (fatal_spare_ptr) {
781    deallocate(fatal_spare_ptr);
782    fatal_spare_ptr = NULL;
783  }
784  fprintf(stderr, "Fatal error: %s\n%s\n", param0, param1);
785  _exit(-1);
786}
787
788OSErr application_load_err = noErr;
789
790area *
791set_nil(LispObj);
792
793
794#if defined(DARWIN) || defined(WINDOWS)
795#ifdef WINDOWS
796/* Chop the trailing ".exe" from the kernel image name */
797char *
798chop_exe_suffix(char *path)
799{
800  int len = strlen(path);
801  char *copy = malloc(len+1), *tail;
802
803  strcpy(copy,path);
804  tail = strrchr(copy, '.');
805  if (tail) {
806    *tail = 0;
807  }
808  return copy;
809}
810#endif
811
812/*
813   The underlying file system may be case-insensitive (e.g., HFS),
814   so we can't just case-invert the kernel's name.
815   Tack ".image" onto the end of the kernel's name.  Much better ...
816*/
817char *
818default_image_name(char *orig)
819{
820#ifdef WINDOWS
821  char *path = chop_exe_suffix(orig);
822#else
823  char *path = orig;
824#endif
825  int len = strlen(path) + strlen(".image") + 1;
826  char *copy = (char *) malloc(len);
827
828  if (copy) {
829    strcpy(copy, path);
830    strcat(copy, ".image");
831  }
832  return copy;
833}
834
835#else
836char *
837default_image_name(char *orig)
838{
839  char *copy = strdup(orig), *base = copy, *work = copy, c;
840  if (copy == NULL) {
841    return NULL;
842  }
843  while(*work) {
844    if (*work++ == '/') {
845      base = work;
846    }
847  }
848  work = base;
849  while ((c = *work) != '\0') {
850    if (islower(c)) {
851      *work++ = toupper(c);
852    } else {
853      *work++ = tolower(c);
854    }
855  }
856  return copy;
857}
858#endif
859
860
861char *program_name = NULL;
862char *real_executable_name = NULL;
863
864char *
865determine_executable_name(char *argv0)
866{
867#ifdef DARWIN
868  uint32_t len = 1024;
869  char exepath[1024], *p = NULL;
870
871  if (_NSGetExecutablePath(exepath, (void *)&len) == 0) {
872    p = malloc(len+1);
873    memmove(p, exepath, len);
874    p[len]=0;
875    return p;
876  } 
877  return argv0;
878#endif
879#ifdef LINUX
880  char exepath[PATH_MAX], *p;
881  int n;
882
883  if ((n = readlink("/proc/self/exe", exepath, PATH_MAX)) > 0) {
884    p = malloc(n+1);
885    memmove(p,exepath,n);
886    p[n]=0;
887    return p;
888  }
889  return argv0;
890#endif
891#ifdef FREEBSD
892  return argv0;
893#endif
894#ifdef SOLARIS
895  char exepath[PATH_MAX], proc_path[PATH_MAX], *p;
896  int n;
897
898  snprintf(proc_path,PATH_MAX-1,"/proc/%d/path/a.out",getpid());
899
900  if ((n = readlink(proc_path, exepath, PATH_MAX)) > 0) {
901    p = malloc(n+1);
902    memmove(p,exepath,n);
903    p[n]=0;
904    return p;
905  }
906  return argv0;
907#endif
908#ifdef WINDOWS
909  char path[PATH_MAX], *p;
910  int len = GetModuleFileName(NULL, path, PATH_MAX);
911  if (len > 0) {
912    p = malloc(len + 1);
913    memmove(p, path, len);
914    p[len] = 0;
915    return p;
916  }
917  return argv0;
918#endif
919}
920
921void
922usage_exit(char *herald, int exit_status, char* other_args)
923{
924  if (herald && *herald) {
925    fprintf(stderr, "%s\n", herald);
926  }
927  fprintf(stderr, "usage: %s <options>\n", program_name);
928  fprintf(stderr, "\t or %s <image-name>\n", program_name);
929  fprintf(stderr, "\t where <options> are one or more of:\n");
930  if (other_args && *other_args) {
931    fputs(other_args, stderr);
932  }
933  fprintf(stderr, "\t-R, --heap-reserve <n>: reserve <n> (default: %lld)\n",
934          (u64_t) reserved_area_size);
935  fprintf(stderr, "\t\t bytes for heap expansion\n");
936  fprintf(stderr, "\t-S, --stack-size <n>: set  size of initial thread's control stack to <n>\n");
937  fprintf(stderr, "\t-Z, --thread-stack-size <n>: set default size of first (listener)  thread's stacks based on <n>\n");
938  fprintf(stderr, "\t-b, --batch: exit when EOF on *STANDARD-INPUT*\n");
939  fprintf(stderr, "\t--no-sigtrap : obscure option for running under GDB\n");
940  fprintf(stderr, "\t-I, --image-name <image-name>\n");
941  fprintf(stderr, "\t and <image-name> defaults to %s\n", 
942          default_image_name(program_name));
943  fprintf(stderr, "\n");
944  _exit(exit_status);
945}
946
947int no_sigtrap = 0;
948char *image_name = NULL;
949int batch_flag = 0;
950
951
952natural
953parse_numeric_option(char *arg, char *argname, natural default_val)
954{
955  char *tail;
956  natural val = 0;
957
958  val = strtoul(arg, &tail, 0);
959  switch(*tail) {
960  case '\0':
961    break;
962   
963  case 'M':
964  case 'm':
965    val = val << 20;
966    break;
967   
968  case 'K':
969  case 'k':
970    val = val << 10;
971    break;
972   
973  case 'G':
974  case 'g':
975    val = val << 30;
976    break;
977   
978  default:
979    fprintf(stderr, "couldn't parse %s argument %s", argname, arg);
980    val = default_val;
981    break;
982  }
983  return val;
984}
985 
986
987
988/*
989   The set of arguments recognized by the kernel is
990   likely to remain pretty small and pretty simple.
991   This removes everything it recognizes from argv;
992   remaining args will be processed by lisp code.
993*/
994
995void
996process_options(int argc, char *argv[])
997{
998  int i, j, k, num_elide, flag, arg_error;
999  char *arg, *val;
1000#ifdef DARWIN
1001  extern int NXArgc;
1002#endif
1003
1004  for (i = 1; i < argc;) {
1005    arg = argv[i];
1006    arg_error = 0;
1007    if (*arg != '-') {
1008      i++;
1009    } else {
1010      num_elide = 0;
1011      val = NULL;
1012      if ((flag = (strncmp(arg, "-I", 2) == 0)) ||
1013          (strcmp (arg, "--image-name") == 0)) {
1014        if (flag && arg[2]) {
1015          val = arg+2;
1016          num_elide = 1;
1017        } else {
1018          if ((i+1) < argc) {
1019            val = argv[i+1];
1020            num_elide = 2;
1021          } else {
1022            arg_error = 1;
1023          }
1024        }
1025        if (val) {
1026          image_name = val;
1027        }
1028      } else if ((flag = (strncmp(arg, "-R", 2) == 0)) ||
1029                 (strcmp(arg, "--heap-reserve") == 0)) {
1030        natural reserved_size = reserved_area_size;
1031
1032        if (flag && arg[2]) {
1033          val = arg+2;
1034          num_elide = 1;
1035        } else {
1036          if ((i+1) < argc) {
1037            val = argv[i+1];
1038            num_elide = 2;
1039          } else {
1040            arg_error = 1;
1041          }
1042        }
1043
1044        if (val) {
1045          reserved_size = parse_numeric_option(val, 
1046                                               "-R/--heap-reserve", 
1047                                               reserved_area_size);
1048        }
1049
1050        if (reserved_size <= MAXIMUM_MAPPABLE_MEMORY) {
1051          reserved_area_size = reserved_size;
1052        }
1053
1054      } else if ((flag = (strncmp(arg, "-S", 2) == 0)) ||
1055                 (strcmp(arg, "--stack-size") == 0)) {
1056        natural stack_size;
1057
1058        if (flag && arg[2]) {
1059          val = arg+2;
1060          num_elide = 1;
1061        } else {
1062          if ((i+1) < argc) {
1063            val = argv[i+1];
1064            num_elide = 2;
1065          } else {
1066            arg_error = 1;
1067          }
1068        }
1069
1070        if (val) {
1071          stack_size = parse_numeric_option(val, 
1072                                            "-S/--stack-size", 
1073                                            initial_stack_size);
1074         
1075
1076          if (stack_size >= MIN_CSTACK_SIZE) {
1077            initial_stack_size = stack_size;
1078          }
1079        }
1080
1081      } else if ((flag = (strncmp(arg, "-Z", 2) == 0)) ||
1082                 (strcmp(arg, "--thread-stack-size") == 0)) {
1083        natural stack_size;
1084
1085        if (flag && arg[2]) {
1086          val = arg+2;
1087          num_elide = 1;
1088        } else {
1089          if ((i+1) < argc) {
1090            val = argv[i+1];
1091            num_elide = 2;
1092          } else {
1093            arg_error = 1;
1094          }
1095        }
1096
1097        if (val) {
1098          stack_size = parse_numeric_option(val, 
1099                                            "-Z/--thread-stack-size", 
1100                                            thread_stack_size);
1101         
1102
1103          if (stack_size >= MIN_CSTACK_SIZE) {
1104           thread_stack_size = stack_size;
1105          }
1106          if (thread_stack_size >= (1LL<<((WORD_SIZE-fixnumshift)-1))) {
1107            thread_stack_size = (1LL<<((WORD_SIZE-fixnumshift)-1))-1;
1108          }
1109         
1110        }
1111
1112      } else if (strcmp(arg, "--no-sigtrap") == 0) {
1113        no_sigtrap = 1;
1114        num_elide = 1;
1115      } else if ((strcmp(arg, "-b") == 0) ||
1116                 (strcmp(arg, "--batch") == 0)) {
1117        batch_flag = 1;
1118        num_elide = 1;
1119      } else if (strcmp(arg,"--") == 0) {
1120        break;
1121      } else {
1122        i++;
1123      }
1124      if (arg_error) {
1125        usage_exit("error in program arguments", 1, "");
1126      }
1127      if (num_elide) {
1128        for (j = i+num_elide, k=i; j < argc; j++, k++) {
1129          argv[k] = argv[j];
1130        }
1131        argc -= num_elide;
1132#ifdef DARWIN
1133        NXArgc -= num_elide;
1134#endif
1135        argv[argc] = NULL;
1136      }
1137    }
1138  }
1139}
1140
1141#ifdef WINDOWS
1142void
1143terminate_lisp()
1144{
1145  ExitProcess(EXIT_FAILURE);
1146}
1147#else
1148pid_t main_thread_pid = (pid_t)0;
1149
1150void
1151terminate_lisp()
1152{
1153  kill(main_thread_pid, SIGKILL);
1154  _exit(-1);
1155}
1156#endif
1157
1158#ifdef DARWIN
1159#ifdef PPC64
1160#define min_os_version "8.0"    /* aka Tiger */
1161#else
1162#define min_os_version "7.0"    /* aka Panther */
1163#endif
1164#endif
1165#ifdef LINUX
1166#ifdef PPC
1167#define min_os_version "2.2"
1168#endif
1169#ifdef X86
1170#define min_os_version "2.6"
1171#endif
1172#endif
1173#ifdef FREEBSD
1174#define min_os_version "6.0"
1175#endif
1176#ifdef SOLARIS
1177#define min_os_version "5.10"
1178#endif
1179
1180#ifdef DARWIN
1181#ifdef PPC64
1182/* ld64 on Darwin doesn't offer anything close to reliable control
1183   over the layout of a program in memory.  About all that we can
1184   be assured of is that the canonical subprims jump table address
1185   (currently 0x5000) is unmapped.  Map that page, and copy the
1186   actual spjump table there. */
1187
1188
1189void
1190remap_spjump()
1191{
1192  extern opcode spjump_start, spjump_end;
1193  pc new,
1194    old = &spjump_start,
1195    limit = &spjump_end,
1196    work;
1197  opcode instr;
1198  void *target;
1199  int disp;
1200 
1201  if (old != (pc)0x5000) {
1202    new = mmap((pc) 0x5000,
1203               0x1000,
1204               PROT_READ | PROT_WRITE | PROT_EXEC,
1205               MAP_PRIVATE | MAP_ANON | MAP_FIXED,
1206               -1,
1207               0);
1208    if (new != (pc) 0x5000) {
1209      _exit(1);
1210    }
1211   
1212    for (work = new; old < limit; work++, old++) {
1213      instr = *old;
1214      disp = instr & ((1<<26)-1);
1215      target = (void*)old+disp;
1216      disp = target-(void *)work;
1217      *work = ((instr >> 26) << 26) | disp;
1218    }
1219    xMakeDataExecutable(new, (void*)work-(void*)new);
1220    ProtectMemory(new, 0x1000);
1221  }
1222}
1223#endif
1224#endif
1225
1226#ifdef X86
1227#ifdef WINDOWS
1228
1229/* By using linker tricks, we ensure there's memory between 0x11000
1230   and 0x21000, so we just need to fix permissions and copy the spjump
1231   table. */
1232
1233void
1234remap_spjump()
1235{
1236  extern opcode spjump_start;
1237  DWORD old_protect;
1238
1239  if (!VirtualProtect((pc) 0x15000,
1240                      0x1000,
1241                      PAGE_EXECUTE_READWRITE,
1242                      &old_protect)) {
1243    wperror("VirtualProtect spjump");
1244    _exit(1);
1245  }
1246  memmove((pc) 0x15000, &spjump_start, 0x1000);
1247}
1248#else
1249void
1250remap_spjump()
1251{
1252  extern opcode spjump_start;
1253  pc new = mmap((pc) 0x15000,
1254                0x1000,
1255                PROT_READ | PROT_WRITE | PROT_EXEC,
1256                MAP_PRIVATE | MAP_ANON | MAP_FIXED,
1257                -1,
1258                0),
1259    old = &spjump_start;
1260  if (new == (pc)-1) {
1261    perror("remap spjump");
1262    _exit(1);
1263  }
1264  memmove(new, old, 0x1000);
1265}
1266#endif
1267#endif
1268
1269
1270void
1271check_os_version(char *progname)
1272{
1273#ifdef WINDOWS
1274  /* 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. */
1275#else
1276  struct utsname uts;
1277  long got, want;
1278  char *got_end,*want_end;
1279  want = strtoul(min_os_version,&want_end,10);
1280
1281  uname(&uts);
1282  got = strtoul(uts.release,&got_end,10);
1283
1284  while (got == want) {
1285    if (*want_end == '.') {
1286      want = strtoul(want_end+1,&want_end,10);
1287      got = 0;
1288      if (*got_end == '.') {
1289        got = strtoul(got_end+1,&got_end,10);
1290      } else {
1291        break;
1292      }
1293    } else {
1294      break;
1295    }
1296  }
1297
1298  if (got < want) {
1299    fprintf(stderr, "\n%s requires %s version %s or later; the current version is %s.\n", progname, uts.sysname, min_os_version, uts.release);
1300    exit(1);
1301  }
1302#ifdef PPC
1303#ifdef DARWIN
1304  {
1305    char *hosttype = getenv("HOSTTYPE");
1306    if (hosttype && !strncmp("intel", hosttype, 5)) {
1307      running_under_rosetta = true;
1308      use_mach_exception_handling = false;
1309      reserved_area_size = 1U << 30;
1310    }
1311  }
1312#endif
1313#endif
1314#endif
1315}
1316
1317#ifdef X86
1318/*
1319  This should determine the cache block size.  It should also
1320  probably complain if we don't have (at least) SSE2.
1321*/
1322extern int cpuid(natural, natural*, natural*, natural*);
1323
1324#define X86_FEATURE_CMOV    (1<<15)
1325#define X86_FEATURE_CLFLUSH (1<<19)
1326#define X86_FEATURE_MMX     (1<<23)
1327#define X86_FEATURE_SSE     (1<<25)
1328#define X86_FEATURE_SSE2    (1<<26)
1329
1330#define X86_REQUIRED_FEATURES (X86_FEATURE_CMOV|X86_FEATURE_CLFLUSH|X86_FEATURE_MMX|X86_FEATURE_SSE|X86_FEATURE_SSE2)
1331
1332Boolean
1333check_x86_cpu()
1334{
1335  natural eax, ebx, ecx, edx;
1336 
1337  eax = cpuid(0, &ebx, &ecx, &edx);
1338
1339  if (eax >= 1) {
1340    eax = cpuid(1, &ebx, &ecx, &edx);
1341    cache_block_size = (ebx & 0xff00) >> 5;
1342    if ((X86_REQUIRED_FEATURES & edx) == X86_REQUIRED_FEATURES) {
1343      return true;
1344    }
1345  }
1346  return false;
1347}
1348#endif
1349
1350void
1351lazarus()
1352{
1353  TCR *tcr = get_tcr(false);
1354  if (tcr) {
1355    /* Some threads may be dying; no threads should be created. */
1356    LOCK(lisp_global(TCR_AREA_LOCK),tcr);
1357    tcr->vs_area->active = tcr->vs_area->high - node_size;
1358    tcr->save_vsp = (LispObj *)(tcr->vs_area->active);
1359    tcr->ts_area->active = tcr->ts_area->high;
1360    tcr->save_tsp = (LispObj *)(tcr->ts_area->active);
1361    tcr->catch_top = 0;
1362    tcr->db_link = 0;
1363    tcr->xframe = 0;
1364    start_lisp(tcr, 0);
1365  }
1366}
1367
1368#ifdef LINUX
1369#ifdef X8664
1370#include <asm/prctl.h>
1371#include <sys/prctl.h>
1372
1373void
1374ensure_gs_available(char *progname)
1375{
1376  LispObj fs_addr = 0L, gs_addr = 0L, cur_thread = (LispObj)pthread_self();
1377  char *gnu_get_libc_version(void);
1378 
1379  arch_prctl(ARCH_GET_GS, &gs_addr);
1380  arch_prctl(ARCH_GET_FS, &fs_addr);
1381  if ((gs_addr == cur_thread) && (fs_addr != cur_thread)) {
1382    fprintf(stderr, "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);
1383    _exit(1);
1384  }
1385}
1386#endif
1387#endif
1388
1389Boolean
1390bogus_fp_exceptions = false;
1391
1392typedef
1393float (*float_arg_returns_float)(float);
1394
1395float
1396fcallf(float_arg_returns_float fun, float arg)
1397{
1398  return fun(arg);
1399}
1400
1401void
1402check_bogus_fp_exceptions()
1403{
1404#ifdef X8664
1405  float asinf(float),result;
1406   
1407
1408  natural save_mxcsr = get_mxcsr(), post_mxcsr;
1409  set_mxcsr(0x1f80);
1410
1411  result = fcallf(asinf, 1.0);
1412  post_mxcsr = get_mxcsr();
1413  set_mxcsr(save_mxcsr);
1414  if (post_mxcsr & (FE_ALL_EXCEPT & (~FE_INEXACT))) {
1415    bogus_fp_exceptions = true;
1416  }
1417#endif
1418}
1419
1420
1421int
1422main(int argc, char *argv[]
1423#ifndef WINDOWS
1424, char *envp[], void *aux
1425#endif
1426)
1427{
1428  extern int page_size;
1429
1430#ifdef PPC
1431  extern int altivec_present;
1432#endif
1433  extern LispObj load_image(char *);
1434  area *a;
1435  BytePtr stack_base, current_sp = (BytePtr) current_stack_pointer();
1436  TCR *tcr;
1437
1438
1439#ifdef WINDOWS
1440  extern void init_winsock(void);
1441  extern void init_windows_io(void);
1442
1443  _fmode = O_BINARY;
1444  _setmode(1, O_BINARY);
1445  _setmode(2, O_BINARY);
1446  setvbuf(stderr, NULL, _IONBF, 0);
1447  init_winsock();
1448  init_windows_io();
1449#endif
1450
1451  check_os_version(argv[0]);
1452  real_executable_name = determine_executable_name(argv[0]);
1453  page_size = getpagesize(); /* Implement with GetSystemInfo on Windows w/o MinGW */
1454
1455  check_bogus_fp_exceptions();
1456#ifdef LINUX
1457#ifdef X8664
1458  ensure_gs_available(real_executable_name);
1459#endif
1460#endif
1461#if (defined(DARWIN) && defined(PPC64)) || defined(X8664) || (defined(X8632) && !defined(DARWIN))
1462  remap_spjump();
1463#endif
1464
1465#ifdef PPC
1466#ifdef LINUX
1467  {
1468    ElfW(auxv_t) *av = aux;
1469    int hwcap, done = false;
1470   
1471    if (av) {
1472      do {
1473        switch (av->a_type) {
1474        case AT_DCACHEBSIZE:
1475          cache_block_size = av->a_un.a_val;
1476          break;
1477
1478        case AT_HWCAP:
1479          hwcap = av->a_un.a_val;
1480          altivec_present = ((hwcap & PPC_FEATURE_HAS_ALTIVEC) != 0);
1481          break;
1482
1483        case AT_NULL:
1484          done = true;
1485          break;
1486        }
1487        av++;
1488      } while (!done);
1489    }
1490  }
1491#endif
1492#ifdef DARWIN
1493  {
1494    unsigned value = 0;
1495    size_t len = sizeof(value);
1496    int mib[2];
1497   
1498    mib[0] = CTL_HW;
1499    mib[1] = HW_CACHELINE;
1500    if (sysctl(mib,2,&value,&len, NULL, 0) != -1) {
1501      if (len == sizeof(value)) {
1502        cache_block_size = value;
1503      }
1504    }
1505    mib[1] = HW_VECTORUNIT;
1506    value = 0;
1507    len = sizeof(value);
1508    if (sysctl(mib,2,&value,&len, NULL, 0) != -1) {
1509      if (len == sizeof(value)) {
1510        altivec_present = value;
1511      }
1512    }
1513  }
1514#endif
1515#endif
1516
1517#ifdef X86
1518  if (!check_x86_cpu()) {
1519    fprintf(stderr, "CPU doesn't support required features\n");
1520    exit(1);
1521  }
1522#endif
1523
1524#ifndef WINDOWS
1525  main_thread_pid = getpid();
1526#endif
1527  tcr_area_lock = (void *)new_recursive_lock();
1528
1529  program_name = argv[0];
1530  if ((argc == 2) && (*argv[1] != '-')) {
1531    image_name = argv[1];
1532    argv[1] = NULL;
1533  } else {
1534    process_options(argc,argv);
1535  }
1536  initial_stack_size = ensure_stack_limit(initial_stack_size);
1537  if (image_name == NULL) {
1538    if (check_for_embedded_image(real_executable_name)) {
1539      image_name = real_executable_name;
1540    } else {
1541      image_name = default_image_name(real_executable_name);
1542    }
1543  }
1544
1545
1546  if (!create_reserved_area(reserved_area_size)) {
1547    exit(-1);
1548  }
1549  gc_init();
1550
1551  set_nil(load_image(image_name));
1552  lisp_global(TCR_AREA_LOCK) = ptr_to_lispobj(tcr_area_lock);
1553
1554#ifdef X86
1555  lisp_global(SUBPRIMS_BASE) = (LispObj)((1<<16)+(5<<10));
1556#else
1557  lisp_global(SUBPRIMS_BASE) = (LispObj)(5<<10);
1558#endif
1559  lisp_global(RET1VALN) = (LispObj)&ret1valn;
1560  lisp_global(LEXPR_RETURN) = (LispObj)&nvalret;
1561  lisp_global(LEXPR_RETURN1V) = (LispObj)&popj;
1562  lisp_global(ALL_AREAS) = ptr_to_lispobj(all_areas);
1563#ifdef X86
1564  lisp_global(BAD_FUNCALL) = ptr_to_lispobj(&bad_funcall);
1565#endif
1566  lisp_global(DEFAULT_ALLOCATION_QUANTUM) = log2_heap_segment_size << fixnumshift;
1567  lisp_global(STACK_SIZE) = thread_stack_size<<fixnumshift;
1568
1569
1570  exception_init();
1571
1572 
1573
1574  lisp_global(IMAGE_NAME) = ptr_to_lispobj(image_name);
1575  lisp_global(ARGV) = ptr_to_lispobj(argv);
1576  lisp_global(KERNEL_IMPORTS) = (LispObj)import_ptrs_base;
1577
1578  lisp_global(GET_TCR) = (LispObj) get_tcr;
1579  *(double *) &(lisp_global(DOUBLE_FLOAT_ONE)) = (double) 1.0;
1580
1581  lisp_global(HOST_PLATFORM) = (LispObj) PLATFORM << fixnumshift;
1582
1583  lisp_global(BATCH_FLAG) = (batch_flag << fixnumshift);
1584
1585  a = active_dynamic_area;
1586
1587  if (nilreg_area != NULL) {
1588    BytePtr lowptr = (BytePtr) a->low;
1589
1590    /* Create these areas as AREA_STATIC, change them to AREA_DYNAMIC */
1591    g1_area = new_area(lowptr, lowptr, AREA_STATIC);
1592    g2_area = new_area(lowptr, lowptr, AREA_STATIC);
1593    tenured_area = new_area(lowptr, lowptr, AREA_STATIC);
1594    add_area_holding_area_lock(tenured_area);
1595    add_area_holding_area_lock(g2_area);
1596    add_area_holding_area_lock(g1_area);
1597
1598    g1_area->code = AREA_DYNAMIC;
1599    g2_area->code = AREA_DYNAMIC;
1600    tenured_area->code = AREA_DYNAMIC;
1601
1602/*    a->older = g1_area; */ /* Not yet: this is what "enabling the EGC" does. */
1603    g1_area->younger = a;
1604    g1_area->older = g2_area;
1605    g2_area->younger = g1_area;
1606    g2_area->older = tenured_area;
1607    tenured_area->younger = g2_area;
1608    tenured_area->refbits = a->markbits;
1609    tenured_area->static_dnodes = a->static_dnodes;
1610    a->static_dnodes = 0;
1611    tenured_area->static_used = a->static_used;
1612    a->static_used = 0;
1613    lisp_global(TENURED_AREA) = ptr_to_lispobj(tenured_area);
1614    lisp_global(REFBITS) = ptr_to_lispobj(tenured_area->refbits);
1615    g2_area->threshold = G2_AREA_THRESHOLD;
1616    g1_area->threshold = G1_AREA_THRESHOLD;
1617    a->threshold = G0_AREA_THRESHOLD;
1618  }
1619
1620  tcr = new_tcr(initial_stack_size, MIN_TSTACK_SIZE);
1621  stack_base = initial_stack_bottom()-xStackSpace();
1622  init_threads((void *)(stack_base), tcr);
1623  thread_init_tcr(tcr, current_sp, current_sp-stack_base);
1624
1625  lisp_global(EXCEPTION_LOCK) = ptr_to_lispobj(new_recursive_lock());
1626  enable_fp_exceptions();
1627  register_sigint_handler();
1628
1629#ifdef PPC
1630  lisp_global(ALTIVEC_PRESENT) = altivec_present << fixnumshift;
1631#endif
1632#if STATIC
1633  lisp_global(STATICALLY_LINKED) = 1 << fixnumshift;
1634#endif
1635  tcr->prev = tcr->next = tcr;
1636#ifndef WINDOWS
1637  lisp_global(INTERRUPT_SIGNAL) = (LispObj) box_fixnum(SIGNAL_FOR_PROCESS_INTERRUPT);
1638#endif
1639  tcr->vs_area->active -= node_size;
1640  *(--tcr->save_vsp) = nrs_TOPLFUNC.vcell;
1641  nrs_TOPLFUNC.vcell = lisp_nil;
1642#ifdef GC_INTEGRITY_CHECKING
1643  (nrs_GC_EVENT_STATUS_BITS.vcell |= gc_integrity_check_bit);
1644#endif
1645#ifndef DISABLE_EGC
1646  egc_control(true, NULL);
1647#endif
1648  atexit(lazarus);
1649  start_lisp(TCR_TO_TSD(tcr), 0);
1650  _exit(0);
1651}
1652
1653area *
1654set_nil(LispObj r)
1655{
1656
1657  if (lisp_nil == (LispObj)NULL) {
1658
1659    lisp_nil = r;
1660  }
1661  return NULL;
1662}
1663
1664
1665void
1666xMakeDataExecutable(void *start, unsigned long nbytes)
1667{
1668  extern void flush_cache_lines();
1669  natural ustart = (natural) start, base, end;
1670 
1671  base = (ustart) & ~(cache_block_size-1);
1672  end = (ustart + nbytes + cache_block_size - 1) & ~(cache_block_size-1);
1673#ifdef DARWIN
1674  if (running_under_rosetta) {
1675    /* We probably need to flush something's cache even if running
1676       under Rosetta, but (a) this is agonizingly slow and (b) we're
1677       dying before we get to the point where this would matter.
1678    */
1679    return;
1680  }
1681#endif
1682#ifndef X86
1683  flush_cache_lines(base, (end-base)/cache_block_size, cache_block_size);
1684#endif
1685}
1686
1687natural
1688xStackSpace()
1689{
1690  return initial_stack_size+CSTACK_HARDPROT+CSTACK_SOFTPROT;
1691}
1692
1693#ifndef DARWIN
1694#ifdef WINDOWS
1695extern void *windows_open_shared_library(char *);
1696
1697void *
1698xGetSharedLibrary(char *path, int mode)
1699{
1700  return windows_open_shared_library(path);
1701}
1702#else
1703void *
1704xGetSharedLibrary(char *path, int mode)
1705{
1706  return dlopen(path, mode);
1707}
1708#endif
1709#else
1710void *
1711xGetSharedLibrary(char *path, int *resultType)
1712{
1713#if defined(PPC) && (WORD_SIZE == 32)
1714  NSObjectFileImageReturnCode code;
1715  NSObjectFileImage              moduleImage;
1716  NSModule                       module;
1717  const struct mach_header *     header;
1718  const char *                   error;
1719  void *                         result;
1720  /* not thread safe */
1721  /*
1722  static struct {
1723    const struct mach_header  *header;
1724    NSModule                  *module;
1725    const char                *error;
1726  } results;   
1727  */
1728  result = NULL;
1729  error = NULL;
1730
1731  /* first try to open this as a bundle */
1732  code = NSCreateObjectFileImageFromFile(path,&moduleImage);
1733  if (code != NSObjectFileImageSuccess &&
1734      code != NSObjectFileImageInappropriateFile &&
1735      code != NSObjectFileImageAccess)
1736    {
1737      /* compute error strings */
1738      switch (code)
1739        {
1740        case NSObjectFileImageFailure:
1741          error = "NSObjectFileImageFailure";
1742          break;
1743        case NSObjectFileImageArch:
1744          error = "NSObjectFileImageArch";
1745          break;
1746        case NSObjectFileImageFormat:
1747          error = "NSObjectFileImageFormat";
1748          break;
1749        case NSObjectFileImageAccess:
1750          /* can't find the file */
1751          error = "NSObjectFileImageAccess";
1752          break;
1753        default:
1754          error = "unknown error";
1755        }
1756      *resultType = 0;
1757      return (void *)error;
1758    }
1759  if (code == NSObjectFileImageInappropriateFile ||
1760      code == NSObjectFileImageAccess ) {
1761    /* the pathname might be a partial pathane (hence the access error)
1762       or it might be something other than a bundle, if so perhaps
1763       it is a .dylib so now try to open it as a .dylib */
1764
1765    /* protect against redundant loads, Gary Byers noticed possible
1766       heap corruption if this isn't done */
1767    header = NSAddImage(path, NSADDIMAGE_OPTION_RETURN_ON_ERROR |
1768                        NSADDIMAGE_OPTION_WITH_SEARCHING |
1769                        NSADDIMAGE_OPTION_RETURN_ONLY_IF_LOADED);
1770    if (!header)
1771      header = NSAddImage(path, NSADDIMAGE_OPTION_RETURN_ON_ERROR |
1772                          NSADDIMAGE_OPTION_WITH_SEARCHING);
1773    result = (void *)header;
1774    *resultType = 1;
1775  }
1776  else if (code == NSObjectFileImageSuccess) {
1777    /* we have a sucessful module image
1778       try to link it, don't bind symbols privately */
1779
1780    module = NSLinkModule(moduleImage, path,
1781                          NSLINKMODULE_OPTION_RETURN_ON_ERROR | NSLINKMODULE_OPTION_BINDNOW);
1782    NSDestroyObjectFileImage(moduleImage);     
1783    result = (void *)module;
1784    *resultType = 2;
1785  }
1786  if (!result)
1787    {
1788      /* compute error string */
1789      NSLinkEditErrors ler;
1790      int lerno;
1791      const char* file;
1792      NSLinkEditError(&ler,&lerno,&file,&error);
1793      if (error) {
1794        result = (void *)error;
1795        *resultType = 0;
1796      }
1797    }
1798  return result;
1799#else
1800  const char *                   error;
1801  void *                         result;
1802
1803  result = dlopen(path, RTLD_NOW | RTLD_GLOBAL);
1804 
1805  if (result == NULL) {
1806    error = dlerror();
1807    *resultType = 0;
1808    return (void *)error;
1809  }
1810  *resultType = 1;
1811  return result;
1812#endif
1813}
1814#endif
1815
1816
1817
1818int
1819fd_setsize_bytes()
1820{
1821  return FD_SETSIZE/8;
1822}
1823
1824void
1825do_fd_set(int fd, fd_set *fdsetp)
1826{
1827  FD_SET(fd, fdsetp);
1828}
1829
1830void
1831do_fd_clr(int fd, fd_set *fdsetp)
1832{
1833  FD_CLR(fd, fdsetp);
1834}
1835
1836int
1837do_fd_is_set(int fd, fd_set *fdsetp)
1838{
1839  return FD_ISSET(fd,fdsetp);
1840}
1841
1842
1843void
1844do_fd_zero(fd_set *fdsetp)
1845{
1846  FD_ZERO(fdsetp);
1847}
1848
1849#include "image.h"
1850
1851
1852
1853Boolean
1854check_for_embedded_image (char *path)
1855{
1856  int fd = open(path, O_RDONLY);
1857  Boolean image_is_embedded = false;
1858
1859  if (fd >= 0) {
1860    openmcl_image_file_header h;
1861
1862    if (find_openmcl_image_file_header (fd, &h)) {
1863      image_is_embedded = true;
1864    }
1865    close (fd);
1866  }
1867  return image_is_embedded;
1868}
1869
1870LispObj
1871load_image(char *path)
1872{
1873  int fd = open(path, O_RDONLY, 0666);
1874  LispObj image_nil = 0;
1875  if (fd > 0) {
1876    openmcl_image_file_header ih;
1877    image_nil = load_openmcl_image(fd, &ih);
1878    /* We -were- using a duplicate fd to map the file; that
1879       seems to confuse Darwin (doesn't everything ?), so
1880       we'll instead keep the original file open.
1881    */
1882    if (!image_nil) {
1883      close(fd);
1884    }
1885  }
1886  if (image_nil == 0) {
1887    fprintf(stderr, "Couldn't load lisp heap image from %s:\n%s\n", path, strerror(errno));
1888    exit(-1);
1889  }
1890  return image_nil;
1891}
1892
1893int
1894set_errno(int val)
1895{
1896  errno = val;
1897  return -1;
1898}
1899
1900
1901
1902
1903void *
1904xFindSymbol(void* handle, char *name)
1905{
1906#if defined(LINUX) || defined(FREEBSD) || defined(SOLARIS)
1907  return dlsym(handle, name);
1908#endif
1909#ifdef DARWIN
1910#if defined(PPC64) || defined(X86)
1911  if ((handle == NULL) || (handle == ((void *) -1))) {
1912    handle = RTLD_DEFAULT;
1913  }   
1914  if (*name == '_') {
1915    name++;
1916  }
1917  return dlsym(handle, name);
1918#else
1919  natural address = 0;
1920
1921  if ((handle == NULL) ||
1922      (handle == (void *)-1) ||
1923      (handle == (void *)-2)){
1924    if (NSIsSymbolNameDefined(name)) { /* Keep dyld_lookup from crashing */
1925      _dyld_lookup_and_bind(name, (void *) &address, (void*) NULL);
1926    }
1927    return (void *)address;
1928  }
1929  Bug(NULL, "How did this happen ?");
1930#endif
1931#endif
1932#ifdef WINDOWS
1933  extern void *windows_find_symbol(void *, char *);
1934  return windows_find_symbol(handle, name);
1935#endif
1936}
1937
1938void *
1939get_r_debug()
1940{
1941#if defined(LINUX) || defined(FREEBSD) || defined(SOLARIS)
1942#if WORD_SIZE == 64
1943  extern Elf64_Dyn _DYNAMIC[];
1944  Elf64_Dyn *dp;
1945#else
1946  extern Elf32_Dyn _DYNAMIC[];
1947  Elf32_Dyn *dp;
1948#endif
1949  int tag;
1950
1951  for (dp = _DYNAMIC; (tag = dp->d_tag) != 0; dp++) {
1952    if (tag == DT_DEBUG) {
1953      return (void *)(dp->d_un.d_ptr);
1954    }
1955  }
1956#endif
1957  return NULL;
1958}
1959
1960
1961#ifdef DARWIN
1962void
1963sample_paging_info(paging_info *stats)
1964{
1965  mach_msg_type_number_t count = TASK_EVENTS_INFO_COUNT;
1966
1967  task_info(mach_task_self(),
1968            TASK_EVENTS_INFO,
1969            (task_info_t)stats,
1970            &count);
1971}
1972
1973void
1974report_paging_info_delta(FILE *out, paging_info *start, paging_info *stop)
1975{
1976  fprintf(out,";;; %d soft faults, %d faults, %d pageins\n\n",
1977          stop->cow_faults-start->cow_faults,
1978          stop->faults-start->faults,
1979          stop->pageins-start->pageins);
1980}
1981
1982#else
1983#ifdef WINDOWS
1984void
1985sample_paging_info(paging_info *stats)
1986{
1987}
1988
1989void
1990report_paging_info_delta(FILE *out, paging_info *start, paging_info *stop)
1991{
1992}
1993#else
1994void
1995sample_paging_info(paging_info *stats)
1996{
1997  getrusage(RUSAGE_SELF, stats);
1998}
1999
2000void
2001report_paging_info_delta(FILE *out, paging_info *start, paging_info *stop)
2002{
2003  fprintf(out,";;; %ld soft faults, %ld faults, %ld pageins\n\n",
2004          stop->ru_minflt-start->ru_minflt,
2005          stop->ru_majflt-start->ru_majflt,
2006          stop->ru_nswap-start->ru_nswap);
2007}
2008
2009#endif
2010#endif
Note: See TracBrowser for help on using the repository browser.