static void stub_xtl_ocaml_progress(struct xentoollog_logger *logger,
const char *context,
const char *doing_what /* no \r,\n */,
int percent, unsigned long done, unsigned long total)
{
caml_leave_blocking_section();
CAMLparam0();
CAMLlocalN(args, 5);
struct caml_xtl *xtl = (struct caml_xtl*)logger;
value *func = caml_named_value(xtl->progress_cb) ;
if (func == NULL)
caml_raise_sys_error(caml_copy_string("Unable to find callback"));
/* progress : string option -> string -> int -> int64 -> int64 -> unit; */
args[0] = Val_context(context);
args[1] = caml_copy_string(doing_what);
args[2] = Val_int(percent);
args[3] = caml_copy_int64(done);
args[4] = caml_copy_int64(total);
caml_callbackN(*func, 5, args);
CAMLdone;
caml_enter_blocking_section();
}
void proc_start( const char* logdir,
const uint32_t analysis_id,
const char* sockname,
bool debug_flag,
const THREADID tid,
char** argvp,
int envc,
char** envp )
{
CAMLparam0();
CAMLlocalN( caml_args, 8 );
static value *proc_start_closure = NULL;
if ( !proc_start_closure ) {
proc_start_closure = caml_named_value( "proc_start" );
}
caml_args[0] = caml_copy_string( logdir );
caml_args[1] = caml_copy_int32( analysis_id );
caml_args[2] = caml_copy_string( sockname );
caml_args[3] = Val_bool( debug_flag );
caml_args[4] = Val_int( tid );
caml_args[5] = caml_copy_nativeint( (long) argvp );
caml_args[6] = caml_copy_int32( envc );
caml_args[7] = caml_copy_nativeint( (long) envp );
caml_callbackN( *proc_start_closure, 8, caml_args );
CAMLreturn0;
}
static void stub_xtl_ocaml_vmessage(struct xentoollog_logger *logger,
xentoollog_level level,
int errnoval,
const char *context,
const char *format,
va_list al)
{
caml_leave_blocking_section();
CAMLparam0();
CAMLlocalN(args, 4);
struct caml_xtl *xtl = (struct caml_xtl*)logger;
value *func = caml_named_value(xtl->vmessage_cb) ;
char *msg;
if (func == NULL)
caml_raise_sys_error(caml_copy_string("Unable to find callback"));
if (vasprintf(&msg, format, al) < 0)
caml_raise_out_of_memory();
/* vmessage : level -> int option -> string option -> string -> unit; */
args[0] = Val_level(level);
args[1] = Val_errno(errnoval);
args[2] = Val_context(context);
args[3] = caml_copy_string(msg);
free(msg);
caml_callbackN(*func, 4, args);
CAMLdone;
caml_enter_blocking_section();
}
//onMouseClicked: string->unit
void Controller::onMouseClicked(QString x0) {
CAMLparam0();
CAMLlocal3(_ans,_meth,_x0);
CAMLlocalN(_args,2);
CAMLlocal1(_cca0);
value _camlobj = this->_camlobjHolder;
Q_ASSERT(Is_block(_camlobj));
Q_ASSERT(Tag_val(_camlobj) == Object_tag);
_meth = caml_get_public_method(_camlobj, caml_hash_variant("onMouseClicked"));
_args[0] = _camlobj;
_cca0 = caml_copy_string(x0.toLocal8Bit().data() );
_args[1] = _cca0;
caml_callbackN(_meth, 2, _args);
CAMLreturn0;
}
/* LibPar.register_untyped_function(
fn_name_c_str,
globals_array, n_globals,
postional_args_array, n_positional,
default_args_array, default_values_array, n_defaults,
parakeet_syntax))
*/
int register_untyped_function(
char *name,
char **globals, int num_globals,
char **args, int num_args,
char **default_args, paranode *default_arg_values, int num_defaults,
paranode ast) {
CAMLparam0();
CAMLlocal3(val_name, globals_list, args_list);
CAMLlocal2(default_arg_names_list, default_arg_values_list);
CAMLlocal1(fn_id);
printf(":: registering untyped fn (%s, %d/%d/%d globals/args/defaults)\n",
name, num_globals, num_args, num_defaults);
printf("::: ast pointer %p\n", ast);
val_name = caml_copy_string(name);
printf("::: building globals list\n");
globals_list = build_str_list(globals, num_globals);
printf("::: building args list\n");
args_list = build_str_list(args, num_args);
printf("::: building defaults list\n");
default_arg_names_list = build_str_list(default_args, num_defaults);
printf("::: building default values list\n");
default_arg_values_list = mk_val_list(default_arg_values, num_defaults);
printf("::: building fn args\n");
printf("::: ast = %d\n", ast);
printf("::: ast->v = %d\n", ast->v);
value func_args[6] = {
val_name,
globals_list,
args_list,
default_arg_names_list,
default_arg_values_list,
ast->v
};
printf("\n\n");
printf(" ...calling into OCaml's register function\n");
fn_id = caml_callbackN(*ocaml_register_untyped_function, 6, func_args);
printf("DONE WITH FN ID: %d\n", Int_val(fn_id));
CAMLreturnT(int, Int_val(fn_id));
}
static void invoke_completion_callback
(long id, long len, long errCode, long action) {
CAMLlocal2 (err, name);
value args[4];
err = Val_long(0);
if (errCode != NO_ERROR) {
len = -1;
win32_maperr (errCode);
err = unix_error_of_code(errno);
}
name = copy_string (action_name[action]);
D(printf("Action %s completed: id %ld -> len %ld / err %d (errCode %ld)\n",
action_name[action], id, len, errno, errCode));
args[0] = Val_long(id);
args[1] = Val_long(len);
args[2] = err;
args[3] = name;
caml_callbackN(completionCallback, 4, args);
D(printf("Callback performed\n"));
}
int bbl_instrument( unsigned long addr,
const bbl_content* content,
const reg_context* context,
const THREADID tid )
{
CAMLparam0();
CAMLlocal1( ret );
CAMLlocalN( caml_args, 5 );
unsigned i, j;
uint32_t size = (uint32_t) content->size;
static value *bbl_instrument_closure = NULL;
if ( !bbl_instrument_closure ) {
bbl_instrument_closure = caml_named_value( "bbl_instrument" );
}
caml_args[0] = caml_copy_nativeint( addr );
caml_args[1] = caml_copy_int32( size );
caml_args[2] = caml_alloc_string( size );
memcpy( (unsigned char*)String_val(caml_args[2]), content->content, size );
caml_args[3] = caml_alloc_tuple( 45 );
for ( i = 0; i < 20; ++i ) {
Store_field( caml_args[3], i, caml_copy_nativeint( ((long*) &context->eax)[i] ) );
}
for ( i = 20; i < 29; ++i ) {
Store_field( caml_args[3], i, Val_bool( ((long*) &context->eax)[i] ) );
}
for ( i = 29, j = 0; i < 45; ++i ) {
Store_field( caml_args[3], i, caml_copy_int64( ((uint64_t*) &context->xmm0)[j++] ) );
Store_field( caml_args[3], i, caml_copy_int64( ((uint64_t*) &context->xmm0)[j++] ) );
}
caml_args[4] = Val_int( tid );
ret = caml_callbackN( *bbl_instrument_closure, 5, caml_args );
CAMLreturnT( int, Int_val(ret) );
}
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;
}
static value __callb0( value callb ) {
return caml_callbackN(callb,0,NULL);
}
return_val_t run_adverb(
char* adverb_name,
int fn_id,
host_val* fixed, int num_fixed,
int combine_fn_id, int combine_provided,
host_val* combine_fixed, int num_combine_fixed,
host_val* init, int num_init,
int axes_given, int* axes, int num_axes,
host_val* array_positional, int num_array_positional,
char** array_keyword_names, host_val* array_keyword_values,
int num_array_keyword_values) {
CAMLparam0();
CAMLlocal1(fn_id_val);
CAMLlocal1(combine_id_val_opt);
CAMLlocal1(adverb);
CAMLlocal2(fixed_actuals, combine_fixed_actuals);
CAMLlocal1(array_actuals);
CAMLlocal2(init_list, axes_list_option);
CAMLlocal1(ocaml_result);
fn_id_val = Val_int(fn_id);
if (combine_provided) {
combine_id_val_opt = caml_alloc_tuple(1);
Store_field(combine_id_val_opt, 0, Val_int(combine_fn_id));
} else {
combine_id_val_opt = Val_int(0);
}
printf("Making fixed args from %d fixed values and %d fixed kwds\n",
num_fixed, num_fixed_keywords);
fixed_actuals = mk_actual_args(fixed, num_fixed, 0, 0, 0);
printf("Making fixed args for combiner\n");
combine_fixed_actuals = mk_actual_args(combine_fixed,
num_combine_fixed, 0, 0, 0);
printf("Making array args from %d arrays and %d kwds\n",
num_array_positional, num_array_keyword_values);
array_actuals = mk_actual_args(array_positional, num_array_positional, \
array_keyword_names, array_keyword_values, num_array_keyword_values);
printf("Building list of %d init args\n", num_init);
init_list = build_host_val_list(init, num_init);
printf("Axes given? %d\n", axes_given);
if (axes_given) {
printf("Building %d axes\n", num_axes);
axes_list_option = caml_alloc(1, 0);
Store_field( axes_list_option, 0, build_int_list(axes, num_axes) );
} else {
axes_list_option = Val_int(0);
}
printf("Calling into OCaml\n");
adverb = get_adverb(adverb_name);
value func_args[8] = {
adverb,
fn_id_val,
fixed_actuals,
combine_id_val_opt,
combine_fixed_actuals,
init_list,
axes_list_option,
array_actuals
};
ocaml_result = caml_callbackN(*ocaml_run_adverb, 7, func_args);
printf("Returned from OCaml\n");
CAMLreturnT(return_val_t, translate_return_value(ocaml_result));
}
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);
}