runtime.c

Scheme跨平台编译器

  p = (C_byte *)mmap (NULL, size, (PROT_READ | PROT_WRITE),
                      (MAP_PRIVATE | MAP_ANON), -1, 0);
  if (p != NULL && page_aligned) *page_aligned = p;
#else
  p = (C_byte *)C_malloc (size + page_size);
  if (p != NULL && page_aligned) *page_aligned = align_to_page (p);
#endif

  /* . */
  return p;
}

static void
heap_free (C_byte *ptr, size_t size)
{
#ifdef C_LOCK_TOSPACE
  int r = munmap (ptr, size);
  assert (r == 0);
#else
  C_free (ptr);
#endif
  /* . */
}

static C_byte *
heap_realloc (C_byte *ptr, size_t old_size,
	      size_t new_size, C_byte **page_aligned)
{
  C_byte *p;
#ifdef C_LOCK_TOSPACE
  p = (C_byte *)mmap (NULL, new_size, (PROT_READ | PROT_WRITE),
                      (MAP_PRIVATE | MAP_ANON), -1, 0);
  if (ptr != NULL) {
    memcpy (p, ptr, old_size);
    heap_free (ptr, old_size);
  }
  if (p != NULL && page_aligned) *page_aligned = p;
#else
  p = (C_byte *)C_realloc (ptr, new_size + page_size);
  if (p != NULL && page_aligned) *page_aligned = align_to_page (p);
#endif

  /* . */
  return p;
}

/* Modify heap size at runtime: */

void C_set_or_change_heap_size(C_word heap, int reintern)
{
  C_byte *ptr1, *ptr2, *ptr1a, *ptr2a;
  C_word size = heap / 2;

  if(heap_size_changed && fromspace_start) return;

  if(fromspace_start && heap_size >= heap) return;

  if(debug_mode) C_printf(C_text("[debug] heap resized to %d bytes\n"), (int)heap);

  heap_size = heap;

  if((ptr1 = heap_realloc (fromspace_start,
			   C_fromspace_limit - fromspace_start,
			   size, &ptr1a)) == NULL ||
     (ptr2 = heap_realloc (tospace_start,
			   tospace_limit - tospace_start,
			   size, &ptr2a)) == NULL)
    panic(C_text("out of memory - can not allocate heap"));

  heapspace1 = ptr1, heapspace1_size = size;
  heapspace2 = ptr2, heapspace2_size = size;
  fromspace_start = ptr1a;
  C_fromspace_top = fromspace_start;
  C_fromspace_limit = fromspace_start + size;
  tospace_start = ptr2a;
  tospace_top = tospace_start;
  tospace_limit = tospace_start + size;
  mutation_stack_top = mutation_stack_bottom;
  lock_tospace(1);

  if(reintern) initialize_symbol_table();
}
 

/* Modify stack-size at runtime: */

void C_do_resize_stack(C_word stack)
{
  C_uword old = stack_size,
          diff = stack - old;

  if(diff != 0 && !stack_size_changed) {
    if(debug_mode) C_printf(C_text("[debug] stack resized to %d bytes\n"), (int)stack);

    stack_size = stack;

#if C_STACK_GROWS_DOWNWARD
    C_stack_limit = (C_word *)((C_byte *)C_stack_limit - diff);
#else
    C_stack_limit = (C_word *)((C_byte *)C_stack_limit + diff);
#endif
  }
}


/* Check whether nursery is sufficiently big: */

void C_check_nursery_minimum(C_word words)
{
  if(words >= C_bytestowords(stack_size))
    panic(C_text("nursery is too small - try higher setting using the `-:s' option"));
}

C_word C_resize_pending_finalizers(C_word size) {
  int sz = C_num_to_int(size);

  FINALIZER_NODE **newmem = 
    (FINALIZER_NODE **)C_realloc(pending_finalizer_indices, sz * sizeof(FINALIZER_NODE *));
  
  if (newmem == NULL)
    return C_SCHEME_FALSE;

  pending_finalizer_indices = newmem;
  C_max_pending_finalizers = sz;
  return C_SCHEME_TRUE;
}


/* Parse runtime options from command-line: */

void CHICKEN_parse_command_line(int argc, char *argv[], C_word *heap, C_word *stack, C_word *symbols)
{
  int i;
  char *ptr;
  C_word x;

  C_main_argc = argc;
  C_main_argv = argv;
  *heap = DEFAULT_HEAP_SIZE;
  *stack = DEFAULT_STACK_SIZE;
  *symbols = DEFAULT_SYMBOL_TABLE_SIZE;

  for(i = 1; i < C_main_argc; ++i)
    if(!strncmp(C_main_argv[ i ], C_text("-:"), 2)) {
      for(ptr = &C_main_argv[ i ][ 2 ]; *ptr != '\0';) {
	switch(*(ptr++)) {
	case '?':
	  C_printf("\nRuntime options:\n\n"
		 " -:?              display this text\n"
		 " -:c              always treat stdin as console\n"
		 " -:d              enable debug output\n"
		 " -:D              enable more debug output\n"
		 " -:o              disable stack overflow checks\n"
		 " -:hiSIZE         set initial heap size\n"
		 " -:hmSIZE         set maximal heap size\n"
		 " -:hgPERCENTAGE   set heap growth percentage\n"
		 " -:hsPERCENTAGE   set heap shrink percentage\n"
		 " -:hSIZE          set fixed heap size\n"
		 " -:r              write trace output to stderr\n"
		 " -:sSIZE          set nursery (stack) size\n"
		 " -:tSIZE          set symbol-table size\n"
                 " -:fSIZE          set maximal number of pending finalizers\n"
		 " -:w              enable garbage collection of unused symbols\n"
		 " -:x              deliver uncaught exceptions of other threads to primordial one\n"
		 " -:b              enter REPL on error\n"
		 " -:B              sound bell on major GC\n"
		 " -:aSIZE          set trace-buffer/call-chain size\n"
		 "\n  SIZE may have a `k' (`K'), `m' (`M') or `g' (`G') suffix, meaning size\n"
		 "  times 1024, 1048576, and 1073741824, respectively.\n\n");
	  exit(0);

	case 'h':
	  switch(*ptr) {
	  case 'i':
	    *heap = arg_val(ptr + 1); 
	    heap_size_changed = 1;
	    goto next;
	  case 'g':
	    C_heap_growth = arg_val(ptr + 1);
	    goto next;
	  case 'm':
	    C_maximal_heap_size = arg_val(ptr + 1);
	    goto next;
	  case 's':
	    C_heap_shrinkage = arg_val(ptr + 1);
	    goto next;
	  default:
	    *heap = arg_val(ptr); 
	    heap_size_changed = 1;
	    C_heap_size_is_fixed = 1;
	    goto next;
	  }

	case 'o':
	  C_disable_overflow_check = 1;
	  break;

	case 'B':
	  gc_bell = 1;
	  break;

	case 's':
	  *stack = arg_val(ptr);
	  stack_size_changed = 1;
	  goto next;

	case 'f':
	  C_max_pending_finalizers = arg_val(ptr);
	  goto next;

	case 'a':
	  C_trace_buffer_size = arg_val(ptr);
	  goto next;

	case 't':
	  *symbols = arg_val(ptr);
	  goto next;

	case 'c':
	  fake_tty_flag = 1;
	  break;

	case 'd':
	  debug_mode = 1;
	  break;

	case 'D':
	  debug_mode = 2;
	  break;

	case 'w':
	  C_enable_gcweak = 1;
	  break;

	case 'r':
	  show_trace = 1;
	  break;

	case 'x':
	  C_abort_on_thread_exceptions = 1;
	  break;

	case 'b':
	  C_enable_repl = 1;
	  break;

	default: panic(C_text("illegal runtime option"));
	}
      }

    next:;
    }
}


C_word arg_val(C_char *arg)
{
     int len;
     
     if (arg == NULL) panic(C_text("illegal runtime-option argument"));
     
     len = C_strlen(arg);
     
     if(len < 1) panic(C_text("illegal runtime-option argument"));
     
     switch(arg[ len - 1 ]) {
     case 'k':
     case 'K':
	  return atol(arg) * 1024;
	  
     case 'm':
     case 'M':
	  return atol(arg) * 1024 * 1024;
	  
     case 'g':
     case 'G':
	  return atol(arg) * 1024 * 1024 * 1024;
	  
     default:
	  return atol(arg);
     }
}


/* Run embedded code with arguments: */

C_word CHICKEN_run(void *toplevel)
{
  if(!chicken_is_initialized && !CHICKEN_initialize(0, 0, 0, toplevel))
    panic(C_text("could not initialize"));

  if(chicken_is_running)
    panic(C_text("re-invocation of Scheme world while process is already running"));

  chicken_is_running = chicken_ran_once = 1;
  return_to_host = 0;

#if C_STACK_GROWS_DOWNWARD
  C_stack_limit = (C_word *)((C_byte *)C_stack_pointer - stack_size);
#else
  C_stack_limit = (C_word *)((C_byte *)C_stack_pointer + stack_size);
#endif

  stack_bottom = C_stack_pointer;

  if(debug_mode)
    C_printf(C_text("[debug] stack bottom is 0x%lx.\n"), (long)stack_bottom);

  /* The point of (usually) no return... */
  C_setjmp(C_restart);

  if(!return_to_host)
    (C_restart_trampoline)(C_restart_address);

  chicken_is_running = 0;
  return C_restore;
}


C_word CHICKEN_continue(C_word k)
{
  if(C_temporary_stack_bottom != C_temporary_stack)
    panic(C_text("invalid temporary stack level"));

  if(!chicken_is_initialized)
    panic(C_text("runtime system has not been initialized - `CHICKEN_run' has probably not been called"));

  C_save(k);
  return CHICKEN_run(NULL);
}


/* Trampoline called at system startup: */

C_regparm void C_fcall initial_trampoline(void *proc)
{
  TOPLEVEL top = (TOPLEVEL)proc;
  C_word closure = (C_word)C_alloc(2);

  ((C_SCHEME_BLOCK *)closure)->header = C_CLOSURE_TYPE | 1;
  C_set_block_item(closure, 0, (C_word)termination_continuation);
  (top)(2, C_SCHEME_UNDEFINED, closure);
}


/* The final continuation: */

void C_ccall termination_continuation(C_word c, C_word self, C_word result)
{
  if(debug_mode) C_printf(C_text("[debug] application terminated normally.\n"));

  exit(0);
}


/* Signal unrecoverable runtime error: */

void panic(C_char *msg)
{
  C_panic_hook(msg);
  usual_panic(msg);
}


void usual_panic(C_char *msg)
{
  C_char *dmp = C_dump_trace(0);

  C_dbg_hook(C_SCHEME_UNDEFINED);

#ifdef C_MICROSOFT_WINDOWS
  C_sprintf(buffer, C_text("%s\n\n%s"), msg, dmp);

  MessageBox(NULL, buffer, C_text("CHICKEN runtime"), MB_OK);
  ExitProcess(1);
#else
  C_fprintf(C_stderr, C_text("\n%s - execution terminated\n\n%s"), msg, dmp);
  
# if defined(__MWERKS__) && !defined(__INTEL__) && !defined(MACINTOSH_GUI)
  C_printf("\n[press RETURN to exit...]");
  C_fflush(C_stdout);
  C_getchar();
# endif

  C_exit(1);
#endif
}


void horror(C_char *msg)
{
  C_dbg_hook(C_SCHEME_UNDEFINED);

#ifdef C_MICROSOFT_WINDOWS
  C_sprintf(buffer, C_text("%s"), msg);

  MessageBox(NULL, buffer, C_text("CHICKEN runtime"), MB_OK);
  ExitProcess(1);
#else
  C_fprintf(C_stderr, C_text("\n%s - execution terminated"), msg);
  
# if defined(__MWERKS__) && !defined(__INTEL__) && !defined(MACINTOSH_GUI)
  C_printf("\n[press RETURN to exit...]");
  C_fflush(C_stdout);
  C_getchar();
# endif

  C_exit(1);
#endif
}


/* Error-hook, called from C-level runtime routines: */

void barf(int code, char *loc, ...)
{
  C_char *msg;
  C_word err = error_hook_symbol;
  int c, i;
  va_list v;

  C_dbg_hook(C_SCHEME_UNDEFINED);

  C_temporary_stack = C_temporary_stack_bottom;
  err = C_u_i_car(err);

  if(C_immediatep(err))
    panic(C_text("`##sys#error-hook' is not defined - the `library' unit was probably not linked with this executable"));

  switch(code) {
  case C_BAD_ARGUMENT_COUNT_ERROR:
    msg = C_text("wrong number of arguments in function call");
    c = 3;
    break;

  case C_BAD_MINIMUM_ARGUMENT_COUNT_ERROR:
    msg = C_text("too few arguments in function call");
    c = 3;
    break;
  
  case C_BAD_ARGUMENT_TYPE_ERROR:
    msg = C_text("bad argument type");
    c = 1;
    break;

  case C_UNBOUND_VARIABLE_ERROR:
    msg = C_text("unbound variable");
    c = 1;
    break;

  case C_TOO_MANY_PARAMETERS_ERROR:
    msg = C_text("parameter limit exceeded");
    c = 0;
    break;

  case C_OUT_OF_MEMORY_ERROR:
    msg = C_text("not enough memory");
    c = 0;
    break;

  case C_DIVISION_BY_ZERO_ERROR:
    msg = C_text("division by zero");
    c = 0;
    break;

  case C_OUT_OF_RANGE_ERROR:
    msg = C_text("out of range");
    c = 2;
    break;

  case C_NOT_A_CLOSURE_ERROR:
    msg = C_text("call of non-procedure");
    c = 1;
    break;

  case C_CONTINUATION_CANT_RECEIVE_VALUES_ERROR:
    msg = C_text("continuation can not receive multiple values");
    c = 1;
    break;

  case C_TOO_DEEP_RECURSION_ERROR:
    msg = C_text("recursion too deep");
    c = 0;
    break;

  case C_CANT_REPRESENT_INEXACT_ERROR:
    msg = C_text("inexact number can not be represented as an exact number");
    c = 1;
    break;

  case C_NOT_A_PROPER_LIST_ERROR:
    msg = C_text("argument is not a proper list");
    c = 1;
    break;

  case C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR:
    msg = C_text("bad argument type - not a fixnum");
    c = 1;
    break;

  case C_BAD_ARGUMENT_TYPE_NO_STRING_ERROR:
    msg = C_text("bad argument type - not a string");
    c = 1;
    break;

  case C_BAD_ARGUMENT_TYPE_NO_PAIR_ERROR:
    msg = C_text("bad argument type - not a pair");
    c = 1;
    break;

  case C_BAD_ARGUMENT_TYPE_NO_LIST_ERROR:
    msg = C_text("bad argument type - not a list");
    c = 1;
    break;

  case C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR:
    msg = C_text("bad argument type - not a number");
    c = 1;
    break;

  case C_BAD_ARGUMENT_TYPE_NO_SYMBOL_ERROR:
    msg = C_text("bad argument type - not a symbol");
    c = 1;
    break;