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

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

In the Windows version of terminate_lisp(), use #exit (not ExitProcess?,
which seems to want to run things registers via #_atexit. Windows' little
joke.)

Don't claim to run on Panther on Darwin. (We probably haven't in quite
a while, but try to catch that earlier.)

Use SPJUMP_TARGET_ADDRESS in all of the various versions of remap_spjump;
in the Windows version, consider the possibility that the jump table's
already where it needs to be.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 44.2 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  _exit(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#define min_os_version "8.0"    /* aka Tiger */
1160#endif
1161#ifdef LINUX
1162#ifdef PPC
1163#define min_os_version "2.2"
1164#endif
1165#ifdef X86
1166#define min_os_version "2.6"
1167#endif
1168#endif
1169#ifdef FREEBSD
1170#define min_os_version "6.0"
1171#endif
1172#ifdef SOLARIS
1173#define min_os_version "5.10"
1174#endif
1175
1176#ifdef DARWIN
1177#ifdef PPC64
1178/* ld64 on Darwin doesn't offer anything close to reliable control
1179   over the layout of a program in memory.  About all that we can
1180   be assured of is that the canonical subprims jump table address
1181   (currently 0x5000) is unmapped.  Map that page, and copy the
1182   actual spjump table there. */
1183
1184
1185void
1186remap_spjump()
1187{
1188  extern opcode spjump_start, spjump_end;
1189  pc new,
1190    old = &spjump_start,
1191    limit = &spjump_end,
1192    work;
1193  opcode instr;
1194  void *target;
1195  int disp;
1196 
1197  if (old != (pc)SPJUMP_TARGET_ADDRESS) {
1198    new = mmap((pc) SPJUMP_TARGET_ADDRESS,
1199               0x1000,
1200               PROT_READ | PROT_WRITE | PROT_EXEC,
1201               MAP_PRIVATE | MAP_ANON | MAP_FIXED,
1202               -1,
1203               0);
1204    if (new != (pc) SPJUMP_TARGET_ADDRESS) {
1205      perror("remap spjump");
1206      _exit(1);
1207    }
1208   
1209    for (work = new; old < limit; work++, old++) {
1210      instr = *old;
1211      disp = instr & ((1<<26)-1);
1212      target = (void*)old+disp;
1213      disp = target-(void *)work;
1214      *work = ((instr >> 26) << 26) | disp;
1215    }
1216    xMakeDataExecutable(new, (void*)work-(void*)new);
1217    ProtectMemory(new, 0x1000);
1218  }
1219}
1220#endif
1221#endif
1222
1223#ifdef X86
1224#ifdef WINDOWS
1225
1226/* By using linker tricks, we ensure there's memory between 0x11000
1227   and 0x21000, so we just need to fix permissions and copy the spjump
1228   table. */
1229
1230void
1231remap_spjump()
1232{
1233  extern opcode spjump_start;
1234  DWORD old_protect;
1235
1236  if ((void *)(&spjump_start) != (void *) SPJUMP_TARGET_ADDRESS) {
1237    if (!VirtualProtect((pc) SPJUMP_TARGET_ADDRESS,
1238                        0x1000,
1239                        PAGE_EXECUTE_READWRITE,
1240                        &old_protect)) {
1241      wperror("VirtualProtect spjump");
1242      _exit(1);
1243    }
1244    memmove((pc) SPJUMP_TARGET_ADDRESS, &spjump_start, 0x1000);
1245  }
1246}
1247#else
1248void
1249remap_spjump()
1250{
1251  extern opcode spjump_start;
1252  pc new = mmap((pc) SPJUMP_TARGET_ADDRESS,
1253                0x1000,
1254                PROT_READ | PROT_WRITE | PROT_EXEC,
1255                MAP_PRIVATE | MAP_ANON | MAP_FIXED,
1256                -1,
1257                0),
1258    old = &spjump_start;
1259  if (new == (pc)-1) {
1260    perror("remap spjump");
1261    _exit(1);
1262  }
1263  memmove(new, old, 0x1000);
1264}
1265#endif
1266#endif
1267
1268
1269void
1270check_os_version(char *progname)
1271{
1272#ifdef WINDOWS
1273  /* 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. */
1274#else
1275  struct utsname uts;
1276  long got, want;
1277  char *got_end,*want_end;
1278  want = strtoul(min_os_version,&want_end,10);
1279
1280  uname(&uts);
1281  got = strtoul(uts.release,&got_end,10);
1282
1283  while (got == want) {
1284    if (*want_end == '.') {
1285      want = strtoul(want_end+1,&want_end,10);
1286      got = 0;
1287      if (*got_end == '.') {
1288        got = strtoul(got_end+1,&got_end,10);
1289      } else {
1290        break;
1291      }
1292    } else {
1293      break;
1294    }
1295  }
1296
1297  if (got < want) {
1298    fprintf(stderr, "\n%s requires %s version %s or later; the current version is %s.\n", progname, uts.sysname, min_os_version, uts.release);
1299    exit(1);
1300  }
1301#ifdef PPC
1302#ifdef DARWIN
1303  {
1304    char *hosttype = getenv("HOSTTYPE");
1305    if (hosttype && !strncmp("intel", hosttype, 5)) {
1306      running_under_rosetta = true;
1307      use_mach_exception_handling = false;
1308      reserved_area_size = 1U << 30;
1309    }
1310  }
1311#endif
1312#endif
1313#endif
1314}
1315
1316#ifdef X86
1317/*
1318  This should determine the cache block size.  It should also
1319  probably complain if we don't have (at least) SSE2.
1320*/
1321extern int cpuid(natural, natural*, natural*, natural*);
1322
1323#define X86_FEATURE_CMOV    (1<<15)
1324#define X86_FEATURE_CLFLUSH (1<<19)
1325#define X86_FEATURE_MMX     (1<<23)
1326#define X86_FEATURE_SSE     (1<<25)
1327#define X86_FEATURE_SSE2    (1<<26)
1328
1329#define X86_REQUIRED_FEATURES (X86_FEATURE_CMOV|X86_FEATURE_CLFLUSH|X86_FEATURE_MMX|X86_FEATURE_SSE|X86_FEATURE_SSE2)
1330
1331Boolean
1332check_x86_cpu()
1333{
1334  natural eax, ebx, ecx, edx;
1335 
1336  eax = cpuid(0, &ebx, &ecx, &edx);
1337
1338  if (eax >= 1) {
1339    eax = cpuid(1, &ebx, &ecx, &edx);
1340    cache_block_size = (ebx & 0xff00) >> 5;
1341    if ((X86_REQUIRED_FEATURES & edx) == X86_REQUIRED_FEATURES) {
1342      return true;
1343    }
1344  }
1345  return false;
1346}
1347#endif
1348
1349void
1350lazarus()
1351{
1352  TCR *tcr = get_tcr(false);
1353  if (tcr) {
1354    /* Some threads may be dying; no threads should be created. */
1355    LOCK(lisp_global(TCR_AREA_LOCK),tcr);
1356    tcr->vs_area->active = tcr->vs_area->high - node_size;
1357    tcr->save_vsp = (LispObj *)(tcr->vs_area->active);
1358    tcr->ts_area->active = tcr->ts_area->high;
1359    tcr->save_tsp = (LispObj *)(tcr->ts_area->active);
1360    tcr->catch_top = 0;
1361    tcr->db_link = 0;
1362    tcr->xframe = 0;
1363    start_lisp(tcr, 0);
1364  }
1365}
1366
1367#ifdef LINUX
1368#ifdef X8664
1369#include <asm/prctl.h>
1370#include <sys/prctl.h>
1371
1372void
1373ensure_gs_available(char *progname)
1374{
1375  LispObj fs_addr = 0L, gs_addr = 0L, cur_thread = (LispObj)pthread_self();
1376  char *gnu_get_libc_version(void);
1377 
1378  arch_prctl(ARCH_GET_GS, &gs_addr);
1379  arch_prctl(ARCH_GET_FS, &fs_addr);
1380  if ((gs_addr == cur_thread) && (fs_addr != cur_thread)) {
1381    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);
1382    _exit(1);
1383  }
1384}
1385#endif
1386#endif
1387
1388Boolean
1389bogus_fp_exceptions = false;
1390
1391typedef
1392float (*float_arg_returns_float)(float);
1393
1394float
1395fcallf(float_arg_returns_float fun, float arg)
1396{
1397  return fun(arg);
1398}
1399
1400void
1401check_bogus_fp_exceptions()
1402{
1403#ifdef X8664
1404  float asinf(float),result;
1405   
1406
1407  natural save_mxcsr = get_mxcsr(), post_mxcsr;
1408  set_mxcsr(0x1f80);
1409
1410  result = fcallf(asinf, 1.0);
1411  post_mxcsr = get_mxcsr();
1412  set_mxcsr(save_mxcsr);
1413  if (post_mxcsr & (FE_ALL_EXCEPT & (~FE_INEXACT))) {
1414    bogus_fp_exceptions = true;
1415  }
1416#endif
1417}
1418
1419
1420int
1421main(int argc, char *argv[]
1422#ifndef WINDOWS
1423, char *envp[], void *aux
1424#endif
1425)
1426{
1427  extern int page_size;
1428
1429#ifdef PPC
1430  extern int altivec_present;
1431#endif
1432  extern LispObj load_image(char *);
1433  area *a;
1434  BytePtr stack_base, current_sp = (BytePtr) current_stack_pointer();
1435  TCR *tcr;
1436
1437
1438#ifdef WINDOWS
1439  extern void init_winsock(void);
1440  extern void init_windows_io(void);
1441
1442  _fmode = O_BINARY;
1443  _setmode(1, O_BINARY);
1444  _setmode(2, O_BINARY);
1445  setvbuf(stderr, NULL, _IONBF, 0);
1446  init_winsock();
1447  init_windows_io();
1448#endif
1449
1450  check_os_version(argv[0]);
1451  real_executable_name = determine_executable_name(argv[0]);
1452  page_size = getpagesize(); /* Implement with GetSystemInfo on Windows w/o MinGW */
1453
1454  check_bogus_fp_exceptions();
1455#ifdef LINUX
1456#ifdef X8664
1457  ensure_gs_available(real_executable_name);
1458#endif
1459#endif
1460#if (defined(DARWIN) && defined(PPC64)) || defined(X8664) || (defined(X8632) && !defined(DARWIN))
1461  remap_spjump();
1462#endif
1463
1464#ifdef PPC
1465#ifdef LINUX
1466  {
1467    ElfW(auxv_t) *av = aux;
1468    int hwcap, done = false;
1469   
1470    if (av) {
1471      do {
1472        switch (av->a_type) {
1473        case AT_DCACHEBSIZE:
1474          cache_block_size = av->a_un.a_val;
1475          break;
1476
1477        case AT_HWCAP:
1478          hwcap = av->a_un.a_val;
1479          altivec_present = ((hwcap & PPC_FEATURE_HAS_ALTIVEC) != 0);
1480          break;
1481
1482        case AT_NULL:
1483          done = true;
1484          break;
1485        }
1486        av++;
1487      } while (!done);
1488    }
1489  }
1490#endif
1491#ifdef DARWIN
1492  {
1493    unsigned value = 0;
1494    size_t len = sizeof(value);
1495    int mib[2];
1496   
1497    mib[0] = CTL_HW;
1498    mib[1] = HW_CACHELINE;
1499    if (sysctl(mib,2,&value,&len, NULL, 0) != -1) {
1500      if (len == sizeof(value)) {
1501        cache_block_size = value;
1502      }
1503    }
1504    mib[1] = HW_VECTORUNIT;
1505    value = 0;
1506    len = sizeof(value);
1507    if (sysctl(mib,2,&value,&len, NULL, 0) != -1) {
1508      if (len == sizeof(value)) {
1509        altivec_present = value;
1510      }
1511    }
1512  }
1513#endif
1514#endif
1515
1516#ifdef X86
1517  if (!check_x86_cpu()) {
1518    fprintf(stderr, "CPU doesn't support required features\n");
1519    exit(1);
1520  }
1521#endif
1522
1523#ifndef WINDOWS
1524  main_thread_pid = getpid();
1525#endif
1526  tcr_area_lock = (void *)new_recursive_lock();
1527
1528  program_name = argv[0];
1529  if ((argc == 2) && (*argv[1] != '-')) {
1530    image_name = argv[1];
1531    argv[1] = NULL;
1532  } else {
1533    process_options(argc,argv);
1534  }
1535  initial_stack_size = ensure_stack_limit(initial_stack_size);
1536  if (image_name == NULL) {
1537    if (check_for_embedded_image(real_executable_name)) {
1538      image_name = real_executable_name;
1539    } else {
1540      image_name = default_image_name(real_executable_name);
1541    }
1542  }
1543
1544
1545  if (!create_reserved_area(reserved_area_size)) {
1546    exit(-1);
1547  }
1548  gc_init();
1549
1550  set_nil(load_image(image_name));
1551  lisp_global(TCR_AREA_LOCK) = ptr_to_lispobj(tcr_area_lock);
1552
1553#ifdef X86
1554  lisp_global(SUBPRIMS_BASE) = (LispObj)((1<<16)+(5<<10));
1555#else
1556  lisp_global(SUBPRIMS_BASE) = (LispObj)(5<<10);
1557#endif
1558  lisp_global(RET1VALN) = (LispObj)&ret1valn;
1559  lisp_global(LEXPR_RETURN) = (LispObj)&nvalret;
1560  lisp_global(LEXPR_RETURN1V) = (LispObj)&popj;
1561  lisp_global(ALL_AREAS) = ptr_to_lispobj(all_areas);
1562#ifdef X86
1563  lisp_global(BAD_FUNCALL) = ptr_to_lispobj(&bad_funcall);
1564#endif
1565  lisp_global(DEFAULT_ALLOCATION_QUANTUM) = log2_heap_segment_size << fixnumshift;
1566  lisp_global(STACK_SIZE) = thread_stack_size<<fixnumshift;
1567
1568
1569  exception_init();
1570
1571 
1572
1573  lisp_global(IMAGE_NAME) = ptr_to_lispobj(image_name);
1574  lisp_global(ARGV) = ptr_to_lispobj(argv);
1575  lisp_global(KERNEL_IMPORTS) = (LispObj)import_ptrs_base;
1576
1577  lisp_global(GET_TCR) = (LispObj) get_tcr;
1578  *(double *) &(lisp_global(DOUBLE_FLOAT_ONE)) = (double) 1.0;
1579
1580  lisp_global(HOST_PLATFORM) = (LispObj) PLATFORM << fixnumshift;
1581
1582  lisp_global(BATCH_FLAG) = (batch_flag << fixnumshift);
1583
1584  a = active_dynamic_area;
1585
1586  if (nilreg_area != NULL) {
1587    BytePtr lowptr = (BytePtr) a->low;
1588
1589    /* Create these areas as AREA_STATIC, change them to AREA_DYNAMIC */
1590    g1_area = new_area(lowptr, lowptr, AREA_STATIC);
1591    g2_area = new_area(lowptr, lowptr, AREA_STATIC);
1592    tenured_area = new_area(lowptr, lowptr, AREA_STATIC);
1593    add_area_holding_area_lock(tenured_area);
1594    add_area_holding_area_lock(g2_area);
1595    add_area_holding_area_lock(g1_area);
1596
1597    g1_area->code = AREA_DYNAMIC;
1598    g2_area->code = AREA_DYNAMIC;
1599    tenured_area->code = AREA_DYNAMIC;
1600
1601/*    a->older = g1_area; */ /* Not yet: this is what "enabling the EGC" does. */
1602    g1_area->younger = a;
1603    g1_area->older = g2_area;
1604    g2_area->younger = g1_area;
1605    g2_area->older = tenured_area;
1606    tenured_area->younger = g2_area;
1607    tenured_area->refbits = a->markbits;
1608    tenured_area->static_dnodes = a->static_dnodes;
1609    a->static_dnodes = 0;
1610    tenured_area->static_used = a->static_used;
1611    a->static_used = 0;
1612    lisp_global(TENURED_AREA) = ptr_to_lispobj(tenured_area);
1613    lisp_global(REFBITS) = ptr_to_lispobj(tenured_area->refbits);
1614    g2_area->threshold = G2_AREA_THRESHOLD;
1615    g1_area->threshold = G1_AREA_THRESHOLD;
1616    a->threshold = G0_AREA_THRESHOLD;
1617  }
1618
1619  tcr = new_tcr(initial_stack_size, MIN_TSTACK_SIZE);
1620  stack_base = initial_stack_bottom()-xStackSpace();
1621  init_threads((void *)(stack_base), tcr);
1622  thread_init_tcr(tcr, current_sp, current_sp-stack_base);
1623
1624  lisp_global(EXCEPTION_LOCK) = ptr_to_lispobj(new_recursive_lock());
1625  enable_fp_exceptions();
1626  register_sigint_handler();
1627
1628#ifdef PPC
1629  lisp_global(ALTIVEC_PRESENT) = altivec_present << fixnumshift;
1630#endif
1631#if STATIC
1632  lisp_global(STATICALLY_LINKED) = 1 << fixnumshift;
1633#endif
1634  tcr->prev = tcr->next = tcr;
1635#ifndef WINDOWS
1636  lisp_global(INTERRUPT_SIGNAL) = (LispObj) box_fixnum(SIGNAL_FOR_PROCESS_INTERRUPT);
1637#endif
1638  tcr->vs_area->active -= node_size;
1639  *(--tcr->save_vsp) = nrs_TOPLFUNC.vcell;
1640  nrs_TOPLFUNC.vcell = lisp_nil;
1641#ifdef GC_INTEGRITY_CHECKING
1642  (nrs_GC_EVENT_STATUS_BITS.vcell |= gc_integrity_check_bit);
1643#endif
1644#ifndef DISABLE_EGC
1645  egc_control(true, NULL);
1646#endif
1647  atexit(lazarus);
1648  start_lisp(TCR_TO_TSD(tcr), 0);
1649  _exit(0);
1650}
1651
1652area *
1653set_nil(LispObj r)
1654{
1655
1656  if (lisp_nil == (LispObj)NULL) {
1657
1658    lisp_nil = r;
1659  }
1660  return NULL;
1661}
1662
1663
1664void
1665xMakeDataExecutable(void *start, unsigned long nbytes)
1666{
1667  extern void flush_cache_lines();
1668  natural ustart = (natural) start, base, end;
1669 
1670  base = (ustart) & ~(cache_block_size-1);
1671  end = (ustart + nbytes + cache_block_size - 1) & ~(cache_block_size-1);
1672#ifdef DARWIN
1673  if (running_under_rosetta) {
1674    /* We probably need to flush something's cache even if running
1675       under Rosetta, but (a) this is agonizingly slow and (b) we're
1676       dying before we get to the point where this would matter.
1677    */
1678    return;
1679  }
1680#endif
1681#ifndef X86
1682  flush_cache_lines(base, (end-base)/cache_block_size, cache_block_size);
1683#endif
1684}
1685
1686natural
1687xStackSpace()
1688{
1689  return initial_stack_size+CSTACK_HARDPROT+CSTACK_SOFTPROT;
1690}
1691
1692#ifndef DARWIN
1693#ifdef WINDOWS
1694extern void *windows_open_shared_library(char *);
1695
1696void *
1697xGetSharedLibrary(char *path, int mode)
1698{
1699  return windows_open_shared_library(path);
1700}
1701#else
1702void *
1703xGetSharedLibrary(char *path, int mode)
1704{
1705  return dlopen(path, mode);
1706}
1707#endif
1708#else
1709void *
1710xGetSharedLibrary(char *path, int *resultType)
1711{
1712#if defined(PPC) && (WORD_SIZE == 32)
1713  NSObjectFileImageReturnCode code;
1714  NSObjectFileImage              moduleImage;
1715  NSModule                       module;
1716  const struct mach_header *     header;
1717  const char *                   error;
1718  void *                         result;
1719  /* not thread safe */
1720  /*
1721  static struct {
1722    const struct mach_header  *header;
1723    NSModule                  *module;
1724    const char                *error;
1725  } results;   
1726  */
1727  result = NULL;
1728  error = NULL;
1729
1730  /* first try to open this as a bundle */
1731  code = NSCreateObjectFileImageFromFile(path,&moduleImage);
1732  if (code != NSObjectFileImageSuccess &&
1733      code != NSObjectFileImageInappropriateFile &&
1734      code != NSObjectFileImageAccess)
1735    {
1736      /* compute error strings */
1737      switch (code)
1738        {
1739        case NSObjectFileImageFailure:
1740          error = "NSObjectFileImageFailure";
1741          break;
1742        case NSObjectFileImageArch:
1743          error = "NSObjectFileImageArch";
1744          break;
1745        case NSObjectFileImageFormat:
1746          error = "NSObjectFileImageFormat";
1747          break;
1748        case NSObjectFileImageAccess:
1749          /* can't find the file */
1750          error = "NSObjectFileImageAccess";
1751          break;
1752        default:
1753          error = "unknown error";
1754        }
1755      *resultType = 0;
1756      return (void *)error;
1757    }
1758  if (code == NSObjectFileImageInappropriateFile ||
1759      code == NSObjectFileImageAccess ) {
1760    /* the pathname might be a partial pathane (hence the access error)
1761       or it might be something other than a bundle, if so perhaps
1762       it is a .dylib so now try to open it as a .dylib */
1763
1764    /* protect against redundant loads, Gary Byers noticed possible
1765       heap corruption if this isn't done */
1766    header = NSAddImage(path, NSADDIMAGE_OPTION_RETURN_ON_ERROR |
1767                        NSADDIMAGE_OPTION_WITH_SEARCHING |
1768                        NSADDIMAGE_OPTION_RETURN_ONLY_IF_LOADED);
1769    if (!header)
1770      header = NSAddImage(path, NSADDIMAGE_OPTION_RETURN_ON_ERROR |
1771                          NSADDIMAGE_OPTION_WITH_SEARCHING);
1772    result = (void *)header;
1773    *resultType = 1;
1774  }
1775  else if (code == NSObjectFileImageSuccess) {
1776    /* we have a sucessful module image
1777       try to link it, don't bind symbols privately */
1778
1779    module = NSLinkModule(moduleImage, path,
1780                          NSLINKMODULE_OPTION_RETURN_ON_ERROR | NSLINKMODULE_OPTION_BINDNOW);
1781    NSDestroyObjectFileImage(moduleImage);     
1782    result = (void *)module;
1783    *resultType = 2;
1784  }
1785  if (!result)
1786    {
1787      /* compute error string */
1788      NSLinkEditErrors ler;
1789      int lerno;
1790      const char* file;
1791      NSLinkEditError(&ler,&lerno,&file,&error);
1792      if (error) {
1793        result = (void *)error;
1794        *resultType = 0;
1795      }
1796    }
1797  return result;
1798#else
1799  const char *                   error;
1800  void *                         result;
1801
1802  result = dlopen(path, RTLD_NOW | RTLD_GLOBAL);
1803 
1804  if (result == NULL) {
1805    error = dlerror();
1806    *resultType = 0;
1807    return (void *)error;
1808  }
1809  *resultType = 1;
1810  return result;
1811#endif
1812}
1813#endif
1814
1815
1816
1817int
1818fd_setsize_bytes()
1819{
1820  return FD_SETSIZE/8;
1821}
1822
1823void
1824do_fd_set(int fd, fd_set *fdsetp)
1825{
1826  FD_SET(fd, fdsetp);
1827}
1828
1829void
1830do_fd_clr(int fd, fd_set *fdsetp)
1831{
1832  FD_CLR(fd, fdsetp);
1833}
1834
1835int
1836do_fd_is_set(int fd, fd_set *fdsetp)
1837{
1838  return FD_ISSET(fd,fdsetp);
1839}
1840
1841
1842void
1843do_fd_zero(fd_set *fdsetp)
1844{
1845  FD_ZERO(fdsetp);
1846}
1847
1848#include "image.h"
1849
1850
1851
1852Boolean
1853check_for_embedded_image (char *path)
1854{
1855  int fd = open(path, O_RDONLY);
1856  Boolean image_is_embedded = false;
1857
1858  if (fd >= 0) {
1859    openmcl_image_file_header h;
1860
1861    if (find_openmcl_image_file_header (fd, &h)) {
1862      image_is_embedded = true;
1863    }
1864    close (fd);
1865  }
1866  return image_is_embedded;
1867}
1868
1869LispObj
1870load_image(char *path)
1871{
1872  int fd = open(path, O_RDONLY, 0666);
1873  LispObj image_nil = 0;
1874  if (fd > 0) {
1875    openmcl_image_file_header ih;
1876    image_nil = load_openmcl_image(fd, &ih);
1877    /* We -were- using a duplicate fd to map the file; that
1878       seems to confuse Darwin (doesn't everything ?), so
1879       we'll instead keep the original file open.
1880    */
1881    if (!image_nil) {
1882      close(fd);
1883    }
1884  }
1885  if (image_nil == 0) {
1886    fprintf(stderr, "Couldn't load lisp heap image from %s:\n%s\n", path, strerror(errno));
1887    exit(-1);
1888  }
1889  return image_nil;
1890}
1891
1892int
1893set_errno(int val)
1894{
1895  errno = val;
1896  return -1;
1897}
1898
1899
1900
1901
1902void *
1903xFindSymbol(void* handle, char *name)
1904{
1905#if defined(LINUX) || defined(FREEBSD) || defined(SOLARIS)
1906  return dlsym(handle, name);
1907#endif
1908#ifdef DARWIN
1909#if defined(PPC64) || defined(X86)
1910  if ((handle == NULL) || (handle == ((void *) -1))) {
1911    handle = RTLD_DEFAULT;
1912  }   
1913  if (*name == '_') {
1914    name++;
1915  }
1916  return dlsym(handle, name);
1917#else
1918  natural address = 0;
1919
1920  if ((handle == NULL) ||
1921      (handle == (void *)-1) ||
1922      (handle == (void *)-2)){
1923    if (NSIsSymbolNameDefined(name)) { /* Keep dyld_lookup from crashing */
1924      _dyld_lookup_and_bind(name, (void *) &address, (void*) NULL);
1925    }
1926    return (void *)address;
1927  }
1928  Bug(NULL, "How did this happen ?");
1929#endif
1930#endif
1931#ifdef WINDOWS
1932  extern void *windows_find_symbol(void *, char *);
1933  return windows_find_symbol(handle, name);
1934#endif
1935}
1936
1937void *
1938get_r_debug()
1939{
1940#if defined(LINUX) || defined(FREEBSD) || defined(SOLARIS)
1941#if WORD_SIZE == 64
1942  extern Elf64_Dyn _DYNAMIC[];
1943  Elf64_Dyn *dp;
1944#else
1945  extern Elf32_Dyn _DYNAMIC[];
1946  Elf32_Dyn *dp;
1947#endif
1948  int tag;
1949
1950  for (dp = _DYNAMIC; (tag = dp->d_tag) != 0; dp++) {
1951    if (tag == DT_DEBUG) {
1952      return (void *)(dp->d_un.d_ptr);
1953    }
1954  }
1955#endif
1956  return NULL;
1957}
1958
1959
1960#ifdef DARWIN
1961void
1962sample_paging_info(paging_info *stats)
1963{
1964  mach_msg_type_number_t count = TASK_EVENTS_INFO_COUNT;
1965
1966  task_info(mach_task_self(),
1967            TASK_EVENTS_INFO,
1968            (task_info_t)stats,
1969            &count);
1970}
1971
1972void
1973report_paging_info_delta(FILE *out, paging_info *start, paging_info *stop)
1974{
1975  fprintf(out,";;; %d soft faults, %d faults, %d pageins\n\n",
1976          stop->cow_faults-start->cow_faults,
1977          stop->faults-start->faults,
1978          stop->pageins-start->pageins);
1979}
1980
1981#else
1982#ifdef WINDOWS
1983void
1984sample_paging_info(paging_info *stats)
1985{
1986}
1987
1988void
1989report_paging_info_delta(FILE *out, paging_info *start, paging_info *stop)
1990{
1991}
1992#else
1993void
1994sample_paging_info(paging_info *stats)
1995{
1996  getrusage(RUSAGE_SELF, stats);
1997}
1998
1999void
2000report_paging_info_delta(FILE *out, paging_info *start, paging_info *stop)
2001{
2002  fprintf(out,";;; %ld soft faults, %ld faults, %ld pageins\n\n",
2003          stop->ru_minflt-start->ru_minflt,
2004          stop->ru_majflt-start->ru_majflt,
2005          stop->ru_nswap-start->ru_nswap);
2006}
2007
2008#endif
2009#endif
Note: See TracBrowser for help on using the repository browser.