runtime.c

Scheme跨平台编译器

/* runtime.c - Runtime code for compiler generated executables
;
; Copyright (c) 2000-2007, Felix L. Winkelmann
; Copyright (c) 2008, The Chicken Team
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
; conditions are met:
;
;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
;     disclaimer. 
;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
;     disclaimer in the documentation and/or other materials provided with the distribution. 
;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
;     products derived from this software without specific prior written permission. 
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
; POSSIBILITY OF SUCH DAMAGE.
*/

#include "chicken.h"
#include <errno.h>
#include <signal.h>
#include <assert.h>
#include <limits.h>
#include <math.h>

#ifdef HAVE_SYSEXITS_H
# include <sysexits.h>
#endif

#if !defined(PIC)
# define NO_DLOAD2
#endif

#ifndef NO_DLOAD2
# ifdef HAVE_DLFCN_H
#  include <dlfcn.h>
# endif

# ifdef HAVE_DL_H
#  include <dl.h>
# endif
#endif

#ifndef EX_SOFTWARE
# define EX_SOFTWARE  70
#endif

#ifdef __WATCOMC__
# define NSIG (_SIGMAX - _SIGMIN + 1)
#endif

#if defined(__MWERKS__) && !defined(__INTEL__)

# include <stat.h>
# ifndef MACINTOSH_GUI
#  include <console.h>
#  include <SIOUX.h>
# endif

# define NSIG                          32
# define EINVAL                        ERANGE
static C_TLS int timezone;

#elif !defined(C_NONUNIX)

# include <sys/types.h>
# include <sys/stat.h>
# include <sys/time.h>
# include <sys/resource.h>
# include <sys/wait.h>

#else

# include <sys/types.h>
# include <sys/stat.h>

#ifdef ECOS
#include <cyg/kernel/kapi.h>
static C_TLS int timezone;
#define NSIG                          32
#endif

#endif

#ifndef RTLD_GLOBAL
# define RTLD_GLOBAL                   0
#endif

#ifndef RTLD_NOW
# define RTLD_NOW                      0
#endif

#ifndef RTLD_LOCAL
# define RTLD_LOCAL                    0
#endif

#ifndef RTLD_LAZY
# define RTLD_LAZY                     0
#endif

#ifdef HAVE_WINDOWS_H
# include <windows.h>
#endif

#ifdef HAVE_CONFIG_H
# ifdef PACKAGE
#  undef PACKAGE
# endif
# ifdef VERSION
#  undef VERSION
# endif
# include <chicken-config.h>

# ifndef HAVE_ALLOCA
#  error this package requires "alloca()"
# endif
#endif

#ifdef _MSC_VER
# define S_IFMT             _S_IFMT
# define S_IFDIR            _S_IFDIR
# define timezone           _timezone
# if defined(_M_IX86)
#  ifndef C_HACKED_APPLY
#   define C_HACKED_APPLY
#  endif
# endif
#else
# ifdef C_HACKED_APPLY
#  if defined(__MACH__) || defined(__MINGW32__) || defined(__CYGWIN__)
extern void C_do_apply_hack(void *proc, C_word *args, int count) C_noret;
#  else
extern void _C_do_apply_hack(void *proc, C_word *args, int count) C_noret;
#   define C_do_apply_hack _C_do_apply_hack
#  endif
# endif
#endif

#if defined(C_NO_HACKED_APPLY) && defined(C_HACKED_APPLY)
# undef C_HACKED_APPLY
#endif

#ifdef C_LOCK_TOSPACE
#include <sys/mman.h>
#endif

#define BITWISE_UINT_ONLY

/* Parameters: */

#define RELAX_MULTIVAL_CHECK

#define DEFAULT_STACK_SIZE             64000
#define DEFAULT_SYMBOL_TABLE_SIZE      2999
#define DEFAULT_HEAP_SIZE              500000
#define MINIMAL_HEAP_SIZE              500000
#define DEFAULT_MAXIMAL_HEAP_SIZE      0x7ffffff0
#define DEFAULT_HEAP_GROWTH            200
#define DEFAULT_HEAP_SHRINKAGE         50
#define DEFAULT_HEAP_SHRINKAGE_USED    25
#define DEFAULT_FORWARDING_TABLE_SIZE  32
#define DEFAULT_LOCATIVE_TABLE_SIZE    32
#define DEFAULT_COLLECTIBLES_SIZE      1024
#define DEFAULT_TRACE_BUFFER_SIZE      8

#define MAX_HASH_PREFIX                64

#define WEAK_TABLE_SIZE                997
#define WEAK_HASH_ITERATIONS           4
#define WEAK_HASH_DISPLACEMENT         7
#define WEAK_COUNTER_MASK              3
#define WEAK_COUNTER_MAX               2

#define TEMPORARY_STACK_SIZE	       2048
#define STRING_BUFFER_SIZE             4096
#define DEFAULT_MUTATION_STACK_SIZE    1024
#define MUTATION_STACK_GROWTH          1024

#define FILE_INFO_SIZE                 7

#ifdef C_DOUBLE_IS_32_BITS
# define FLONUM_PRINT_PRECISION         7
#else
# define FLONUM_PRINT_PRECISION         15
#endif

#define WORDS_PER_FLONUM              C_SIZEOF_FLONUM

#define MAXIMAL_NUMBER_OF_COMMAND_LINE_ARGUMENTS 32

#define INITIAL_TIMER_INTERRUPT_PERIOD 10000


/* Constants: */

#ifdef C_SIXTY_FOUR
# define ALIGNMENT_HOLE_MARKER         ((C_word)0xfffffffffffffffeL)
# define FORWARDING_BIT_SHIFT          63
# define UWORD_FORMAT_STRING           "0x%lx"
# define UWORD_COUNT_FORMAT_STRING     "%ld"
#else
# define ALIGNMENT_HOLE_MARKER         ((C_word)0xfffffffe)
# define FORWARDING_BIT_SHIFT          31
# define UWORD_FORMAT_STRING           "0x%x"
# define UWORD_COUNT_FORMAT_STRING     "%d"
#endif

#define GC_MINOR           0
#define GC_MAJOR           1
#define GC_REALLOC         2


/* Macros: */

#ifdef PARANOIA
# define check_alignment(p)           assert(((C_word)(p) & 3) == 0)
#else
# ifndef NDEBUG
#  define NDEBUG
# endif
# define check_alignment(p)
#endif

#define aligned8(n)                  ((((C_word)(n)) & 7) == 0)
#define nmax(x, y)                   ((x) > (y) ? (x) : (y))
#define nmin(x, y)                   ((x) < (y) ? (x) : (y))
#define percentage(n, p)             ((long)(((double)(n) * (double)p) / 100))

#define is_fptr(x)                   (((x) & C_GC_FORWARDING_BIT) != 0)
#define ptr_to_fptr(x)               ((((x) >> FORWARDING_BIT_SHIFT) & 1) | C_GC_FORWARDING_BIT | ((x) & ~1))
#define fptr_to_ptr(x)               (((x) << FORWARDING_BIT_SHIFT) | ((x) & ~(C_GC_FORWARDING_BIT | 1)))

#ifdef C_UNSAFE_RUNTIME
# define C_check_flonum(x, w)
# define C_check_real(x, w, v)       if(((x) & C_FIXNUM_BIT) != 0) v = C_unfix(x); \
                                     else v = C_flonum_magnitude(x);
# define resolve_procedure(x, w)     (x)
#else
# define C_check_flonum(x, w)        if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG) \
                                       barf(C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR, w, x);
# define C_check_real(x, w, v)       if(((x) & C_FIXNUM_BIT) != 0) v = C_unfix(x); \
                                     else if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG) \
                                       barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, w, x); \
                                     else v = C_flonum_magnitude(x);
#endif

#define C_isnan(f)                   (!((f) == (f)))
#define C_isinf(f)                   ((f) == (f) + (f) && (f) != 0.0)


/* these could be shorter in unsafe mode: */
#define C_check_int(x, f, n, w)     if(((x) & C_FIXNUM_BIT) != 0) n = C_unfix(x); \
                                     else if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG) \
                                       barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, w, x); \
                                     else { double _m; \
                                       f = C_flonum_magnitude(x); \
                                       if(modf(f, &_m) != 0.0 || f < C_WORD_MIN || f > C_WORD_MAX) \
                                         barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, w, x); \
                                       else n = (C_word)f; \
                                     }

#define C_check_uint(x, f, n, w)    if(((x) & C_FIXNUM_BIT) != 0) n = C_unfix(x); \
                                     else if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG) \
                                       barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, w, x); \
                                     else { double _m; \
                                       f = C_flonum_magnitude(x); \
                                       if(modf(f, &_m) != 0.0 || f < 0 || f > C_UWORD_MAX) \
                                         barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, w, x); \
                                       else n = (C_uword)f; \
                                     }

#define C_check_uintX(x, f, n, w)    if(((x) & C_FIXNUM_BIT) != 0) n = C_unfix(x); \
                                      else if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG) \
                                        barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, w, x); \
                                      else { double _m; \
                                        f = C_flonum_magnitude(x); \
                                        if(modf(f, &_m) != 0.0 || f > C_UWORD_MAX) \
                                          barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, w, x); \
                                        else n = (C_uword)f; \
                                      }

#define C_check_uintX(x, f, n, w)    if(((x) & C_FIXNUM_BIT) != 0) n = C_unfix(x); \
                                      else if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG) \
                                        barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, w, x); \
                                      else { double _m; \
                                        f = C_flonum_magnitude(x); \
                                        if(modf(f, &_m) != 0.0 || f > C_UWORD_MAX) \
                                          barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, w, x); \
                                        else n = (C_uword)f; \
                                      }

#ifdef C_SIXTY_FOUR
#define C_limit_fixnum(n)            ((n) & C_MOST_POSITIVE_FIXNUM)
#else
#define C_limit_fixnum(n)            (n)
#endif

#define C_pte(name)                  pt[ i ].id = #name; pt[ i++ ].ptr = (void *)name;


/* Type definitions: */

typedef void (*TOPLEVEL)(C_word c, C_word self, C_word k) C_noret;
typedef void (C_fcall *TRAMPOLINE)(void *proc) C_regparm C_noret;

typedef struct lf_list_struct
{
  C_word *lf;
  int count;
  struct lf_list_struct *next, *prev;
  C_PTABLE_ENTRY *ptable;
  void *module_handle;
  char *module_name;
} LF_LIST;

typedef struct weak_table_entry_struct
{
  C_word item,
         container;
} WEAK_TABLE_ENTRY;

typedef struct finalizer_node_struct
{
  struct finalizer_node_struct
    *next,
    *previous;
  C_word
    item,
    finalizer;
} FINALIZER_NODE;

typedef struct trace_info_struct
{
  C_char *raw;
  C_word cooked1, cooked2, thread;
} TRACE_INFO;


/* Variables: */

C_TLS C_word
  *C_temporary_stack,
  *C_temporary_stack_bottom,
  *C_temporary_stack_limit,
  *C_stack_limit;
C_TLS long
  C_timer_interrupt_counter,
  C_initial_timer_interrupt_period;
C_TLS C_byte 
  *C_fromspace_top,
  *C_fromspace_limit;
C_TLS double C_temporary_flonum;
C_TLS jmp_buf C_restart;
C_TLS void *C_restart_address;
C_TLS int C_entry_point_status;
C_TLS int (*C_gc_mutation_hook)(C_word *slot, C_word val);
C_TLS void (*C_gc_trace_hook)(C_word *var, int mode);
C_TLS C_word(*C_get_unbound_variable_value_hook)(C_word sym);
C_TLS void (*C_panic_hook)(C_char *msg);
C_TLS void (*C_pre_gc_hook)(int mode);
C_TLS void (*C_post_gc_hook)(int mode, long ms);
C_TLS void (C_fcall *C_restart_trampoline)(void *proc) C_regparm C_noret;

C_TLS int
  C_abort_on_thread_exceptions,
  C_enable_repl,
  C_interrupts_enabled,
  C_disable_overflow_check,
#ifdef C_COLLECT_ALL_SYMBOLS
  C_enable_gcweak = 1,
#else
  C_enable_gcweak = 0,
#endif
  C_heap_size_is_fixed,
  C_trace_buffer_size = DEFAULT_TRACE_BUFFER_SIZE,
  C_max_pending_finalizers = C_DEFAULT_MAX_PENDING_FINALIZERS,
  C_main_argc;
C_TLS C_uword 
  C_heap_growth,
  C_heap_shrinkage;
C_TLS C_uword C_maximal_heap_size;
C_TLS time_t C_startup_time_seconds;

C_TLS char 
  **C_main_argv,
  *C_dlerror;

static C_TLS TRACE_INFO
  *trace_buffer,
  *trace_buffer_limit,
  *trace_buffer_top;

static C_TLS C_byte 
  *heapspace1, 
  *heapspace2,
  *fromspace_start,
  *tospace_start,
  *tospace_top,
  *tospace_limit,
  *new_tospace_start,
  *new_tospace_top,
  *new_tospace_limit,
  *heap_scan_top,
  *timer_start_fromspace_top;
static C_TLS size_t
  heapspace1_size,
  heapspace2_size;
static C_TLS C_char 
  buffer[ STRING_BUFFER_SIZE ],
  *current_module_name,
  *save_string;
static C_TLS C_SYMBOL_TABLE
  *symbol_table,
  *symbol_table_list;
static C_TLS C_word 
  **collectibles,
  **collectibles_top,
  **collectibles_limit,
  *saved_stack_limit,
  **mutation_stack_bottom,
  **mutation_stack_limit,
  **mutation_stack_top,
  *stack_bottom,
  *locative_table,
  error_location,
  interrupt_hook_symbol,
  current_thread_symbol,
  error_hook_symbol,
  invalid_procedure_call_hook_symbol,
  unbound_variable_value_hook_symbol,
  last_invalid_procedure_symbol,
  identity_unbound_value_symbol,
  apply_hook_symbol,
  last_applied_procedure_symbol,
  pending_finalizers_symbol,
  callback_continuation_stack_symbol,
  *forwarding_table;
static C_TLS int 
  trace_buffer_full,
  forwarding_table_size,
  return_to_host,
  page_size,
  show_trace,
  fake_tty_flag,
  debug_mode,
  gc_bell,
  gc_report_flag,
  gc_mode,
  gc_count_1,
  gc_count_2,
  timer_start_gc_count_1,
  timer_start_gc_count_2,
  interrupt_reason,
  stack_size_changed,
  dlopen_flags,
  heap_size_changed,
  chicken_is_running,
  chicken_ran_once,
  callback_continuation_level;
static C_TLS unsigned int
  mutation_count,
  stack_size,
  heap_size,
  timer_start_mutation_count;
static C_TLS int chicken_is_initialized;
static C_TLS jmp_buf gc_restart;
static C_TLS long
  timer_start_ms,
  timer_start_gc_ms,
  timer_accumulated_gc_ms,
  interrupt_time,
  last_interrupt_latency;
static C_TLS LF_LIST 
  *lf_list,
  *reload_lf;
static C_TLS int signal_mapping_table[ NSIG ];
static C_TLS int
  locative_table_size,
  locative_table_count,
  live_finalizer_count,
  allocated_finalizer_count,
  pending_finalizer_count,
  callback_returned_flag;
static C_TLS WEAK_TABLE_ENTRY *weak_item_table;
static C_TLS C_GC_ROOT *gc_root_list = NULL;
static C_TLS FINALIZER_NODE 
  *finalizer_list,
  *finalizer_free_list,
  **pending_finalizer_indices;
static C_TLS void *current_module_handle;
static C_TLS int flonum_print_precision = FLONUM_PRINT_PRECISION;

/* Prototypes: */

static void parse_argv(C_char *cmds);
static void initialize_symbol_table(void);
static void global_signal_handler(int signum);
static C_word arg_val(C_char *arg);
static void barf(int code, char *loc, ...) C_noret;
static void panic(C_char *msg) C_noret;
static void usual_panic(C_char *msg) C_noret;
static void horror(C_char *msg) C_noret;
static void C_fcall initial_trampoline(void *proc) C_regparm C_noret;
static C_ccall void termination_continuation(C_word c, C_word self, C_word result) C_noret;
static void C_fcall mark_system_globals(void) C_regparm;
static void C_fcall mark(C_word *x) C_regparm;
static WEAK_TABLE_ENTRY *C_fcall lookup_weak_table_entry(C_word item, C_word container) C_regparm;
static C_ccall void values_continuation(C_word c, C_word closure, C_word dummy, ...) C_noret;
static C_word add_symbol(C_word **ptr, C_word key, C_word string, C_SYMBOL_TABLE *stable);
static int C_fcall hash_string(int len, C_char *str, unsigned int m) C_regparm;
static C_word C_fcall lookup(C_word key, int len, C_char *str, C_SYMBOL_TABLE *stable) C_regparm;
static double compute_symbol_table_load(double *avg_bucket_len, int *total);
static C_word C_fcall convert_string_to_number(C_char *str, int radix, C_word *fix, double *flo) C_regparm;
static long C_fcall milliseconds(void);
static long C_fcall cpu_milliseconds(void);
static void C_fcall remark_system_globals(void) C_regparm;