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

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

Don't insist on X96_FEATURE_CLFLUSH; we don't actually flush cache
lines, and at least some virtual environemts don't seem to set
the bit correctly.

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