value camlidl_c2ml_shape_internal_ptr(internal_ptr * _c2, camlidl_ctx _ctx)
{
value _v1;
_v1 = camlidl_alloc((sizeof(internal_ptr) + sizeof(value) - 1) / sizeof(value), Abstract_tag);
*((internal_ptr *) Bp_val(_v1)) = *_c2;
return _v1;
}
// Called from FStar code to receive via TCP
CAMLprim value ocaml_recv_tcp(value cookie, value bytes)
{
mlsize_t buffer_size;
char *buffer;
ssize_t retval;
struct _FFI_mitls_callbacks *callbacks;
char *localbuffer;
CAMLparam2(cookie, bytes);
callbacks = (struct _FFI_mitls_callbacks *)ValueToPtr(cookie);
buffer_size = caml_string_length(bytes);
localbuffer = (char*)alloca(buffer_size);
caml_release_runtime_system();
// All pointers into the OCaml heap are now off-limits until the
// runtime_system lock has been re-aquired.
retval = (*callbacks->recv)(callbacks, localbuffer, buffer_size);
caml_acquire_runtime_system();
buffer = Bp_val(bytes);
memcpy(buffer, localbuffer, buffer_size);
CAMLreturn(Val_int(retval));
}
value camlidl_c2ml_libbfd_section_ptr(section_ptr * _c2, camlidl_ctx _ctx)
{
value _v1;
_v1 = camlidl_alloc((sizeof(section_ptr) + sizeof(value) - 1) / sizeof(value), Abstract_tag);
*((section_ptr *) Bp_val(_v1)) = *_c2;
return _v1;
}
value camlidl_c2ml_libbfd_bfdp(bfdp * _c2, camlidl_ctx _ctx)
{
value _v1;
_v1 = camlidl_alloc((sizeof(bfdp) + sizeof(value) - 1) / sizeof(value), Abstract_tag);
*((bfdp *) Bp_val(_v1)) = *_c2;
return _v1;
}
static void oldify (value *p, value v)
{
value result;
mlsize_t i;
tail_call:
if (IS_BLOCK(v) && Is_young (v)){
assert (Hp_val (v) < young_ptr);
if (Is_blue_val (v)){ /* Already forwarded ? */
*p = Field (v, 0); /* Then the forward pointer is the first field. */
}else if (Tag_val (v) >= No_scan_tag){
result = alloc_shr (Wosize_val (v), Tag_val (v));
bcopy (Bp_val (v), Bp_val (result), Bosize_val (v));
Hd_val (v) = Bluehd_hd (Hd_val (v)); /* Put the forward flag. */
Field (v, 0) = result; /* And the forward pointer. */
*p = result;
}else{
/* We can do recursive calls before all the fields are filled, because
we will not be calling the major GC. */
value field0 = Field (v, 0);
mlsize_t sz = Wosize_val (v);
result = alloc_shr (sz, Tag_val (v));
*p = result;
Hd_val (v) = Bluehd_hd (Hd_val (v)); /* Put the forward flag. */
Field (v, 0) = result; /* And the forward pointer. */
if (sz == 1){
p = &Field (result, 0);
v = field0;
goto tail_call;
}else{
oldify (&Field (result, 0), field0);
for (i = 1; i < sz - 1; i++){
oldify (&Field (result, i), Field (v, i));
}
p = &Field (result, i);
v = Field (v, i);
goto tail_call;
}
}
}else{
*p = v;
}
}
CAMLprim value ml_gsl_cheb_coefs(value c)
{
CAMLparam1(c);
CAMLlocal1(a);
gsl_cheb_series *cs = CHEB_VAL(c);
size_t len = cs->order + 1;
a = alloc(len * Double_wosize, Double_array_tag);
memcpy(Bp_val(a), cs->c, len * sizeof (double));
CAMLreturn(a);
}
value caml_aligned_array_free(size_t alignment, value val)
{
CAMLparam1 (val);
void* bp = Bp_val(val);
bp -= alignment;
free(bp);
CAMLreturn (Val_unit);
}
CAMLprim value caml_weak_get_copy (value ar, value n)
{
CAMLparam2 (ar, n);
mlsize_t offset = Long_val (n) + 1;
CAMLlocal2 (res, elt);
value v; /* Caution: this is NOT a local root. */
Assert (Is_in_heap (ar));
if (offset < 1 || offset >= Wosize_val (ar)){
caml_invalid_argument ("Weak.get");
}
v = Field (ar, offset);
if (v == caml_weak_none) CAMLreturn (None_val);
if (Is_block (v) && Is_in_heap_or_young(v)) {
elt = caml_alloc (Wosize_val (v), Tag_val (v));
/* The GC may erase or move v during this call to caml_alloc. */
v = Field (ar, offset);
if (v == caml_weak_none) CAMLreturn (None_val);
if (Tag_val (v) < No_scan_tag){
mlsize_t i;
for (i = 0; i < Wosize_val (v); i++){
value f = Field (v, i);
if (caml_gc_phase == Phase_mark && Is_block (f) && Is_in_heap (f)){
caml_darken (f, NULL);
}
Modify (&Field (elt, i), f);
}
}else{
memmove (Bp_val (elt), Bp_val (v), Bosize_val (v));
}
}else{
elt = v;
}
res = caml_alloc_small (1, Some_tag);
Field (res, 0) = elt;
CAMLreturn (res);
}
CAMLexport value caml_alloc (mlsize_t wosize, tag_t tag)
{
value result;
mlsize_t i;
Assert (tag < 256);
Assert (tag != Infix_tag);
if (wosize == 0){
result = Atom (tag);
}else if (wosize <= Max_young_wosize){
Alloc_small (result, wosize, tag);
if (tag < No_scan_tag){
for (i = 0; i < wosize; i++) Field (result, i) = 0;
}
}else{
result = caml_alloc_shr (wosize, tag);
if (tag < No_scan_tag) memset (Bp_val (result), 0, Bsize_wsize (wosize));
result = caml_check_urgent_gc (result);
}
return result;
}
static void set_geom (State *s, void **ptrs, value vertexa_v, value normala_v,
value uva_v, value skin_v, value colors_v)
{
int i;
float *p;
int num_vertices;
struct skin *skin;
num_vertices = Wosize_val (vertexa_v) / (Double_wosize * 3);
copy_vertices (ptrs[V_IDX], num_vertices, vertexa_v);
copy_vertices (ptrs[N_IDX], num_vertices, normala_v);
for (i = 0, p = ptrs[UV_IDX]; i < num_vertices * 2; ++i) {
p[i] = Double_field (uva_v, i);
}
memcpy (ptrs[C_IDX], String_val (colors_v), num_vertices * 4);
skin = s->skin;
for (i = 0; i < num_vertices; ++i) {
int j;
value v;
v = Field (skin_v, i);
skin[i].boneinfo = Int_val (Field (v, 3));
for (j = 0; j < Int_val (Field (v, 3)); ++j) {
double val;
int boneindex;
const int shifts[] = {2,12,22};
val = Double_val (Bp_val (Field (v, j)));
boneindex = (int) val;
skin[i].weights[j] = val - boneindex;
skin[i].boneinfo |= (boneindex + 1) << shifts[j];
}
}
}
// Called by the host app transmit a packet
int FFI_mitls_send(/* in */ mitls_state *state, const void* buffer, size_t buffer_size, /* out */ char **outmsg, /* out */ char **errmsg)
{
CAMLparam0();
CAMLlocal2(buffer_value, result);
int ret = 0;
*outmsg = NULL;
*errmsg = NULL;
caml_acquire_runtime_system();
buffer_value = caml_alloc_string(buffer_size);
memcpy(Bp_val(buffer_value), buffer, buffer_size);
result = caml_callback2_exn(*g_mitls_FFI_Send, state->fstar_state, buffer_value);
if (Is_exception_result(result)) {
// Call caml_format_exception(Extract_exception(result)) to extract the exception text
ret = 0;
} else {
ret = 1;
}
caml_release_runtime_system();
CAMLreturnT(int,ret);
}
CAMLprim value caml_new_lex_engine(struct lexing_table *tbl, value start_state,
struct lexer_buffer *lexbuf)
{
int state, base, backtrk, c, pstate ;
state = Int_val(start_state);
if (state >= 0) {
/* First entry */
lexbuf->lex_last_pos = lexbuf->lex_start_pos = lexbuf->lex_curr_pos;
lexbuf->lex_last_action = Val_int(-1);
} else {
/* Reentry after refill */
state = -state - 1;
}
while(1) {
/* Lookup base address or action number for current state */
base = Short(tbl->lex_base, state);
if (base < 0) {
int pc_off = Short(tbl->lex_base_code, state) ;
run_tag(Bp_val(tbl->lex_code) + pc_off, lexbuf->lex_mem);
/* __fprintf(stderr,"Perform: %d\n",-base-1) ; */
return Val_int(-base-1);
}
/* See if it's a backtrack point */
backtrk = Short(tbl->lex_backtrk, state);
if (backtrk >= 0) {
int pc_off = Short(tbl->lex_backtrk_code, state);
run_tag(Bp_val(tbl->lex_code) + pc_off, lexbuf->lex_mem);
lexbuf->lex_last_pos = lexbuf->lex_curr_pos;
lexbuf->lex_last_action = Val_int(backtrk);
}
/* See if we need a refill */
if (lexbuf->lex_curr_pos >= lexbuf->lex_buffer_len){
if (lexbuf->lex_eof_reached == Val_bool (0)){
return Val_int(-state - 1);
}else{
c = 256;
}
}else{
/* Read next input char */
c = Byte_u(lexbuf->lex_buffer, Long_val(lexbuf->lex_curr_pos));
lexbuf->lex_curr_pos += 2;
}
/* Determine next state */
pstate=state ;
if (Short(tbl->lex_check, base + c) == state)
state = Short(tbl->lex_trans, base + c);
else
state = Short(tbl->lex_default, state);
/* If no transition on this char, return to last backtrack point */
if (state < 0) {
lexbuf->lex_curr_pos = lexbuf->lex_last_pos;
if (lexbuf->lex_last_action == Val_int(-1)) {
caml_failwith("lexing: empty token");
} else {
return lexbuf->lex_last_action;
}
}else{
/* If some transition, get and perform memory moves */
int base_code = Short(tbl->lex_base_code, pstate) ;
int pc_off ;
if (Short(tbl->lex_check_code, base_code + c) == pstate)
pc_off = Short(tbl->lex_trans_code, base_code + c) ;
else
pc_off = Short(tbl->lex_default_code, pstate) ;
if (pc_off > 0)
run_mem(Bp_val(tbl->lex_code) + pc_off, lexbuf->lex_mem,
lexbuf->lex_curr_pos) ;
/* Erase the EOF condition only if the EOF pseudo-character was
consumed by the automaton (i.e. there was no backtrack above)
*/
if (c == 256) lexbuf->lex_eof_reached = Val_bool (0);
}
}
}
// XXX: memory leak!
[](value val, Smoke::StackItem &item) { item.s_voidp = new int (Int_val (Field (Field (val, 0), 0))); },
}
},
{ "const char*",
{
Type_String,
[](Smoke::StackItem item) { return alloc_variant<DataType> (Type_String, Val_bp (item.s_voidp)); },
[](value val, Smoke::StackItem &item) { item.s_voidp = String_val (Field (val, 0)); },
}
},
{ "char**",
{
Type_VoidP,
nullptr,
[](value val, Smoke::StackItem &item) { item.s_voidp = Bp_val (Field (val, 0)); },
}
},
{ "QObject*",
{
Type_ClassP,
[](Smoke::StackItem item) { return alloc_variant<DataType> (Type_ClassP, Val_bp (item.s_voidp)); },
[](value val, Smoke::StackItem &item) { item.s_voidp = Bp_val (Field (val, 0)); },
}
},
};
void
Marshaller::checkType (value val, DataType expected, char const *fmt, ...)
{
void camlidl_ml2c_shape_internal_ptr(value _v1, internal_ptr * _c2, camlidl_ctx _ctx)
{
*_c2 = *((internal_ptr *) Bp_val(_v1));
}
void camlidl_ml2c_libbfd_section_ptr(value _v1, section_ptr * _c2, camlidl_ctx _ctx)
{
*_c2 = *((section_ptr *) Bp_val(_v1));
}
void camlidl_ml2c_libbfd_bfdp(value _v1, bfdp * _c2, camlidl_ctx _ctx)
{
*_c2 = *((bfdp *) Bp_val(_v1));
}
