source: trunk/ccl/lisp-kernel/pmcl-kernel.c @ 510

Last change on this file since 510 was 510, checked in by gb, 16 years ago

egc back on

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 35.2 KB
Line 
1/*
2   Copyright (C) 1994-2001 Digitool, Inc
3   This file is part of OpenMCL. 
4
5   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
6   License , known as the LLGPL and distributed with OpenMCL as the
7   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
8   which is distributed with OpenMCL as the file "LGPL".  Where these
9   conflict, the preamble takes precedence. 
10
11   OpenMCL is referenced in the preamble as the "LIBRARY."
12
13   The LLGPL is also available online at
14   http://opensource.franz.com/preamble.html
15*/
16
17#ifdef DARWIN
18/*      dyld.h included here because something in "lisp.h" causes
19    a conflict (actually I think the problem is in "constants.h")
20*/
21#include <mach-o/dyld.h>
22#endif
23#include "lisp.h"
24#include "lisp_globals.h"
25#include "gc.h"
26#include "area.h"
27#include <stdlib.h>
28#include <string.h>
29#include "lisp-exceptions.h"
30#include <stdio.h>
31#include <stdlib.h>
32#include <sys/mman.h>
33#include <fcntl.h>
34#include <signal.h>
35#include <unistd.h>
36#include <errno.h>
37#ifdef LINUX
38#include <mcheck.h>
39#include <dirent.h>
40#include <dlfcn.h>
41#include <sys/time.h>
42#include <sys/resource.h>
43#include <link.h>
44#include <elf.h>
45#include <asm/cputable.h>
46#endif
47
48#ifdef DARWIN
49#include <sys/types.h>
50#include <sys/time.h>
51#include <sys/mman.h>
52#include <sys/resource.h>
53#include <mach/mach_types.h>
54#include <mach/message.h>
55#include <mach/vm_region.h>
56#include <sys/sysctl.h>
57#endif
58
59#include <ctype.h>
60#include <sys/select.h>
61#include "Threads.h"
62
63LispObj lisp_nil = (LispObj) 0;
64bitvector global_mark_ref_bits = NULL;
65
66
67/* These are all "persistent" : they're initialized when
68   subprims are first loaded and should never change. */
69extern LispObj ret1valn;
70extern LispObj nvalret;
71extern LispObj popj;
72LispObj real_subprims_base = 0;
73LispObj text_start = 0;
74
75/* A pointer to some of the kernel's own data; also persistent. */
76
77extern LispObj import_ptrs_base;
78
79
80
81
82void
83xMakeDataExecutable(void *, unsigned);
84
85void
86make_dynamic_heap_executable(LispObj *p, LispObj *q)
87{
88  void * cache_start = (void *) p;
89  unsigned ncacheflush = (unsigned) q - (unsigned) p;
90
91  xMakeDataExecutable(cache_start, ncacheflush); 
92}
93     
94size_t
95ensure_stack_limit(size_t stack_size)
96{
97  struct rlimit limits;
98  rlim_t cur_stack_limit, max_stack_limit;
99 
100  stack_size += (CSTACK_HARDPROT+CSTACK_SOFTPROT);
101  getrlimit(RLIMIT_STACK, &limits);
102  cur_stack_limit = limits.rlim_cur;
103  max_stack_limit = limits.rlim_max;
104  if (stack_size > max_stack_limit) {
105    stack_size = max_stack_limit;
106  }
107  if (cur_stack_limit < stack_size) {
108    limits.rlim_cur = stack_size;
109    errno = 0;
110    if (setrlimit(RLIMIT_STACK, &limits)) {
111      int e = errno;
112      fprintf(stderr, "errno = %d\n", e);
113      Fatal(": Stack resource limit too small", "");
114    }
115  }
116  return stack_size - (CSTACK_HARDPROT+CSTACK_SOFTPROT);
117}
118
119
120/* This should write-protect the bottom of the stack.
121   Doing so reliably involves ensuring that everything's unprotected on exit.
122*/
123
124BytePtr
125allocate_lisp_stack(unsigned useable,
126                    unsigned softsize,
127                    unsigned hardsize,
128                    lisp_protection_kind softkind,
129                    lisp_protection_kind hardkind,
130                    Ptr *h_p,
131                    BytePtr *base_p,
132                    protected_area_ptr *softp,
133                    protected_area_ptr *hardp)
134{
135  void *allocate_stack(unsigned);
136  void free_stack(void *);
137  unsigned size = useable+softsize+hardsize;
138  unsigned overhead;
139  BytePtr base, softlimit, hardlimit;
140  OSErr err;
141  Ptr h = allocate_stack(size+4095);
142  protected_area_ptr hprotp = NULL, sprotp;
143
144  if (h == NULL) {
145    return NULL;
146  }
147  if (h_p) *h_p = h;
148  base = (BytePtr) align_to_power_of_2( h, 12);
149  hardlimit = (BytePtr) (base+hardsize);
150  softlimit = hardlimit+softsize;
151
152  overhead = (base - (BytePtr) h);
153  if (hardsize) {
154    hprotp = new_protected_area((BytePtr)base,hardlimit,hardkind, hardsize, true);
155    if (hprotp == NULL) {
156      if (base_p) *base_p = NULL;
157      if (h_p) *h_p = NULL;
158      deallocate(h);
159      return NULL;
160    }
161    if (hardp) *hardp = hprotp;
162  }
163  if (softsize) {
164    sprotp = new_protected_area(hardlimit,softlimit, softkind, softsize, true);
165    if (sprotp == NULL) {
166      if (base_p) *base_p = NULL;
167      if (h_p) *h_p = NULL;
168      if (hardp) *hardp = NULL;
169      if (hprotp) delete_protected_area(hprotp);
170      free_stack(h);
171      return NULL;
172    }
173    if (softp) *softp = sprotp;
174  }
175  if (base_p) *base_p = base;
176  return (BytePtr) ((unsigned)(base+size));
177}
178
179/* This'll allocate a tstack or a vstack, but the thread
180   mangler won't let us allocate or reliably protect
181   a control stack.
182*/
183area *
184allocate_lisp_stack_area(area_code stack_type,
185                         unsigned useable, 
186                         unsigned softsize, 
187                         unsigned hardsize, 
188                         lisp_protection_kind softkind, 
189                         lisp_protection_kind hardkind)
190
191{
192  BytePtr base, bottom;
193  Ptr h;
194  area *a = NULL;
195  protected_area_ptr soft_area=NULL, hard_area=NULL;
196
197  bottom = allocate_lisp_stack(useable, 
198                               softsize, 
199                               hardsize, 
200                               softkind, 
201                               hardkind, 
202                               &h, 
203                               &base,
204                               &soft_area, 
205                               &hard_area);
206
207  if (bottom) {
208    a = new_area(base, bottom, stack_type);
209    a->hardlimit = base+hardsize;
210    a->softlimit = base+hardsize+softsize;
211    a->h = h;
212    a->softprot = soft_area;
213    a->hardprot = hard_area;
214    add_area(a);
215  }
216  return a;
217}
218
219area*
220register_cstack(BytePtr bottom, unsigned size)
221{
222  BytePtr lowlimit = (BytePtr) (((((unsigned)bottom)-size)+4095)&~4095);
223  area *a = new_area((BytePtr) bottom-size, bottom, AREA_CSTACK);
224
225  a->hardlimit = lowlimit+CSTACK_HARDPROT;
226  a->softlimit = a->hardlimit+CSTACK_SOFTPROT;
227  add_area(a);
228  return a;
229}
230 
231area*
232allocate_vstack(unsigned usable)
233{
234  return allocate_lisp_stack_area(AREA_VSTACK, 
235                                  usable > MIN_VSTACK_SIZE ?
236                                  usable : MIN_VSTACK_SIZE,
237                                  VSTACK_SOFTPROT,
238                                  VSTACK_HARDPROT,
239                                  kVSPsoftguard,
240                                  kVSPhardguard);
241}
242
243area *
244allocate_tstack(unsigned usable)
245{
246  return allocate_lisp_stack_area(AREA_TSTACK, 
247                                  usable > MIN_TSTACK_SIZE ?
248                                  usable : MIN_TSTACK_SIZE,
249                                  TSTACK_SOFTPROT,
250                                  TSTACK_HARDPROT,
251                                  kTSPsoftguard,
252                                  kTSPhardguard);
253}
254
255
256/* It's hard to believe that max & min don't exist already */
257unsigned unsigned_min(unsigned x, unsigned y)
258{
259  if (x <= y) {
260    return x;
261  } else {
262    return y;
263  }
264}
265
266unsigned unsigned_max(unsigned x, unsigned y)
267{
268  if (x >= y) {
269    return x;
270  } else {
271    return y;
272  }
273}
274
275
276
277
278
279
280int
281reserved_area_size = (1<<30);
282
283area *nilreg_area=NULL, *tenured_area=NULL, *g2_area=NULL, *g1_area=NULL;
284area *all_areas=NULL;
285int cache_block_size=32;
286
287
288#define DEFAULT_LISP_HEAP_GC_THRESHOLD (16<<20)
289#define DEFAULT_INITIAL_STACK_SIZE (1<<20)
290
291unsigned
292lisp_heap_gc_threshold = DEFAULT_LISP_HEAP_GC_THRESHOLD;
293
294unsigned 
295initial_stack_size = DEFAULT_INITIAL_STACK_SIZE;
296
297
298/*
299  'start' should be on a segment boundary; 'len' should be
300  an integral number of segments.
301  remap the entire range, a segment at a time.
302*/
303
304void 
305uncommit_pages(void *start, unsigned len)
306{
307  if (len) {
308    madvise(start, len, MADV_DONTNEED);
309    if (mmap(start, 
310             len, 
311             PROT_NONE, 
312             MAP_PRIVATE | MAP_FIXED | MAP_ANON,
313             -1,
314             0) != start) {
315      int err = errno;
316      Fatal("mmap error", "");
317      fprintf(stderr, "errno = %d", err);
318    }
319  }
320}
321
322void
323commit_pages(void *start, unsigned len)
324{
325  if (len != 0) {
326    int i, err;
327    void *addr;
328    for (i = 0; i < 3; i++) {
329      addr = mmap(start, 
330                  len, 
331                  PROT_READ | PROT_WRITE,
332                  MAP_PRIVATE | MAP_FIXED | MAP_ANON,
333                  -1,
334                  0);
335      if (addr  == start) {
336        return;
337      }
338      err = errno;
339      Bug(NULL, "mmap failure returned 0x%08x, attempt %d: %s\n",
340          addr,
341          i,
342          strerror(errno));
343      sleep(5);
344    }
345    Fatal("mmap error", "");
346  }
347}
348
349area *
350find_readonly_area()
351{
352  area *a;
353
354  for (a = active_dynamic_area->succ; a != all_areas; a = a->succ) {
355    if (a->code == AREA_READONLY) {
356      return a;
357    }
358  }
359  return NULL;
360}
361
362area *
363extend_readonly_area(unsigned more)
364{
365  area *a;
366  unsigned mask;
367  BytePtr new_start, new_end;
368
369  if (a = find_readonly_area()) {
370    if ((a->active + more) > a->high) {
371      return NULL;
372    }
373    mask = ((unsigned)a->active) & 4095;
374    if (mask) {
375      UnProtectMemory(a->active-mask, 4096);
376    }
377    new_start = (BytePtr)(align_to_power_of_2(a->active,12));
378    new_end = (BytePtr)(align_to_power_of_2(a->active+more,12));
379    if (mmap(new_start,
380             new_end-new_start,
381             PROT_READ | PROT_WRITE,
382             MAP_PRIVATE | MAP_ANON | MAP_FIXED,
383             -1,
384             0) != new_start) {
385      return NULL;
386    }
387    return a;
388  }
389  return NULL;
390}
391
392LispObj image_base=0;
393BytePtr pure_space_start, pure_space_active, pure_space_limit;
394BytePtr static_space_start, static_space_active, static_space_limit;
395
396#ifdef DARWIN
397/*
398  Check to see if the specified address is unmapped by trying to get
399  information about the mapped address at or beyond the target.  If
400  the difference between the target address and the next mapped address
401  is >= len, we can safely mmap len bytes at addr.
402*/
403Boolean
404address_unmapped_p(char *addr, unsigned len)
405{
406  vm_address_t vm_addr = (vm_address_t)addr;
407  vm_size_t vm_size;
408  vm_region_basic_info_data_t vm_info;
409  mach_msg_type_number_t vm_info_size = VM_REGION_BASIC_INFO_COUNT;
410  port_t vm_object_name = (port_t) 0;
411  kern_return_t kret;
412
413  kret = vm_region(mach_task_self(),
414                   &vm_addr,
415                   &vm_size,
416                   VM_REGION_BASIC_INFO,
417                   (vm_region_info_t)&vm_info,
418                   &vm_info_size,
419                   &vm_object_name);
420  if (kret != KERN_SUCCESS) {
421    return false;
422  }
423
424  return vm_addr >= (vm_address_t)(addr+len);
425}
426#endif
427
428
429
430
431area *
432create_reserved_area(unsigned totalsize)
433{
434  OSErr err;
435  Ptr h;
436  unsigned base, n;
437  BytePtr
438    end, 
439    lastbyte, 
440    start, 
441    protstart, 
442    p, 
443    want = (BytePtr)IMAGE_BASE_ADDRESS,
444    try2;
445  area *reserved;
446  Boolean fixed_map_ok = false;
447
448  /*
449    Through trial and error, we've found that IMAGE_BASE_ADDRESS is
450    likely to reside near the beginning of an unmapped block of memory
451    that's at least 1GB in size.  We'd like to load the heap image's
452    sections relative to IMAGE_BASE_ADDRESS; if we're able to do so,
453    that'd allow us to file-map those sections (and would enable us to
454    avoid having to relocate references in the data sections.)
455
456    In short, we'd like to reserve 1GB starting at IMAGE_BASE_ADDRESS
457    by creating an anonymous mapping with mmap().
458
459    If we try to insist that mmap() map a 1GB block at
460    IMAGE_BASE_ADDRESS exactly (by specifying the MAP_FIXED flag),
461    mmap() will gleefully clobber any mapped memory that's already
462    there.  (That region's empty at this writing, but some future
463    version of the OS might decide to put something there.)
464
465    If we don't specify MAP_FIXED, mmap() is free to treat the address
466    we give it as a hint; Linux seems to accept the hint if doing so
467    wouldn't cause a problem.  Naturally, that behavior's too useful
468    for Darwin (or perhaps too inconvenient for it): it'll often
469    return another address, even if the hint would have worked fine.
470
471    We call address_unmapped_p() to ask Mach whether using MAP_FIXED
472    would conflict with anything.  Until we discover a need to do
473    otherwise, we'll assume that if Linux's mmap() fails to take the
474    hint, it's because of a legitimate conflict.
475
476    If Linux starts ignoring hints, we can parse /proc/<pid>/maps
477    to implement an address_unmapped_p() for Linux.
478  */
479
480  totalsize = align_to_power_of_2((void *)totalsize, log2_heap_segment_size);
481
482#ifdef DARWIN
483  fixed_map_ok = address_unmapped_p(want,totalsize);
484#endif
485  start = mmap((void *)want,
486               totalsize + heap_segment_size,
487               PROT_NONE,
488               MAP_PRIVATE | MAP_ANON | (fixed_map_ok ? MAP_FIXED : 0),
489               -1,
490               0);
491  if (start == MAP_FAILED) {
492    perror("Initial mmap");
493    return NULL;
494  }
495
496  if (start != want) {
497    munmap(start, totalsize+heap_segment_size);
498    start = (void *)((((unsigned)start)+heap_segment_size-1) & ~(heap_segment_size-1));
499    if(mmap(start, totalsize, PROT_NONE, MAP_PRIVATE | MAP_ANON | MAP_FIXED, -1, 0) != start) {
500      return NULL;
501    }
502  }
503  mprotect(start, totalsize, PROT_NONE);
504
505  h = (Ptr) start;
506  base = (unsigned) start;
507  image_base = base;
508  lastbyte = (BytePtr) (start+totalsize);
509  static_space_start = static_space_active = (BytePtr)STATIC_BASE_ADDRESS;
510  static_space_limit = static_space_start + STATIC_RESERVE;
511  pure_space_start = pure_space_active = start;
512  pure_space_limit = start + PURESPACE_RESERVE;
513  start = pure_space_limit;
514
515  /*
516    Allocate mark bits here.  They need to be 1/64 the size of the
517     maximum useable area of the heap (+ 3 words for the EGC.)
518  */
519  end = lastbyte;
520  end = (BytePtr) ((unsigned)((((unsigned)end) - ((totalsize+63)>>6)) & ~4095));
521
522  global_mark_ref_bits = (bitvector)end;
523  end = (BytePtr) ((unsigned)((((unsigned)end) - ((totalsize+63) >> 6)) & ~4095));
524  global_reloctab = (LispObj *) end;
525  /* We need 2 bytes for every page for the egc pagemap */
526  end = (BytePtr) ((unsigned)((((unsigned)end) - ((totalsize+4095) >> 11)) & ~4095));
527  pagemap = (pageentry *) end;
528  reserved = new_area(start, end, AREA_VOID);
529  /* The root of all evil is initially linked to itself. */
530  reserved->pred = reserved->succ = reserved;
531  all_areas = reserved;
532  reserved->markbits = global_mark_ref_bits;
533  return reserved;
534}
535
536void *
537allocate_from_reserved_area(unsigned size)
538{
539  area *reserved = reserved_area;
540  BytePtr low = reserved->low, high = reserved->high;
541  unsigned avail = high-low;
542  size = align_to_power_of_2(size, log2_heap_segment_size);
543
544  if (size > avail) {
545    return NULL;
546  }
547  reserved->low += size;
548  reserved->active = reserved->low;
549  reserved->ndwords -= (size>>3);
550  return low;
551}
552
553
554#define FILE_MAP_FROM_RESERVED_AREA 0
555
556void *
557file_map_reserved_pages(unsigned len, int prot, int fd, unsigned offset)
558{
559  void *start;
560  unsigned 
561    offset_of_page = offset & ~((1<<12)-1), 
562    offset_in_page = offset - offset_of_page,
563    segment_len = align_to_power_of_2((offset+len)-offset_of_page, 
564                                      log2_heap_segment_size);
565 
566  /* LOCK_MMAP_LOCK(); */
567#if FILE_MAP_FROM_RESERVED_AREA
568  start = allocate_from_reserved_area(segment_len);
569  if (start == NULL) {
570    return start;
571  }
572#endif
573#if FILE_MAP_FROM_RESERVED_AREA
574  if (start != mmap(start,
575                    segment_len,
576                    prot,
577                    MAP_PRIVATE | MAP_FIXED,
578                    fd,
579                    offset_of_page)) {
580    return NULL;
581  }
582#else
583  if ((start = mmap(NULL,
584                    segment_len,
585                    prot,
586                    MAP_PRIVATE,
587                    fd,
588                    offset_of_page)) == (void *)-1) {
589    return NULL;
590  }
591#endif
592  /* UNLOCK_MMAP_LOCK(); */
593  return (void *) (((unsigned)start) + offset_in_page);
594}
595
596BytePtr pagemap_limit = NULL, 
597  reloctab_limit = NULL, markbits_limit = NULL;
598void
599ensure_gc_structures_writable()
600{
601  unsigned 
602    ndwords = area_dword(lisp_global(HEAP_END),lisp_global(HEAP_START)),
603    npages = (lisp_global(HEAP_END)-lisp_global(HEAP_START)) >> 12,
604    markbits_size = 12+((ndwords+7)>>3),
605    reloctab_size = (sizeof(LispObj)*(((ndwords+31)>>5)+1)),
606    pagemap_size = align_to_power_of_2(npages*sizeof(pageentry),12);
607  BytePtr
608    new_reloctab_limit = ((BytePtr)global_reloctab)+reloctab_size,
609    new_markbits_limit = ((BytePtr)global_mark_ref_bits)+markbits_size,
610    new_pagemap_limit = ((BytePtr)pagemap)+ pagemap_size;
611
612  if (new_reloctab_limit > reloctab_limit) {
613    UnProtectMemory(global_reloctab, reloctab_size);
614    reloctab_limit = new_reloctab_limit;
615  }
616 
617  if (new_markbits_limit > markbits_limit) {
618    UnProtectMemory(global_mark_ref_bits, markbits_size);
619    markbits_limit = new_markbits_limit;
620  }
621 
622  if (new_pagemap_limit > pagemap_limit) {
623    UnProtectMemory(pagemap,align_to_power_of_2(npages*sizeof(pageentry),12));
624    pagemap_limit = new_pagemap_limit;
625  }
626
627}
628
629protected_area_ptr
630oldspace_protected_area = NULL;
631
632area *
633allocate_dynamic_area(unsigned initsize)
634{
635  unsigned totalsize = align_to_power_of_2(initsize, log2_heap_segment_size);
636  BytePtr start, end;
637  area *a;
638
639  start = allocate_from_reserved_area(totalsize);
640  if (start == NULL) {
641    return NULL;
642  }
643  end = start + totalsize;
644  a = new_area(start, end, AREA_DYNAMIC);
645  a->active = start+initsize;
646  add_area(a);
647  a->markbits = reserved_area->markbits;
648  reserved_area->markbits = NULL;
649  UnProtectMemory(start, end-start);
650  a->h = start;
651  a->softprot = NULL;
652  a->hardprot = NULL;
653  oldspace_protected_area = new_protected_area(start, end, kTenuredprotect, 0, false);
654  a->hardlimit = end;
655  ensure_gc_structures_writable();
656  return a;
657}
658
659
660Boolean
661grow_dynamic_area(unsigned delta)
662{
663  area *a = active_dynamic_area, *reserved = reserved_area;
664  unsigned avail = reserved->high - reserved->low;
665 
666  delta = align_to_power_of_2(delta, log2_heap_segment_size);
667  if (delta > avail) {
668    delta = avail;
669  }
670  if (!allocate_from_reserved_area(delta)) {
671    return false;
672  }
673  if ( nrs_GC_EVENT_STATUS_BITS.vcell & gc_retain_pages_bit) {
674    commit_pages(a->high,delta);
675  }
676
677  a->high += delta;
678  a->ndwords = area_dword(a->high, a->low);
679  a->hardlimit = a->high;
680  oldspace_protected_area->end = a->high;
681  lisp_global(HEAP_END) += delta;
682  ensure_gc_structures_writable();
683  return true;
684}
685
686/*
687  As above.  Pages that're returned to the reserved_area are
688  "condemned" (e.g, we try to convince the OS that they never
689  existed ...)
690*/
691Boolean
692shrink_dynamic_area(unsigned delta)
693{
694  area *a = active_dynamic_area, *reserved = reserved_area;
695 
696  delta = align_to_power_of_2(delta, log2_heap_segment_size);
697
698  a->high -= delta;
699  a->ndwords = area_dword(a->high, a->low);
700  a->hardlimit = a->high;
701  oldspace_protected_area->end = a->high;
702  uncommit_pages(a->high, delta);
703  reserved->low -= delta;
704  reserved->ndwords += (delta>>3);
705  lisp_global(HEAP_END) -= delta;
706  return true;
707}
708
709
710/*
711 interrupt-level is >= 0 when interrupts are enabled and < 0
712 during without-interrupts. Normally, it is 0. When this timer
713 goes off, it sets it to 1 if it's 0, or if it's negative,
714 walks up the special binding list looking for a previous
715 value of 0 to set to 1.
716*/
717
718 
719
720
721
722typedef struct {
723  int total_hits;
724  int lisp_hits;
725  int active;
726  int interval;
727} metering_info;
728
729metering_info
730lisp_metering =
731{
732  0, 
733  0, 
734  0, 
735  0
736  };
737
738void
739metering_proc(int signum, struct sigcontext *context)
740{
741  lisp_metering.total_hits++;
742#ifndef DARWIN
743#ifdef BAD_IDEA
744  if (xpGPR(context,rnil) == lisp_nil) {
745    unsigned current_lisp = lisp_metering.lisp_hits, element;
746    LispObj
747      rpc = (LispObj) xpPC(context),
748      rfn = xpGPR(context, fn),
749      rnfn = xpGPR(context, nfn),
750      reg,
751      v =  nrs_ALLMETEREDFUNS.vcell;
752
753    if (area_containing((BytePtr)rfn) == NULL) {
754      rfn = (LispObj) 0;
755    }
756    if (area_containing((BytePtr)rnfn) == NULL) {
757      rnfn = (LispObj) 0;
758    }
759
760    if (tag_of(rpc) == tag_fixnum) {
761      if (register_codevector_contains_pc(rfn, rpc)) {
762        reg = rfn;
763      } else if (register_codevector_contains_pc(rnfn, rpc)) {
764        reg = rnfn;
765      } else {
766        reg = rpc;
767      }
768      element = current_lisp % lisp_metering.active;
769      lisp_metering.lisp_hits++;
770      deref(v,element+1) = reg; /* NOT memoized */
771    }
772  }
773#endif
774#endif
775}
776
777void
778sigint_handler (int signum, siginfo_t *info, struct ucontext *context)
779{
780  if (signum == SIGINT) {
781    lisp_global(INTFLAG) = (1 << fixnumshift);
782  }
783#ifdef DARWIN
784  DarwinSigReturn(context);
785#endif
786}
787
788
789
790void
791start_vbl()
792{
793  struct sigaction sa;
794
795  sa.sa_sigaction = (void *)sigint_handler;
796  sigfillset(&sa.sa_mask);
797  sa.sa_flags = SA_RESTART | SA_SIGINFO;
798
799  sigaction(SIGINT, &sa, NULL);
800 
801}
802
803
804extern BytePtr
805current_stack_pointer(void);
806
807BytePtr
808initial_stack_bottom()
809{
810  extern char **environ;
811  char *p = *environ;
812  while (*p) {
813    p += (1+strlen(p));
814  }
815  return (BytePtr)((((unsigned) p) +4095) & ~4095);
816}
817
818
819 
820Ptr fatal_spare_ptr = NULL;
821
822void
823prepare_for_the_worst()
824{
825  /* I guess that CouldDialog is no more */
826  /* CouldDialog(666); */
827}
828
829void
830Fatal(StringPtr param0, StringPtr param1)
831{
832
833  if (fatal_spare_ptr) {
834    deallocate(fatal_spare_ptr);
835    fatal_spare_ptr = NULL;
836  }
837  fprintf(stderr, "Fatal error: %s\n%s\n", param0, param1);
838  exit(-1);
839}
840
841OSErr application_load_err = noErr;
842
843area *
844set_nil(LispObj);
845
846
847#ifdef DARWIN
848/*
849   The underlying file system may be case-insensitive (e.g., HFS),
850   so we can't just case-invert the kernel's name.
851   Tack ".image" onto the end of the kernel's name.  Much better ...
852*/
853char *
854default_image_name(char *orig)
855{
856  int len = strlen(orig) + strlen(".image") + 1;
857  char *copy = (char *) malloc(len);
858
859  if (copy) {
860    strcat(copy, orig);
861    strcat(copy, ".image");
862  }
863  return copy;
864}
865
866#else
867char *
868default_image_name(char *orig)
869{
870  char *copy = strdup(orig), *base = copy, *work = copy, c;
871  if (copy == NULL) {
872    return NULL;
873  }
874  while(*work) {
875    if (*work++ == '/') {
876      base = work;
877    }
878  }
879  work = base;
880  while (c = *work) {
881    if (islower(c)) {
882      *work++ = toupper(c);
883    } else {
884      *work++ = tolower(c);
885    }
886  }
887  return copy;
888}
889#endif
890
891
892char *program_name = NULL;
893
894void
895usage_exit(char *herald, int exit_status, char* other_args)
896{
897  if (herald && *herald) {
898    fprintf(stderr, "%s\n", herald);
899  }
900  fprintf(stderr, "usage: %s <options>\n", program_name);
901  fprintf(stderr, "\t or %s <image-name>\n", program_name);
902  fprintf(stderr, "\t where <options> are one or more of:\n");
903  if (other_args && *other_args) {
904    fputs(other_args, stderr);
905  }
906  fprintf(stderr, "\t-R, --heap-reserve <n>: reserve <n> (default: %d)\n",
907          reserved_area_size);
908  fprintf(stderr, "\t\t bytes for heap expansion\n");
909  fprintf(stderr, "\t-S, --stack-size <n>: set size of initial stacks to <n> (default: %d)\n", initial_stack_size);
910  fprintf(stderr, "\t-b, --batch: exit when EOF on *STANDARD-INPUT*\n");
911  fprintf(stderr, "\t--no-sigtrap : obscure option for running under GDB\n");
912  fprintf(stderr, "\t-I, --image-name <image-name>\n");
913  fprintf(stderr, "\t and <image-name> defaults to %s\n", 
914          default_image_name(program_name));
915  fprintf(stderr, "\n");
916  exit(exit_status);
917}
918
919int no_sigtrap = 0;
920char *image_name = NULL;
921int batch_flag = 0;
922
923
924unsigned
925parse_numeric_option(char *arg, char *argname, unsigned default_val)
926{
927  char *tail;
928  unsigned val = 0;
929
930  val = strtoul(arg, &tail, 0);
931  switch(*tail) {
932  case '\0':
933    break;
934   
935  case 'M':
936  case 'm':
937    val = val << 20;
938    break;
939   
940  case 'K':
941  case 'k':
942    val = val << 10;
943    break;
944   
945  case 'G':
946  case 'g':
947    val = val << 30;
948    break;
949   
950  default:
951    fprintf(stderr, "couldn't parse %s argument %s", argname, arg);
952    val = default_val;
953    break;
954  }
955  return val;
956}
957 
958
959
960/*
961   The set of arguments recognized by the kernel is
962   likely to remain pretty small and pretty simple.
963   This removes everything it recognizes from argv;
964   remaining args will be processed by lisp code.
965*/
966
967void
968process_options(int argc, char *argv[])
969{
970  int i, j, k, num_elide, flag, arg_error;
971  char *arg, *val;
972#ifdef DARWIN
973  extern int NXArgc;
974#endif
975
976  for (i = 1; i < argc;) {
977    arg = argv[i];
978    arg_error = 0;
979    if (*arg != '-') {
980      i++;
981    } else {
982      num_elide = 0;
983      val = NULL;
984      if ((flag = (strncmp(arg, "-I", 2) == 0)) ||
985          (strcmp (arg, "--image-name") == 0)) {
986        if (flag && arg[2]) {
987          val = arg+2;
988          num_elide = 1;
989        } else {
990          if ((i+1) < argc) {
991            val = argv[i+1];
992            num_elide = 2;
993          } else {
994            arg_error = 1;
995          }
996        }
997        if (val) {
998          image_name = val;
999        }
1000      } else if ((flag = (strncmp(arg, "-R", 2) == 0)) ||
1001                 (strcmp(arg, "--heap-reserve") == 0)) {
1002        unsigned reserved_size;
1003
1004        if (flag && arg[2]) {
1005          val = arg+2;
1006          num_elide = 1;
1007        } else {
1008          if ((i+1) < argc) {
1009            val = argv[i+1];
1010            num_elide = 2;
1011          } else {
1012            arg_error = 1;
1013          }
1014        }
1015
1016        if (val) {
1017          reserved_size = parse_numeric_option(val, 
1018                                               "-R/--heap-reserve", 
1019                                               reserved_area_size);
1020        }
1021
1022        if (reserved_size <= (1<< 30)) {
1023          reserved_area_size = reserved_size;
1024        }
1025
1026      } else if ((flag = (strncmp(arg, "-S", 2) == 0)) ||
1027                 (strcmp(arg, "--stack-size") == 0)) {
1028        unsigned stack_size;
1029
1030        if (flag && arg[2]) {
1031          val = arg+2;
1032          num_elide = 1;
1033        } else {
1034          if ((i+1) < argc) {
1035            val = argv[i+1];
1036            num_elide = 2;
1037          } else {
1038            arg_error = 1;
1039          }
1040        }
1041
1042        if (val) {
1043          stack_size = parse_numeric_option(val, 
1044                                            "-S/--stack-size", 
1045                                            initial_stack_size);
1046         
1047
1048          if (stack_size >= MIN_CSTACK_SIZE) {
1049            initial_stack_size = stack_size;
1050          }
1051        }
1052
1053      } else if (strcmp(arg, "--no-sigtrap") == 0) {
1054        no_sigtrap = 1;
1055        num_elide = 1;
1056      } else if ((strcmp(arg, "-b") == 0) ||
1057                 (strcmp(arg, "--batch") == 0)) {
1058        batch_flag = 1;
1059        num_elide = 1;
1060      } else {
1061        i++;
1062      }
1063      if (arg_error) {
1064        usage_exit("error in program arguments", 1, "");
1065      }
1066      if (num_elide) {
1067        for (j = i+num_elide, k=i; j < argc; j++, k++) {
1068          argv[k] = argv[j];
1069        }
1070        argc -= num_elide;
1071#ifdef DARWIN
1072        NXArgc -= num_elide;
1073#endif
1074        argv[argc] = NULL;
1075      }
1076    }
1077  }
1078}
1079
1080pid_t main_thread_pid = (pid_t)0;
1081
1082void
1083terminate_lisp()
1084{
1085  kill(main_thread_pid, SIGKILL);
1086  exit(-1);
1087}
1088
1089
1090 
1091main(int argc, char *argv[], char *envp[], void *aux)
1092{
1093  extern  set_fpscr(unsigned);
1094
1095  extern int altivec_present;
1096  extern LispObj load_image(char *);
1097  long resp;
1098  BytePtr stack_end;
1099  area *a;
1100  BytePtr stack_base, current_sp = current_stack_pointer();
1101  TCR *tcr;
1102
1103#ifdef LINUX
1104  {
1105    ElfW(auxv_t) *av = aux;
1106    int hwcap, done = false;
1107   
1108    if (av) {
1109      do {
1110        switch (av->a_type) {
1111        case AT_DCACHEBSIZE:
1112          cache_block_size = av->a_un.a_val;
1113          break;
1114
1115        case AT_HWCAP:
1116          hwcap = av->a_un.a_val;
1117          altivec_present = ((hwcap & PPC_FEATURE_HAS_ALTIVEC) != 0);
1118          break;
1119
1120        case AT_NULL:
1121          done = true;
1122          break;
1123        }
1124        av++;
1125      } while (!done);
1126    }
1127  }
1128#endif
1129#ifdef DARWIN
1130  {
1131    unsigned value = 0;
1132    size_t len = sizeof(value);
1133    int mib[2];
1134   
1135    mib[0] = CTL_HW;
1136    mib[1] = HW_CACHELINE;
1137    if (sysctl(mib,2,&value,&len, NULL, 0) != -1) {
1138      if (len == sizeof(value)) {
1139        cache_block_size = value;
1140      }
1141    }
1142    mib[1] = HW_VECTORUNIT;
1143    value = 0;
1144    len = sizeof(value);
1145    if (sysctl(mib,2,&value,&len, NULL, 0) != -1) {
1146      if (len == sizeof(value)) {
1147        altivec_present = value;
1148      }
1149    }
1150  }
1151#endif
1152
1153  main_thread_pid = getpid();
1154  area_lock = (void *)new_recursive_lock();
1155
1156  program_name = argv[0];
1157  if ((argc == 2) && (*argv[1] != '-')) {
1158#ifdef DARWIN
1159    extern int NXArgc;
1160    NXArgc = 1;
1161#endif
1162    image_name = argv[1];
1163    argv[1] = NULL;
1164  } else {
1165    process_options(argc,argv);
1166  }
1167  initial_stack_size = ensure_stack_limit(initial_stack_size);
1168  if (image_name == NULL) {
1169    if (check_for_embedded_image(argv[0])) {
1170      image_name = argv[0];
1171    } else {
1172      image_name = default_image_name(argv[0]);
1173    }
1174  }
1175
1176  prepare_for_the_worst();
1177
1178  real_subprims_base = (LispObj)(1<<20);
1179  create_reserved_area(reserved_area_size);
1180  set_nil(load_image(image_name));
1181  lisp_global(SUBPRIMS_BASE) = (LispObj)(1<<20);
1182  lisp_global(RET1VALN) = (LispObj)&ret1valn;
1183  lisp_global(LEXPR_RETURN) = (LispObj)&nvalret;
1184  lisp_global(LEXPR_RETURN1V) = (LispObj)&popj;
1185  lisp_global(ALL_AREAS) = (LispObj) (all_areas);
1186
1187
1188
1189  exception_init();
1190
1191  if (lisp_global(SUBPRIMS_BASE) == 0) {
1192    Fatal(": Couldn't load subprims library.", "");
1193  }
1194 
1195
1196  lisp_global(IMAGE_NAME) = (LispObj) image_name;
1197  lisp_global(ARGV) = (LispObj) argv;
1198  lisp_global(KERNEL_IMPORTS) = (LispObj) import_ptrs_base;
1199
1200  lisp_global(METERING_INFO) = (LispObj) &lisp_metering;
1201  lisp_global(GET_TCR) = (LispObj) get_tcr;
1202  *(double *) &(lisp_global(DOUBLE_FLOAT_ONE)) = (double) 1.0;
1203
1204  lisp_global(ARGV) = (LispObj) argv;
1205  lisp_global(HOST_PLATFORM) = (LispObj)
1206#ifdef LINUX
1207    1
1208#endif
1209#ifdef DARWIN
1210    3
1211#endif
1212    /* We'll get a syntax error here if nothing's defined. */
1213    << fixnumshift;
1214
1215
1216  lisp_global(BATCH_FLAG) = (batch_flag << fixnumshift);
1217
1218  a = active_dynamic_area;
1219
1220  if (nilreg_area != NULL) {
1221    BytePtr lowptr = (BytePtr) a->low;
1222
1223    /* Create these areas as AREA_STATIC, change them to AREA_DYNAMIC */
1224    g1_area = new_area(lowptr, lowptr, AREA_STATIC);
1225    g2_area = new_area(lowptr, lowptr, AREA_STATIC);
1226    tenured_area = new_area(lowptr, lowptr, AREA_STATIC);
1227    add_area(tenured_area);
1228    add_area(g2_area);
1229    add_area(g1_area);
1230
1231    g1_area->code = AREA_DYNAMIC;
1232    g2_area->code = AREA_DYNAMIC;
1233    tenured_area->code = AREA_DYNAMIC;
1234
1235/*    a->older = g1_area; */ /* Not yet: this is what "enabling the EGC" does. */
1236    g1_area->younger = a;
1237    g1_area->older = g2_area;
1238    g2_area->younger = g1_area;
1239    g2_area->older = tenured_area;
1240    tenured_area->younger = g2_area;
1241    tenured_area->refbits = a->markbits;
1242    lisp_global(TENURED_AREA) = (LispObj)(tenured_area);
1243    g2_area->threshold = (4<<20); /* 4MB */
1244    g1_area->threshold = (2<<20); /* 2MB */
1245    a->threshold = (1<<20);     /* 1MB */
1246  }
1247
1248  tcr = new_tcr(initial_stack_size, MIN_TSTACK_SIZE);
1249  stack_base = initial_stack_bottom()-xStackSpace();
1250  init_threads((void *)(stack_base), tcr);
1251  thread_init_tcr(tcr, current_sp, current_sp-stack_base);
1252
1253  lisp_global(EXCEPTION_LOCK) = (LispObj)new_recursive_lock();
1254  enable_fp_exceptions();
1255  start_vbl();
1256
1257  lisp_global(ALTIVEC_PRESENT) = altivec_present << fixnumshift;
1258#if STATIC
1259  lisp_global(STATICALLY_LINKED) = 1 << fixnumshift;
1260#endif
1261  tcr->prev = tcr->next = tcr;
1262  lisp_global(TCR_LOCK) = (LispObj)new_recursive_lock();
1263  lisp_global(INTERRUPT_SIGNAL) = (LispObj) box_fixnum(SIGNAL_FOR_PROCESS_INTERRUPT);
1264  tcr->interrupt_level = (-1<<fixnumshift);
1265  tcr->vs_area->active -= 4;
1266  *(--tcr->save_vsp) = nrs_TOPLFUNC.vcell;
1267  nrs_TOPLFUNC.vcell = lisp_nil;
1268  enable_fp_exceptions();
1269#if 1
1270  egc_control(true, NULL);
1271#endif
1272  start_lisp(tcr, 0);
1273  exit(0);
1274}
1275
1276area *
1277set_nil(LispObj r)
1278{
1279
1280  if (lisp_nil == (LispObj)NULL) {
1281
1282    lisp_nil = r;
1283  }
1284  return NULL;
1285}
1286
1287
1288void
1289xMakeDataExecutable(void *start, unsigned nbytes)
1290{
1291  extern void flush_cache_lines();
1292  unsigned ustart = (unsigned) start, base, end;
1293 
1294  base = (ustart) & ~(cache_block_size-1);
1295  end = (ustart + nbytes + cache_block_size - 1) & ~(cache_block_size-1);
1296  flush_cache_lines(base, (end-base)/cache_block_size, cache_block_size);
1297}
1298
1299int
1300xStackSpace()
1301{
1302  return initial_stack_size+CSTACK_HARDPROT+CSTACK_SOFTPROT;
1303}
1304
1305#ifndef DARWIN
1306void *
1307xGetSharedLibrary(char *path, int mode)
1308{
1309  return dlopen(path, mode);
1310}
1311#else
1312void *
1313xGetSharedLibrary(char *path, int mode)
1314{
1315  NSObjectFileImageReturnCode code;
1316  NSObjectFileImage              moduleImage;
1317  NSModule                       module;
1318  const struct mach_header *     header;
1319  const char *                   error;
1320  int *                          resultType;
1321  void *                         result;
1322  /* not thread safe */
1323  /*
1324  static struct {
1325    const struct mach_header  *header;
1326    NSModule                  *module;
1327    const char                *error;
1328  } results;   
1329  */
1330  resultType = (int *)mode;
1331  result = NULL;
1332  error = NULL;
1333
1334  /* first try to open this as a bundle */
1335  code = NSCreateObjectFileImageFromFile(path,&moduleImage);
1336  if (code != NSObjectFileImageSuccess &&
1337      code != NSObjectFileImageInappropriateFile &&
1338      code != NSObjectFileImageAccess)
1339    {
1340      /* compute error strings */
1341      switch (code)
1342        {
1343        case NSObjectFileImageFailure:
1344          error = "NSObjectFileImageFailure";
1345          break;
1346        case NSObjectFileImageArch:
1347          error = "NSObjectFileImageArch";
1348          break;
1349        case NSObjectFileImageFormat:
1350          error = "NSObjectFileImageFormat";
1351          break;
1352        case NSObjectFileImageAccess:
1353          /* can't find the file */
1354          error = "NSObjectFileImageAccess";
1355          break;
1356        default:
1357          error = "unknown error";
1358        }
1359      *resultType = 0;
1360      return (void *)error;
1361    }
1362  if (code == NSObjectFileImageInappropriateFile ||
1363      code == NSObjectFileImageAccess ) {
1364    /* the pathname might be a partial pathane (hence the access error)
1365       or it might be something other than a bundle, if so perhaps
1366       it is a .dylib so now try to open it as a .dylib */
1367
1368    /* protect against redundant loads, Gary Byers noticed possible
1369       heap corruption if this isn't done */
1370    header = NSAddImage(path, NSADDIMAGE_OPTION_RETURN_ON_ERROR |
1371                        NSADDIMAGE_OPTION_WITH_SEARCHING |
1372                        NSADDIMAGE_OPTION_RETURN_ONLY_IF_LOADED);
1373    if (!header)
1374      header = NSAddImage(path, NSADDIMAGE_OPTION_RETURN_ON_ERROR |
1375                          NSADDIMAGE_OPTION_WITH_SEARCHING);
1376    result = (void *)header;
1377    *resultType = 1;
1378  }
1379  else if (code == NSObjectFileImageSuccess) {
1380    /* we have a sucessful module image
1381       try to link it, don't bind symbols privately */
1382
1383    module = NSLinkModule(moduleImage, path,
1384                          NSLINKMODULE_OPTION_RETURN_ON_ERROR | NSLINKMODULE_OPTION_BINDNOW);
1385    NSDestroyObjectFileImage(moduleImage);     
1386    result = (void *)module;
1387    *resultType = 2;
1388  }
1389  if (!result)
1390    {
1391      /* compute error string */
1392      NSLinkEditErrors ler;
1393      int lerno;
1394      const char* file;
1395      NSLinkEditError(&ler,&lerno,&file,&error);
1396      if (error) {
1397        result = (void *)error;
1398        *resultType = 0;
1399      }
1400    }
1401  return result;
1402}
1403#endif
1404
1405
1406
1407
1408int
1409metering_control(int interval)
1410{
1411#ifdef DARWIN
1412  return -1;
1413#else
1414  if (interval) {
1415    if (! lisp_metering.active) {
1416      LispObj amf = nrs_ALLMETEREDFUNS.vcell;
1417      if (fulltag_of(amf) == fulltag_misc) {
1418        unsigned header = header_of(amf);
1419
1420        if (header_subtag(header) == subtag_simple_vector) {
1421
1422          lisp_metering.interval = interval;
1423          lisp_metering.total_hits = 0;
1424          lisp_metering.lisp_hits = 0;
1425          lisp_metering.active = header_element_count(header);
1426          return 0;
1427        }
1428      }
1429    }
1430    return -1;
1431  }  else {
1432    if (lisp_metering.active) {
1433      lisp_metering.active = 0;
1434      return 0;
1435    } else {
1436      return -1;
1437    }
1438  }
1439#endif
1440}
1441
1442
1443
1444
1445
1446int
1447fd_setsize_bytes()
1448{
1449  return FD_SETSIZE/8;
1450}
1451
1452void
1453do_fd_set(int fd, fd_set *fdsetp)
1454{
1455  FD_SET(fd, fdsetp);
1456}
1457
1458void
1459do_fd_clr(int fd, fd_set *fdsetp)
1460{
1461  FD_CLR(fd, fdsetp);
1462}
1463
1464int
1465do_fd_is_set(int fd, fd_set *fdsetp)
1466{
1467  return FD_ISSET(fd,fdsetp);
1468}
1469
1470void
1471do_fd_zero(fd_set *fdsetp)
1472{
1473  FD_ZERO(fdsetp);
1474}
1475
1476#include "image.h"
1477
1478
1479Boolean
1480check_for_embedded_image (char *path)
1481{
1482  int fd = open(path, O_RDONLY);
1483  Boolean image_is_embedded = false;
1484
1485  if (fd >= 0) {
1486    openmcl_image_file_header h;
1487
1488    if (find_openmcl_image_file_header (fd, &h)) {
1489      image_is_embedded = true;
1490    }
1491    close (fd);
1492  }
1493  return image_is_embedded;
1494}
1495
1496LispObj
1497load_image(char *path)
1498{
1499  int fd = open(path, O_RDONLY, 0666);
1500  LispObj image_nil = 0;
1501  if (fd > 0) {
1502    openmcl_image_file_header ih;
1503    image_nil = load_openmcl_image(fd, &ih);
1504    /* We -were- using a duplicate fd to map the file; that
1505       seems to confuse Darwin (doesn't everything ?), so
1506       we'll instead keep the original file open.
1507    */
1508    if (!image_nil) {
1509      close(fd);
1510    }
1511  }
1512  if (image_nil == 0) {
1513    fprintf(stderr, "Couldn't load lisp heap image from %s\n", path);
1514    exit(-1);
1515  }
1516  return image_nil;
1517}
1518
1519int
1520set_errno(int val)
1521{
1522  errno = val;
1523  return -1;
1524}
1525
1526
1527
1528
1529void *
1530xFindSymbol(void* handle, char *name)
1531{
1532#ifdef LINUX
1533  return dlsym(handle, name);
1534#endif
1535#ifdef DARWIN
1536  unsigned long address = 0;
1537
1538  if (handle == NULL) {
1539    if (NSIsSymbolNameDefined(name)) { /* Keep dyld_lookup from crashing */
1540      _dyld_lookup_and_bind(name, &address, (void**) NULL);
1541    }
1542    return (void *)address;
1543  }
1544  Bug(NULL, "How did this happen ?");
1545#endif
1546}
1547
Note: See TracBrowser for help on using the repository browser.