source: branches/working-0711/ccl/lisp-kernel/pmcl-kernel.c @ 11089

Last change on this file since 11089 was 11089, checked in by gz, 13 years ago

Merge/bootstrap assorted low level stuff from trunk - kernel, syscall stuff, lowmem-bias, formatting tweaks, a few bug fixes included

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