161 lines
4.4 KiB
C
161 lines
4.4 KiB
C
/***********************************************************************/
|
|
/* */
|
|
/* Objective Caml */
|
|
/* */
|
|
/* 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 Library General Public License, with */
|
|
/* the special exception on linking described in file ../LICENSE. */
|
|
/* */
|
|
/***********************************************************************/
|
|
|
|
/* $Id$ */
|
|
|
|
/* Primitives for the toplevel */
|
|
|
|
#include "alloc.h"
|
|
#include "config.h"
|
|
#include "fail.h"
|
|
#include "fix_code.h"
|
|
#include "interp.h"
|
|
#include "major_gc.h"
|
|
#include "memory.h"
|
|
#include "minor_gc.h"
|
|
#include "misc.h"
|
|
#include "mlvalues.h"
|
|
#include "prims.h"
|
|
#include "stacks.h"
|
|
|
|
#ifndef NATIVE_CODE
|
|
|
|
CAMLprim value get_global_data(value unit)
|
|
{
|
|
return global_data;
|
|
}
|
|
|
|
CAMLprim value reify_bytecode(value prog, value len)
|
|
{
|
|
value clos;
|
|
#ifdef ARCH_BIG_ENDIAN
|
|
fixup_endianness((code_t) prog, (asize_t) Long_val(len));
|
|
#endif
|
|
#ifdef THREADED_CODE
|
|
thread_code((code_t) prog, (asize_t) Long_val(len));
|
|
#endif
|
|
clos = alloc_small (1, Closure_tag);
|
|
Code_val(clos) = (code_t) prog;
|
|
return clos;
|
|
}
|
|
|
|
CAMLprim value realloc_global(value size)
|
|
{
|
|
mlsize_t requested_size, actual_size, i;
|
|
value new_global_data;
|
|
|
|
requested_size = Long_val(size);
|
|
actual_size = Wosize_val(global_data);
|
|
if (requested_size >= actual_size) {
|
|
requested_size = (requested_size + 0x100) & 0xFFFFFF00;
|
|
gc_message (0x08, "Growing global data to %lu entries\n", requested_size);
|
|
new_global_data = alloc_shr(requested_size, 0);
|
|
for (i = 0; i < actual_size; i++)
|
|
initialize(&Field(new_global_data, i), Field(global_data, i));
|
|
for (i = actual_size; i < requested_size; i++){
|
|
Field (new_global_data, i) = Val_long (0);
|
|
}
|
|
global_data = new_global_data;
|
|
}
|
|
return Val_unit;
|
|
}
|
|
|
|
CAMLprim value get_current_environment(value unit)
|
|
{
|
|
return *extern_sp;
|
|
}
|
|
|
|
CAMLprim value 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 = extern_sp;
|
|
extern_sp -= 4;
|
|
nsp = 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 get_global_data(value unit)
|
|
{
|
|
invalid_argument("Meta.get_global_data");
|
|
return Val_unit; /* not reached */
|
|
}
|
|
|
|
value realloc_global(value size)
|
|
{
|
|
invalid_argument("Meta.realloc_global");
|
|
return Val_unit; /* not reached */
|
|
}
|
|
|
|
value available_primitives(value unit)
|
|
{
|
|
invalid_argument("Meta.available_primitives");
|
|
return Val_unit; /* not reached */
|
|
}
|
|
|
|
value invoke_traced_function(value codeptr, value env, value arg)
|
|
{
|
|
invalid_argument("Meta.invoke_traced_function");
|
|
return Val_unit; /* not reached */
|
|
}
|
|
|
|
value * stack_low;
|
|
value * stack_high;
|
|
value * stack_threshold;
|
|
value * extern_sp;
|
|
value * trapsp;
|
|
int backtrace_active;
|
|
int backtrace_pos;
|
|
code_t * backtrace_buffer;
|
|
value backtrace_last_exn;
|
|
int callback_depth;
|
|
int volatile something_to_do;
|
|
void (* volatile async_action_hook)(void);
|
|
void print_exception_backtrace(void) { }
|
|
struct longjmp_buffer * external_raise;
|
|
|
|
#endif
|