diff options
Diffstat (limited to 'test/monniaux/ocaml/byterun/meta.c')
| -rw-r--r-- | test/monniaux/ocaml/byterun/meta.c | 234 |
1 files changed, 234 insertions, 0 deletions
diff --git a/test/monniaux/ocaml/byterun/meta.c b/test/monniaux/ocaml/byterun/meta.c new file mode 100644 index 00000000..03e0479d --- /dev/null +++ b/test/monniaux/ocaml/byterun/meta.c @@ -0,0 +1,234 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS + +/* Primitives for the toplevel */ + +#include <string.h> +#include "caml/alloc.h" +#include "caml/config.h" +#include "caml/fail.h" +#include "caml/fix_code.h" +#include "caml/interp.h" +#include "caml/intext.h" +#include "caml/major_gc.h" +#include "caml/memory.h" +#include "caml/minor_gc.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/prims.h" +#include "caml/stacks.h" + +#ifndef NATIVE_CODE + +CAMLprim value caml_get_global_data(value unit) +{ + return caml_global_data; +} + +char * caml_section_table = NULL; +asize_t caml_section_table_size; + +CAMLprim value caml_get_section_table(value unit) +{ + if (caml_section_table == NULL) caml_raise_not_found(); + return caml_input_value_from_block(caml_section_table, + caml_section_table_size); +} + +CAMLprim value caml_reify_bytecode(value prog, value len) +{ + struct code_fragment * cf = caml_stat_alloc(sizeof(struct code_fragment)); + value clos; + + cf->code_start = (char *) prog; + cf->code_end = (char *) prog + Long_val(len); + cf->digest_computed = 0; + caml_ext_table_add(&caml_code_fragments_table, cf); + +#ifdef ARCH_BIG_ENDIAN + caml_fixup_endianness((code_t) prog, (asize_t) Long_val(len)); +#endif +#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; +} + +/* 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 prog, value len) +{ + struct code_fragment * cf = NULL, * cfi; + int i; + for (i = 0; i < caml_code_fragments_table.size; i++) { + cfi = (struct code_fragment *) caml_code_fragments_table.contents[i]; + if (cfi->code_start == (char *) prog && + cfi->code_end == (char *) prog + Long_val(len)) { + cf = cfi; + break; + } + } + + if (!cf) { + /* [cf] Not matched with a caml_reify_bytecode call; impossible. */ + CAMLassert (0); + } else { + caml_ext_table_remove(&caml_code_fragments_table, cf); + } + +#ifndef NATIVE_CODE + caml_release_bytecode((code_t) prog, (asize_t) Long_val(len)); +#else + caml_failwith("Meta.static_release_bytecode impossible with native code"); +#endif + return Val_unit; +} + +CAMLprim value caml_register_code_fragment(value prog, value len, value digest) +{ + struct code_fragment * cf = caml_stat_alloc(sizeof(struct code_fragment)); + cf->code_start = (char *) prog; + cf->code_end = (char *) prog + Long_val(len); + memcpy(cf->digest, String_val(digest), 16); + cf->digest_computed = 1; + caml_ext_table_add(&caml_code_fragments_table, cf); + return Val_unit; +} + +CAMLprim value caml_realloc_global(value size) +{ + mlsize_t requested_size, actual_size, i; + value new_global_data; + + requested_size = Long_val(size); + actual_size = Wosize_val(caml_global_data); + if (requested_size >= actual_size) { + requested_size = (requested_size + 0x100) & 0xFFFFFF00; + caml_gc_message (0x08, "Growing global data to %" + ARCH_INTNAT_PRINTF_FORMAT "u entries\n", + requested_size); + new_global_data = caml_alloc_shr(requested_size, 0); + for (i = 0; i < actual_size; i++) + caml_initialize(&Field(new_global_data, i), Field(caml_global_data, i)); + for (i = actual_size; i < requested_size; i++){ + Field (new_global_data, i) = Val_long (0); + } + caml_global_data = new_global_data; + } + return Val_unit; +} + +CAMLprim value caml_get_current_environment(value unit) +{ + return *caml_extern_sp; +} + +CAMLprim value caml_invoke_traced_function(value codeptr, value env, value arg) +{ + /* Stack layout on entry: + return frame into instrument_closure function + arg3 to call_original_code (arg) + arg2 to call_original_code (env) + arg1 to call_original_code (codeptr) + arg3 to call_original_code (arg) + arg2 to call_original_code (env) + saved env */ + + /* Stack layout on exit: + return frame into instrument_closure function + actual arg to code (arg) + pseudo return frame into codeptr: + extra_args = 0 + environment = env + PC = codeptr + arg3 to call_original_code (arg) same 6 bottom words as + arg2 to call_original_code (env) on entrance, but + arg1 to call_original_code (codeptr) shifted down 4 words + arg3 to call_original_code (arg) + arg2 to call_original_code (env) + saved env */ + + value * osp, * nsp; + int i; + + osp = caml_extern_sp; + caml_extern_sp -= 4; + nsp = caml_extern_sp; + for (i = 0; i < 6; i++) nsp[i] = osp[i]; + nsp[6] = codeptr; + nsp[7] = env; + nsp[8] = Val_int(0); + nsp[9] = arg; + return Val_unit; +} + +#else + +/* Dummy definitions to support compilation of ocamlc.opt */ + +value caml_get_global_data(value unit) +{ + caml_invalid_argument("Meta.get_global_data"); + return Val_unit; /* not reached */ +} + +value caml_get_section_table(value unit) +{ + caml_invalid_argument("Meta.get_section_table"); + return Val_unit; /* not reached */ +} + +value caml_realloc_global(value size) +{ + caml_invalid_argument("Meta.realloc_global"); + return Val_unit; /* not reached */ +} + +value caml_invoke_traced_function(value codeptr, value env, value arg) +{ + caml_invalid_argument("Meta.invoke_traced_function"); + return Val_unit; /* not reached */ +} + +value caml_reify_bytecode(value prog, value len) +{ + caml_invalid_argument("Meta.reify_bytecode"); + return Val_unit; /* not reached */ +} + +value caml_static_release_bytecode(value prog, value len) +{ + caml_invalid_argument("Meta.static_release_bytecode"); + return Val_unit; /* not reached */ +} + +value * caml_stack_low; +value * caml_stack_high; +value * caml_stack_threshold; +value * caml_extern_sp; +value * caml_trapsp; +int caml_callback_depth; +int volatile caml_something_to_do; +void (* volatile caml_async_action_hook)(void); +struct longjmp_buffer * caml_external_raise; + +#endif |