runtime.c

Scheme跨平台编译器

static void C_fcall remark(C_word *x) C_regparm;
static C_word C_fcall intern0(C_char *name) C_regparm;
static void C_fcall update_locative_table(int mode) C_regparm;
static C_word get_unbound_variable_value(C_word sym);
static LF_LIST *find_module_handle(C_char *name);
static void lock_tospace(int lock);

static C_ccall void call_cc_wrapper(C_word c, C_word closure, C_word k, C_word result) C_noret;
static C_ccall void call_cc_values_wrapper(C_word c, C_word closure, C_word k, ...) C_noret;
static void cons_flonum_trampoline(void *dummy) C_noret;
static void gc_2(void *dummy) C_noret;
static void allocate_vector_2(void *dummy) C_noret;
static void cons_string_trampoline(void *dummy) C_noret;
static void get_argv_2(void *dummy) C_noret;
static void make_structure_2(void *dummy) C_noret;
static void generic_trampoline(void *dummy) C_noret;
static void file_info_2(void *dummy) C_noret;
static void get_environment_variable_2(void *dummy) C_noret;
static void handle_interrupt(void *trampoline, void *proc) C_noret;
static void callback_trampoline(void *dummy) C_noret;
static C_ccall void callback_return_continuation(C_word c, C_word self, C_word r) C_noret;
static void become_2(void *dummy) C_noret;
static void copy_closure_2(void *dummy) C_noret;

static C_PTABLE_ENTRY *create_initial_ptable();

#if !defined(NO_DLOAD2) &&(defined(HAVE_DLFCN_H) || defined(HAVE_DL_H) || (defined(HAVE_LOADLIBRARY) && defined(HAVE_GETPROCADDRESS)))
static void dload_2(void *dummy) C_noret;
#endif


/* Startup code: */

int CHICKEN_main(int argc, char *argv[], void *toplevel) 
{
  C_word h, s, n;

#if defined(__MWERKS__) && !defined(__INTEL__) && !defined(MACINTOSH_GUI)
  argc = ccommand(&argv);
  SIOUXSettings.asktosaveonclose = 0;
  SIOUXSettings.autocloseonquit = 1;
#elif defined(C_WINDOWS_GUI)
  parse_argv(GetCommandLine());
  argc = C_main_argc;
  argv = C_main_argv;
#endif

  CHICKEN_parse_command_line(argc, argv, &h, &s, &n);
  
  if(!CHICKEN_initialize(h, s, n, toplevel))
    panic(C_text("can not initialize - out of memory"));

  CHICKEN_run(NULL);
  return 0;
}


/* Custom argv parser for Windoze: */

#ifdef C_WINDOWS_GUI
void parse_argv(C_char *cmds)
{
  C_char *ptr = cmds,
         *bptr0, *bptr, *aptr;
  int n = 0;

  C_main_argv = (C_char **)malloc(MAXIMAL_NUMBER_OF_COMMAND_LINE_ARGUMENTS * sizeof(C_char *));

  if(C_main_argv == NULL)
    panic(C_text("can not allocate argument-list buffer"));

  C_main_argc = 0;

  for(;;) {
    while(isspace(*ptr)) ++ptr;

    if(*ptr == '\0') break;

    for(bptr0 = bptr = buffer; !isspace(*ptr) && *ptr != '\0'; *(bptr++) = *(ptr++))
      ++n;
    
    *bptr = '\0';
    aptr = (C_char *)malloc(sizeof(C_char) * (n + 1));
    
    if(aptr == NULL)
      panic(C_text("can not allocate argument buffer"));

    C_strcpy(aptr, bptr0);
    C_main_argv[ C_main_argc++ ] = aptr;
  }
}
#endif


#if defined(__MWERKS__) && !defined(__INTEL__)
int strncasecmp(const C_char *one, const C_char *two, size_t n)
{
  int c;

  while(n--) {
    if((c = C_tolower(*(one++)) - C_tolower(*(two++))) < 0) return -1;
    else if(c > 0) return 1;
  }

  return 0;
}
#endif


/* Initialize runtime system: */

int CHICKEN_initialize(int heap, int stack, int symbols, void *toplevel)
{
  int i;

#ifndef C_NONUNIX
  struct timeval tv;
  C_gettimeofday(&tv, NULL);
  C_startup_time_seconds = tv.tv_sec;
#else
  C_startup_time_seconds = (time_t)0;
#endif

  if(chicken_is_initialized) return 1;
  else chicken_is_initialized = 1;

  if(debug_mode) C_printf(C_text("[debug] application startup...\n"));

  C_panic_hook = usual_panic;
  symbol_table_list = NULL;

  if((symbol_table = C_new_symbol_table(".", symbols ? symbols : DEFAULT_SYMBOL_TABLE_SIZE)) == NULL)
    return 0;

#ifdef C_LOCK_TOSPACE
  page_size = sysconf(_SC_PAGESIZE);
  assert(page_size > -1);
#else
  page_size = 0;
#endif
  stack_size = stack ? stack : DEFAULT_STACK_SIZE;
  C_set_or_change_heap_size(heap ? heap : DEFAULT_HEAP_SIZE, 0);

  /* Allocate temporary stack: */
  if((C_temporary_stack_limit = (C_word *)C_malloc(TEMPORARY_STACK_SIZE * sizeof(C_word))) == NULL)
    return 0;
  
  C_temporary_stack_bottom = C_temporary_stack_limit + TEMPORARY_STACK_SIZE;
  C_temporary_stack = C_temporary_stack_bottom;
  
  /* Allocate mutation stack: */
  mutation_stack_bottom = (C_word **)C_malloc(DEFAULT_MUTATION_STACK_SIZE * sizeof(C_word *));

  if(mutation_stack_bottom == NULL) return 0;

  mutation_stack_top = mutation_stack_bottom;
  mutation_stack_limit = mutation_stack_bottom + DEFAULT_MUTATION_STACK_SIZE;
  C_gc_mutation_hook = NULL;
  C_gc_trace_hook = NULL;
  C_get_unbound_variable_value_hook = get_unbound_variable_value;

  /* Allocate weak item table: */
  if(C_enable_gcweak) {
    if((weak_item_table = (WEAK_TABLE_ENTRY *)C_calloc(WEAK_TABLE_SIZE, sizeof(WEAK_TABLE_ENTRY))) == NULL)
      return 0;
  }

  /* Initialize finalizer lists: */
  finalizer_list = NULL;
  finalizer_free_list = NULL;
  pending_finalizer_indices = (FINALIZER_NODE **)C_malloc(C_max_pending_finalizers * sizeof(FINALIZER_NODE *));

  if(pending_finalizer_indices == NULL) return 0;

  /* Initialize forwarding table: */
  forwarding_table = (C_word *)C_malloc((DEFAULT_FORWARDING_TABLE_SIZE + 1) * 2 * sizeof(C_word));

  if(forwarding_table == NULL) return 0;
  
  *forwarding_table = 0;
  forwarding_table_size = DEFAULT_FORWARDING_TABLE_SIZE;

  /* Initialize locative table: */
  locative_table = (C_word *)C_malloc(DEFAULT_LOCATIVE_TABLE_SIZE * sizeof(C_word));
   
  if(locative_table == NULL) return 0;
 
  locative_table_size = DEFAULT_LOCATIVE_TABLE_SIZE;
  locative_table_count = 0;

  /* Setup collectibles: */
  collectibles = (C_word **)C_malloc(sizeof(C_word *) * DEFAULT_COLLECTIBLES_SIZE);

  if(collectibles == NULL) return 0;

  collectibles_top = collectibles;
  collectibles_limit = collectibles + DEFAULT_COLLECTIBLES_SIZE;
  gc_root_list = NULL;
 
  /* Initialize global variables: */
  if(C_heap_growth == 0) C_heap_growth = DEFAULT_HEAP_GROWTH;

  if(C_heap_shrinkage == 0) C_heap_shrinkage = DEFAULT_HEAP_SHRINKAGE;

  if(C_maximal_heap_size == 0) C_maximal_heap_size = DEFAULT_MAXIMAL_HEAP_SIZE;

#if !defined(NO_DLOAD2) && defined(HAVE_DLFCN_H)
  dlopen_flags = RTLD_LAZY | RTLD_GLOBAL;
#else
  dlopen_flags = 0;
#endif

  gc_report_flag = 0;
  mutation_count = gc_count_1 = gc_count_2 = 0;
  lf_list = NULL;
  C_register_lf2(NULL, 0, create_initial_ptable());
  C_restart_address = toplevel;
  C_restart_trampoline = initial_trampoline;
  trace_buffer = NULL;
  C_clear_trace_buffer();
  chicken_is_running = chicken_ran_once = 0;
  interrupt_reason = 0;
  last_interrupt_latency = 0;
  C_interrupts_enabled = 1;
  C_initial_timer_interrupt_period = INITIAL_TIMER_INTERRUPT_PERIOD;
  C_timer_interrupt_counter = INITIAL_TIMER_INTERRUPT_PERIOD;
  memset(signal_mapping_table, 0, sizeof(int) * NSIG);
  initialize_symbol_table();
  C_dlerror = "can not load compiled code dynamically - this is a statically linked executable";
  error_location = C_SCHEME_FALSE;
  C_pre_gc_hook = NULL;
  C_post_gc_hook = NULL;
  live_finalizer_count = 0;
  allocated_finalizer_count = 0;
  current_module_name = NULL;
  current_module_handle = NULL;
  reload_lf = NULL;
  callback_continuation_level = 0;
  timer_start_gc_ms = 0;
  C_randomize(time(NULL));
  return 1;
}


static C_PTABLE_ENTRY *create_initial_ptable()
{
  C_PTABLE_ENTRY *pt = (C_PTABLE_ENTRY *)C_malloc(sizeof(C_PTABLE_ENTRY) * 66);
  int i = 0;

  if(pt == NULL)
    panic(C_text("out of memory - can not create initial ptable"));

  C_pte(termination_continuation);
  C_pte(callback_return_continuation);
  C_pte(values_continuation);
  C_pte(call_cc_values_wrapper);
  C_pte(call_cc_wrapper);
  C_pte(C_gc);
  C_pte(C_allocate_vector);
  C_pte(C_get_argv);
  C_pte(C_make_structure);
  C_pte(C_ensure_heap_reserve);
  C_pte(C_return_to_host);
  C_pte(C_file_info);
  C_pte(C_get_symbol_table_info);
  C_pte(C_get_memory_info);
  C_pte(C_cpu_time);
  C_pte(C_decode_seconds);
  C_pte(C_get_environment_variable);
  C_pte(C_stop_timer);
  C_pte(C_dload);
  C_pte(C_set_dlopen_flags);
  C_pte(C_become);
  C_pte(C_apply_values);
  C_pte(C_times);
  C_pte(C_minus);
  C_pte(C_plus);
  C_pte(C_divide);
  C_pte(C_nequalp);
  C_pte(C_greaterp);
  C_pte(C_lessp);
  C_pte(C_greater_or_equal_p);
  C_pte(C_less_or_equal_p);
  C_pte(C_flonum_floor);
  C_pte(C_flonum_ceiling);
  C_pte(C_flonum_truncate);
  C_pte(C_flonum_round);
  C_pte(C_quotient);
  C_pte(C_cons_flonum);
  C_pte(C_flonum_fraction);
  C_pte(C_expt);
  C_pte(C_exact_to_inexact);
  C_pte(C_string_to_number);
  C_pte(C_number_to_string);
  C_pte(C_make_symbol);
  C_pte(C_string_to_symbol);
  C_pte(C_apply);
  C_pte(C_call_cc);
  C_pte(C_values);
  C_pte(C_call_with_values);
  C_pte(C_continuation_graft);
  C_pte(C_open_file_port);
  C_pte(C_software_type);
  C_pte(C_machine_type);
  C_pte(C_machine_byte_order);
  C_pte(C_software_version);
  C_pte(C_build_platform);
  C_pte(C_c_runtime);
  C_pte(C_make_pointer);
  C_pte(C_make_tagged_pointer);
  C_pte(C_peek_signed_integer);
  C_pte(C_peek_unsigned_integer);
  C_pte(C_context_switch);
  C_pte(C_register_finalizer);
  C_pte(C_locative_ref);
  C_pte(C_call_with_cthulhu);
  C_pte(C_dunload);
  pt[ i ].id = NULL;
  return pt;
}


void *CHICKEN_new_gc_root()
{
  C_GC_ROOT *r = (C_GC_ROOT *)C_malloc(sizeof(C_GC_ROOT));

  if(r == NULL)
    panic(C_text("out of memory - can not allocate GC root"));

  r->value = C_SCHEME_UNDEFINED;
  r->next = gc_root_list;
  r->prev = NULL;

  if(gc_root_list != NULL) gc_root_list->prev = r;

  gc_root_list = r;
  return (void *)r;
}


void CHICKEN_delete_gc_root(void *root)
{
  C_GC_ROOT *r = (C_GC_ROOT *)root;

  if(r->prev == NULL) gc_root_list = r->next;
  else r->prev->next = r->next;

  if(r->next != NULL) r->next->prev = r->prev;

  C_free(root);
}


void *CHICKEN_global_lookup(char *name)
{
  int 
    len = C_strlen(name),
    key = hash_string(len, name, symbol_table->size);
  C_word s;
  void *root = CHICKEN_new_gc_root();

  if(C_truep(s = lookup(key, len, name, symbol_table))) {
    if(C_u_i_car(s) != C_SCHEME_UNBOUND) {
      CHICKEN_gc_root_set(root, s);
      return root;
    }
  }

  return NULL;
}


int CHICKEN_is_running()
{
  return chicken_is_running;
}


void CHICKEN_interrupt()
{
  C_timer_interrupt_counter = 0;
}


C_regparm C_SYMBOL_TABLE *C_new_symbol_table(char *name, unsigned int size)
{
  C_SYMBOL_TABLE *stp;
  int i;

  if((stp = C_find_symbol_table(name)) != NULL) return stp;

  if((stp = (C_SYMBOL_TABLE *)C_malloc(sizeof(C_SYMBOL_TABLE))) == NULL)
    return NULL;

  stp->name = name;
  stp->size = size;
  stp->next = symbol_table_list;

  if((stp->table = (C_word *)C_malloc(size * sizeof(C_word))) == NULL)
    return NULL;

  for(i = 0; i < stp->size; stp->table[ i++ ] = C_SCHEME_END_OF_LIST);

  symbol_table_list = stp;
  return stp;
}  


C_regparm void C_delete_symbol_table(C_SYMBOL_TABLE *st)
{
  C_SYMBOL_TABLE *stp, *prev = NULL;

  for(stp = symbol_table_list; stp != NULL; stp = stp->next)
    if(stp == st) {
      if(prev != NULL) prev->next = stp->next;
      else symbol_table_list = stp->next;

      return;
    }
}


C_regparm void C_set_symbol_table(C_SYMBOL_TABLE *st)
{
  symbol_table = st;
}


C_regparm C_SYMBOL_TABLE *C_find_symbol_table(char *name)
{
  C_SYMBOL_TABLE *stp;

  for(stp = symbol_table_list; stp != NULL; stp = stp->next)
    if(!C_strcmp(name, stp->name)) return stp;

  return NULL;
}


C_regparm C_word C_find_symbol(C_word str, C_SYMBOL_TABLE *stable)
{
  char *sptr = C_c_string(str);
  int 
    len = C_header_size(str),
    key = hash_string(len, sptr, stable->size);
  C_word s;

  if(C_truep(s = lookup(key, len, sptr, stable))) return s;
  else return C_SCHEME_FALSE;
}


C_regparm C_word C_enumerate_symbols(C_SYMBOL_TABLE *stable, C_word pos)
{
  int i;
  C_word 
    sym,
    bucket = C_u_i_car(pos);

  if(!C_truep(bucket)) return C_SCHEME_FALSE; /* end already reached */
  else i = C_unfix(bucket);

  bucket = C_u_i_cdr(pos); 

  while(bucket == C_SCHEME_END_OF_LIST) {
    if(++i >= stable->size) {
      C_set_block_item(pos, 0, C_SCHEME_FALSE);	/* no more buckets */
      return C_SCHEME_FALSE;
    }
    else bucket = stable->table[ i ];
  }

  sym = C_u_i_car(bucket);
  C_set_block_item(pos, 0, C_fix(i));
  C_mutate(&C_u_i_cdr(pos), C_u_i_cdr(bucket));
  return sym;
}


/* Setup symbol-table with internally used symbols; */

void initialize_symbol_table(void)
{
  int i;

  for(i = 0; i < symbol_table->size; symbol_table->table[ i++ ] = C_SCHEME_END_OF_LIST);

  /* Obtain reference to hooks for later: */
  interrupt_hook_symbol = C_intern2(C_heaptop, C_text("\003sysinterrupt-hook"));
  error_hook_symbol = C_intern2(C_heaptop, C_text("\003syserror-hook"));
  callback_continuation_stack_symbol = C_intern3(C_heaptop, C_text("\003syscallback-continuation-stack"), C_SCHEME_END_OF_LIST);
  pending_finalizers_symbol = C_intern2(C_heaptop, C_text("\003syspending-finalizers"));
  invalid_procedure_call_hook_symbol = C_intern3(C_heaptop, C_text("\003sysinvalid-procedure-call-hook"), C_SCHEME_FALSE);
  unbound_variable_value_hook_symbol = C_intern3(C_heaptop, C_text("\003sysunbound-variable-value-hook"), C_SCHEME_FALSE);
  last_invalid_procedure_symbol = C_intern3(C_heaptop, C_text("\003syslast-invalid-procedure"), C_SCHEME_FALSE);
  identity_unbound_value_symbol = C_intern3(C_heaptop, C_text("\003sysidentity-unbound-value"), C_SCHEME_FALSE);
  current_thread_symbol = C_intern3(C_heaptop, C_text("\003syscurrent-thread"), C_SCHEME_FALSE);
  apply_hook_symbol = C_intern3(C_heaptop, C_text("\003sysapply-hook"), C_SCHEME_FALSE);
  last_applied_procedure_symbol = C_intern2(C_heaptop, C_text("\003syslast-applied-procedure"));
}


/* This is called from POSIX signals: */

void global_signal_handler(int signum)
{
  C_raise_interrupt(signal_mapping_table[ signum ]);
  signal(signum, global_signal_handler);
}


/* Align memory to page boundary */

#ifndef C_LOCK_TOSPACE
static void *align_to_page(void *mem)
{
  return (void *)C_align((C_uword)mem);
}
#endif

static C_byte *
heap_alloc (size_t size, C_byte **page_aligned)
{
  C_byte *p;
#ifdef C_LOCK_TOSPACE