source: branches/win64/lisp-kernel/pmcl-kernel.c @ 10039

Last change on this file since 10039 was 10039, checked in by gb, 13 years ago

natural stack sizes.

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