void symbolic_read( ADDRINT addr,
ADDRINT pos,
ADDRINT ret,
ADDRINT totalsize,
const char* fname )
{
CAMLparam0();
CAMLlocalN( caml_args, 5 );
static value *proc_symbolic_read = NULL;
if ( !proc_symbolic_read ) {
proc_symbolic_read = caml_named_value( "symbolic_read" );
}
caml_args[0] = caml_copy_nativeint( (long) addr );
caml_args[1] = caml_copy_nativeint( (long) pos );
caml_args[2] = Val_int( (int) ret );
caml_args[3] = Val_int( (int) totalsize );
caml_args[4] = caml_copy_string( fname );
caml_callbackN( *proc_symbolic_read, 5, caml_args );
CAMLreturn0;
}
value caml_ba_get_N(value vb, value * vind, int nind)
{
struct caml_ba_array * b = Caml_ba_array_val(vb);
intnat index[CAML_BA_MAX_NUM_DIMS];
int i;
intnat offset;
/* Check number of indices = number of dimensions of array
(maybe not necessary if ML typing guarantees this) */
if (nind != b->num_dims)
caml_invalid_argument("Bigarray.get: wrong number of indices");
/* Compute offset and check bounds */
for (i = 0; i < b->num_dims; i++) index[i] = Long_val(vind[i]);
offset = caml_ba_offset(b, index);
/* Perform read */
switch ((b->flags) & CAML_BA_KIND_MASK) {
default:
Assert(0);
case CAML_BA_FLOAT32:
return caml_copy_double(((float *) b->data)[offset]);
case CAML_BA_FLOAT64:
return caml_copy_double(((double *) b->data)[offset]);
case CAML_BA_SINT8:
return Val_int(((int8 *) b->data)[offset]);
case CAML_BA_UINT8:
return Val_int(((uint8 *) b->data)[offset]);
case CAML_BA_SINT16:
return Val_int(((int16 *) b->data)[offset]);
case CAML_BA_UINT16:
return Val_int(((uint16 *) b->data)[offset]);
case CAML_BA_INT32:
return caml_copy_int32(((int32 *) b->data)[offset]);
case CAML_BA_INT64:
return caml_copy_int64(((int64 *) b->data)[offset]);
case CAML_BA_NATIVE_INT:
return caml_copy_nativeint(((intnat *) b->data)[offset]);
case CAML_BA_CAML_INT:
return Val_long(((intnat *) b->data)[offset]);
case CAML_BA_COMPLEX32:
{ float * p = ((float *) b->data) + offset * 2;
return copy_two_doubles(p[0], p[1]); }
case CAML_BA_COMPLEX64:
{ double * p = ((double *) b->data) + offset * 2;
return copy_two_doubles(p[0], p[1]); }
}
}
void handle_callret( const ADDRINT addr, const THREADID tid, UINT32 type )
{
CAMLparam0();
CAMLlocal3( caml_addr, caml_tid, caml_type );
static value *proc_handle_callret = NULL;
if ( !proc_handle_callret ) {
proc_handle_callret = caml_named_value( "handle_callret" );
}
caml_addr = caml_copy_nativeint( (long) addr );
caml_tid = Val_int( (int) tid );
caml_type = Val_int( (int) type );
caml_callback3( *proc_handle_callret, caml_addr, caml_tid, caml_type );
CAMLreturn0;
}
/* read : 'a prim -> offset:int -> raw_pointer -> 'a */
value ctypes_read(value prim_, value offset_, value buffer_)
{
CAMLparam3(prim_, offset_, buffer_);
CAMLlocal1(b);
int offset = Int_val(offset_);
void *buf = (char *)CTYPES_TO_PTR(buffer_) + offset;
switch (Int_val(prim_))
{
case Char: b = Val_int(*(char *)buf); break;
case Schar: b = Val_int(*(signed char *)buf); break;
case Uchar: b = ctypes_copy_uint8(*(unsigned char *)buf); break;
case Short: b = Val_int(*(short *)buf); break;
case Int: b = Val_int(*(int *)buf); break;
case Long: b = ctypes_copy_long(*(long *)buf); break;
case Llong: b = ctypes_copy_llong(*(long long *)buf); break;
case Ushort: b = ctypes_copy_ushort(*(unsigned short *)buf); break;
case Uint: b = ctypes_copy_uint(*(unsigned int *)buf); break;
case Ulong: b = ctypes_copy_ulong(*(unsigned long *)buf); break;
case Ullong: b = ctypes_copy_ullong(*(unsigned long long *)buf); break;
case Size_t: b = ctypes_copy_size_t(*(size_t *)buf); break;
case Int8_t: b = Val_int(*(int8_t *)buf); break;
case Int16_t: b = Val_int(*(int16_t *)buf); break;
case Int32_t: b = caml_copy_int32(*(int32_t *)buf); break;
case Int64_t: b = caml_copy_int64(*(int64_t *)buf); break;
case Uint8_t: b = ctypes_copy_uint8(*(uint8_t *)buf); break;
case Uint16_t: b = ctypes_copy_uint16(*(uint16_t *)buf); break;
case Uint32_t: b = ctypes_copy_uint32(*(uint32_t *)buf); break;
case Uint64_t: b = ctypes_copy_uint64(*(uint64 *)buf); break;
case Camlint: b = Val_int(*(intnat *)buf); break;
case Nativeint: b = caml_copy_nativeint(*(intnat *)buf); break;
case Float: b = caml_copy_double(*(float *)buf); break;
case Double: b = caml_copy_double(*(double *)buf); break;
case Complex32: b = ctypes_copy_float_complex(*(float complex *)buf); break;
case Complex64: b = ctypes_copy_double_complex(*(double complex *)buf); break;
default:
assert(0);
}
CAMLreturn(b);
}
CAMLprim value caml_nativeint_of_int(value v)
{ return caml_copy_nativeint(Long_val(v)); }
CAMLprim value caml_nativeint_shift_left(value v1, value v2)
{ return caml_copy_nativeint(Nativeint_val(v1) << Int_val(v2)); }
CAMLprim value caml_nativeint_xor(value v1, value v2)
{ return caml_copy_nativeint(Nativeint_val(v1) ^ Nativeint_val(v2)); }
extern "C" void
monda_val_print (struct type* type, struct frame_info* frame,
int embedded_offset, CORE_ADDR address,
struct ui_file* stream, int recurse, struct value* val,
const struct value_print_options* options, int depth,
int max_string_length, int only_print_short_type,
int only_print_short_value)
{
CAMLparam0();
CAMLlocal4(v_type, v_stream, v_value, v_search_path);
CAMLlocal2(v_val, v_frame);
CAMLlocalN(args, 12);
static caml_value* callback = NULL;
int is_synthetic_pointer;
const gdb_byte* valaddr;
/* The try/catch is required so we don't leave local roots incorrectly
registered in the case of an exception.
We also ensure that any GDB function we call from the OCaml code
invoked below (via [caml_callbackN]) never throws any exceptions
across the OCaml -> C boundary. If it were to, then we would fail to
run the second part of the [caml_start_program] code, causing global
variables (e.g. [caml_last_return_address]) to be set incorrectly. */
TRY {
if (callback == NULL) {
callback = caml_named_value("From_gdb_ocaml.print_value");
assert (callback != NULL);
}
valaddr = value_contents_for_printing(val);
v_value =
(valaddr == NULL) ? caml_copy_nativeint(0)
: caml_copy_nativeint(*(intnat*) valaddr);
/* Determine whether the value is actually a construction made up in the
debugger's address space by virtue of interpreting DW_OP_implicit_pointer.
The second part of this conditional is really just a sanity check.
*/
is_synthetic_pointer =
(value_lval_const(val) == lval_computed
&& value_bits_synthetic_pointer(val, 0, sizeof(CORE_ADDR) * 8));
/*
fprintf(stderr, "monda_val_print. SP %d *valaddr=%p v_value=%p value_lval_const=%d lval_funcs=%p lazy=%d\n",
is_synthetic_pointer,
(void*) *(intnat*) valaddr,
(void*) v_value,
(int) (value_lval_const(val)),
value_lval_const(val) == lval_computed ? value_computed_funcs(val) : NULL,
value_lazy(val));
*/
/* CR mshinwell: improve this test */
#if 0
if ((TYPE_NAME(type) == NULL && !is_synthetic_pointer)
|| (is_synthetic_pointer && TYPE_CODE(type) != TYPE_CODE_PTR)) {
/*
fprintf(stderr, "monda_val_print -> c_val_print (1)\n");
fflush(stderr);
*/
c_val_print(type, frame, valaddr, embedded_offset, address, stream,
recurse, val, options, depth);
}
else
#endif
{
v_type = caml_copy_string(TYPE_NAME(type) == NULL ? "" : TYPE_NAME(type));
v_stream = caml_copy_int64((uint64_t) stream);
v_search_path = caml_copy_string(""); /* CR mshinwell: remove */
v_val = caml_copy_nativeint((intnat) val);
v_frame = caml_copy_nativeint((intnat) frame);
/* N.B. [Store_field] must not be used on [args]! */
args[0] = Val_bool(is_synthetic_pointer);
args[1] = v_value;
args[2] = v_val;
args[3] = v_stream;
args[4] = v_type;
args[5] = Val_bool(options->summary);
args[6] = Val_long(depth);
args[7] = Val_long(max_string_length);
args[8] = v_search_path;
args[9] = Val_bool(only_print_short_type);
args[10] = Val_bool(only_print_short_value);
args[11] = v_frame;
/*
fprintf(stderr, "monda_val_print -> OCaml printer. Type '%s'\n", TYPE_NAME(type));
fflush(stderr);
*/
/* CR mshinwell: This should catch any OCaml exceptions. */
if (caml_callbackN(*callback, 12, args) == Val_false) {
/*
fprintf(stderr, "monda_val_print -> c_val_print (2)\n");
fflush(stderr);
*/
c_val_print (type, frame, embedded_offset, address, stream, recurse,
val, options);
}
}
}
CATCH (exn, RETURN_MASK_ALL) {
fprintf(stderr, "monda_val_print: exception: %s\n",
exn.message ? exn.message : "<no message>");
CAMLdrop;
throw_exception(exn);
}
CAMLprim value stub_xc_linux_build_native(value xc_handle, value domid,
value mem_max_mib, value mem_start_mib,
value image_name, value ramdisk_name,
value cmdline, value features,
value flags, value store_evtchn,
value console_evtchn)
{
CAMLparam5(xc_handle, domid, mem_max_mib, mem_start_mib, image_name);
CAMLxparam5(ramdisk_name, cmdline, features, flags, store_evtchn);
CAMLxparam1(console_evtchn);
CAMLlocal1(result);
unsigned long store_mfn;
unsigned long console_mfn;
int r;
struct xc_dom_image *dom;
char c_protocol[64];
/* Copy the ocaml values into c-land before dropping the mutex */
xc_interface *xch = _H(xc_handle);
unsigned int c_mem_start_mib = Int_val(mem_start_mib);
uint32_t c_domid = _D(domid);
char *c_image_name = strdup(String_val(image_name));
char *c_ramdisk_name = ramdisk_name == None_val ? NULL : strdup(String_val(Field(ramdisk_name, 0)));
unsigned long c_flags = Int_val(flags);
unsigned int c_store_evtchn = Int_val(store_evtchn);
unsigned int c_console_evtchn = Int_val(console_evtchn);
struct flags f;
get_flags(&f,c_domid);
xc_dom_loginit(xch);
dom = xc_dom_allocate(xch, String_val(cmdline), String_val(features));
if (!dom)
failwith_oss_xc(xch, "xc_dom_allocate");
configure_vcpus(xch, c_domid, f);
configure_tsc(xch, c_domid, f);
#ifdef XC_HAVE_DECOMPRESS_LIMITS
if ( xc_dom_kernel_max_size(dom, f.kernel_max_size) )
failwith_oss_xc(xch, "xc_dom_kernel_max_size");
if ( xc_dom_ramdisk_max_size(dom, f.ramdisk_max_size) )
failwith_oss_xc(xch, "xc_dom_ramdisk_max_size");
#else
if ( f.kernel_max_size || f.ramdisk_max_size ) {
syslog(LOG_WARNING|LOG_DAEMON,"Kernel/Ramdisk limits set, but no support compiled in");
}
#endif
caml_enter_blocking_section();
r = xc_dom_linux_build(xch, dom, c_domid, c_mem_start_mib,
c_image_name, c_ramdisk_name, c_flags,
c_store_evtchn, &store_mfn,
c_console_evtchn, &console_mfn);
caml_leave_blocking_section();
#ifndef XEN_UNSTABLE
strncpy(c_protocol, xc_dom_get_native_protocol(dom), 64);
#else
memset(c_protocol, '\0', 64);
#endif
free(c_image_name);
free(c_ramdisk_name);
xc_dom_release(dom);
if (r != 0)
failwith_oss_xc(xch, "xc_dom_linux_build");
result = caml_alloc_tuple(3);
Store_field(result, 0, caml_copy_nativeint(store_mfn));
Store_field(result, 1, caml_copy_nativeint(console_mfn));
Store_field(result, 2, caml_copy_string(c_protocol));
CAMLreturn(result);
}
CAMLprim value
nativeint_of_int64(value v)
{
CAMLparam1(v);
CAMLreturn (caml_copy_nativeint((int)Int64_val(v)));
}
CAMLprim value netsys_hdr_address(value objv)
{
return caml_copy_nativeint((intnat) Hp_val(objv));
}
CAMLprim value caml_nativeint_of_string(value s)
{
return caml_copy_nativeint(parse_intnat(s, 8 * sizeof(value)));
}
CAMLprim value caml_nativeint_of_float(value v)
{ return caml_copy_nativeint((intnat)(Double_val(v))); }
CAMLprim value nth_digit_nat_native(value nat, value ofs)
{
return caml_copy_nativeint(Digit_val(nat, Long_val(ofs)));
}
value
mlptrace_peekregisters (value pid_v)
{
pid_t pid;
struct user usreg;
long l = 0;
int savederrno = errno;
CAMLparam1 (pid_v);
CAMLlocal5 (res_v, eip_v, eax_v, ebx_v, ecx_v);
CAMLlocal5 (edx_v, esi_v, edi_v, ebp_v, esp_v);
CAMLlocal2 (eflags_v, origeax_v);
pid = Long_val (pid_v);
memset (&usreg, 0, sizeof (usreg));
#ifndef NO_BLOCKING_SECTION
caml_enter_blocking_section ();
#endif
l = ptrace (PTRACE_GETREGS, pid, (void *) 0, &usreg);
#ifndef NO_BLOCKING_SECTION
caml_leave_blocking_section ();
#endif
if (l == -1 && errno)
uerror ("Ptrace.peekregisters", Nothing);
if (savederrno)
errno = savederrno;
eip_v = caml_copy_nativeint (usreg.regs.eip);
eax_v = caml_copy_nativeint (usreg.regs.eax);
ebx_v = caml_copy_nativeint (usreg.regs.ebx);
ecx_v = caml_copy_nativeint (usreg.regs.ecx);
edx_v = caml_copy_nativeint (usreg.regs.edx);
esi_v = caml_copy_nativeint (usreg.regs.esi);
edi_v = caml_copy_nativeint (usreg.regs.edi);
ebp_v = caml_copy_nativeint (usreg.regs.ebp);
esp_v = caml_copy_nativeint (usreg.regs.esp);
eflags_v = caml_copy_nativeint (usreg.regs.eflags);
origeax_v = caml_copy_nativeint (usreg.regs.orig_eax);
res_v = alloc_small (0, 11);
Field (res_v, 0) = eip_v;
Field (res_v, 1) = eax_v;
Field (res_v, 2) = ebx_v;
Field (res_v, 3) = ecx_v;
Field (res_v, 4) = edx_v;
Field (res_v, 5) = esi_v;
Field (res_v, 6) = edi_v;
Field (res_v, 7) = ebp_v;
Field (res_v, 8) = esp_v;
Field (res_v, 9) = eflags_v;
Field (res_v, 10) = origeax_v;
CAMLreturn (res_v);
}
CAMLprim value stub_xc_hvm_build_native(value xc_handle, value domid,
value mem_max_mib, value mem_start_mib, value image_name,
value store_evtchn, value store_domid,
value console_evtchn, value console_domid)
{
CAMLparam5(xc_handle, domid, mem_max_mib, mem_start_mib, image_name);
CAMLxparam2(store_evtchn, console_evtchn);
CAMLlocal1(result);
char *image_name_c = strdup(String_val(image_name));
xc_interface *xch;
unsigned long store_mfn=0;
unsigned long console_mfn=0;
int r;
struct flags f;
/* The xenguest interface changed and was backported to XCP: */
#if defined(XENGUEST_HAS_HVM_BUILD_ARGS) || (__XEN_LATEST_INTERFACE_VERSION__ >= 0x00040200)
struct xc_hvm_build_args args;
memset(&args, 0, sizeof(struct xc_hvm_build_args));
#endif
get_flags(&f, _D(domid));
xch = _H(xc_handle);
configure_vcpus(xch, _D(domid), f);
configure_tsc(xch, _D(domid), f);
#if defined(XENGUEST_HAS_HVM_BUILD_ARGS) || (__XEN_LATEST_INTERFACE_VERSION__ >= 0x00040200)
args.mem_size = (uint64_t)Int_val(mem_max_mib) << 20;
args.mem_target = (uint64_t)Int_val(mem_start_mib) << 20;
args.mmio_size = f.mmio_size_mib << 20;
args.image_file_name = image_name_c;
#endif
caml_enter_blocking_section ();
#if defined(XENGUEST_HAS_HVM_BUILD_ARGS) || (__XEN_LATEST_INTERFACE_VERSION__ >= 0x00040200)
r = xc_hvm_build(xch, _D(domid), &args);
#else
r = xc_hvm_build_target_mem(xch, _D(domid),
Int_val(mem_max_mib),
Int_val(mem_start_mib),
image_name_c);
#endif
caml_leave_blocking_section ();
free(image_name_c);
if (r)
failwith_oss_xc(xch, "hvm_build");
r = hvm_build_set_params(xch, _D(domid), Int_val(store_evtchn), &store_mfn,
Int_val(console_evtchn), &console_mfn, f);
if (r)
failwith_oss_xc(xch, "hvm_build_params");
#ifdef XENGUEST_4_2
xc_dom_gnttab_hvm_seed(xch, _D(domid), console_mfn, store_mfn, Int_val(console_domid), Int_val(store_domid));
#endif
result = caml_alloc_tuple(2);
Store_field(result, 0, caml_copy_nativeint(store_mfn));
Store_field(result, 1, caml_copy_nativeint(console_mfn));
CAMLreturn(result);
}
value f_i0_ptr(value _) {
return caml_copy_nativeint((intptr_t)(void *)f_i0);
}
CAMLprim value caml_nativeint_of_int32(value v)
{ return caml_copy_nativeint(Int32_val(v)); }
CAMLprim value caml_int64_to_nativeint(value v)
{ return caml_copy_nativeint(I64_to_intnat(Int64_val(v))); }
value netsys_copy_value(value flags, value orig)
{
int code;
int cflags;
intnat start_offset, bytelen;
mlsize_t wosize;
char *dest, *dest_end, *extra_block, *extra_block_end;
int color;
struct named_custom_ops bigarray_ops;
struct named_custom_ops int32_ops;
struct named_custom_ops int64_ops;
struct named_custom_ops nativeint_ops;
CAMLparam2(orig,flags);
CAMLlocal1(block);
/* First test on trivial cases: */
if (Is_long(orig) || Wosize_val(orig) == 0) {
CAMLreturn(orig);
};
code = prep_stat_tab();
if (code != 0) goto exit;
code = prep_stat_queue();
if (code != 0) goto exit;
cflags = caml_convert_flag_list(flags, init_value_flags);
/* fprintf (stderr, "counting\n"); */
/* Count only! */
code = netsys_init_value_1(stat_tab, stat_queue, NULL, NULL, orig,
(cflags & 1) ? 1 : 0, /* enable_bigarrays */
(cflags & 2) ? 1 : 0, /* enable_customs */
1, /* enable_atoms */
1, /* simulate */
NULL, NULL, 0, &start_offset, &bytelen);
if (code != 0) goto exit;
/* fprintf (stderr, "done counting bytelen=%ld\n", bytelen); */
/* set up the custom ops. We always set this, because we assume that
the values in [orig] are not trustworthy
*/
bigarray_ops.name = "_bigarray";
bigarray_ops.ops =
Custom_ops_val(alloc_bigarray_dims(CAML_BA_UINT8 | BIGARRAY_C_LAYOUT,
1, NULL, 1));
bigarray_ops.next = &int32_ops;
int32_ops.name = "_i";
int32_ops.ops = Custom_ops_val(caml_copy_int32(0));
int32_ops.next = &int64_ops;
int64_ops.name = "_j";
int64_ops.ops = Custom_ops_val(caml_copy_int64(0));
int64_ops.next = &nativeint_ops;
nativeint_ops.name = "_n";
nativeint_ops.ops = Custom_ops_val(caml_copy_nativeint(0));
nativeint_ops.next = NULL;
/* alloc */
extra_block = NULL;
extra_block_end = NULL;
/* shamelessly copied from intern.c */
wosize = Wosize_bhsize(bytelen);
/* fprintf (stderr, "wosize=%ld\n", wosize); */
if (wosize > Max_wosize) {
/* Round desired size up to next page */
asize_t request = ((bytelen + Page_size - 1) >> Page_log) << Page_log;
extra_block = caml_alloc_for_heap(request);
if (extra_block == NULL) caml_raise_out_of_memory();
extra_block_end = extra_block + request;
color = caml_allocation_color(extra_block);
dest = extra_block;
dest_end = dest + bytelen;
block = Val_hp(extra_block);
} else {
CAMLprim value caml_nativeint_neg(value v)
{ return caml_copy_nativeint(- Nativeint_val(v)); }
CAMLprim value netsys_memory_address(value memv)
{
struct caml_bigarray *mem = Bigarray_val(memv);
return caml_copy_nativeint((intnat) mem->data);
}
CAMLprim value caml_nativeint_sub(value v1, value v2)
{ return caml_copy_nativeint(Nativeint_val(v1) - Nativeint_val(v2)); }
CAMLprim value
nativeint_of_uint128(value v)
{
CAMLparam1(v);
CAMLreturn (caml_copy_nativeint((int)Uint128_val(v)));
}
CAMLprim value caml_nativeint_and(value v1, value v2)
{ return caml_copy_nativeint(Nativeint_val(v1) & Nativeint_val(v2)); }
CAMLprim value stub_xc_domain_restore(value handle, value fd, value domid,
value store_evtchn, value store_domid,
value console_evtchn, value console_domid,
value hvm, value no_incr_generationid)
{
CAMLparam5(handle, fd, domid, store_evtchn, console_evtchn);
CAMLxparam1(hvm);
CAMLlocal1(result);
unsigned long store_mfn, console_mfn;
domid_t c_store_domid, c_console_domid;
unsigned long c_vm_generationid_addr;
char c_vm_generationid_addr_s[32];
unsigned int c_store_evtchn, c_console_evtchn;
int r;
size_t size, written;
struct flags f;
get_flags(&f,_D(domid));
c_store_evtchn = Int_val(store_evtchn);
c_store_domid = Int_val(store_domid);
c_console_evtchn = Int_val(console_evtchn);
c_console_domid = Int_val(console_domid);
#ifdef HVM_PARAM_VIRIDIAN
xc_set_hvm_param(_H(handle), _D(domid), HVM_PARAM_VIRIDIAN, f.viridian);
#endif
configure_vcpus(_H(handle), _D(domid), f);
caml_enter_blocking_section();
r = xc_domain_restore(_H(handle), Int_val(fd), _D(domid),
c_store_evtchn, &store_mfn,
#ifdef XENGUEST_4_2
c_store_domid,
#endif
c_console_evtchn, &console_mfn,
#ifdef XENGUEST_4_2
c_console_domid,
#endif
Bool_val(hvm), f.pae, 0 /*superpages*/
#ifdef XENGUEST_4_2
,
Bool_val(no_incr_generationid),
&c_vm_generationid_addr,
NULL /* restore_callbacks */
#endif
);
if (!r) {
size = sizeof(c_vm_generationid_addr_s) - 1; /* guarantee a NULL remains on the end */
written = snprintf(c_vm_generationid_addr_s, size, "0x%lx", c_vm_generationid_addr);
if (written < size)
r = xenstore_puts(_D(domid), c_vm_generationid_addr_s, GENERATION_ID_ADDRESS);
else {
syslog(LOG_ERR|LOG_DAEMON,"Failed to write %s (%d >= %d)", GENERATION_ID_ADDRESS, written, size);
r = 1;
}
}
caml_leave_blocking_section();
if (r)
failwith_oss_xc(_H(handle), "xc_domain_restore");
result = caml_alloc_tuple(2);
Store_field(result, 0, caml_copy_nativeint(store_mfn));
Store_field(result, 1, caml_copy_nativeint(console_mfn));
CAMLreturn(result);
}
CAMLprim value caml_natjit_malloc(value text_size, value data_size)
{
#define ABS(x) (((x) < 0) ? -(x) : (x))
#define ALIGN(x, n) ((((x) + ((n) - 1)) / (n)) * (n))
CAMLparam2 (text_size, data_size);
CAMLlocal1 (res);
static char *data_ptr = NULL, *data_end = NULL;
static char *text_ptr = NULL, *text_end = NULL;
mlsize_t tsize = ALIGN(Long_val(text_size), 16);
mlsize_t dsize = ALIGN(Long_val(data_size), 16);
mlsize_t psize, size;
char *area, *text, *data;
/* Memory allocation tries to reuse already allocated memory,
* which works in many cases. For 64bit architectures we ensure
* that all data memory is within 32bit range from the text
* memory allocated.
*/
for (;;){
/* Check if leftover space is sufficient */
if (dsize < data_end - data_ptr && tsize < text_end - text_ptr){
text = text_ptr; text_ptr += tsize;
data = data_ptr; data_ptr += dsize;
break;
}
psize = getpagesize();
if (dsize < data_end - data_ptr){
/* Need new text area */
size = 2 * ALIGN(tsize, psize);
area = (char *)mmap(NULL, size,
PROT_EXEC | PROT_READ | PROT_WRITE,
MAP_ANON | MAP_PRIVATE, -1, 0);
if (area == (char *)MAP_FAILED) caml_raise_out_of_memory();
text_ptr = area;
text_end = area + size;
}
else if (tsize < text_end - text_ptr){
/* Need new data area */
size = 2 * ALIGN(dsize, psize);
area = (char *)mmap(NULL, size,
PROT_READ | PROT_WRITE,
MAP_ANON | MAP_PRIVATE, -1, 0);
if (area == (char *)MAP_FAILED) caml_raise_out_of_memory();
data_ptr = area;
data_end = area + size;
}
else{
/* Need both new data and new text area */
mlsize_t tsize_aligned = 2 * ALIGN(tsize, psize);
mlsize_t dsize_aligned = 2 * ALIGN(dsize, psize);
size = tsize_aligned + dsize_aligned;
area = (char *)mmap(NULL, size,
PROT_EXEC | PROT_READ | PROT_WRITE,
MAP_ANON | MAP_PRIVATE, -1, 0);
if (area == (char *)MAP_FAILED) caml_raise_out_of_memory();
mprotect(area + tsize_aligned, dsize_aligned, PROT_READ | PROT_WRITE);
text_ptr = area;
text_end = text_ptr + tsize_aligned;
data_ptr = text_end;
data_end = data_ptr + dsize_aligned;
}
#ifdef ARCH_SIXTYFOUR
if (ABS(text_end - data_ptr) >= 2147483647
|| ABS(data_end - text_ptr) >= 2147483647){
/* Out of 32bit addressing range, try again... */
munmap(area, size);
text_ptr = text_end = NULL;
data_ptr = data_end = NULL;
}
#endif
}
D("caml_natjit_malloc(%d, %d) = (%p, %p)\n", Long_val(text_size), Long_val(data_size), text, data);
res = caml_alloc_tuple(2);
Field(res, 0) = (value)caml_copy_nativeint((intnat)text);
Field(res, 1) = (value)caml_copy_nativeint((intnat)data);
CAMLreturn(res);
#undef ALIGN
#undef ABS
}
