runtime.c

Scheme跨平台编译器

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

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

  case C_STACK_OVERFLOW_ERROR:
    msg = C_text("stack overflow");
    c = 0;
    break;

  case C_BAD_ARGUMENT_TYPE_BAD_STRUCT_ERROR:
    msg = C_text("bad argument type - not a structure of the required type");
    c = 2;
    break;

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

  case C_LOST_LOCATIVE_ERROR:
    msg = C_text("locative refers to reclaimed object");
    c = 1;
    break;

  case C_BAD_ARGUMENT_TYPE_NO_BLOCK_ERROR:
    msg = C_text("bad argument type - immediate value expected");
    c = 1;
    break;

  case C_BAD_ARGUMENT_TYPE_NO_NUMBER_VECTOR_ERROR:
    msg = C_text("bad argument type - number vector expected");
    c = 2;
    break;

  case C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR:
    msg = C_text("bad argument type - integer expected");
    c = 1;
    break;

  case C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR:
    msg = C_text("bad argument type - unsigned integer expected");
    c = 1;
    break;

  case C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR:
    msg = C_text("bad argument type - pointer expected");
    c = 1;
    break;

  case C_BAD_ARGUMENT_TYPE_NO_TAGGED_POINTER_ERROR:
    msg = C_text("bad argument type - tagged pointer expected");
    c = 2;
    break;

  case C_RUNTIME_UNSAFE_DLOAD_SAFE_ERROR:
    msg = C_text("code to load dynamically was linked with safe runtime libraries, but executing runtime was not");
    c = 0;
    break;

  case C_RUNTIME_SAFE_DLOAD_UNSAFE_ERROR:
    msg = C_text("code to load dynamically was linked with unsafe runtime libraries, but executing runtime was not");
    c = 0;
    break;

  case C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR:
    msg = C_text("bad argument type - floating-point number expected");
    c = 1;
    break;

  case C_BAD_ARGUMENT_TYPE_NO_CLOSURE_ERROR:
    msg = C_text("bad argument type - procedure expected");
    c = 1;
    break;

  default: panic(C_text("illegal internal error code"));
  }
  
  if(!C_immediatep(err)) {
    C_save(C_fix(code));
    
    if(loc != NULL)
      C_save(intern0(loc));
    else {
      C_save(error_location);
      error_location = C_SCHEME_FALSE;
    }
    
    va_start(v, loc);
    i = c;

    while(i--)
      C_save(va_arg(v, C_word));

    va_end(v);
    /* No continuation is passed: '##sys#error-hook' may not return: */
    C_do_apply(c + 2, err, C_SCHEME_UNDEFINED); 
  }
  else panic(msg);
}


/* Hook for setting breakpoints */

C_word C_dbg_hook(C_word dummy)
{
  return dummy;
}


/* Timing routines: */

long C_fcall milliseconds(void)
{
#ifdef C_NONUNIX
    if(CLOCKS_PER_SEC == 1000) return clock();
    else return ((double)clock() / (double)CLOCKS_PER_SEC) * 1000;
#else
    struct timeval tv;

    if(C_gettimeofday(&tv, NULL) == -1) return 0;
    else return (tv.tv_sec - C_startup_time_seconds) * 1000 + tv.tv_usec / 1000;
#endif
}


C_regparm time_t C_fcall C_seconds(long *ms)
{
#ifdef C_NONUNIX
  if(ms != NULL) *ms = 0;

  return (time_t)(clock() / CLOCKS_PER_SEC);
#else
  struct timeval tv;

  if(C_gettimeofday(&tv, NULL) == -1) {
    if(ms != NULL) *ms = 0;

    return (time_t)0;
  }
  else {
    if(ms != NULL) *ms = tv.tv_usec / 1000;

    return tv.tv_sec;
  }
#endif
}


long C_fcall cpu_milliseconds(void)
{
#if defined(C_NONUNIX) || defined(__CYGWIN__)
    if(CLOCKS_PER_SEC == 1000) return clock();
    else return ((double)clock() / (double)CLOCKS_PER_SEC) * 1000;
#else
    struct rusage ru;

    if(C_getrusage(RUSAGE_SELF, &ru) == -1) return 0;
    else return (ru.ru_utime.tv_sec + ru.ru_stime.tv_sec) * 1000 + (ru.ru_utime.tv_usec + ru.ru_stime.tv_usec) / 1000;
#endif
}


/* Support code for callbacks: */

int C_fcall C_save_callback_continuation(C_word **ptr, C_word k)
{
  C_word p = C_pair(ptr, k, C_block_item(callback_continuation_stack_symbol, 0));
  
  C_mutate(&C_block_item(callback_continuation_stack_symbol, 0), p);
  return ++callback_continuation_level;
}


C_word C_fcall C_restore_callback_continuation(void) 
{
  /* obsolete, but retained for keeping old code working */
  C_word p = C_block_item(callback_continuation_stack_symbol, 0),
         k;

  assert(!C_immediatep(p) && C_block_header(p) == C_PAIR_TAG);
  k = C_u_i_car(p);

  C_mutate(&C_block_item(callback_continuation_stack_symbol, 0), C_u_i_cdr(p));
  --callback_continuation_level;
  return k;
}


C_word C_fcall C_restore_callback_continuation2(int level) 
{
  C_word p = C_block_item(callback_continuation_stack_symbol, 0),
         k;

#ifndef C_UNSAFE_RUNTIME
  if(level != callback_continuation_level || C_immediatep(p) || C_block_header(p) != C_PAIR_TAG)
    panic(C_text("unbalanced callback continuation stack"));
#endif

  k = C_u_i_car(p);

  C_mutate(&C_block_item(callback_continuation_stack_symbol, 0), C_u_i_cdr(p));
  --callback_continuation_level;
  return k;
}


C_word C_fcall C_callback(C_word closure, int argc)
{
  jmp_buf prev;
  C_word 
    *a = C_alloc(2),
    k = C_closure(&a, 1, (C_word)callback_return_continuation);
  int old = chicken_is_running;

#ifndef C_UNSAFE_RUNTIME
  if(old && C_block_item(callback_continuation_stack_symbol, 0) == C_SCHEME_END_OF_LIST)
    panic(C_text("callback invoked in non-safe context"));
#endif

  C_memcpy(&prev, &C_restart, sizeof(jmp_buf));
  callback_returned_flag = 0;       
  chicken_is_running = 1;

  if(!C_setjmp(C_restart)) C_do_apply(argc, closure, k);

  if(!callback_returned_flag) (C_restart_trampoline)(C_restart_address);
  else {
    C_memcpy(&C_restart, &prev, sizeof(jmp_buf));
    callback_returned_flag = 0;
  }
 
  chicken_is_running = old;
  return C_restore;
}


void C_fcall C_callback_adjust_stack(C_word *a, int size)
{
  if(!chicken_is_running && !C_in_stackp((C_word)a)) {
    if(debug_mode)
      C_printf(C_text("[debug] callback invoked in lower stack region - adjusting limits:\n"
		      "[debug]   current:  \t%p\n"
		      "[debug]   previous: \t%p (bottom) - %p (limit)\n"),
	       a, stack_bottom, C_stack_limit);

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

    if(debug_mode)
      C_printf(C_text("[debug]   new:      \t%p (bottom) - %p (limit)\n"),
	       stack_bottom, C_stack_limit);
  }
}


void C_fcall C_callback_adjust_stack_limits(C_word *a) /* DEPRECATED */
{
  if(!chicken_is_running && !C_in_stackp((C_word)a)) {
    if(debug_mode)
      C_printf(C_text("[debug] callback invoked in lower stack region - adjusting limits:\n"
		      "[debug]   current:  \t%p\n"
		      "[debug]   previous: \t%p (bottom) - %p (limit)\n"),
	       a, stack_bottom, C_stack_limit);

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

    if(debug_mode)
      C_printf(C_text("[debug]   new:      \t%p (bottom) - %p (limit)\n"),
	       stack_bottom, C_stack_limit);
  }
}


C_word C_fcall C_callback_wrapper(void *proc, int argc)
{
  C_word
    *a = C_alloc(2),
    closure = C_closure(&a, 1, (C_word)proc),
    result;
  
  result = C_callback(closure, argc);
  assert(C_temporary_stack == C_temporary_stack_bottom);
  return result;
}


void C_ccall callback_return_continuation(C_word c, C_word self, C_word r)
{
  assert(callback_returned_flag == 0);
  callback_returned_flag = 1;
  C_save(r);
  C_reclaim(NULL, NULL);
}


/* Zap symbol names: */

void C_zap_strings(C_word str)
{
  C_word bucket, sym;
  int i;
  
  for(i = 0; i < symbol_table->size; ++i)
    for(bucket = symbol_table->table[ i ]; bucket != C_SCHEME_END_OF_LIST; bucket = C_u_i_cdr(bucket)) {
      sym = C_u_i_car(bucket);
      C_set_block_item(sym, 1, str);
    }  
}


/* Register/unregister literal frame: */

void C_initialize_lf(C_word *lf, int count)
{
  while(count-- > 0)
    *(lf++) = C_SCHEME_UNBOUND;
}


void *C_register_lf(C_word *lf, int count)
{
  return C_register_lf2(lf, count, NULL);
}


void *C_register_lf2(C_word *lf, int count, C_PTABLE_ENTRY *ptable)
{
  LF_LIST *node = (LF_LIST *)C_malloc(sizeof(LF_LIST));
  LF_LIST *np;
  int status = 0;

  node->lf = lf;
  node->count = count;
  node->ptable = ptable;
  node->module_name = NULL;
  node->module_handle = NULL;
  
  if(reload_lf != NULL) {
    if(debug_mode)
      C_printf(C_text("[debug] replacing previous LF-entry for `%s'\n"), current_module_name);
    
    C_free(reload_lf->module_name);
    reload_lf->lf = lf;
    reload_lf->count = count;
    reload_lf->ptable = ptable;
    C_free(node);
    node = reload_lf;
  }

  node->module_name = current_module_name;
  node->module_handle = current_module_handle;
  current_module_handle = NULL;

  if(reload_lf != node) {
    if(lf_list) lf_list->prev = node;

    node->next = lf_list;
    node->prev = NULL;
    lf_list = node;
  }
  else reload_lf = NULL;

  return (void *)node;
}


LF_LIST *find_module_handle(char *name)
{
  LF_LIST *np;

  for(np = lf_list; np != NULL; np = np->next) {
    if(np->module_name != NULL && !C_strcmp(np->module_name, name)) 
      return np;
  }

  return NULL;
}


void C_unregister_lf(void *handle)
{
  LF_LIST *node = (LF_LIST *) handle;

  if (node->next) node->next->prev = node->prev;

  if (node->prev) node->prev->next = node->next;

  if (lf_list == node) lf_list = node->next;

  C_free(node->module_name);
  C_free(node);
}


/* Intern symbol into symbol-table: */

C_regparm C_word C_fcall C_intern(C_word **ptr, int len, C_char *str)
{
  return C_intern_in(ptr, len, str, symbol_table);
}


C_regparm C_word C_fcall C_h_intern(C_word *slot, int len, C_char *str)
{
  return C_h_intern_in(slot, len, str, symbol_table);
}


C_regparm C_word C_fcall C_intern_in(C_word **ptr, int len, C_char *str, C_SYMBOL_TABLE *stable)
{
  int key;
  C_word s;

  if(stable == NULL) stable = symbol_table;

  key = hash_string(len, str, stable->size);

  if(C_truep(s = lookup(key, len, str, stable))) return s;

  s = C_string(ptr, len, str);
  return add_symbol(ptr, key, s, stable);
}


C_regparm C_word C_fcall C_h_intern_in(C_word *slot, int len, C_char *str, C_SYMBOL_TABLE *stable)
{
  /* Intern as usual, but remember slot, if looked up symbol is in nursery.
     also: allocate in static memory. */
  int key;
  C_word s;

  if(stable == NULL) stable = symbol_table;

  key = hash_string(len, str, stable->size);

  if(C_truep(s = lookup(key, len, str, stable))) {
    if(C_in_stackp(s)) C_mutate(slot, s);
    
    return s;
  }

  s = C_static_string(C_heaptop, len, str);
  return add_symbol(C_heaptop, key, s, stable);
}


C_regparm C_word C_fcall intern0(C_char *str)
{
  int len = C_strlen(str);
  int key = hash_string(len, str, symbol_table->size);
  C_word s;

  if(C_truep(s = lookup(key, len, str, symbol_table))) return s;
  else return C_SCHEME_FALSE;
}


C_regparm C_word C_fcall C_lookup_symbol(C_word sym)
{
  int key;
  C_word str = C_block_item(sym, 1);
  int len = C_header_size(str);

  key = hash_string(len, C_c_string(str), symbol_table->size);

  return lookup(key, len, C_c_string(str), symbol_table);
}


C_regparm C_word C_fcall C_intern2(C_word **ptr, C_char *str)
{
  return C_intern_in(ptr, C_strlen(str), str, symbol_table);
}


C_regparm C_word C_fcall C_intern3(C_word **ptr, C_char *str, C_word value)
{
  C_word s = C_intern_in(ptr, C_strlen(str), str, symbol_table);
  
  C_mutate(&C_u_i_car(s), value);
  return s;
}


C_regparm int C_fcall hash_string(int len, C_char *str, unsigned int m)
{
  unsigned int key = 2166136261U;

  while(len--) key = ((key * 16777619U) + (*str++));

  return (int)(key % m);
}


C_regparm C_word C_fcall lookup(C_word key, int len, C_char *str, C_SYMBOL_TABLE *stable)
{
  C_word bucket, sym, s;

  for(bucket = stable->table[ key ]; bucket != C_SCHEME_END_OF_LIST; bucket = C_u_i_cdr(bucket)) {
    sym = C_u_i_car(bucket);
    s = C_u_i_cdr(sym);

    if(C_header_size(s) == (C_word)len && !C_memcmp(str, (C_char *)((C_SCHEME_BLOCK *)s)->data, len))
      return sym;
  }

  return C_SCHEME_FALSE;
}