summaryrefslogtreecommitdiff
path: root/byterun
diff options
context:
space:
mode:
Diffstat (limited to 'byterun')
-rw-r--r--byterun/Makefile1
-rw-r--r--byterun/Makefile.nt6
-rw-r--r--byterun/callback.c32
-rw-r--r--byterun/compatibility.h392
-rw-r--r--byterun/config.h2
-rw-r--r--byterun/exec.h2
-rw-r--r--byterun/extern.c44
-rw-r--r--byterun/fail.c3
-rw-r--r--byterun/finalise.c120
-rw-r--r--byterun/fix_code.c2
-rw-r--r--byterun/gc_ctrl.c1
-rw-r--r--byterun/instrtrace.c196
-rw-r--r--byterun/instrtrace.h4
-rw-r--r--byterun/instruct.h1
-rw-r--r--byterun/intern.c6
-rw-r--r--byterun/interp.c106
-rw-r--r--byterun/interp.h7
-rw-r--r--byterun/major_gc.c30
-rw-r--r--byterun/major_gc.h3
-rw-r--r--byterun/memory.c52
-rw-r--r--byterun/memory.h23
-rw-r--r--byterun/meta.c1
-rw-r--r--byterun/misc.c7
-rw-r--r--byterun/misc.h18
-rw-r--r--byterun/obj.c72
-rw-r--r--byterun/parsing.c1
-rw-r--r--byterun/startup.c2
-rw-r--r--byterun/str.c2
-rw-r--r--byterun/sys.c24
29 files changed, 621 insertions, 539 deletions
diff --git a/byterun/Makefile b/byterun/Makefile
index dcbcdaee52..34d024961c 100644
--- a/byterun/Makefile
+++ b/byterun/Makefile
@@ -84,6 +84,7 @@ prims.c : primitives
echo ' 0 };') > prims.c
opnames.h : instruct.h
+ LANG=C; \
sed -e '/\/\*/d' \
-e '/^#/d' \
-e 's/enum /char * names_of_/' \
diff --git a/byterun/Makefile.nt b/byterun/Makefile.nt
index 506ae7549d..0325cf37fb 100644
--- a/byterun/Makefile.nt
+++ b/byterun/Makefile.nt
@@ -35,7 +35,7 @@ PRIMS=alloc.c array.c compare.c extern.c floats.c gc_ctrl.c hash.c \
dynlink.c
PUBLIC_INCLUDES=alloc.h callback.h config.h custom.h fail.h intext.h \
- memory.h misc.h mlvalues.h
+ memory.h misc.h mlvalues.h signals.h compatibility.h
all: ocamlrun.exe libcamlrun.$(A)
@@ -68,10 +68,10 @@ prims.c : primitives
(echo '#include "mlvalues.h"'; \
echo '#include "prims.h"'; \
sed -e 's/.*/extern value &();/' primitives; \
- echo 'c_primitive builtin_cprim[] = {'; \
+ echo 'c_primitive caml_builtin_cprim[] = {'; \
sed -e 's/.*/ &,/' primitives; \
echo ' 0 };'; \
- echo 'char * names_of_builtin_cprim[] = {'; \
+ echo 'char * caml_names_of_builtin_cprim[] = {'; \
sed -e 's/.*/ "&",/' primitives; \
echo ' 0 };') > prims.c
diff --git a/byterun/callback.c b/byterun/callback.c
index f16c4728c9..a960df5448 100644
--- a/byterun/callback.c
+++ b/byterun/callback.c
@@ -32,7 +32,10 @@
CAMLexport int caml_callback_depth = 0;
+#ifndef LOCAL_CALLBACK_BYTECODE
static opcode_t callback_code[] = { ACC, 0, APPLY, 0, POP, 1, STOP };
+#endif
+
#ifdef THREADED_CODE
@@ -57,17 +60,44 @@ CAMLexport value caml_callbackN_exn(value closure, int narg, value args[])
int i;
value res;
+ /* some alternate bytecode implementations (e.g. a JIT translator)
+ might require that the bytecode is kept in a local variable on
+ the C stack */
+#ifdef LOCAL_CALLBACK_BYTECODE
+ opcode_t local_callback_code[7];
+#endif
+
Assert(narg + 4 <= 256);
- Init_callback();
+
caml_extern_sp -= narg + 4;
for (i = 0; i < narg; i++) caml_extern_sp[i] = args[i]; /* arguments */
+#ifndef LOCAL_CALLBACK_BYTECODE
caml_extern_sp[narg] = (value) (callback_code + 4); /* return address */
caml_extern_sp[narg + 1] = Val_unit; /* environment */
caml_extern_sp[narg + 2] = Val_long(0); /* extra args */
caml_extern_sp[narg + 3] = closure;
+ Init_callback();
callback_code[1] = narg + 3;
callback_code[3] = narg;
res = caml_interprete(callback_code, sizeof(callback_code));
+#else /*have LOCAL_CALLBACK_BYTECODE*/
+ caml_extern_sp[narg] = (value) (local_callback_code + 4); /* return address */
+ caml_extern_sp[narg + 1] = Val_unit; /* environment */
+ caml_extern_sp[narg + 2] = Val_long(0); /* extra args */
+ caml_extern_sp[narg + 3] = closure;
+ local_callback_code[0] = ACC;
+ local_callback_code[1] = narg + 3;
+ local_callback_code[2] = APPLY;
+ local_callback_code[3] = narg;
+ local_callback_code[4] = POP;
+ local_callback_code[5] = 1;
+ local_callback_code[6] = STOP;
+#ifdef THREADED_CODE
+ caml_thread_code(local_callback_code, sizeof(local_callback_code));
+#endif /*THREADED_CODE*/
+ res = caml_interprete(local_callback_code, sizeof(local_callback_code));
+ caml_release_bytecode(local_callback_code, sizeof(local_callback_code));
+#endif /*LOCAL_CALLBACK_BYTECODE*/
if (Is_exception_result(res)) caml_extern_sp += narg + 4; /* PR#1228 */
return res;
}
diff --git a/byterun/compatibility.h b/byterun/compatibility.h
index 8db284f3fc..f65717b62e 100644
--- a/byterun/compatibility.h
+++ b/byterun/compatibility.h
@@ -48,33 +48,14 @@
#define alloc_array caml_alloc_array
#define copy_string_array caml_copy_string_array
#define convert_flag_list caml_convert_flag_list
-/* alloc_dummy -> caml_alloc_dummy */
-/* update_dummy -> caml_update_dummy */
-/* **** asmrun/<arch>.s */
-/* g caml_alloc -> caml_allocN SP*/
/* **** array.c */
-/* array_get_addr -> caml_array_get_addr */
-/* array_get_float -> caml_array_get_float */
-/* array_get -> caml_array_get */
-/* array_set_addr -> caml_array_set_addr */
-/* array_set_float -> caml_array_set_float */
-/* array_set -> caml_array_set */
-/* array_unsafe_get_float -> caml_array_unsafe_get_float */
-/* array_unsafe_get -> caml_array_unsafe_get */
-/* array_unsafe_set_addr -> caml_array_unsafe_set_addr */
-/* array_unsafe_set_float -> caml_array_unsafe_set_float */
-/* array_unsafe_set -> caml_array_unsafe_set */
-/* make_vect -> caml_make_vect */
-/* make_array -> caml_make_array */
/* **** backtrace.c */
#define backtrace_active caml_backtrace_active
#define backtrace_pos caml_backtrace_pos
#define backtrace_buffer caml_backtrace_buffer
#define backtrace_last_exn caml_backtrace_last_exn
-/* g init_backtrace -> caml_init_backtrace */
-/* g stash_backtrace -> caml_stash_backtrace */
#define print_exception_backtrace caml_print_exception_backtrace
/* **** callback.c */
@@ -87,52 +68,22 @@
#define callback2 caml_callback2
#define callback3 caml_callback3
#define callbackN caml_callbackN
-/* register_named_value -> caml_register_named_value */
/* **** compact.c */
-/* g compact_heap -> caml_compact_heap */
-/* g percent_max -> caml_percent_max */
-/* g compact_heap_maybe -> caml_compact_heap_maybe */
/* **** compare.c */
#define compare_unordered caml_compare_unordered
-/* compare -> caml_compare */
-/* equal -> caml_equal */
-/* notequal -> caml_notequal */
-/* lessthan -> caml_lessthan */
-/* lessequal -> caml_lessequal */
-/* greaterthan -> caml_greaterthan */
-/* greaterequal -> caml_greaterequal */
/* **** custom.c */
#define alloc_custom caml_alloc_custom
#define register_custom_operations caml_register_custom_operations
-/* g find_custom_operations -> caml_find_custom_operations */
-/* g final_custom_operations -> caml_final_custom_operations */
-/* g init_custom_operations -> caml_init_custom_operations */
/* **** debugger.c */
-/* g debugger_in_use -> caml_debugger_in_use */
-/* g event_count -> caml_event_count */
-/* g debugger_init -> caml_debugger_init */
-/* g debugger -> caml_debugger */
/* **** dynlink.c */
-/* g prim_table -> caml_prim_table */
-/* g prim_name_table -> caml_prim_name_table */
-/* g shared_libs_path -> caml_shared_libs_path */
-/* g build_primitive_table -> caml_build_primitive_table */
-/* dynlink_open_lib -> caml_dynlink_open_lib */
-/* dynlink_close_lib -> caml_dynlink_close_lib */
-/* dynlink_lookup_symbol -> caml_dynlink_lookup_symbol */
-/* dynlink_add_primitive -> caml_dynlink_add_primitive */
-/* dynlink_get_current_libs -> caml_dynlink_get_current_libs */
/* **** extern.c */
#define output_val caml_output_val
-/* output_value -> caml_output_value */
-/* output_value_to_string -> caml_output_value_to_string */
-/* output_value_to_buffer -> caml_output_value_to_buffer */
#define output_value_to_malloc caml_output_value_to_malloc
#define output_value_to_block caml_output_value_to_block
#define serialize_int_1 caml_serialize_int_1
@@ -149,7 +100,6 @@
/* **** fail.c */
#define external_raise caml_external_raise
-/* g exn_bucket -> caml_exn_bucket */
#define mlraise caml_raise /*SP*/
#define raise_constant caml_raise_constant
#define raise_with_arg caml_raise_with_arg
@@ -166,132 +116,35 @@
#define raise_sys_blocked_io caml_raise_sys_blocked_io
#define init_exceptions caml_init_exceptions
/* **** asmrun/fail.c */
-/* g raise_caml_exception -> caml_raise_exception SP*/
/* **** asmrun/<arch>.s */
-/* g caml_array_bound_error -> caml_ml_array_bound_error SP*/
/* **** finalise.c */
-/* g final_update -> caml_final_update */
-/* g final_do_calls -> caml_final_do_calls */
-/* g final_do_strong_roots -> caml_final_do_strong_roots */
-/* g final_do_weak_roots -> caml_final_do_weak_roots */
-/* g final_do_young_roots -> caml_final_do_young_roots */
-/* g final_empty_young -> caml_final_empty_young */
-/* final_register -> caml_final_register */
/* **** fix_code.c */
-/* g start_code -> caml_start_code */
-/* g code_size -> caml_code_size */
-/* g saved_code -> caml_saved_code */
-/* g code_md5 -> caml_code_md5 */
-/* g load_code -> caml_load_code */
-/* g fixup_endianness -> caml_fixup_endianness */
-/* g instr_table -> caml_instr_table */
-/* g instr_base -> caml_instr_base */
-/* g thread_code -> caml_thread_code */
-/* g set_instruction -> caml_set_instruction */
-/* g is_instruction -> caml_is_instruction */
/* **** floats.c */
/*#define Double_val caml_Double_val done in mlvalues.h as needed */
/*#define Store_double_val caml_Store_double_val done in mlvalues.h as needed */
#define copy_double caml_copy_double
-/* format_float -> caml_format_float */
-/* float_of_string -> caml_float_of_string */
-/* int_of_float -> caml_int_of_float */
-/* float_of_int -> caml_float_of_int */
-/* neg_float -> caml_neg_float */
-/* abs_float -> caml_abs_float */
-/* add_float -> caml_add_float */
-/* sub_float -> caml_sub_float */
-/* mul_float -> caml_mul_float */
-/* div_float -> caml_div_float */
-/* exp_float -> caml_exp_float */
-/* floor_float -> caml_floor_float */
-/* fmod_float -> caml_fmod_float */
-/* frexp_float -> caml_frexp_float */
-/* ldexp_float -> caml_ldexp_float */
-/* log_float -> caml_log_float */
-/* log10_float -> caml_log10_float */
-/* modf_float -> caml_modf_float */
-/* sqrt_float -> caml_sqrt_float */
-/* power_float -> caml_power_float */
-/* sin_float -> caml_sin_float */
-/* sinh_float -> caml_sinh_float */
-/* cos_float -> caml_cos_float */
-/* cosh_float -> caml_cosh_float */
-/* tan_float -> caml_tan_float */
-/* tanh_float -> caml_tanh_float */
-/* asin_float -> caml_asin_float */
-/* acos_float -> caml_acos_float */
-/* atan_float -> caml_atan_float */
-/* atan2_float -> caml_atan2_float */
-/* ceil_float -> caml_ceil_float */
-/* eq_float -> caml_eq_float */
-/* neq_float -> caml_neq_float */
-/* le_float -> caml_le_float */
-/* lt_float -> caml_lt_float */
-/* ge_float -> caml_ge_float */
-/* gt_float -> caml_gt_float */
-/* float_compare -> caml_float_compare */
-/* classify_float -> caml_classify_float */
-/* init_ieee_float -> caml_init_ieee_float */
/* **** freelist.c */
-/* g fl_merge -> caml_fl_merge */
-/* g fl_cur_size -> caml_fl_cur_size */
-/* * fl_check *** becomes static */
-/* g fl_allocate -> caml_fl_allocate */
-/* g fl_init_merge -> caml_fl_init_merge */
-/* g fl_reset -> caml_fl_reset */
-/* g fl_merge_block -> caml_fl_merge_block */
-/* g fl_add_block -> caml_fl_add_block */
-/* g make_free_blocks -> caml_make_free_blocks */
/* **** gc_ctrl.c */
-/* g stat_minor_words -> caml_stat_minor_words */
-/* g stat_promoted_words -> caml_stat_promoted_words */
-/* g stat_major-words -> caml_stat_major_words */
-/* g stat_minor_collections -> caml_stat_minor_collections */
-/* g stat_major_collections -> caml_stat_major_collections */
-/* g stat_heap_size -> caml_stat_heap_size */
-/* g stat_top_heap_size -> caml_stat_top_heap_size */
-/* g stat_compactions -> caml_stat_compactions */
-/* g stat_heap_chunks -> caml_stat_heap_chunks */
-/* g heap_check -> caml_heap_check */
-/* gc_stat -> caml_gc_stat */
-/* gc_counters -> caml_gc_counters */
-/* gc_get -> caml_gc_get */
-/* gc_set -> caml_gc_set */
-/* gc_minor -> caml_gc_minor */
-/* gc_major -> caml_gc_major */
-/* gc_full_major -> caml_gc_full_major */
-/* gc_major_slice -> caml_gc_major_slice */
-/* gc_compaction -> caml_gc_compaction */
/* **** globroots.c */
#define register_global_root caml_register_global_root
#define remove_global_root caml_remove_global_root
/* **** hash.c */
-/* hash_univ_param -> caml_hash_univ_param */
#define hash_variant caml_hash_variant
/* **** instrtrace.c */
-/* g icount -> caml_icount */
-/* g stop_here -> caml_stop_here */
-/* g trace_flag -> caml_trace_flag */
-/* g disasm_instr -> caml_disasm_instr */
/* **** intern.c */
#define input_val caml_input_val
-/* input_value -> caml_input_value */
#define input_val_from_string caml_input_val_from_string
-/* input_value_from_string -> caml_input_value_from_string */
#define input_value_from_malloc caml_input_value_from_malloc
#define input_value_from_block caml_input_value_from_block
-/* marshal_data_size -> caml_marshal_data_size */
-/* g code_checksum -> caml_code_checksum */
#define deserialize_uint_1 caml_deserialize_uint_1
#define deserialize_sint_1 caml_deserialize_sint_1
#define deserialize_uint_2 caml_deserialize_uint_2
@@ -310,86 +163,15 @@
#define deserialize_error caml_deserialize_error
/* **** interp.c */
-/* g interprete -> caml_interprete */
/* **** ints.c */
-/* int_compare -> caml_int_compare */
-/* int_of_string -> caml_int_of_string */
-/* format_int -> caml_format_int */
#define int32_ops caml_int32_ops
#define copy_int32 caml_copy_int32
-/* int32_neg -> caml_int32_neg */
-/* int32_add -> caml_int32_add */
-/* int32_sub -> caml_int32_sub */
-/* int32_mul -> caml_int32_mul */
-/* int32_div -> caml_int32_div */
-/* int32_mod -> caml_int32_mod */
-/* int32_and -> caml_int32_and */
-/* int32_or -> caml_int32_or */
-/* int32_xor -> caml_int32_xor */
-/* int32_shift_left -> caml_int32_shift_left */
-/* int32_shift_right -> caml_int32_shift_right */
-/* int32_shift_right_unsigned -> caml_int32_shift_right_unsigned */
-/* int32_of_int -> caml_int32_of_int */
-/* int32_to_int -> caml_int32_to_int */
-/* int32_of_float -> caml_int32_of_float */
-/* int32_to_float -> caml_int32_to_float */
-/* int32_compare -> caml_int32_compare */
-/* int32_format -> caml_int32_format */
-/* int32_of_string -> caml_int32_of_string */
-/* int32_bits_of_float -> caml_int32_bits_of_float */
-/* int32_float_of_bits -> caml_int32_float_of_bits */
/*#define Int64_val caml_Int64_val *** done in mlvalues.h as needed */
#define int64_ops caml_int64_ops
#define copy_int64 caml_copy_int64
-/* int64_neg -> caml_int64_neg */
-/* int64_add -> caml_int64_add */
-/* int64_sub -> caml_int64_sub */
-/* int64_mul -> caml_int64_mul */
-/* int64_div -> caml_int64_div */
-/* int64_mod -> caml_int64_mod */
-/* int64_and -> caml_int64_and */
-/* int64_or -> caml_int64_or */
-/* int64_xor -> caml_int64_xor */
-/* int64_shift_left -> caml_int64_shift_left */
-/* int64_shift_right -> caml_int64_shift_right */
-/* int64_shift_right_unsigned -> caml_int64_shift_right_unsigned */
-/* int64_of_int -> caml_int64_of_int */
-/* int64_to_int -> caml_int64_to_int */
-/* int64_of_float -> caml_int64_of_float */
-/* int64_to_float -> caml_int64_to_float */
-/* int64_of_int32 -> caml_int64_of_int32 */
-/* int64_to_int32 -> caml_int64_to_int32 */
-/* int64_of_nativeint -> caml_int64_of_nativeint */
-/* int64_to_nativeint -> caml_int64_to_nativeint */
-/* int64_compare -> caml_int64_compare */
-/* int64_format -> caml_int64_format */
-/* int64_of_string -> caml_int64_of_string */
-/* int64_bits_of_float -> caml_int64_bits_of_float */
-/* int64_float_of_bits -> caml_int64_float_of_bits */
#define nativeint_ops caml_nativeint_ops
#define copy_nativeint caml_copy_nativeint
-/* nativeint_neg -> caml_nativeint_neg */
-/* nativeint_add -> caml_nativeint_add */
-/* nativeint_sub -> caml_nativeint_sub */
-/* nativeint_mul -> caml_nativeint_mul */
-/* nativeint_div -> caml_nativeint_div */
-/* nativeint_mod -> caml_nativeint_mod */
-/* nativeint_and -> caml_nativeint_and */
-/* nativeint_or -> caml_nativeint_or */
-/* nativeint_xor -> caml_nativeint_xor */
-/* nativeint_shift_left -> caml_nativeint_shift_left */
-/* nativeint_shift_right -> caml_nativeint_shift_right */
-/* nativeint_shift_right_unsigned -> caml_nativeint_shift_right_unsigned */
-/* nativeint_of_int -> caml_nativeint_of_int */
-/* nativeint_to_int -> caml_nativeint_to_int */
-/* nativeint_of_float -> caml_nativeint_of_float */
-/* nativeint_to_float -> caml_nativeint_to_float */
-/* nativeint_of_int32 -> caml_nativeint_of_int32 */
-/* nativeint_to_int32 -> caml_nativeint_to_int32 */
-/* nativeint_compare -> caml_nativeint_compare */
-/* nativeint_format -> caml_nativeint_format */
-/* nativeint_of_string -> caml_nativeint_of_string */
/* **** io.c */
#define channel_mutex_free caml_channel_mutex_free
@@ -419,60 +201,18 @@
#define input_scan_line caml_input_scan_line /*SP*/
#define finalize_channel caml_finalize_channel
#define alloc_channel caml_alloc_channel
-/* caml_open_descriptor_in -> caml_ml_open_descriptor_in SP*/
-/* caml_open_descriptor_out -> caml_ml_open_descriptor_out SP*/
-/* caml_out_channels_list -> caml_ml_out_channels_list SP*/
-/* channel_descriptor -> caml_channel_descriptor */
-/* caml_close_channel -> caml_ml_close_channel SP*/
-/* caml_channel_size -> caml_ml_channel_size SP*/
-/* caml_channel_size_64 -> caml_ml_channel_size_64 SP*/
-/* caml_set_binary_mode -> caml_ml_set_binary_mode SP*/
-/* caml_flush_partial -> caml_ml_flush_partial SP*/
-/* caml_flush -> caml_ml_flush SP*/
-/* caml_output_char -> caml_ml_output_char SP*/
-/* caml_output_int -> caml_ml_output_int SP*/
-/* caml_output_partial -> caml_ml_output_partial SP*/
-/* caml_output -> caml_ml_output SP*/
-/* caml_seek_out -> caml_ml_seek_out SP*/
-/* caml_seek_out_64 -> caml_ml_seek_out_64 SP*/
-/* caml_pos_out -> caml_ml_pos_out SP*/
-/* caml_pos_out_64 -> caml_ml_pos_out_64 SP*/
-/* caml_input_char -> caml_ml_input_char SP*/
-/* caml_input_int -> caml_ml_input_int SP*/
-/* caml_input -> caml_ml_input SP*/
-/* caml_seek_in -> caml_ml_seek_in SP*/
-/* caml_seek_in_64 -> caml_ml_seek_in_64 SP*/
-/* caml_pos_in -> caml_ml_pos_in SP*/
-/* caml_pos_in_64 -> caml_ml_pos_in_64 SP*/
-/* caml_input_scan_line -> caml_ml_input_scan_line SP*/
/*#define Val_file_offset caml_Val_file_offset *** done in io.h as needed */
/*#define File_offset_val caml_File_offset_val *** done in io.h as needed */
/* **** lexing.c */
-/* lex_engine -> caml_lex_engine */
-/* new_lex_engine -> caml_new_lex_engine */
/* **** main.c */
/* *** no change */
/* **** major_gc.c */
-/* g percent_free -> caml_percent_free */
-/* g major_heap_increment -> caml_major_heap_increment */
#define heap_start caml_heap_start
#define heap_end caml_heap_end
#define page_table caml_page_table
-/* g page_low -> caml_page_low */
-/* g page_high -> caml_page_high */
-/* g gc_sweep_hp -> caml_gc_sweep_hp */
-/* g gc_phase -> caml_gc_phase */
-/* g allocated_words -> caml_allocated_words */
-/* g extra_heap_memory -> caml_extra_heap_memory */
-/* g fl_size_at_phase_change -> caml_fl_size_at_phase_change */
-/* g darken -> caml_darken */
-/* g major_collection_slice -> caml_major_collection_slice */
-/* g finish_major_cycle -> caml_finish_major_cycle */
-/* g round_heap_chunk_size -> caml_round_heap_chunk_size */
-/* g init_major_heap -> caml_init_major_heap */
/* **** md5.c */
#define md5_string caml_md5_string
@@ -483,13 +223,7 @@
#define MD5Transform caml_MD5Transform
/* **** memory.c */
-/* g alloc_for_heap -> caml_alloc_for_heap */
-/* g free_for_heap -> caml_free_for_heap */
-/* g add_to_heap -> caml_add_to_heap */
-/* g shrink_heap -> caml_shrink_heap */
-/* g allocation_color -> caml_allocation_color */
#define alloc_shr caml_alloc_shr
-/* g adjust_gc_speed -> caml_adjust_gc_speed */
#define initialize caml_initialize
#define modify caml_modify
#define stat_alloc caml_stat_alloc
@@ -497,93 +231,45 @@
#define stat_resize caml_stat_resize
/* **** meta.c */
-/* get_global_data -> caml_get_global_data */
-/* reify_bytecode -> caml_reify_bytecode */
-/* realloc_global -> caml_realloc_global */
-/* get_current_environment -> caml_get_current_environment */
-/* invoke_traced_function -> caml_invoke_traced_function */
/* **** minor_gc.c */
-/* g minor_heap_size -> caml_minor_heap_size */
#define young_start caml_young_start
#define young_end caml_young_end
#define young_ptr caml_young_ptr
#define young_limit caml_young_limit
#define ref_table_ptr caml_ref_table_ptr
#define ref_table_limit caml_ref_table_limit
-/* g in_minor_collection -> caml_in_minor_collection */
-/* g set_minor_heap_size -> caml_set_minor_heap_size */
-/* g oldify_one -> caml_oldify_one */
-/* g oldify_mopup -> caml_oldify_mopup */
-/* g empty_minor_heap -> caml_empty_minor_heap */
#define minor_collection caml_minor_collection
#define check_urgent_gc caml_check_urgent_gc
-/* g realloc_ref_table -> caml_realloc_ref_table */
/* **** misc.c */
-/* g verb_gc -> caml_verb_gc */
-/* g gc_message -> caml_gc_message */
-/* g fatal_error -> caml_fatal_error */
-/* g fatal_error_arg -> caml_fatal_error_arg */
-/* g fatal_error_arg2 -> caml_fatal_error_arg2 */
-/* g aligned_malloc -> caml_aligned_malloc */
-/* g ext_table_init -> caml_ext_table_init */
-/* g ext_table_add -> caml_ext_table_add */
-/* g ext_table_free -> caml_ext_table_free */
/* **** obj.c */
-/* static_alloc -> caml_static_alloc */
-/* static_free -> caml_static_free */
-/* static_resize -> caml_static_resize */
-/* obj_is_block -> caml_obj_is_block */
-/* obj_tag -> caml_obj_tag */
-/* obj_set_tag -> caml_obj_set_tag */
-/* obj_block -> caml_obj_block */
-/* obj_dup -> caml_obj_dup */
-/* obj_truncate -> caml_obj_truncate */
-/* lazy_follow_forward -> caml_lazy_follow_forward */
-/* lazy_make_forward -> caml_lazy_make_forward */
/* **** parsing.c */
-/* g parser_trace -> caml_parser_trace */
-/* parse_engine -> caml_parse_engine */
/* **** prims.c */
-/* g buitin_cprim -> caml_builtin_cprim */
-/* g names_of_builtin_cprim -> caml_names_of_builtin_cprim */
/* **** printexc.c */
#define format_caml_exception caml_format_exception /*SP*/
-/* g fatal_uncaught_exception -> caml_fatal_uncaught_exception */
/* **** roots.c */
#define local_roots caml_local_roots
#define scan_roots_hook caml_scan_roots_hook
-/* g oldify_local_roots -> caml_oldify_local_roots */
-/* g darken_all_roots -> caml_darken_all_roots */
-/* g do_roots -> caml_do_roots */
#define do_local_roots caml_do_local_roots
/* **** signals.c */
#define async_signal_mode caml_async_signal_mode
#define pending_signal caml_pending_signal
#define something_to_do caml_something_to_do
-/* g force_major_slice -> caml_force_major_slice */
-/* g signal_handlers -> caml_signal_handlers */
#define enter_blocking_section_hook caml_enter_blocking_section_hook
#define leave_blocking_section_hook caml_leave_blocking_section_hook
#define async_action_hook caml_async_action_hook
-/* g process_event -> caml_process_event */
-/* g execute_signal -> caml_execute_signal */
-/* * handle_signal *** becomes static */
-/* g urge_major_slice -> caml_urge_major_slice */
#define enter_blocking_section caml_enter_blocking_section
#define leave_blocking_section caml_leave_blocking_section
#define convert_signal_number caml_convert_signal_number
-/* install_signal_handler -> caml_install_signal_handler */
/* **** asmrun/signals.c */
#define garbage_collection caml_garbage_collection
-/* g init_signals -> caml_init_signals */
/* **** stacks.c */
#define stack_low caml_stack_low
@@ -592,110 +278,32 @@
#define extern_sp caml_extern_sp
#define trapsp caml_trapsp
#define trap_barrier caml_trap_barrier
-/* g global_data -> caml_global_data */
-/* g max_stack_size -> caml_max_stack_size */
-/* g init_stack -> caml_init_stack */
-/* g realloc_stack -> caml_realloc_stack */
-/* ensure_stack_capacity -> caml_ensure_stack_capacity */
-/* g change_max_stack_size -> caml_change_max_stack_size */
/* **** startup.c */
#define atom_table caml_atom_table
-/* g attempt_open -> caml_attempt_open */
-/* g read_section_descriptors -> caml_read_section_descriptors */
-/* g seek_optional_section -> caml_seek_optional_section */
-/* g seek_section -> caml_seek_section */
/* **** asmrun/startup.c */
#define static_data_start caml_static_data_start
#define static_data_end caml_static_data_end
-/* g code_area_start -> caml_code_area_start */
-/* g code_area_end -> caml_code_area_end */
/* **** str.c */
#define string_length caml_string_length
-/* ml_string_length -> caml_ml_string_length */
-/* create_string -> caml_create_string */
-/* string_get -> caml_string_get */
-/* string_set -> caml_string_set */
-/* string_equal -> caml_string_equal */
-/* string_notequal -> caml_string_notequal */
-/* string_compare -> caml_string_compare */
-/* string_lessthan -> caml_string_lessthan */
-/* string_lessequal -> caml_string_lessequal */
-/* string_greaterthan -> caml_string_greaterthan */
-/* string_greaterequal -> caml_string_greaterequal */
-/* blit_string -> caml_blit_string */
-/* fill_string -> caml_fill_string */
-/* is_printable -> caml_is_printable */
-/* bitvect_test -> caml_bitvect_test */
/* **** sys.c */
#define sys_error caml_sys_error
#define sys_exit caml_sys_exit
-/* sys_open -> caml_sys_open */
-/* sys_close -> caml_sys_close */
-/* sys_file_exists -> caml_sys_file_exists */
-/* sys_remove -> caml_sys_remove */
-/* sys_chdir -> caml_sys_chdir */
-/* sys_getcwd -> caml_sys_getcwd */
-/* sys_getenv -> caml_sys_getenv */
-/* sys_get_argv -> caml_sys_get_argv */
-/* g sys_init -> caml_sys_init */
-/* sys_system_command -> caml_sys_system_command */
-/* sys_time -> caml_sys_time */
-/* sys_random_seed -> caml_sys_random_seed */
-/* sys_get_config -> caml_sys_get_config */
-/* sys_read_directory -> caml_sys_read_directory */
/* **** terminfo.c */
-/* terminfo_setup -> caml_terminfo_setup */
-/* terminfo_backup -> caml_terminfo_backup */
-/* terminfo_standout -> caml_terminfo_standout*/
-/* terminfo_resume -> caml_terminfo_resume */
/* **** unix.c & win32.c */
-/* g decompose_path -> caml_decompose_path */
-/* g search_in_path -> caml_search_in_path */
#define search_exe_in_path caml_search_exe_in_path
-/* g search_dll_in_path -> caml_search_dll_in_path */
-/* g aligned_mmap -> caml_aligned_mmap */
-/* g aligned_munmap -> caml_aligned_munmap */
-/* g executable_name -> caml_executable_name */
-/* g win32_signal -> caml_win32_signal */
-/* x expand_command_line -> caml_expand_command_line private CAMLexport */
/* **** weak.c */
-/* g weak_list_head -> caml_weak_list_head */
-/* g weak_none -> caml_weak_none */
-/* weak_create -> caml_weak_create */
-/* weak_set -> caml_weak_set */
-/* weak_get -> caml_weak_get */
-/* weak_get_copy -> caml_weak_get_copy */
-/* weak_check -> caml_weak_check */
/* **** asmcomp/asmlink.ml */
-/* g startup -> caml_startup */
-/* g startup__frametable -> caml_startup_frametable */
-/* g system__frametable -> caml_system__frametable */
/* **** asmcomp/cmmgen.ml */
-/* g bucket_* -> caml_bucket_* */
-/* g globals_map -> caml_globals_map */
-/* g Match_failure -> caml_exn_Match_failure */
-/* g Out_of_memory -> caml_exn_Out_of_memory */
-/* g Invalid_argument -> caml_exn_Invalid_argument */
-/* g Failure -> caml_exn_Failure */
-/* g Not_found -> caml_exn_Not_found */
-/* g Sys_error -> caml_exn_Sys_error */
-/* g End_of_file -> caml_exn_End_of_file */
-/* g Division_by_zero -> caml_exn_Division_by_zero */
-/* g Stack_overflow -> caml_exn_Stack_overflow */
-/* g Sys_blocked_io -> caml_exn_Sys_blocked_io */
-/* g Assert_failure -> caml_exn_Assert_failure */
-/* g Undefined_recursive_module -> caml_exn_Undefined_recursive_module */
/* **** asmcomp/asmlink.ml, asmcomp/cmmgen.ml, asmcomp/compilenv.ml */
-/* g Module_name -> camlModule_name */
#endif /* CAML_NAME_SPACE */
#endif /* CAML_COMPATIBILITY_H */
diff --git a/byterun/config.h b/byterun/config.h
index b2e79aa19a..da9612489c 100644
--- a/byterun/config.h
+++ b/byterun/config.h
@@ -74,7 +74,7 @@ typedef struct { uint32 l, h; } uint64, int64;
/* We use threaded code interpretation if the compiler provides labels
as first-class values (GCC 2.x). */
-#if defined(__GNUC__) && __GNUC__ >= 2 && !defined(DEBUG) && !defined (SHRINKED_GNUC)
+#if defined(__GNUC__) && __GNUC__ >= 2 && !defined(DEBUG) && !defined (SHRINKED_GNUC) && !defined(CAML_JIT)
#define THREADED_CODE
#endif
diff --git a/byterun/exec.h b/byterun/exec.h
index 56609573e6..1abfa455c3 100644
--- a/byterun/exec.h
+++ b/byterun/exec.h
@@ -56,7 +56,7 @@ struct exec_trailer {
/* Magic number for this release */
-#define EXEC_MAGIC "Caml1999X007"
+#define EXEC_MAGIC "Caml1999X008"
#endif /* CAML_EXEC_H */
diff --git a/byterun/extern.c b/byterun/extern.c
index 2faeb9e853..85a549539b 100644
--- a/byterun/extern.c
+++ b/byterun/extern.c
@@ -332,15 +332,17 @@ static void extern_rec(value v)
break;
}
case Abstract_tag:
- extern_invalid_argument("output_value: abstract value");
+ extern_invalid_argument("output_value: abstract value (Abstract)");
break;
case Infix_tag:
writecode32(CODE_INFIXPOINTER, Infix_offset_hd(hd));
extern_rec(v - Infix_offset_hd(hd));
break;
+ /* Use default case for objects
case Object_tag:
extern_invalid_argument("output_value: object value");
break;
+ */
case Custom_tag: {
unsigned long sz_32, sz_64;
char * ident = Custom_ops_val(v)->identifier;
@@ -348,7 +350,7 @@ static void extern_rec(value v)
unsigned long * wsize_64)
= Custom_ops_val(v)->serialize;
if (serialize == NULL)
- extern_invalid_argument("output_value: abstract value");
+ extern_invalid_argument("output_value: abstract value (Custom)");
Write(CODE_CUSTOM);
writeblock(ident, strlen(ident) + 1);
Custom_ops_val(v)->serialize(v, &sz_32, &sz_64);
@@ -383,7 +385,7 @@ static void extern_rec(value v)
writeblock((char *) caml_code_checksum(), 16);
return;
}
- extern_invalid_argument("output_value: abstract value");
+ extern_invalid_argument("output_value: abstract value (outside heap)");
}
enum { NO_SHARING = 1, CLOSURES = 2 };
@@ -565,13 +567,15 @@ CAMLexport void caml_serialize_block_1(void * data, long len)
CAMLexport void caml_serialize_block_2(void * data, long len)
{
- unsigned char * p;
- char * q;
if (extern_ptr + 2 * len > extern_limit) resize_extern_block(2 * len);
#ifndef ARCH_BIG_ENDIAN
- for (p = data, q = extern_ptr; len > 0; len--, p += 2, q += 2)
- Reverse_16(q, p);
- extern_ptr = q;
+ {
+ unsigned char * p;
+ char * q;
+ for (p = data, q = extern_ptr; len > 0; len--, p += 2, q += 2)
+ Reverse_16(q, p);
+ extern_ptr = q;
+ }
#else
memmove(extern_ptr, data, len * 2);
extern_ptr += len * 2;
@@ -580,13 +584,15 @@ CAMLexport void caml_serialize_block_2(void * data, long len)
CAMLexport void caml_serialize_block_4(void * data, long len)
{
- unsigned char * p;
- char * q;
if (extern_ptr + 4 * len > extern_limit) resize_extern_block(4 * len);
#ifndef ARCH_BIG_ENDIAN
- for (p = data, q = extern_ptr; len > 0; len--, p += 4, q += 4)
- Reverse_32(q, p);
- extern_ptr = q;
+ {
+ unsigned char * p;
+ char * q;
+ for (p = data, q = extern_ptr; len > 0; len--, p += 4, q += 4)
+ Reverse_32(q, p);
+ extern_ptr = q;
+ }
#else
memmove(extern_ptr, data, len * 4);
extern_ptr += len * 4;
@@ -595,13 +601,15 @@ CAMLexport void caml_serialize_block_4(void * data, long len)
CAMLexport void caml_serialize_block_8(void * data, long len)
{
- unsigned char * p;
- char * q;
if (extern_ptr + 8 * len > extern_limit) resize_extern_block(8 * len);
#ifndef ARCH_BIG_ENDIAN
- for (p = data, q = extern_ptr; len > 0; len--, p += 8, q += 8)
- Reverse_64(q, p);
- extern_ptr = q;
+ {
+ unsigned char * p;
+ char * q;
+ for (p = data, q = extern_ptr; len > 0; len--, p += 8, q += 8)
+ Reverse_64(q, p);
+ extern_ptr = q;
+ }
#else
memmove(extern_ptr, data, len * 8);
extern_ptr += len * 8;
diff --git a/byterun/fail.c b/byterun/fail.c
index d785d98f31..64d766fe4f 100644
--- a/byterun/fail.c
+++ b/byterun/fail.c
@@ -49,6 +49,7 @@ CAMLexport void caml_raise_constant(value tag)
bucket = caml_alloc_small (1, 0);
Field(bucket, 0) = tag;
caml_raise(bucket);
+ CAMLnoreturn;
}
CAMLexport void caml_raise_with_arg(value tag, value arg)
@@ -60,6 +61,7 @@ CAMLexport void caml_raise_with_arg(value tag, value arg)
Field(bucket, 0) = tag;
Field(bucket, 1) = arg;
caml_raise(bucket);
+ CAMLnoreturn;
}
CAMLexport void caml_raise_with_string(value tag, char *msg)
@@ -69,6 +71,7 @@ CAMLexport void caml_raise_with_string(value tag, char *msg)
vmsg = caml_copy_string(msg);
caml_raise_with_arg(tag, vmsg);
+ CAMLnoreturn;
}
CAMLexport void caml_failwith (char *msg)
diff --git a/byterun/finalise.c b/byterun/finalise.c
index 6b955d9c59..76c2d43d49 100644
--- a/byterun/finalise.c
+++ b/byterun/finalise.c
@@ -27,31 +27,61 @@ struct final {
};
static struct final *final_table = NULL;
-static unsigned long old = 0, young = 0, active = 0, size = 0;
+static unsigned long old = 0, young = 0, size = 0;
/* [0..old) : finalisable set
[old..young) : recent set
- [young..active) : free space
- [active..size) : finalising set
+ [young..size) : free space
*/
-/* Find white finalisable values, darken them, and put them in the
- finalising set.
+struct to_do {
+ struct to_do *next;
+ int size;
+ struct final item[1]; /* variable size */
+};
+
+static struct to_do *to_do_hd = NULL;
+static struct to_do *to_do_tl = NULL;
+
+static void alloc_to_do (int size)
+{
+ struct to_do *result = malloc (sizeof (struct to_do)
+ + size * sizeof (struct final));
+ if (result == NULL) caml_fatal_error ("out of memory");
+ result->next = NULL;
+ result->size = size;
+ if (to_do_tl == NULL){
+ to_do_hd = result;
+ to_do_tl = result;
+ }else{
+ Assert (to_do_tl->next == NULL);
+ to_do_tl->next = result;
+ to_do_tl = result;
+ }
+}
+
+/* Find white finalisable values, put them in the finalising set, and
+ darken them.
The recent set is empty.
*/
void caml_final_update (void)
{
- unsigned long i;
- unsigned long oldactive = active;
+ unsigned long i, j, k;
+ unsigned long todo_count = 0;
Assert (young == old);
- Assert (young <= active);
+ for (i = 0; i < old; i++){
+ Assert (Is_block (final_table[i].val));
+ Assert (Is_in_heap (final_table[i].val));
+ if (Is_white_val (final_table[i].val)) ++ todo_count;
+ }
+
+ alloc_to_do (todo_count);
+ j = k = 0;
for (i = 0; i < old; i++){
again:
Assert (Is_block (final_table[i].val));
Assert (Is_in_heap (final_table[i].val));
if (Is_white_val (final_table[i].val)){
- struct final f;
-
if (Tag_val (final_table[i].val) == Forward_tag){
value fv = Forward_val (final_table[i].val);
if (Is_block (fv) && (Is_young (fv) || Is_in_heap (fv))
@@ -65,31 +95,40 @@ void caml_final_update (void)
}
}
}
- f = final_table[i];
- final_table[i] = final_table[--old];
- final_table[--active] = f;
- -- i;
+ to_do_tl->item[k++] = final_table[i];
+ }else{
+ final_table[j++] = final_table[i];
}
}
- young = old;
- for (i = active; i < oldactive; i++) caml_darken (final_table[i].val, NULL);
+ old = young = j;
+ to_do_tl->size = k;
+ for (i = 0; i < k; i++) caml_darken (to_do_tl->item[i++].val, NULL);
}
+static int running_finalisation_function = 0;
+
/* Call the finalisation functions for the finalising set.
Note that this function must be reentrant.
*/
void caml_final_do_calls (void)
{
struct final f;
-
- Assert (active <= size);
- if (active < size){
- caml_gc_message (0x80, "Calling finalisation functions.\n", 0);
- while (active < size){
- f = final_table[active++];
- caml_callback (f.fun, f.val);
- }
- caml_gc_message (0x80, "Done calling finalisation functions.\n", 0);
+
+ if (running_finalisation_function) return;
+
+ while (to_do_hd != NULL && to_do_hd->size == 0){
+ to_do_hd = to_do_hd->next;
+ if (to_do_hd == NULL) to_do_tl = NULL;
+ }
+ if (to_do_hd != NULL){
+ Assert (to_do_hd->size > 0);
+ -- to_do_hd->size;
+ f = to_do_hd->item[to_do_hd->size];
+ caml_gc_message (0x80, "Calling finalisation function.\n", 0);
+ running_finalisation_function = 1;
+ caml_callback (f.fun, f.val);
+ running_finalisation_function = 0;
+ caml_gc_message (0x80, "Return from finalisation function.\n", 0);
}
}
@@ -105,14 +144,16 @@ void caml_final_do_calls (void)
void caml_final_do_strong_roots (scanning_action f)
{
unsigned long i;
+ struct to_do *todo;
Assert (old == young);
- Assert (young <= active);
- Assert (active <= size);
for (i = 0; i < old; i++) Call_action (f, final_table[i].fun);
- for (i = active; i < size; i++){
- Call_action (f, final_table[i].fun);
- Call_action (f, final_table[i].val);
+
+ for (todo = to_do_hd; todo != NULL; todo = todo->next){
+ for (i = 0; i < todo->size; i++){
+ Call_action (f, todo->item[i].fun);
+ Call_action (f, todo->item[i].val);
+ }
}
}
@@ -159,29 +200,22 @@ CAMLprim value caml_final_register (value f, value v)
}
Assert (old <= young);
- Assert (young <= active);
- Assert (active <= size);
- if (young >= active){
+ if (young >= size){
if (final_table == NULL){
unsigned long new_size = 30;
final_table = caml_stat_alloc (new_size * sizeof (struct final));
Assert (old == 0);
Assert (young == 0);
- active = size = new_size;
+ size = new_size;
}else{
unsigned long new_size = size * 2;
- unsigned long i;
final_table = caml_stat_resize (final_table,
new_size * sizeof (struct final));
- for (i = size-1; i >= active; i--){
- final_table[i + new_size - size] = final_table[i];
- }
- active += new_size - size;
size = new_size;
}
}
- Assert (young < active);
+ Assert (young < size);
final_table[young].fun = f;
if (Tag_val (v) == Infix_tag) v -= Infix_offset_val (v);
final_table[young].val = v;
@@ -189,3 +223,9 @@ CAMLprim value caml_final_register (value f, value v)
return Val_unit;
}
+
+CAMLprim value caml_final_release (value unit)
+{
+ running_finalisation_function = 0;
+ return Val_unit;
+}
diff --git a/byterun/fix_code.c b/byterun/fix_code.c
index 470ae825e1..b626f2cb07 100644
--- a/byterun/fix_code.c
+++ b/byterun/fix_code.c
@@ -113,7 +113,7 @@ void caml_thread_code (code_t code, asize_t len)
l[APPTERM] = l[CLOSURE] = l[PUSHGETGLOBALFIELD] =
l[GETGLOBALFIELD] = l[MAKEBLOCK] = l[C_CALLN] =
l[BEQ] = l[BNEQ] = l[BLTINT] = l[BLEINT] = l[BGTINT] = l[BGEINT] =
- l[BULTINT] = l[BUGEINT] = 2;
+ l[BULTINT] = l[BUGEINT] = l[GETPUBMET] = 2;
len /= sizeof(opcode_t);
for (p = code; p < code + len; /*nothing*/) {
opcode_t instr = *p;
diff --git a/byterun/gc_ctrl.c b/byterun/gc_ctrl.c
index b262bbd9b2..f31ef1de88 100644
--- a/byterun/gc_ctrl.c
+++ b/byterun/gc_ctrl.c
@@ -434,6 +434,7 @@ CAMLprim value caml_gc_compaction(value v)
caml_finish_major_cycle ();
caml_finish_major_cycle ();
caml_compact_heap ();
+ caml_final_do_calls ();
return Val_unit;
}
diff --git a/byterun/instrtrace.c b/byterun/instrtrace.c
index aba9787490..03260b41e3 100644
--- a/byterun/instrtrace.c
+++ b/byterun/instrtrace.c
@@ -18,11 +18,15 @@
#ifdef DEBUG
#include <stdio.h>
+#include <string.h>
+#include <ctype.h>
+
#include "instruct.h"
#include "misc.h"
#include "mlvalues.h"
#include "opnames.h"
#include "prims.h"
+#include "stacks.h"
extern code_t caml_start_code;
@@ -74,4 +78,196 @@ void caml_disasm_instr(pc)
fflush (stdout);
}
+
+
+
+char *
+caml_instr_string (code_t pc)
+{
+ static char buf[96];
+ char nambuf[36];
+ int instr = *pc;
+ char *nam = 0;
+ memset (buf, 0, sizeof (buf));
+#define bufprintf(Fmt,...) snprintf(buf,sizeof(buf)-1,Fmt,##__VA_ARGS__)
+ nam = (instr < 0 || instr > STOP)
+ ? (snprintf (nambuf, sizeof (nambuf), "???%d", instr), nambuf)
+ : names_of_instructions[instr];
+ pc++;
+ switch (instr) {
+ /* Instructions with one integer operand */
+ case PUSHACC:
+ case ACC:
+ case POP:
+ case ASSIGN:
+ case PUSHENVACC:
+ case ENVACC:
+ case PUSH_RETADDR:
+ case APPLY:
+ case APPTERM1:
+ case APPTERM2:
+ case APPTERM3:
+ case RETURN:
+ case GRAB:
+ case PUSHGETGLOBAL:
+ case GETGLOBAL:
+ case SETGLOBAL:
+ case PUSHATOM:
+ case ATOM:
+ case MAKEBLOCK1:
+ case MAKEBLOCK2:
+ case MAKEBLOCK3:
+ case MAKEFLOATBLOCK:
+ case GETFIELD:
+ case SETFIELD:
+ case GETFLOATFIELD:
+ case SETFLOATFIELD:
+ case BRANCH:
+ case BRANCHIF:
+ case BRANCHIFNOT:
+ case PUSHTRAP:
+ case CONSTINT:
+ case PUSHCONSTINT:
+ case OFFSETINT:
+ case OFFSETREF:
+ case OFFSETCLOSURE:
+ case PUSHOFFSETCLOSURE:
+ bufprintf ("%s %d", nam, pc[0]);
+ break;
+ /* Instructions with two operands */
+ case APPTERM:
+ case CLOSURE:
+ case CLOSUREREC:
+ case PUSHGETGLOBALFIELD:
+ case GETGLOBALFIELD:
+ case MAKEBLOCK:
+ case BEQ:
+ case BNEQ:
+ case BLTINT:
+ case BLEINT:
+ case BGTINT:
+ case BGEINT:
+ case BULTINT:
+ case BUGEINT:
+ bufprintf ("%s %d, %d", nam, pc[0], pc[1]);
+ break;
+ case SWITCH:
+ bufprintf ("SWITCH sz%#lx=%ld::ntag%ld nint%ld",
+ (long) pc[0], (long) pc[0], (unsigned long) pc[0] >> 16,
+ (unsigned long) pc[0] & 0xffff);
+ break;
+ /* Instructions with a C primitive as operand */
+ case C_CALLN:
+ bufprintf ("%s %d,", nam, pc[0]);
+ pc++;
+ /* fallthrough */
+ case C_CALL1:
+ case C_CALL2:
+ case C_CALL3:
+ case C_CALL4:
+ case C_CALL5:
+ if (pc[0] < 0 || pc[0] >= caml_prim_name_table.size)
+ bufprintf ("%s unknown primitive %d", nam, pc[0]);
+ else
+ bufprintf ("%s %s", nam, (char *) caml_prim_name_table.contents[pc[0]]);
+ break;
+ default:
+ bufprintf ("%s", nam);
+ break;
+ };
+ return buf;
+}
+
+
+void
+caml_trace_value_file (value v, code_t prog, int proglen, FILE * f)
+{
+ int i;
+ fprintf (f, "%#lx", v);
+ if (!v)
+ return;
+ if (Is_atom (v))
+ fprintf (f, "=atom%ld", v - Atom (0));
+ else if (prog && v % sizeof (int) == 0
+ && (code_t) v >= prog
+ && (code_t) v < (code_t) ((char *) prog + proglen))
+ fprintf (f, "=code@%d", (code_t) v - prog);
+ else if (Is_long (v))
+ fprintf (f, "=long%ld", Long_val (v));
+ else if ((void*)v >= (void*)caml_stack_low
+ && (void*)v < (void*)caml_stack_high)
+ fprintf (f, "=stack_%d", (long*)caml_stack_high - (long*)v);
+ else if (Is_block (v)) {
+ int s = Wosize_val (v);
+ int tg = Tag_val (v);
+ int l = 0;
+ switch (tg) {
+ case Closure_tag:
+ fprintf (f, "=closure[s%d,cod%d]", s, (code_t) (Code_val (v)) - prog);
+ goto displayfields;
+ case String_tag:
+ l = caml_string_length (v);
+ fprintf (f, "=string[s%dL%d]'", s, l);
+ for (i = 0; i < ((l>0x1f)?0x1f:l) ; i++) {
+ if (isprint (Byte (v, i)))
+ putc (Byte (v, i), f);
+ else
+ putc ('?', f);
+ };
+ fprintf (f, "'");
+ goto displayfields;
+ case Double_tag:
+ fprintf (f, "=float[s%d]=%g", s, Double_val (v));
+ goto displayfields;
+ case Double_array_tag:
+ fprintf (f, "=floatarray[s%d]", s);
+ for (i = 0; i < ((s>0xf)?0xf:s); i++)
+ fprintf (f, " %g", Double_field (v, i));
+ goto displayfields;
+ case Abstract_tag:
+ fprintf (f, "=abstract[s%d]", s);
+ goto displayfields;
+ case Custom_tag:
+ fprintf (f, "=custom[s%d]", s);
+ goto displayfields;
+ default:
+ fprintf (f, "=block<T%d/s%d>", tg, s);
+ displayfields:
+ if (s > 0)
+ fputs ("=(", f);
+ for (i = 0; i < s; i++) {
+ if (i > 20) {
+ fputs ("....", f);
+ break;
+ };
+ if (i > 0)
+ putc (' ', f);
+ fprintf (f, "%#lx", Field (v, i));
+ };
+ if (s > 0)
+ putc (')', f);
+ };
+ }
+}
+
+// added by Basile
+void
+caml_trace_accu_sp_file (value accu, value * sp, code_t prog, int proglen,
+ FILE * f)
+{
+ int i;
+ value *p;
+ fprintf (f, "accu=");
+ caml_trace_value_file (accu, prog, proglen, f);
+ fprintf (f, "\n sp=%#lx @%d:", (long) sp, caml_stack_high - sp);
+ for (p = sp, i = 0; i < 12 + (1 << caml_trace_flag) && p < caml_stack_high;
+ p++, i++) {
+ fprintf (f, "\n[%d] ", caml_stack_high - p);
+ caml_trace_value_file (*p, prog, proglen, f);
+ };
+ putc ('\n', f);
+ fflush (f);
+}
+
#endif /* DEBUG */
+/* eof $Id$ */
diff --git a/byterun/instrtrace.h b/byterun/instrtrace.h
index 6b899766b0..9df4a62352 100644
--- a/byterun/instrtrace.h
+++ b/byterun/instrtrace.h
@@ -26,6 +26,6 @@ extern int caml_trace_flag;
extern long caml_icount;
void caml_stop_here (void);
void caml_disasm_instr (code_t pc);
-
-
+void caml_trace_value_file (value v, code_t prog, int proglen, FILE * f);
+void caml_trace_accu_sp_file(value accu, value * sp, code_t prog, int proglen, FILE * f);
#endif
diff --git a/byterun/instruct.h b/byterun/instruct.h
index c0cf5f2df7..a2eb5b7b5e 100644
--- a/byterun/instruct.h
+++ b/byterun/instruct.h
@@ -53,6 +53,7 @@ enum instructions {
BEQ, BNEQ, BLTINT, BLEINT, BGTINT, BGEINT,
ULTINT, UGEINT,
BULTINT, BUGEINT,
+ GETPUBMET, GETDYNMET,
STOP,
EVENT, BREAK
};
diff --git a/byterun/intern.c b/byterun/intern.c
index 34b22340a0..00872d6d50 100644
--- a/byterun/intern.c
+++ b/byterun/intern.c
@@ -651,8 +651,8 @@ CAMLexport void caml_deserialize_block_1(void * data, long len)
CAMLexport void caml_deserialize_block_2(void * data, long len)
{
- unsigned char * p, * q;
#ifndef ARCH_BIG_ENDIAN
+ unsigned char * p, * q;
for (p = intern_src, q = data; len > 0; len--, p += 2, q += 2)
Reverse_16(q, p);
intern_src = p;
@@ -664,8 +664,8 @@ CAMLexport void caml_deserialize_block_2(void * data, long len)
CAMLexport void caml_deserialize_block_4(void * data, long len)
{
- unsigned char * p, * q;
#ifndef ARCH_BIG_ENDIAN
+ unsigned char * p, * q;
for (p = intern_src, q = data; len > 0; len--, p += 4, q += 4)
Reverse_32(q, p);
intern_src = p;
@@ -677,8 +677,8 @@ CAMLexport void caml_deserialize_block_4(void * data, long len)
CAMLexport void caml_deserialize_block_8(void * data, long len)
{
- unsigned char * p, * q;
#ifndef ARCH_BIG_ENDIAN
+ unsigned char * p, * q;
for (p = intern_src, q = data; len > 0; len--, p += 8, q += 8)
Reverse_64(q, p);
intern_src = p;
diff --git a/byterun/interp.c b/byterun/interp.c
index 146baa7744..abf504131a 100644
--- a/byterun/interp.c
+++ b/byterun/interp.c
@@ -114,7 +114,7 @@ sp is a local copy of the global variable caml_extern_sp. */
For GCC, I have hand-assigned hardware registers for several architectures.
*/
-#if defined(__GNUC__) && !defined(DEBUG)
+#if defined(__GNUC__) && !defined(__INTEL_COMPILER) && !defined(DEBUG)
#ifdef __mips__
#define PC_REG asm("$16")
#define SP_REG asm("$17")
@@ -183,6 +183,11 @@ extern long caml_safe_div(long p, long q);
extern long caml_safe_mod(long p, long q);
#endif
+
+#ifdef DEBUG
+static long caml_bcodcount;
+#endif
+
/* The interpreter itself */
value caml_interprete(code_t prog, asize_t prog_size)
@@ -207,15 +212,15 @@ value caml_interprete(code_t prog, asize_t prog_size)
long extra_args;
struct longjmp_buffer * initial_external_raise;
int initial_sp_offset;
- /* volatile prevents collapsing initial_local_roots with another
- local variable, like Digital Unix 4.0 C compiler does (wrongly) */
+ /* volatile ensures that initial_local_roots and saved_pc
+ will keep correct value across longjmp */
struct caml__roots_block * volatile initial_local_roots;
+ volatile code_t saved_pc;
struct longjmp_buffer raise_buf;
value * modify_dest, modify_newval;
#ifndef THREADED_CODE
opcode_t curr_instr;
#endif
- code_t saved_pc;
#ifdef THREADED_CODE
static void * jumptable[] = {
@@ -266,8 +271,17 @@ value caml_interprete(code_t prog, asize_t prog_size)
#else
while(1) {
#ifdef DEBUG
+ caml_bcodcount++;
if (caml_icount-- == 0) caml_stop_here ();
+ if (caml_trace_flag>1) printf("\n##%ld\n", caml_bcodcount);
if (caml_trace_flag) caml_disasm_instr(pc);
+ if (caml_trace_flag>1) {
+ printf("env=");
+ caml_trace_value_file(env,prog,prog_size,stdout);
+ putchar('\n');
+ caml_trace_accu_sp_file(accu,sp,prog,prog_size,stdout);
+ fflush(stdout);
+ };
Assert(sp >= caml_stack_low);
Assert(sp <= caml_stack_high);
#endif
@@ -1012,14 +1026,73 @@ value caml_interprete(code_t prog, asize_t prog_size)
/* Object-oriented operations */
-#define Lookup(obj, lab) \
- Field (Field (Field (obj, 0), ((lab) >> 16) / sizeof (value)), \
- ((lab) / sizeof (value)) & 0xFF)
+#define Lookup(obj, lab) Field (Field (obj, 0), Int_val(lab))
+
+ /* please don't forget to keep below code in sync with the
+ functions caml_cache_public_method and
+ caml_cache_public_method2 in obj.c */
Instruct(GETMETHOD):
accu = Lookup(sp[0], accu);
Next;
+#define CAML_METHOD_CACHE
+#ifdef CAML_METHOD_CACHE
+ Instruct(GETPUBMET): {
+ /* accu == object, pc[0] == tag, pc[1] == cache */
+ value meths = Field (accu, 0);
+ value ofs;
+#ifdef CAML_TEST_CACHE
+ static int calls = 0, hits = 0;
+ if (calls >= 10000000) {
+ fprintf(stderr, "cache hit = %d%%\n", hits / 100000);
+ calls = 0; hits = 0;
+ }
+ calls++;
+#endif
+ *--sp = accu;
+ accu = Val_int(*pc++);
+ ofs = *pc & Field(meths,1);
+ if (*(value*)(((char*)&Field(meths,3)) + ofs) == accu) {
+#ifdef CAML_TEST_CACHE
+ hits++;
+#endif
+ accu = *(value*)(((char*)&Field(meths,2)) + ofs);
+ }
+ else
+ {
+ int li = 3, hi = Field(meths,0), mi;
+ while (li < hi) {
+ mi = ((li+hi) >> 1) | 1;
+ if (accu < Field(meths,mi)) hi = mi-2;
+ else li = mi;
+ }
+ *pc = (li-3)*sizeof(value);
+ accu = Field (meths, li-1);
+ }
+ pc++;
+ Next;
+ }
+#else
+ Instruct(GETPUBMET):
+ *--sp = accu;
+ accu = Val_int(*pc);
+ pc += 2;
+ /* Fallthrough */
+#endif
+ Instruct(GETDYNMET): {
+ /* accu == tag, sp[0] == object, *pc == cache */
+ value meths = Field (sp[0], 0);
+ int li = 3, hi = Field(meths,0), mi;
+ while (li < hi) {
+ mi = ((li+hi) >> 1) | 1;
+ if (accu < Field(meths,mi)) hi = mi-2;
+ else li = mi;
+ }
+ accu = Field (meths, li-1);
+ Next;
+ }
+
/* Debugging and machine control */
Instruct(STOP):
@@ -1054,3 +1127,22 @@ value caml_interprete(code_t prog, asize_t prog_size)
}
#endif
}
+
+void caml_prepare_bytecode(code_t prog, asize_t prog_size) {
+ /* other implementations of the interpreter (such as an hypothetical
+ JIT translator) might want to do something with a bytecode before
+ running it */
+ Assert(prog);
+ Assert(prog_size>0);
+ /* actually, the threading of the bytecode might be done here */
+}
+
+void caml_release_bytecode(code_t prog, asize_t prog_size) {
+ /* other implementations of the interpreter (such as an hypothetical
+ JIT translator) might want to know when a bytecode is removed */
+ /* check that we have a program */
+ Assert(prog);
+ Assert(prog_size>0);
+}
+
+/* eof $Id$ */
diff --git a/byterun/interp.h b/byterun/interp.h
index 075f0ff818..9eb7339405 100644
--- a/byterun/interp.h
+++ b/byterun/interp.h
@@ -18,11 +18,16 @@
#ifndef CAML_INTERP_H
#define CAML_INTERP_H
-
#include "misc.h"
#include "mlvalues.h"
+/* interpret a bytecode */
value caml_interprete (code_t prog, asize_t prog_size);
+/* tell the runtime that a bytecode program might be needed */
+void caml_prepare_bytecode(code_t prog, asize_t prog_size);
+
+/* tell the runtime that a bytecode program is no more needed */
+void caml_release_bytecode(code_t prog, asize_t prog_size);
#endif /* CAML_INTERP_H */
diff --git a/byterun/major_gc.c b/byterun/major_gc.c
index d39cd2f203..06183d5196 100644
--- a/byterun/major_gc.c
+++ b/byterun/major_gc.c
@@ -42,7 +42,8 @@ static asize_t gray_vals_size;
static int heap_is_pure; /* The heap is pure if the only gray objects
below [markhp] are also in [gray_vals]. */
unsigned long caml_allocated_words;
-double caml_extra_heap_memory;
+unsigned long caml_dependent_size, caml_dependent_allocated;
+double caml_extra_heap_resources;
unsigned long caml_fl_size_at_phase_change = 0;
extern char *caml_fl_merge; /* Defined in freelist.c. */
@@ -294,7 +295,7 @@ static void sweep_slice (long work)
*/
long caml_major_collection_slice (long howmuch)
{
- double p;
+ double p, dp;
long computed_work;
/*
Free memory at the start of the GC cycle (garbage + free list) (assumed):
@@ -304,15 +305,15 @@ long caml_major_collection_slice (long howmuch)
Assuming steady state and enforcing a constant allocation rate, then
FM is divided in 2/3 for garbage and 1/3 for free list.
G = 2 * FM / 3
- G is also the amount of memory that will be used during this slice
+ G is also the amount of memory that will be used during this cycle
(still assuming steady state).
Proportion of G consumed since the previous slice:
PH = caml_allocated_words / G
= caml_allocated_words * 3 * (100 + caml_percent_free)
/ (2 * caml_stat_heap_size * caml_percent_free)
- Proportion of extra-heap memory consumed since the previous slice:
- PE = caml_extra_heap_memory
+ Proportion of extra-heap resources consumed since the previous slice:
+ PE = caml_extra_heap_resources
Proportion of total work to do in this slice:
P = max (PH, PE)
Amount of marking work for the GC cycle:
@@ -332,11 +333,18 @@ long caml_major_collection_slice (long howmuch)
p = (double) caml_allocated_words * 3.0 * (100 + caml_percent_free)
/ Wsize_bsize (caml_stat_heap_size) / caml_percent_free / 2.0;
- if (p < caml_extra_heap_memory) p = caml_extra_heap_memory;
+ if (caml_dependent_size > 0){
+ dp = (double) caml_dependent_allocated * (100 + caml_percent_free)
+ / caml_dependent_size / caml_percent_free;
+ }else{
+ dp = 0.0;
+ }
+ if (p < dp) p = dp;
+ if (p < caml_extra_heap_resources) p = caml_extra_heap_resources;
caml_gc_message (0x40, "allocated_words = %lu\n", caml_allocated_words);
- caml_gc_message (0x40, "extra_heap_memory = %luu\n",
- (unsigned long) (caml_extra_heap_memory * 1000000));
+ caml_gc_message (0x40, "extra_heap_resources = %luu\n",
+ (unsigned long) (caml_extra_heap_resources * 1000000));
caml_gc_message (0x40, "amount of work to do = %luu\n",
(unsigned long) (p * 1000000));
@@ -362,7 +370,8 @@ long caml_major_collection_slice (long howmuch)
caml_stat_major_words += caml_allocated_words;
caml_allocated_words = 0;
- caml_extra_heap_memory = 0.0;
+ caml_dependent_allocated = 0;
+ caml_extra_heap_resources = 0.0;
return computed_work;
}
@@ -417,7 +426,6 @@ asize_t caml_round_heap_chunk_size (asize_t request)
void caml_init_major_heap (asize_t heap_size)
{
asize_t i;
- void *block;
asize_t page_table_size;
page_table_entry *page_table_block;
@@ -459,5 +467,5 @@ void caml_init_major_heap (asize_t heap_size)
gray_vals_end = gray_vals + gray_vals_size;
heap_is_pure = 1;
caml_allocated_words = 0;
- caml_extra_heap_memory = 0.0;
+ caml_extra_heap_resources = 0.0;
}
diff --git a/byterun/major_gc.h b/byterun/major_gc.h
index 0c3eb14ec0..3a53d04ac2 100644
--- a/byterun/major_gc.h
+++ b/byterun/major_gc.h
@@ -34,7 +34,8 @@ typedef struct {
extern int caml_gc_phase;
extern unsigned long caml_allocated_words;
-extern double caml_extra_heap_memory;
+extern double caml_extra_heap_resources;
+extern unsigned long caml_dependent_size, caml_dependent_allocated;
extern unsigned long caml_fl_size_at_phase_change;
#define Phase_mark 0
diff --git a/byterun/memory.c b/byterun/memory.c
index 824a01d44c..a4780c6ea2 100644
--- a/byterun/memory.c
+++ b/byterun/memory.c
@@ -21,6 +21,7 @@
#include "gc_ctrl.h"
#include "major_gc.h"
#include "memory.h"
+#include "major_gc.h"
#include "minor_gc.h"
#include "misc.h"
#include "mlvalues.h"
@@ -297,26 +298,49 @@ CAMLexport value caml_alloc_shr (mlsize_t wosize, tag_t tag)
return Val_hp (hp);
}
+/* Dependent memory is all memory blocks allocated out of the heap
+ that depend on the GC (and finalizers) for deallocation.
+ For the GC to take dependent memory in its automatic speed setting,
+ you must call [caml_alloc_dependent_memory] when you alloate some
+ dependent memory, and [caml_free_dependent_memory] when you
+ free it. In both cases, you pass as argument the size of the
+ block being allocated or freed.
+*/
+CAMLexport void caml_alloc_dependent_memory (mlsize_t nbytes)
+{
+ caml_dependent_size += nbytes / sizeof (value);
+ caml_dependent_allocated += nbytes / sizeof (value);
+}
+
+CAMLexport void caml_free_dependent_memory (mlsize_t nbytes)
+{
+ if (caml_dependent_size < nbytes / sizeof (value)){
+ caml_dependent_size = 0;
+ }else{
+ caml_dependent_size -= nbytes / sizeof (value);
+ }
+}
+
/* Use this function to tell the major GC to speed up when you use
- finalized blocks to automatically deallocate extra-heap stuff.
- The GC will do at least one cycle every [max] allocated words;
- [mem] is the number of words allocated this time.
- Note that only [mem/max] is relevant. You can use numbers of bytes
- (or kilobytes, ...) instead of words. You can change units between
- calls to [caml_adjust_gc_speed].
+ finalized blocks to automatically deallocate resources (other
+ than memory). The GC will do at least one cycle every [max]
+ allocated resources; [res] is the number of resources allocated
+ this time.
+ Note that only [res/max] is relevant. The units (and kind of
+ resource) can change between calls to [caml_adjust_gc_speed].
*/
-CAMLexport void caml_adjust_gc_speed (mlsize_t mem, mlsize_t max)
+CAMLexport void caml_adjust_gc_speed (mlsize_t res, mlsize_t max)
{
if (max == 0) max = 1;
- if (mem > max) mem = max;
- caml_extra_heap_memory += (double) mem / (double) max;
- if (caml_extra_heap_memory > 1.0){
- caml_extra_heap_memory = 1.0;
+ if (res > max) res = max;
+ caml_extra_heap_resources += (double) res / (double) max;
+ if (caml_extra_heap_resources > 1.0){
+ caml_extra_heap_resources = 1.0;
caml_urge_major_slice ();
}
- if (caml_extra_heap_memory > (double) Wsize_bsize (caml_minor_heap_size)
- / 2.0
- / (double) Wsize_bsize (caml_stat_heap_size)) {
+ if (caml_extra_heap_resources
+ > (double) Wsize_bsize (caml_minor_heap_size) / 2.0
+ / (double) Wsize_bsize (caml_stat_heap_size)) {
caml_urge_major_slice ();
}
}
diff --git a/byterun/memory.h b/byterun/memory.h
index 4be908b8c5..f986793c9a 100644
--- a/byterun/memory.h
+++ b/byterun/memory.h
@@ -32,6 +32,8 @@
CAMLextern value caml_alloc_shr (mlsize_t, tag_t);
CAMLextern void caml_adjust_gc_speed (mlsize_t, mlsize_t);
+CAMLextern void caml_alloc_dependent_memory (mlsize_t);
+CAMLextern void caml_free_dependent_memory (mlsize_t);
CAMLextern void caml_modify (value *, value);
CAMLextern void caml_initialize (value *, value);
CAMLextern value caml_check_urgent_gc (value);
@@ -168,9 +170,15 @@ CAMLextern struct caml__roots_block *caml_local_roots; /* defined in roots.c */
CAMLxparamN (x, (size))
+#if defined (__GNUC__)
+ #define CAMLunused __attribute__ ((unused))
+#else
+ #define CAMLunused
+#endif
+
#define CAMLxparam1(x) \
struct caml__roots_block caml__roots_##x; \
- int caml__dummy_##x = ( \
+ CAMLunused int caml__dummy_##x = ( \
(caml__roots_##x.next = caml_local_roots), \
(caml_local_roots = &caml__roots_##x), \
(caml__roots_##x.nitems = 1), \
@@ -180,7 +188,7 @@ CAMLextern struct caml__roots_block *caml_local_roots; /* defined in roots.c */
#define CAMLxparam2(x, y) \
struct caml__roots_block caml__roots_##x; \
- int caml__dummy_##x = ( \
+ CAMLunused int caml__dummy_##x = ( \
(caml__roots_##x.next = caml_local_roots), \
(caml_local_roots = &caml__roots_##x), \
(caml__roots_##x.nitems = 1), \
@@ -191,7 +199,7 @@ CAMLextern struct caml__roots_block *caml_local_roots; /* defined in roots.c */
#define CAMLxparam3(x, y, z) \
struct caml__roots_block caml__roots_##x; \
- int caml__dummy_##x = ( \
+ CAMLunused int caml__dummy_##x = ( \
(caml__roots_##x.next = caml_local_roots), \
(caml_local_roots = &caml__roots_##x), \
(caml__roots_##x.nitems = 1), \
@@ -203,7 +211,7 @@ CAMLextern struct caml__roots_block *caml_local_roots; /* defined in roots.c */
#define CAMLxparam4(x, y, z, t) \
struct caml__roots_block caml__roots_##x; \
- int caml__dummy_##x = ( \
+ CAMLunused int caml__dummy_##x = ( \
(caml__roots_##x.next = caml_local_roots), \
(caml_local_roots = &caml__roots_##x), \
(caml__roots_##x.nitems = 1), \
@@ -216,7 +224,7 @@ CAMLextern struct caml__roots_block *caml_local_roots; /* defined in roots.c */
#define CAMLxparam5(x, y, z, t, u) \
struct caml__roots_block caml__roots_##x; \
- int caml__dummy_##x = ( \
+ CAMLunused int caml__dummy_##x = ( \
(caml__roots_##x.next = caml_local_roots), \
(caml_local_roots = &caml__roots_##x), \
(caml__roots_##x.nitems = 1), \
@@ -230,7 +238,7 @@ CAMLextern struct caml__roots_block *caml_local_roots; /* defined in roots.c */
#define CAMLxparamN(x, size) \
struct caml__roots_block caml__roots_##x; \
- int caml__dummy_##x = ( \
+ CAMLunused int caml__dummy_##x = ( \
(caml__roots_##x.next = caml_local_roots), \
(caml_local_roots = &caml__roots_##x), \
(caml__roots_##x.nitems = (size)), \
@@ -273,6 +281,9 @@ CAMLextern struct caml__roots_block *caml_local_roots; /* defined in roots.c */
return (result); \
}while(0)
+#define CAMLnoreturn ((void) caml__frame)
+
+
/* convenience macro */
#define Store_field(block, offset, val) do{ \
mlsize_t caml__temp_offset = (offset); \
diff --git a/byterun/meta.c b/byterun/meta.c
index 021e4680cb..ac86ee8e17 100644
--- a/byterun/meta.c
+++ b/byterun/meta.c
@@ -55,6 +55,7 @@ CAMLprim value caml_reify_bytecode(value prog, value len)
#ifdef THREADED_CODE
caml_thread_code((code_t) prog, (asize_t) Long_val(len));
#endif
+ caml_prepare_bytecode((code_t) prog, (asize_t) Long_val(len));
clos = caml_alloc_small (1, Closure_tag);
Code_val(clos) = (code_t) prog;
return clos;
diff --git a/byterun/misc.c b/byterun/misc.c
index 618729e4af..8791eca42a 100644
--- a/byterun/misc.c
+++ b/byterun/misc.c
@@ -41,19 +41,20 @@ void caml_gc_message (int level, char *msg, unsigned long arg)
}
}
-void caml_fatal_error (char *msg)
+CAMLexport void caml_fatal_error (char *msg)
{
fprintf (stderr, "%s", msg);
exit(2);
}
-void caml_fatal_error_arg (char *fmt, char *arg)
+CAMLexport void caml_fatal_error_arg (char *fmt, char *arg)
{
fprintf (stderr, fmt, arg);
exit(2);
}
-void caml_fatal_error_arg2 (char *fmt1, char *arg1, char *fmt2, char *arg2)
+CAMLexport void caml_fatal_error_arg2 (char *fmt1, char *arg1,
+ char *fmt2, char *arg2)
{
fprintf (stderr, fmt1, arg1);
fprintf (stderr, fmt2, arg2);
diff --git a/byterun/misc.h b/byterun/misc.h
index 298e7c6693..bda864fc49 100644
--- a/byterun/misc.h
+++ b/byterun/misc.h
@@ -41,10 +41,10 @@ typedef char * addr;
/* </private> */
#ifdef __GNUC__
-/* Works only in GCC 2.5 and later */
-#define Noreturn __attribute ((noreturn))
+ /* Works only in GCC 2.5 and later */
+ #define Noreturn __attribute__ ((noreturn))
#else
-#define Noreturn
+ #define Noreturn
#endif
/* Export control (to mark primitives and to handle Windows DLL) */
@@ -69,15 +69,15 @@ typedef char * addr;
#ifdef DEBUG
#define CAMLassert(x) ((x) ? 0 : caml_failed_assert ( #x , __FILE__, __LINE__))
-int caml_failed_assert (char *, char *, int);
+CAMLextern int caml_failed_assert (char *, char *, int);
#else
-#define CAMLassert(x) 0
+#define CAMLassert(x) ((void) 0)
#endif
-void caml_fatal_error (char *msg) Noreturn;
-void caml_fatal_error_arg (char *fmt, char *arg) Noreturn;
-void caml_fatal_error_arg2 (char *fmt1, char *arg1,
- char *fmt2, char *arg2) Noreturn;
+CAMLextern void caml_fatal_error (char *msg) Noreturn;
+CAMLextern void caml_fatal_error_arg (char *fmt, char *arg) Noreturn;
+CAMLextern void caml_fatal_error_arg2 (char *fmt1, char *arg1,
+ char *fmt2, char *arg2) Noreturn;
/* Data structures */
diff --git a/byterun/obj.c b/byterun/obj.c
index 277c24180a..809aeab6d0 100644
--- a/byterun/obj.c
+++ b/byterun/obj.c
@@ -19,6 +19,7 @@
#include "alloc.h"
#include "fail.h"
#include "gc.h"
+#include "interp.h"
#include "major_gc.h"
#include "memory.h"
#include "minor_gc.h"
@@ -37,6 +38,21 @@ CAMLprim value caml_static_free(value blk)
return Val_unit;
}
+/* signal to the interpreter machinery that a bytecode is no more
+ needed (before freeing it) - this might be useful for a JIT
+ implementation */
+
+CAMLprim value caml_static_release_bytecode(value blk, value size)
+{
+#ifndef NATIVE_CODE
+ caml_release_bytecode((code_t) blk, (asize_t) Long_val(size));
+#else
+ caml_failwith("Meta.static_release_bytecode impossible with native code");
+#endif
+ return Val_unit;
+}
+
+
CAMLprim value caml_static_resize(value blk, value new_size)
{
return (value) caml_stat_resize((char *) blk, (asize_t) Long_val(new_size));
@@ -181,3 +197,59 @@ CAMLprim value caml_lazy_make_forward (value v)
Modify (&Field (res, 0), v);
CAMLreturn (res);
}
+
+/* For camlinternalOO.ml
+ See also GETPUBMET in interp.c
+ */
+
+CAMLprim value caml_get_public_method (value obj, value tag)
+{
+ value meths = Field (obj, 0);
+ int li = 3, hi = Field(meths,0), mi;
+ while (li < hi) {
+ mi = ((li+hi) >> 1) | 1;
+ if (tag < Field(meths,mi)) hi = mi-2;
+ else li = mi;
+ }
+ return Field (meths, li-1);
+}
+
+/* these two functions might be useful to an hypothetical JIT */
+
+#ifdef CAML_JIT
+#ifdef NATIVE_CODE
+#define MARK 1
+#else
+#define MARK 0
+#endif
+value caml_cache_public_method (value meths, value tag, value *cache)
+{
+ int li = 3, hi = Field(meths,0), mi;
+ while (li < hi) {
+ mi = ((li+hi) >> 1) | 1;
+ if (tag < Field(meths,mi)) hi = mi-2;
+ else li = mi;
+ }
+ *cache = (li-3)*sizeof(value) + MARK;
+ return Field (meths, li-1);
+}
+
+value caml_cache_public_method2 (value *meths, value tag, value *cache)
+{
+ value ofs = *cache & meths[1];
+ if (*(value*)(((char*)(meths+3)) + ofs - MARK) == tag)
+ return *(value*)(((char*)(meths+2)) + ofs - MARK);
+ {
+ int li = 3, hi = meths[0], mi;
+ while (li < hi) {
+ mi = ((li+hi) >> 1) | 1;
+ if (tag < meths[mi]) hi = mi-2;
+ else li = mi;
+ }
+ *cache = (li-3)*sizeof(value) + MARK;
+ return meths[li-1];
+ }
+}
+#endif /*CAML_JIT*/
+
+/* eof $Id$ */
diff --git a/byterun/parsing.c b/byterun/parsing.c
index 68e687ffdb..2d90fa5524 100644
--- a/byterun/parsing.c
+++ b/byterun/parsing.c
@@ -115,7 +115,6 @@ static char * token_name(char * names, int number)
static void print_token(struct parser_tables *tables, int state, value tok)
{
- mlsize_t i;
value v;
if (Is_long(tok)) {
diff --git a/byterun/startup.c b/byterun/startup.c
index 7918f0eea3..57f8c970a5 100644
--- a/byterun/startup.c
+++ b/byterun/startup.c
@@ -236,7 +236,7 @@ static int parse_command_line(char **argv)
switch(argv[i][1]) {
#ifdef DEBUG
case 't':
- caml_trace_flag = 1;
+ caml_trace_flag++;
break;
#endif
case 'v':
diff --git a/byterun/str.c b/byterun/str.c
index 08bbf839e7..8151fa37c1 100644
--- a/byterun/str.c
+++ b/byterun/str.c
@@ -83,7 +83,7 @@ CAMLprim value caml_string_notequal(value s1, value s2)
CAMLprim value caml_string_compare(value s1, value s2)
{
- mlsize_t len1, len2, len;
+ mlsize_t len1, len2;
int res;
len1 = caml_string_length(s1);
diff --git a/byterun/sys.c b/byterun/sys.c
index 96d0c7bb2a..c5f5c60e14 100644
--- a/byterun/sys.c
+++ b/byterun/sys.c
@@ -51,32 +51,11 @@
extern int errno;
#endif
-#ifdef HAS_STRERROR
-
-#ifndef _WIN32
-extern char * strerror(int);
-#endif
-
static char * error_message(void)
{
return strerror(errno);
}
-#else
-
-extern int sys_nerr;
-extern char * sys_errlist [];
-
-static char * error_message(void)
-{
- if (errno < 0 || errno >= sys_nerr)
- return "unknown error";
- else
- return sys_errlist[errno];
-}
-
-#endif /* HAS_STRERROR */
-
#ifndef EAGAIN
#define EAGAIN (-1)
#endif
@@ -106,6 +85,7 @@ CAMLexport void caml_sys_error(value arg)
}
caml_raise_sys_error(str);
}
+ CAMLnoreturn;
}
CAMLprim value caml_sys_exit(value retcode)
@@ -179,7 +159,7 @@ CAMLprim value caml_sys_remove(value name)
CAMLprim value caml_sys_rename(value oldname, value newname)
{
if (rename(String_val(oldname), String_val(newname)) != 0)
- caml_sys_error(oldname);
+ caml_sys_error(NO_ARG);
return Val_unit;
}
View Lorry Controller Status