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

Last change on this file since 10565 was 10565, checked in by gb, 12 years ago

Merge changes from branches/win64.

As well as the expected low-level exception/suspend/interrupt stuff,
these changes also include changes to [f]printf format strings. Note
that on win64, a 'long' is 32-bits wide, which complicates matters:

  • an address (viewed as an integer) or a natural-sized integer isn't

(portably) a long, and so can't be printed with %l.

  • an address (viewed as an integer) or a natural-sized integer isn't

(portably) a long long, and so can't be printed with %ll.

  • an address (viewed as an integer) or a natural-sized integer can be

portably printed with '%p', but implementations differ as to whether
or not '%p' prepends a gratuitous '0x' to the hex address. (Linux
does, other current platforms seem not to.)

The approach that seems to work is to cast arguments to natural, then
to u64_t, then use %ll. That approach probably isn't taken consistently
(yet), so some debugging information printed by the kernel may be
incorrect.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 43.9 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#endif
409
410natural
411reserved_area_size = MAXIMUM_MAPPABLE_MEMORY;
412
413area
414  *nilreg_area=NULL,
415  *tenured_area=NULL, 
416  *g2_area=NULL, 
417  *g1_area=NULL,
418  *managed_static_area=NULL,
419  *readonly_area=NULL;
420
421area *all_areas=NULL;
422int cache_block_size=32;
423
424
425#if WORD_SIZE == 64
426#define DEFAULT_LISP_HEAP_GC_THRESHOLD (32<<20)
427#define G2_AREA_THRESHOLD (8<<20)
428#define G1_AREA_THRESHOLD (4<<20)
429#define G0_AREA_THRESHOLD (2<<20)
430#else
431#define DEFAULT_LISP_HEAP_GC_THRESHOLD (16<<20)
432#define G2_AREA_THRESHOLD (4<<20)
433#define G1_AREA_THRESHOLD (2<<20)
434#define G0_AREA_THRESHOLD (1<<20)
435#endif
436
437#if (WORD_SIZE == 32)
438#define DEFAULT_INITIAL_STACK_SIZE (1<<20)
439#else
440#define DEFAULT_INITIAL_STACK_SIZE (2<<20)
441#endif
442
443natural
444lisp_heap_gc_threshold = DEFAULT_LISP_HEAP_GC_THRESHOLD;
445
446natural
447initial_stack_size = DEFAULT_INITIAL_STACK_SIZE;
448
449natural
450thread_stack_size = 0;
451
452
453/*
454  'start' should be on a segment boundary; 'len' should be
455  an integral number of segments.  remap the entire range.
456*/
457
458void 
459uncommit_pages(void *start, size_t len)
460{
461  UnCommitMemory(start, len);
462}
463
464#define TOUCH_PAGES_ON_COMMIT 0
465
466Boolean
467touch_all_pages(void *start, size_t len)
468{
469#if TOUCH_PAGES_ON_COMMIT
470  extern Boolean touch_page(void *);
471  char *p = (char *)start;
472
473  while (len) {
474    if (!touch_page(p)) {
475      return false;
476    }
477    len -= page_size;
478    p += page_size;
479  }
480#endif
481  return true;
482}
483
484Boolean
485commit_pages(void *start, size_t len)
486{
487  if (len != 0) {
488    if (CommitMemory(start, len)) {
489      if (touch_all_pages(start, len)) {
490        return true;
491      }
492    }
493  }
494  return true;
495}
496
497area *
498find_readonly_area()
499{
500  area *a;
501
502  for (a = active_dynamic_area->succ; a != all_areas; a = a->succ) {
503    if (a->code == AREA_READONLY) {
504      return a;
505    }
506  }
507  return NULL;
508}
509
510area *
511extend_readonly_area(unsigned more)
512{
513  area *a;
514  unsigned mask;
515  BytePtr new_start, new_end;
516
517  if ((a = find_readonly_area()) != NULL) {
518    if ((a->active + more) > a->high) {
519      return NULL;
520    }
521    mask = ((natural)a->active) & (page_size-1);
522    if (mask) {
523      UnProtectMemory(a->active-mask, page_size);
524    }
525    new_start = (BytePtr)(align_to_power_of_2(a->active,log2_page_size));
526    new_end = (BytePtr)(align_to_power_of_2(a->active+more,log2_page_size));
527    if (!CommitMemory(new_start, new_end-new_start)) {
528      return NULL;
529    }
530    return a;
531  }
532  return NULL;
533}
534
535LispObj image_base=0;
536BytePtr pure_space_start, pure_space_active, pure_space_limit;
537BytePtr static_space_start, static_space_active, static_space_limit;
538
539void
540raise_limit()
541{
542#ifdef RLIMIT_AS
543  struct rlimit r;
544  if (getrlimit(RLIMIT_AS, &r) == 0) {
545    r.rlim_cur = r.rlim_max;
546    setrlimit(RLIMIT_AS, &r);
547    /* Could limit heaplimit to rlim_max here if smaller? */
548  }
549#endif
550} 
551
552
553area *
554create_reserved_area(natural totalsize)
555{
556  Ptr h;
557  natural base;
558  BytePtr
559    end, 
560    lastbyte, 
561    start, 
562    want = (BytePtr)IMAGE_BASE_ADDRESS;
563  area *reserved;
564
565  totalsize = align_to_power_of_2((void *)totalsize, log2_heap_segment_size);
566
567  start = ReserveMemoryForHeap(want, totalsize);
568
569  h = (Ptr) start;
570  base = (natural) start;
571  image_base = base;
572  lastbyte = (BytePtr) (start+totalsize);
573  static_space_start = static_space_active = (BytePtr)STATIC_BASE_ADDRESS;
574  static_space_limit = static_space_start + STATIC_RESERVE;
575  pure_space_start = pure_space_active = start;
576  pure_space_limit = start + PURESPACE_RESERVE;
577  start = pure_space_limit;
578
579  /*
580    Allocate mark bits here.  They need to be 1/64 the size of the
581     maximum useable area of the heap (+ 3 words for the EGC.)
582  */
583  end = lastbyte;
584  end = (BytePtr) ((natural)((((natural)end) - ((totalsize+63)>>6)) & ~4095));
585
586  global_mark_ref_bits = (bitvector)end;
587  end = (BytePtr) ((natural)((((natural)end) - ((totalsize+63) >> 6)) & ~4095));
588  global_reloctab = (LispObj *) end;
589  reserved = new_area(start, end, AREA_VOID);
590  /* The root of all evil is initially linked to itself. */
591  reserved->pred = reserved->succ = reserved;
592  all_areas = reserved;
593  reserved->markbits = global_mark_ref_bits;
594  return reserved;
595}
596
597void *
598allocate_from_reserved_area(natural size)
599{
600  area *reserved = reserved_area;
601  BytePtr low = reserved->low, high = reserved->high;
602  natural avail = high-low;
603 
604  size = align_to_power_of_2(size, log2_heap_segment_size);
605
606  if (size > avail) {
607    return NULL;
608  }
609  reserved->low += size;
610  reserved->active = reserved->low;
611  reserved->ndnodes -= (size>>dnode_shift);
612  return low;
613}
614
615
616
617BytePtr reloctab_limit = NULL, markbits_limit = NULL;
618
619void
620ensure_gc_structures_writable()
621{
622  natural
623    ndnodes = area_dnode(lisp_global(HEAP_END),lisp_global(HEAP_START)),
624    markbits_size = (3*sizeof(LispObj))+((ndnodes+7)>>3),
625    reloctab_size = (sizeof(LispObj)*(((ndnodes+((1<<bitmap_shift)-1))>>bitmap_shift)+1));
626  BytePtr
627    new_reloctab_limit = ((BytePtr)global_reloctab)+reloctab_size,
628    new_markbits_limit = ((BytePtr)global_mark_ref_bits)+markbits_size;
629
630  if (new_reloctab_limit > reloctab_limit) {
631    CommitMemory(global_reloctab, reloctab_size);
632    UnProtectMemory(global_reloctab, reloctab_size);
633    reloctab_limit = new_reloctab_limit;
634  }
635 
636  if (new_markbits_limit > markbits_limit) {
637    CommitMemory(global_mark_ref_bits, markbits_size);
638    UnProtectMemory(global_mark_ref_bits, markbits_size);
639    markbits_limit = new_markbits_limit;
640  }
641}
642
643
644area *
645allocate_dynamic_area(natural initsize)
646{
647  natural totalsize = align_to_power_of_2(initsize, log2_heap_segment_size);
648  BytePtr start, end;
649  area *a;
650
651  start = allocate_from_reserved_area(totalsize);
652  if (start == NULL) {
653    return NULL;
654  }
655  end = start + totalsize;
656  a = new_area(start, end, AREA_DYNAMIC);
657  a->active = start+initsize;
658  add_area_holding_area_lock(a);
659  a->markbits = reserved_area->markbits;
660  reserved_area->markbits = NULL;
661  CommitMemory(start, end-start);
662  a->h = start;
663  a->softprot = NULL;
664  a->hardprot = NULL;
665  lisp_global(HEAP_START) = ptr_to_lispobj(a->low);
666  lisp_global(HEAP_END) = ptr_to_lispobj(a->high);
667  ensure_gc_structures_writable();
668  return a;
669 }
670
671
672Boolean
673grow_dynamic_area(natural delta)
674{
675  area *a = active_dynamic_area, *reserved = reserved_area;
676  natural avail = reserved->high - reserved->low;
677 
678  delta = align_to_power_of_2(delta, log2_heap_segment_size);
679  if (delta > avail) {
680    return false;
681  }
682
683  if (!commit_pages(a->high,delta)) {
684    return false;
685  }
686
687
688  if (!allocate_from_reserved_area(delta)) {
689    return false;
690  }
691
692
693  a->high += delta;
694  a->ndnodes = area_dnode(a->high, a->low);
695  lisp_global(HEAP_END) += delta;
696  ensure_gc_structures_writable();
697  return true;
698}
699
700/*
701  As above.  Pages that're returned to the reserved_area are
702  "condemned" (e.g, we try to convince the OS that they never
703  existed ...)
704*/
705Boolean
706shrink_dynamic_area(natural delta)
707{
708  area *a = active_dynamic_area, *reserved = reserved_area;
709 
710  delta = align_to_power_of_2(delta, log2_heap_segment_size);
711
712  a->high -= delta;
713  a->ndnodes = area_dnode(a->high, a->low);
714  a->hardlimit = a->high;
715  uncommit_pages(a->high, delta);
716  reserved->low -= delta;
717  reserved->ndnodes += (delta>>dnode_shift);
718  lisp_global(HEAP_END) -= delta;
719  return true;
720}
721
722
723
724void
725sigint_handler (int signum, siginfo_t *info, ExceptionInformation *context)
726{
727  if (signum == SIGINT) {
728    lisp_global(INTFLAG) = (1 << fixnumshift);
729  }
730#ifdef DARWIN
731  DarwinSigReturn(context);
732#endif
733}
734
735
736void
737register_sigint_handler()
738{
739#ifdef WINDOWS
740  extern BOOL ControlEventHandler(DWORD);
741
742  signal(SIGINT, SIG_IGN);
743
744  SetConsoleCtrlHandler(ControlEventHandler,TRUE);
745#else
746  install_signal_handler(SIGINT, (void *)sigint_handler);
747#endif
748}
749
750
751
752BytePtr
753initial_stack_bottom()
754{
755#ifndef WINDOWS
756  extern char **environ;
757  char *p = *environ;
758  while (*p) {
759    p += (1+strlen(p));
760  }
761  return (BytePtr)((((natural) p) +4095) & ~4095);
762#endif
763#ifdef WINDOWS
764  return (BytePtr)((current_stack_pointer() + 4095) & ~ 4095);
765#endif
766}
767
768
769 
770Ptr fatal_spare_ptr = NULL;
771
772
773void
774Fatal(StringPtr param0, StringPtr param1)
775{
776
777  if (fatal_spare_ptr) {
778    deallocate(fatal_spare_ptr);
779    fatal_spare_ptr = NULL;
780  }
781  fprintf(stderr, "Fatal error: %s\n%s\n", param0, param1);
782  _exit(-1);
783}
784
785OSErr application_load_err = noErr;
786
787area *
788set_nil(LispObj);
789
790
791#if defined(DARWIN) || defined(WINDOWS)
792#ifdef WINDOWS
793/* Chop the trailing ".exe" from the kernel image name */
794char *
795chop_exe_suffix(char *path)
796{
797  int len = strlen(path);
798  char *copy = malloc(len+1), *tail;
799
800  strcpy(copy,path);
801  tail = strrchr(copy, '.');
802  if (tail) {
803    *tail = 0;
804  }
805  return copy;
806}
807#endif
808
809/*
810   The underlying file system may be case-insensitive (e.g., HFS),
811   so we can't just case-invert the kernel's name.
812   Tack ".image" onto the end of the kernel's name.  Much better ...
813*/
814char *
815default_image_name(char *orig)
816{
817#ifdef WINDOWS
818  char *path = chop_exe_suffix(orig);
819#else
820  char *path = orig;
821#endif
822  int len = strlen(path) + strlen(".image") + 1;
823  char *copy = (char *) malloc(len);
824
825  if (copy) {
826    strcpy(copy, path);
827    strcat(copy, ".image");
828  }
829  return copy;
830}
831
832#else
833char *
834default_image_name(char *orig)
835{
836  char *copy = strdup(orig), *base = copy, *work = copy, c;
837  if (copy == NULL) {
838    return NULL;
839  }
840  while(*work) {
841    if (*work++ == '/') {
842      base = work;
843    }
844  }
845  work = base;
846  while ((c = *work) != '\0') {
847    if (islower(c)) {
848      *work++ = toupper(c);
849    } else {
850      *work++ = tolower(c);
851    }
852  }
853  return copy;
854}
855#endif
856
857
858char *program_name = NULL;
859char *real_executable_name = NULL;
860
861char *
862determine_executable_name(char *argv0)
863{
864#ifdef DARWIN
865  uint32_t len = 1024;
866  char exepath[1024], *p = NULL;
867
868  if (_NSGetExecutablePath(exepath, (void *)&len) == 0) {
869    p = malloc(len+1);
870    memmove(p, exepath, len);
871    p[len]=0;
872    return p;
873  } 
874  return argv0;
875#endif
876#ifdef LINUX
877  char exepath[PATH_MAX], *p;
878  int n;
879
880  if ((n = readlink("/proc/self/exe", exepath, PATH_MAX)) > 0) {
881    p = malloc(n+1);
882    memmove(p,exepath,n);
883    p[n]=0;
884    return p;
885  }
886  return argv0;
887#endif
888#ifdef FREEBSD
889  return argv0;
890#endif
891#ifdef SOLARIS
892  char exepath[PATH_MAX], proc_path[PATH_MAX], *p;
893  int n;
894
895  snprintf(proc_path,PATH_MAX-1,"/proc/%d/path/a.out",getpid());
896
897  if ((n = readlink(proc_path, exepath, PATH_MAX)) > 0) {
898    p = malloc(n+1);
899    memmove(p,exepath,n);
900    p[n]=0;
901    return p;
902  }
903  return argv0;
904#endif
905#ifdef WINDOWS
906  char path[PATH_MAX], *p;
907  int len = GetModuleFileName(NULL, path, PATH_MAX);
908  if (len > 0) {
909    p = malloc(len + 1);
910    memmove(p, path, len);
911    p[len] = 0;
912    return p;
913  }
914  return argv0;
915#endif
916}
917
918void
919usage_exit(char *herald, int exit_status, char* other_args)
920{
921  if (herald && *herald) {
922    fprintf(stderr, "%s\n", herald);
923  }
924  fprintf(stderr, "usage: %s <options>\n", program_name);
925  fprintf(stderr, "\t or %s <image-name>\n", program_name);
926  fprintf(stderr, "\t where <options> are one or more of:\n");
927  if (other_args && *other_args) {
928    fputs(other_args, stderr);
929  }
930  fprintf(stderr, "\t-R, --heap-reserve <n>: reserve <n> (default: %lld)\n",
931          (u64_t) reserved_area_size);
932  fprintf(stderr, "\t\t bytes for heap expansion\n");
933  fprintf(stderr, "\t-S, --stack-size <n>: set  size of initial thread's control stack to <n>\n");
934  fprintf(stderr, "\t-Z, --thread-stack-size <n>: set default size of first (listener)  thread's stacks based on <n>\n");
935  fprintf(stderr, "\t-b, --batch: exit when EOF on *STANDARD-INPUT*\n");
936  fprintf(stderr, "\t--no-sigtrap : obscure option for running under GDB\n");
937  fprintf(stderr, "\t-I, --image-name <image-name>\n");
938  fprintf(stderr, "\t and <image-name> defaults to %s\n", 
939          default_image_name(program_name));
940  fprintf(stderr, "\n");
941  _exit(exit_status);
942}
943
944int no_sigtrap = 0;
945char *image_name = NULL;
946int batch_flag = 0;
947
948
949natural
950parse_numeric_option(char *arg, char *argname, natural default_val)
951{
952  char *tail;
953  natural val = 0;
954
955  val = strtoul(arg, &tail, 0);
956  switch(*tail) {
957  case '\0':
958    break;
959   
960  case 'M':
961  case 'm':
962    val = val << 20;
963    break;
964   
965  case 'K':
966  case 'k':
967    val = val << 10;
968    break;
969   
970  case 'G':
971  case 'g':
972    val = val << 30;
973    break;
974   
975  default:
976    fprintf(stderr, "couldn't parse %s argument %s", argname, arg);
977    val = default_val;
978    break;
979  }
980  return val;
981}
982 
983
984
985/*
986   The set of arguments recognized by the kernel is
987   likely to remain pretty small and pretty simple.
988   This removes everything it recognizes from argv;
989   remaining args will be processed by lisp code.
990*/
991
992void
993process_options(int argc, char *argv[])
994{
995  int i, j, k, num_elide, flag, arg_error;
996  char *arg, *val;
997#ifdef DARWIN
998  extern int NXArgc;
999#endif
1000
1001  for (i = 1; i < argc;) {
1002    arg = argv[i];
1003    arg_error = 0;
1004    if (*arg != '-') {
1005      i++;
1006    } else {
1007      num_elide = 0;
1008      val = NULL;
1009      if ((flag = (strncmp(arg, "-I", 2) == 0)) ||
1010          (strcmp (arg, "--image-name") == 0)) {
1011        if (flag && arg[2]) {
1012          val = arg+2;
1013          num_elide = 1;
1014        } else {
1015          if ((i+1) < argc) {
1016            val = argv[i+1];
1017            num_elide = 2;
1018          } else {
1019            arg_error = 1;
1020          }
1021        }
1022        if (val) {
1023          image_name = val;
1024        }
1025      } else if ((flag = (strncmp(arg, "-R", 2) == 0)) ||
1026                 (strcmp(arg, "--heap-reserve") == 0)) {
1027        natural reserved_size = reserved_area_size;
1028
1029        if (flag && arg[2]) {
1030          val = arg+2;
1031          num_elide = 1;
1032        } else {
1033          if ((i+1) < argc) {
1034            val = argv[i+1];
1035            num_elide = 2;
1036          } else {
1037            arg_error = 1;
1038          }
1039        }
1040
1041        if (val) {
1042          reserved_size = parse_numeric_option(val, 
1043                                               "-R/--heap-reserve", 
1044                                               reserved_area_size);
1045        }
1046
1047        if (reserved_size <= MAXIMUM_MAPPABLE_MEMORY) {
1048          reserved_area_size = reserved_size;
1049        }
1050
1051      } else if ((flag = (strncmp(arg, "-S", 2) == 0)) ||
1052                 (strcmp(arg, "--stack-size") == 0)) {
1053        natural stack_size;
1054
1055        if (flag && arg[2]) {
1056          val = arg+2;
1057          num_elide = 1;
1058        } else {
1059          if ((i+1) < argc) {
1060            val = argv[i+1];
1061            num_elide = 2;
1062          } else {
1063            arg_error = 1;
1064          }
1065        }
1066
1067        if (val) {
1068          stack_size = parse_numeric_option(val, 
1069                                            "-S/--stack-size", 
1070                                            initial_stack_size);
1071         
1072
1073          if (stack_size >= MIN_CSTACK_SIZE) {
1074            initial_stack_size = stack_size;
1075          }
1076        }
1077
1078      } else if ((flag = (strncmp(arg, "-Z", 2) == 0)) ||
1079                 (strcmp(arg, "--thread-stack-size") == 0)) {
1080        natural stack_size;
1081
1082        if (flag && arg[2]) {
1083          val = arg+2;
1084          num_elide = 1;
1085        } else {
1086          if ((i+1) < argc) {
1087            val = argv[i+1];
1088            num_elide = 2;
1089          } else {
1090            arg_error = 1;
1091          }
1092        }
1093
1094        if (val) {
1095          stack_size = parse_numeric_option(val, 
1096                                            "-Z/--thread-stack-size", 
1097                                            thread_stack_size);
1098         
1099
1100          if (stack_size >= MIN_CSTACK_SIZE) {
1101           thread_stack_size = stack_size;
1102          }
1103          if (thread_stack_size >= (1LL<<((WORD_SIZE-fixnumshift)-1))) {
1104            thread_stack_size = (1LL<<((WORD_SIZE-fixnumshift)-1))-1;
1105          }
1106         
1107        }
1108
1109      } else if (strcmp(arg, "--no-sigtrap") == 0) {
1110        no_sigtrap = 1;
1111        num_elide = 1;
1112      } else if ((strcmp(arg, "-b") == 0) ||
1113                 (strcmp(arg, "--batch") == 0)) {
1114        batch_flag = 1;
1115        num_elide = 1;
1116      } else if (strcmp(arg,"--") == 0) {
1117        break;
1118      } else {
1119        i++;
1120      }
1121      if (arg_error) {
1122        usage_exit("error in program arguments", 1, "");
1123      }
1124      if (num_elide) {
1125        for (j = i+num_elide, k=i; j < argc; j++, k++) {
1126          argv[k] = argv[j];
1127        }
1128        argc -= num_elide;
1129#ifdef DARWIN
1130        NXArgc -= num_elide;
1131#endif
1132        argv[argc] = NULL;
1133      }
1134    }
1135  }
1136}
1137
1138#ifdef WINDOWS
1139void
1140terminate_lisp()
1141{
1142  ExitProcess(EXIT_FAILURE);
1143}
1144#else
1145pid_t main_thread_pid = (pid_t)0;
1146
1147void
1148terminate_lisp()
1149{
1150  kill(main_thread_pid, SIGKILL);
1151  _exit(-1);
1152}
1153#endif
1154
1155#ifdef DARWIN
1156#ifdef PPC64
1157#define min_os_version "8.0"    /* aka Tiger */
1158#else
1159#define min_os_version "7.0"    /* aka Panther */
1160#endif
1161#endif
1162#ifdef LINUX
1163#ifdef PPC
1164#define min_os_version "2.2"
1165#endif
1166#ifdef X86
1167#define min_os_version "2.6"
1168#endif
1169#endif
1170#ifdef FREEBSD
1171#define min_os_version "6.0"
1172#endif
1173#ifdef SOLARIS
1174#define min_os_version "5.10"
1175#endif
1176
1177#ifdef DARWIN
1178#ifdef PPC64
1179/* ld64 on Darwin doesn't offer anything close to reliable control
1180   over the layout of a program in memory.  About all that we can
1181   be assured of is that the canonical subprims jump table address
1182   (currently 0x5000) is unmapped.  Map that page, and copy the
1183   actual spjump table there. */
1184
1185
1186void
1187remap_spjump()
1188{
1189  extern opcode spjump_start, spjump_end;
1190  pc new,
1191    old = &spjump_start,
1192    limit = &spjump_end,
1193    work;
1194  opcode instr;
1195  void *target;
1196  int disp;
1197 
1198  if (old != (pc)0x5000) {
1199    new = mmap((pc) 0x5000,
1200               0x1000,
1201               PROT_READ | PROT_WRITE | PROT_EXEC,
1202               MAP_PRIVATE | MAP_ANON | MAP_FIXED,
1203               -1,
1204               0);
1205    if (new != (pc) 0x5000) {
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 X8664
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 (!VirtualProtect((pc) 0x15000,
1237                      0x1000,
1238                      PAGE_EXECUTE_READ,
1239                      &old_protect)) {
1240    wperror("VirtualProtect spjump");
1241    _exit(1);
1242  }
1243  memmove((pc) 0x15000, &spjump_start, 0x1000);
1244}
1245#else
1246void
1247remap_spjump()
1248{
1249  extern opcode spjump_start;
1250  pc new = mmap((pc) 0x15000,
1251                0x1000,
1252                PROT_READ | PROT_WRITE | PROT_EXEC,
1253                MAP_PRIVATE | MAP_ANON | MAP_FIXED,
1254                -1,
1255                0),
1256    old = &spjump_start;
1257  if (new == (pc)-1) {
1258    perror("remap spjump");
1259    _exit(1);
1260  }
1261  memmove(new, old, 0x1000);
1262}
1263#endif
1264#endif
1265
1266
1267void
1268check_os_version(char *progname)
1269{
1270#ifdef WINDOWS
1271  /* 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. */
1272#else
1273  struct utsname uts;
1274  long got, want;
1275  char *got_end,*want_end;
1276  want = strtoul(min_os_version,&want_end,10);
1277
1278  uname(&uts);
1279  got = strtoul(uts.release,&got_end,10);
1280
1281  while (got == want) {
1282    if (*want_end == '.') {
1283      want = strtoul(want_end+1,&want_end,10);
1284      got = 0;
1285      if (*got_end == '.') {
1286        got = strtoul(got_end+1,&got_end,10);
1287      } else {
1288        break;
1289      }
1290    } else {
1291      break;
1292    }
1293  }
1294
1295  if (got < want) {
1296    fprintf(stderr, "\n%s requires %s version %s or later; the current version is %s.\n", progname, uts.sysname, min_os_version, uts.release);
1297    exit(1);
1298  }
1299#ifdef PPC
1300#ifdef DARWIN
1301  {
1302    char *hosttype = getenv("HOSTTYPE");
1303    if (hosttype && !strncmp("intel", hosttype, 5)) {
1304      running_under_rosetta = true;
1305      use_mach_exception_handling = false;
1306      reserved_area_size = 1U << 30;
1307    }
1308  }
1309#endif
1310#endif
1311#endif
1312}
1313
1314#ifdef X86
1315/*
1316  This should determine the cache block size.  It should also
1317  probably complain if we don't have (at least) SSE2.
1318*/
1319extern int cpuid(natural, natural*, natural*, natural*);
1320
1321#define X86_FEATURE_CMOV    (1<<15)
1322#define X86_FEATURE_CLFLUSH (1<<19)
1323#define X86_FEATURE_MMX     (1<<23)
1324#define X86_FEATURE_SSE     (1<<25)
1325#define X86_FEATURE_SSE2    (1<<26)
1326
1327#define X86_REQUIRED_FEATURES (X86_FEATURE_CMOV|X86_FEATURE_CLFLUSH|X86_FEATURE_MMX|X86_FEATURE_SSE|X86_FEATURE_SSE2)
1328
1329Boolean
1330check_x86_cpu()
1331{
1332  natural eax, ebx, ecx, edx;
1333 
1334  eax = cpuid(0, &ebx, &ecx, &edx);
1335
1336  if (eax >= 1) {
1337    eax = cpuid(1, &ebx, &ecx, &edx);
1338    cache_block_size = (ebx & 0xff00) >> 5;
1339    if ((X86_REQUIRED_FEATURES & edx) == X86_REQUIRED_FEATURES) {
1340      return true;
1341    }
1342  }
1343  return false;
1344}
1345#endif
1346
1347void
1348lazarus()
1349{
1350  TCR *tcr = get_tcr(false);
1351  if (tcr) {
1352    /* Some threads may be dying; no threads should be created. */
1353    LOCK(lisp_global(TCR_AREA_LOCK),tcr);
1354    tcr->vs_area->active = tcr->vs_area->high - node_size;
1355    tcr->save_vsp = (LispObj *)(tcr->vs_area->active);
1356    tcr->ts_area->active = tcr->ts_area->high;
1357    tcr->save_tsp = (LispObj *)(tcr->ts_area->active);
1358    tcr->catch_top = 0;
1359    tcr->db_link = 0;
1360    tcr->xframe = 0;
1361    start_lisp(tcr, 0);
1362  }
1363}
1364
1365#ifdef LINUX
1366#ifdef X8664
1367#include <asm/prctl.h>
1368#include <sys/prctl.h>
1369
1370void
1371ensure_gs_available(char *progname)
1372{
1373  LispObj fs_addr = 0L, gs_addr = 0L, cur_thread = (LispObj)pthread_self();
1374  char *gnu_get_libc_version(void);
1375 
1376  arch_prctl(ARCH_GET_GS, &gs_addr);
1377  arch_prctl(ARCH_GET_FS, &fs_addr);
1378  if ((gs_addr == cur_thread) && (fs_addr != cur_thread)) {
1379    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);
1380    _exit(1);
1381  }
1382}
1383#endif
1384#endif
1385
1386Boolean
1387bogus_fp_exceptions = false;
1388
1389typedef
1390float (*float_arg_returns_float)(float);
1391
1392float
1393fcallf(float_arg_returns_float fun, float arg)
1394{
1395  return fun(arg);
1396}
1397
1398void
1399check_bogus_fp_exceptions()
1400{
1401#ifdef X8664
1402  float asinf(float),result;
1403   
1404
1405  natural save_mxcsr = get_mxcsr(), post_mxcsr;
1406  set_mxcsr(0x1f80);
1407
1408  result = fcallf(asinf, 1.0);
1409  post_mxcsr = get_mxcsr();
1410  set_mxcsr(save_mxcsr);
1411  if (post_mxcsr & (FE_ALL_EXCEPT & (~FE_INEXACT))) {
1412    bogus_fp_exceptions = true;
1413  }
1414#endif
1415}
1416
1417
1418int
1419main(int argc, char *argv[]
1420#ifndef WINDOWS
1421, char *envp[], void *aux
1422#endif
1423)
1424{
1425  extern int page_size;
1426
1427#ifdef PPC
1428  extern int altivec_present;
1429#endif
1430  extern LispObj load_image(char *);
1431  area *a;
1432  BytePtr stack_base, current_sp = (BytePtr) current_stack_pointer();
1433  TCR *tcr;
1434
1435
1436#ifdef WINDOWS
1437  extern void init_winsock(void);
1438  extern void init_windows_io(void);
1439
1440  _fmode = O_BINARY;
1441  _setmode(1, O_BINARY);
1442  _setmode(2, O_BINARY);
1443  setvbuf(stderr, NULL, _IONBF, 0);
1444  init_winsock();
1445  init_windows_io();
1446#endif
1447
1448  check_os_version(argv[0]);
1449  real_executable_name = determine_executable_name(argv[0]);
1450  page_size = getpagesize(); /* Implement with GetSystemInfo on Windows w/o MinGW */
1451
1452  check_bogus_fp_exceptions();
1453#ifdef LINUX
1454#ifdef X8664
1455  ensure_gs_available(real_executable_name);
1456#endif
1457#endif
1458#if (defined(DARWIN) && defined(PPC64)) || defined(X8664)
1459  remap_spjump();
1460#endif
1461
1462#ifdef PPC
1463#ifdef LINUX
1464  {
1465    ElfW(auxv_t) *av = aux;
1466    int hwcap, done = false;
1467   
1468    if (av) {
1469      do {
1470        switch (av->a_type) {
1471        case AT_DCACHEBSIZE:
1472          cache_block_size = av->a_un.a_val;
1473          break;
1474
1475        case AT_HWCAP:
1476          hwcap = av->a_un.a_val;
1477          altivec_present = ((hwcap & PPC_FEATURE_HAS_ALTIVEC) != 0);
1478          break;
1479
1480        case AT_NULL:
1481          done = true;
1482          break;
1483        }
1484        av++;
1485      } while (!done);
1486    }
1487  }
1488#endif
1489#ifdef DARWIN
1490  {
1491    unsigned value = 0;
1492    size_t len = sizeof(value);
1493    int mib[2];
1494   
1495    mib[0] = CTL_HW;
1496    mib[1] = HW_CACHELINE;
1497    if (sysctl(mib,2,&value,&len, NULL, 0) != -1) {
1498      if (len == sizeof(value)) {
1499        cache_block_size = value;
1500      }
1501    }
1502    mib[1] = HW_VECTORUNIT;
1503    value = 0;
1504    len = sizeof(value);
1505    if (sysctl(mib,2,&value,&len, NULL, 0) != -1) {
1506      if (len == sizeof(value)) {
1507        altivec_present = value;
1508      }
1509    }
1510  }
1511#endif
1512#endif
1513
1514#ifdef X86
1515  if (!check_x86_cpu()) {
1516    fprintf(stderr, "CPU doesn't support required features\n");
1517    exit(1);
1518  }
1519#endif
1520
1521#ifndef WINDOWS
1522  main_thread_pid = getpid();
1523#endif
1524  tcr_area_lock = (void *)new_recursive_lock();
1525
1526  program_name = argv[0];
1527  if ((argc == 2) && (*argv[1] != '-')) {
1528    image_name = argv[1];
1529    argv[1] = NULL;
1530  } else {
1531    process_options(argc,argv);
1532  }
1533  initial_stack_size = ensure_stack_limit(initial_stack_size);
1534  if (image_name == NULL) {
1535    if (check_for_embedded_image(real_executable_name)) {
1536      image_name = real_executable_name;
1537    } else {
1538      image_name = default_image_name(real_executable_name);
1539    }
1540  }
1541
1542
1543  if (!create_reserved_area(reserved_area_size)) {
1544    exit(-1);
1545  }
1546  gc_init();
1547
1548  set_nil(load_image(image_name));
1549  lisp_global(TCR_AREA_LOCK) = ptr_to_lispobj(tcr_area_lock);
1550
1551#ifdef X86
1552  lisp_global(SUBPRIMS_BASE) = (LispObj)((1<<16)+(5<<10));
1553#else
1554  lisp_global(SUBPRIMS_BASE) = (LispObj)(5<<10);
1555#endif
1556  lisp_global(RET1VALN) = (LispObj)&ret1valn;
1557  lisp_global(LEXPR_RETURN) = (LispObj)&nvalret;
1558  lisp_global(LEXPR_RETURN1V) = (LispObj)&popj;
1559  lisp_global(ALL_AREAS) = ptr_to_lispobj(all_areas);
1560#ifdef X86
1561  lisp_global(BAD_FUNCALL) = ptr_to_lispobj(&bad_funcall);
1562#endif
1563  lisp_global(DEFAULT_ALLOCATION_QUANTUM) = log2_heap_segment_size << fixnumshift;
1564  lisp_global(STACK_SIZE) = thread_stack_size<<fixnumshift;
1565
1566
1567  exception_init();
1568
1569 
1570
1571  lisp_global(IMAGE_NAME) = ptr_to_lispobj(image_name);
1572  lisp_global(ARGV) = ptr_to_lispobj(argv);
1573  lisp_global(KERNEL_IMPORTS) = (LispObj)import_ptrs_base;
1574
1575  lisp_global(GET_TCR) = (LispObj) get_tcr;
1576  *(double *) &(lisp_global(DOUBLE_FLOAT_ONE)) = (double) 1.0;
1577
1578  lisp_global(HOST_PLATFORM) = (LispObj) PLATFORM << fixnumshift;
1579
1580  lisp_global(BATCH_FLAG) = (batch_flag << fixnumshift);
1581
1582  a = active_dynamic_area;
1583
1584  if (nilreg_area != NULL) {
1585    BytePtr lowptr = (BytePtr) a->low;
1586
1587    /* Create these areas as AREA_STATIC, change them to AREA_DYNAMIC */
1588    g1_area = new_area(lowptr, lowptr, AREA_STATIC);
1589    g2_area = new_area(lowptr, lowptr, AREA_STATIC);
1590    tenured_area = new_area(lowptr, lowptr, AREA_STATIC);
1591    add_area_holding_area_lock(tenured_area);
1592    add_area_holding_area_lock(g2_area);
1593    add_area_holding_area_lock(g1_area);
1594
1595    g1_area->code = AREA_DYNAMIC;
1596    g2_area->code = AREA_DYNAMIC;
1597    tenured_area->code = AREA_DYNAMIC;
1598
1599/*    a->older = g1_area; */ /* Not yet: this is what "enabling the EGC" does. */
1600    g1_area->younger = a;
1601    g1_area->older = g2_area;
1602    g2_area->younger = g1_area;
1603    g2_area->older = tenured_area;
1604    tenured_area->younger = g2_area;
1605    tenured_area->refbits = a->markbits;
1606    tenured_area->static_dnodes = a->static_dnodes;
1607    a->static_dnodes = 0;
1608    tenured_area->static_used = a->static_used;
1609    a->static_used = 0;
1610    lisp_global(TENURED_AREA) = ptr_to_lispobj(tenured_area);
1611    lisp_global(REFBITS) = ptr_to_lispobj(tenured_area->refbits);
1612    g2_area->threshold = G2_AREA_THRESHOLD;
1613    g1_area->threshold = G1_AREA_THRESHOLD;
1614    a->threshold = G0_AREA_THRESHOLD;
1615  }
1616
1617  tcr = new_tcr(initial_stack_size, MIN_TSTACK_SIZE);
1618  stack_base = initial_stack_bottom()-xStackSpace();
1619  init_threads((void *)(stack_base), tcr);
1620  thread_init_tcr(tcr, current_sp, current_sp-stack_base);
1621
1622  lisp_global(EXCEPTION_LOCK) = ptr_to_lispobj(new_recursive_lock());
1623  enable_fp_exceptions();
1624  register_sigint_handler();
1625
1626#ifdef PPC
1627  lisp_global(ALTIVEC_PRESENT) = altivec_present << fixnumshift;
1628#endif
1629#if STATIC
1630  lisp_global(STATICALLY_LINKED) = 1 << fixnumshift;
1631#endif
1632  tcr->prev = tcr->next = tcr;
1633#ifndef WINDOWS
1634  lisp_global(INTERRUPT_SIGNAL) = (LispObj) box_fixnum(SIGNAL_FOR_PROCESS_INTERRUPT);
1635#endif
1636  tcr->vs_area->active -= node_size;
1637  *(--tcr->save_vsp) = nrs_TOPLFUNC.vcell;
1638  nrs_TOPLFUNC.vcell = lisp_nil;
1639#ifdef GC_INTEGRITY_CHECKING
1640  (nrs_GC_EVENT_STATUS_BITS.vcell |= gc_integrity_check_bit);
1641#endif
1642#ifndef DISABLE_EGC
1643  egc_control(true, NULL);
1644#endif
1645  atexit(lazarus);
1646  start_lisp(TCR_TO_TSD(tcr), 0);
1647  _exit(0);
1648}
1649
1650area *
1651set_nil(LispObj r)
1652{
1653
1654  if (lisp_nil == (LispObj)NULL) {
1655
1656    lisp_nil = r;
1657  }
1658  return NULL;
1659}
1660
1661
1662void
1663xMakeDataExecutable(void *start, unsigned long nbytes)
1664{
1665  extern void flush_cache_lines();
1666  natural ustart = (natural) start, base, end;
1667 
1668  base = (ustart) & ~(cache_block_size-1);
1669  end = (ustart + nbytes + cache_block_size - 1) & ~(cache_block_size-1);
1670#ifdef DARWIN
1671  if (running_under_rosetta) {
1672    /* We probably need to flush something's cache even if running
1673       under Rosetta, but (a) this is agonizingly slow and (b) we're
1674       dying before we get to the point where this would matter.
1675    */
1676    return;
1677  }
1678#endif
1679#ifndef X86
1680  flush_cache_lines(base, (end-base)/cache_block_size, cache_block_size);
1681#endif
1682}
1683
1684natural
1685xStackSpace()
1686{
1687  return initial_stack_size+CSTACK_HARDPROT+CSTACK_SOFTPROT;
1688}
1689
1690#ifndef DARWIN
1691#ifdef WINDOWS
1692void *
1693xGetSharedLibrary(char *path, int mode)
1694{
1695  return NULL;                  /* fix this */
1696}
1697#else
1698void *
1699xGetSharedLibrary(char *path, int mode)
1700{
1701  return dlopen(path, mode);
1702}
1703#endif
1704#else
1705void *
1706xGetSharedLibrary(char *path, int *resultType)
1707{
1708#if defined(PPC) && (WORD_SIZE == 32)
1709  NSObjectFileImageReturnCode code;
1710  NSObjectFileImage              moduleImage;
1711  NSModule                       module;
1712  const struct mach_header *     header;
1713  const char *                   error;
1714  void *                         result;
1715  /* not thread safe */
1716  /*
1717  static struct {
1718    const struct mach_header  *header;
1719    NSModule                  *module;
1720    const char                *error;
1721  } results;   
1722  */
1723  result = NULL;
1724  error = NULL;
1725
1726  /* first try to open this as a bundle */
1727  code = NSCreateObjectFileImageFromFile(path,&moduleImage);
1728  if (code != NSObjectFileImageSuccess &&
1729      code != NSObjectFileImageInappropriateFile &&
1730      code != NSObjectFileImageAccess)
1731    {
1732      /* compute error strings */
1733      switch (code)
1734        {
1735        case NSObjectFileImageFailure:
1736          error = "NSObjectFileImageFailure";
1737          break;
1738        case NSObjectFileImageArch:
1739          error = "NSObjectFileImageArch";
1740          break;
1741        case NSObjectFileImageFormat:
1742          error = "NSObjectFileImageFormat";
1743          break;
1744        case NSObjectFileImageAccess:
1745          /* can't find the file */
1746          error = "NSObjectFileImageAccess";
1747          break;
1748        default:
1749          error = "unknown error";
1750        }
1751      *resultType = 0;
1752      return (void *)error;
1753    }
1754  if (code == NSObjectFileImageInappropriateFile ||
1755      code == NSObjectFileImageAccess ) {
1756    /* the pathname might be a partial pathane (hence the access error)
1757       or it might be something other than a bundle, if so perhaps
1758       it is a .dylib so now try to open it as a .dylib */
1759
1760    /* protect against redundant loads, Gary Byers noticed possible
1761       heap corruption if this isn't done */
1762    header = NSAddImage(path, NSADDIMAGE_OPTION_RETURN_ON_ERROR |
1763                        NSADDIMAGE_OPTION_WITH_SEARCHING |
1764                        NSADDIMAGE_OPTION_RETURN_ONLY_IF_LOADED);
1765    if (!header)
1766      header = NSAddImage(path, NSADDIMAGE_OPTION_RETURN_ON_ERROR |
1767                          NSADDIMAGE_OPTION_WITH_SEARCHING);
1768    result = (void *)header;
1769    *resultType = 1;
1770  }
1771  else if (code == NSObjectFileImageSuccess) {
1772    /* we have a sucessful module image
1773       try to link it, don't bind symbols privately */
1774
1775    module = NSLinkModule(moduleImage, path,
1776                          NSLINKMODULE_OPTION_RETURN_ON_ERROR | NSLINKMODULE_OPTION_BINDNOW);
1777    NSDestroyObjectFileImage(moduleImage);     
1778    result = (void *)module;
1779    *resultType = 2;
1780  }
1781  if (!result)
1782    {
1783      /* compute error string */
1784      NSLinkEditErrors ler;
1785      int lerno;
1786      const char* file;
1787      NSLinkEditError(&ler,&lerno,&file,&error);
1788      if (error) {
1789        result = (void *)error;
1790        *resultType = 0;
1791      }
1792    }
1793  return result;
1794#else
1795  const char *                   error;
1796  void *                         result;
1797
1798  result = dlopen(path, RTLD_NOW | RTLD_GLOBAL);
1799 
1800  if (result == NULL) {
1801    error = dlerror();
1802    *resultType = 0;
1803    return (void *)error;
1804  }
1805  *resultType = 1;
1806  return result;
1807#endif
1808}
1809#endif
1810
1811
1812
1813int
1814fd_setsize_bytes()
1815{
1816  return FD_SETSIZE/8;
1817}
1818
1819void
1820do_fd_set(int fd, fd_set *fdsetp)
1821{
1822  FD_SET(fd, fdsetp);
1823}
1824
1825void
1826do_fd_clr(int fd, fd_set *fdsetp)
1827{
1828  FD_CLR(fd, fdsetp);
1829}
1830
1831int
1832do_fd_is_set(int fd, fd_set *fdsetp)
1833{
1834  return FD_ISSET(fd,fdsetp);
1835}
1836
1837
1838void
1839do_fd_zero(fd_set *fdsetp)
1840{
1841  FD_ZERO(fdsetp);
1842}
1843
1844#include "image.h"
1845
1846
1847
1848Boolean
1849check_for_embedded_image (char *path)
1850{
1851  int fd = open(path, O_RDONLY);
1852  Boolean image_is_embedded = false;
1853
1854  if (fd >= 0) {
1855    openmcl_image_file_header h;
1856
1857    if (find_openmcl_image_file_header (fd, &h)) {
1858      image_is_embedded = true;
1859    }
1860    close (fd);
1861  }
1862  return image_is_embedded;
1863}
1864
1865LispObj
1866load_image(char *path)
1867{
1868  int fd = open(path, O_RDONLY, 0666);
1869  LispObj image_nil = 0;
1870  if (fd > 0) {
1871    openmcl_image_file_header ih;
1872    image_nil = load_openmcl_image(fd, &ih);
1873    /* We -were- using a duplicate fd to map the file; that
1874       seems to confuse Darwin (doesn't everything ?), so
1875       we'll instead keep the original file open.
1876    */
1877    if (!image_nil) {
1878      close(fd);
1879    }
1880  }
1881  if (image_nil == 0) {
1882#ifdef WINDOWS
1883    wperror("Couldn't load lisp heap image");
1884#else
1885    fprintf(stderr, "Couldn't load lisp heap image from %s:\n%s\n", path, strerror(errno));
1886#endif
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.