static char* hh_store_ocaml(value data) {
size_t data_size = caml_string_length(data);
char* addr = hh_alloc(data_size);
memcpy(addr, String_val(data), data_size);
return addr;
}
/* given a return value in OCaml land, translate it to
the return_val_t C structure
*/
return_val_t translate_return_value(value ocaml_result) {
CAMLparam1(ocaml_result);
CAMLlocal5(ocaml_shape, ocaml_strides, ocaml_data, ocaml_cur, ocaml_type);
CAMLlocal1(v);
return_val_t ret;
if (Is_long(ocaml_result)) {
// In this case, we know that the return code must have been Pass,
// since the other two return codes have data.
ret.return_code = RET_PASS;
ret.results_len = 0;
} else if (Tag_val(ocaml_result) == RET_FAIL) {
ret.return_code = RET_FAIL;
ret.results_len = caml_string_length(Field(ocaml_result, 0));
ret.error_msg = malloc(ret.results_len + 1);
strcpy(ret.error_msg, String_val(Field(ocaml_result, 0)));
} else if (Tag_val(ocaml_result) == RET_SUCCESS) {
ocaml_cur = Field(ocaml_result, 0);
ret.return_code = RET_SUCCESS;
ret.results_len = ocaml_list_length(ocaml_cur);
ret.results = (ret_t*)malloc(sizeof(ret_t) * ret.results_len);
int i, j;
host_val h;
for (i = 0; i < ret.results_len; ++i) {
v = Field(ocaml_cur, 0);
h = create_host_val(v);
ocaml_cur = Field(ocaml_cur, 1);
// returning a scalar
if (value_is_scalar(h)) {
ret.results[i].is_scalar = 1;
ocaml_type = (scalar_type)value_type_of(h);
ret.results[i].data.scalar.ret_type =
get_scalar_element_type(ocaml_type);
// WARNING:
// Tiny Memory Leak Ahead
// -----------------------
// When scalar data is returned to the host language
// on the heap, it should be manually deleted by the
// host frontend
if (type_is_bool(ocaml_type)) {
ret.results[i].data.scalar.ret_scalar_value.boolean = get_bool(h);
} else if (type_is_int32(ocaml_type)) {
ret.results[i].data.scalar.ret_scalar_value.int32 = get_int32(h);
} else if (type_is_int64(ocaml_type)) {
ret.results[i].data.scalar.ret_scalar_value.int64 = get_int64(h);
} else if (type_is_float32(ocaml_type)) {
ret.results[i].data.scalar.ret_scalar_value.float32 = get_float64(h);
} else if (type_is_float64(ocaml_type)) {
ret.results[i].data.scalar.ret_scalar_value.float64 = get_float64(h);
} else {
caml_failwith("Unable to return scalar of this type\n");
}
} else {
// Pass the type
ret.results[i].is_scalar = 0;
ret.results[i].data.array.ret_type = array_type_of(h);
// Pass the data
ret.results[i].data.array.data = get_array_data(h);
// Build the shape array
ocaml_shape = value_get_shape(h);
int shape_len = Wosize_val(ocaml_shape);
ret.results[i].data.array.shape =
(int*)malloc(shape_len * sizeof(int));
ret.results[i].data.array.shape_len = shape_len;
for (j = 0; j < shape_len; ++j) {
ret.results[i].data.array.shape[j] = Int_val(Field(ocaml_shape, j));
}
// Build the strides array
ocaml_strides = value_get_strides(h);
int strides_len = Wosize_val(ocaml_strides);
ret.results[i].data.array.strides_len = strides_len;
ret.results[i].data.array.strides =
(int*)malloc(strides_len * sizeof(int));
for (j = 0; j < strides_len; ++j) {
ret.results[i].data.array.strides[j] =
Int_val(Field(ocaml_strides, j));
}
}
}
}
CAMLreturnT(return_val_t, ret);
}
static void extern_rec(value v)
{
tailcall:
if (Is_long(v)) {
intnat n = Long_val(v);
if (n >= 0 && n < 0x40) {
Write(PREFIX_SMALL_INT + n);
} else if (n >= -(1 << 7) && n < (1 << 7)) {
writecode8(CODE_INT8, n);
} else if (n >= -(1 << 15) && n < (1 << 15)) {
writecode16(CODE_INT16, n);
#ifdef ARCH_SIXTYFOUR
} else if (n < -((intnat)1 << 31) || n >= ((intnat)1 << 31)) {
writecode64(CODE_INT64, n);
#endif
} else
writecode32(CODE_INT32, n);
return;
}
if (Is_young(v) || Is_in_heap(v) || Is_atom(v)) {
header_t hd = Hd_val(v);
tag_t tag = Tag_hd(hd);
mlsize_t sz = Wosize_hd(hd);
if (tag == Forward_tag) {
value f = Forward_val (v);
if (Is_block (f) && (Is_young (f) || Is_in_heap (f))
&& (Tag_val (f) == Forward_tag || Tag_val (f) == Lazy_tag
|| Tag_val (f) == Double_tag)){
/* Do not short-circuit the pointer. */
}else{
v = f;
goto tailcall;
}
}
/* Atoms are treated specially for two reasons: they are not allocated
in the externed block, and they are automatically shared. */
if (sz == 0) {
if (tag < 16) {
Write(PREFIX_SMALL_BLOCK + tag);
} else {
writecode32(CODE_BLOCK32, hd);
}
return;
}
/* Check if already seen */
if (Color_hd(hd) == Caml_blue) {
uintnat d = obj_counter - (uintnat) Field(v, 0);
if (d < 0x100) {
writecode8(CODE_SHARED8, d);
} else if (d < 0x10000) {
writecode16(CODE_SHARED16, d);
} else {
writecode32(CODE_SHARED32, d);
}
return;
}
/* Output the contents of the object */
switch(tag) {
case String_tag: {
mlsize_t len = caml_string_length(v);
if (len < 0x20) {
Write(PREFIX_SMALL_STRING + len);
} else if (len < 0x100) {
writecode8(CODE_STRING8, len);
} else {
writecode32(CODE_STRING32, len);
}
writeblock(String_val(v), len);
size_32 += 1 + (len + 4) / 4;
size_64 += 1 + (len + 8) / 8;
extern_record_location(v);
break;
}
case Double_tag: {
if (sizeof(double) != 8)
extern_invalid_argument("output_value: non-standard floats");
Write(CODE_DOUBLE_NATIVE);
writeblock_float8((double *) v, 1);
size_32 += 1 + 2;
size_64 += 1 + 1;
extern_record_location(v);
break;
}
case Double_array_tag: {
mlsize_t nfloats;
if (sizeof(double) != 8)
extern_invalid_argument("output_value: non-standard floats");
nfloats = Wosize_val(v) / Double_wosize;
if (nfloats < 0x100) {
writecode8(CODE_DOUBLE_ARRAY8_NATIVE, nfloats);
} else {
writecode32(CODE_DOUBLE_ARRAY32_NATIVE, nfloats);
}
writeblock_float8((double *) v, nfloats);
size_32 += 1 + nfloats * 2;
size_64 += 1 + nfloats;
extern_record_location(v);
break;
}
case Abstract_tag:
extern_invalid_argument("output_value: abstract value (Abstract)");
break;
case Infix_tag:
writecode32(CODE_INFIXPOINTER, Infix_offset_hd(hd));
extern_rec(v - Infix_offset_hd(hd));
break;
case Custom_tag: {
uintnat sz_32, sz_64;
char * ident = Custom_ops_val(v)->identifier;
void (*serialize)(value v, uintnat * wsize_32,
uintnat * wsize_64)
= Custom_ops_val(v)->serialize;
if (serialize == NULL)
extern_invalid_argument("output_value: abstract value (Custom)");
Write(CODE_CUSTOM);
writeblock(ident, strlen(ident) + 1);
Custom_ops_val(v)->serialize(v, &sz_32, &sz_64);
size_32 += 2 + ((sz_32 + 3) >> 2); /* header + ops + data */
size_64 += 2 + ((sz_64 + 7) >> 3);
extern_record_location(v);
break;
}
default: {
value field0;
mlsize_t i;
if (tag < 16 && sz < 8) {
Write(PREFIX_SMALL_BLOCK + tag + (sz << 4));
#ifdef ARCH_SIXTYFOUR
} else if (hd >= ((uintnat)1 << 32)) {
writecode64(CODE_BLOCK64, Whitehd_hd (hd));
#endif
} else {
writecode32(CODE_BLOCK32, Whitehd_hd (hd));
}
size_32 += 1 + sz;
size_64 += 1 + sz;
field0 = Field(v, 0);
extern_record_location(v);
if (sz == 1) {
v = field0;
} else {
extern_rec(field0);
for (i = 1; i < sz - 1; i++) extern_rec(Field(v, i));
v = Field(v, i);
}
goto tailcall;
}
}
}
/* Executes a pattern match with runtime options, a regular expression, a
string offset, a string length, a subject string, a number of subgroup
offsets, an offset vector and an optional callout function */
CAMLprim value pcre_exec_stub(value v_opt, value v_rex, value v_ofs,
value v_subj, value v_subgroups2, value v_ovec,
value v_maybe_cof)
{
const int ofs = Int_val(v_ofs), len = caml_string_length(v_subj);
if (ofs > len || ofs < 0)
caml_invalid_argument("Pcre.pcre_exec_stub: illegal offset");
{
const pcre *code = (pcre *) Field(v_rex, 1); /* Compiled pattern */
const pcre_extra *extra = (pcre_extra *) Field(v_rex, 2); /* Extra info */
const char *ocaml_subj = String_val(v_subj); /* Subject string */
const int opt = Int_val(v_opt); /* Runtime options */
int subgroups2 = Int_val(v_subgroups2);
const int subgroups2_1 = subgroups2 - 1;
const int subgroups3 = (subgroups2 >> 1) + subgroups2;
/* Special case when no callout functions specified */
if (v_maybe_cof == None) {
int *ovec = (int *) &Field(v_ovec, 0);
/* Performs the match */
const int ret =
pcre_exec(code, extra, ocaml_subj, len, ofs, opt, ovec, subgroups3);
if (ret < 0) {
switch(ret) {
case PCRE_ERROR_NOMATCH : caml_raise_constant(*pcre_exc_Not_found);
case PCRE_ERROR_PARTIAL : caml_raise_constant(*pcre_exc_Partial);
case PCRE_ERROR_MATCHLIMIT :
caml_raise_constant(*pcre_exc_MatchLimit);
case PCRE_ERROR_BADPARTIAL :
caml_raise_constant(*pcre_exc_BadPartial);
case PCRE_ERROR_BADUTF8 : caml_raise_constant(*pcre_exc_BadUTF8);
case PCRE_ERROR_BADUTF8_OFFSET :
caml_raise_constant(*pcre_exc_BadUTF8Offset);
default :
caml_raise_with_string(*pcre_exc_InternalError, "pcre_exec_stub");
}
}
else {
const int *ovec_src = ovec + subgroups2_1;
long int *ovec_dst = (long int *) ovec + subgroups2_1;
/* Converts offsets from C-integers to OCaml-Integers
This is a bit tricky, because there are 32- and 64-bit platforms
around and OCaml chooses the larger possibility for representing
integers when available (also in arrays) - not so the PCRE */
while (subgroups2--) {
*ovec_dst = Val_int(*ovec_src);
--ovec_src; --ovec_dst;
}
}
}
/* There are callout functions */
else {
value v_cof = Field(v_maybe_cof, 0);
value v_substrings;
char *subj = caml_stat_alloc(sizeof(char) * len);
int *ovec = caml_stat_alloc(sizeof(int) * subgroups3);
int ret;
struct cod cod = { (value *) NULL, (value *) NULL, (value) NULL };
struct pcre_extra new_extra =
#ifdef PCRE_CONFIG_MATCH_LIMIT_RECURSION
{ PCRE_EXTRA_CALLOUT_DATA, NULL, 0, NULL, NULL, 0 };
#else
{ PCRE_EXTRA_CALLOUT_DATA, NULL, 0, NULL, NULL };
#endif
memcpy(subj, ocaml_subj, len);
Begin_roots3(v_rex, v_cof, v_substrings);
Begin_roots2(v_subj, v_ovec);
v_substrings = caml_alloc_small(2, 0);
End_roots();
Field(v_substrings, 0) = v_subj;
Field(v_substrings, 1) = v_ovec;
cod.v_substrings_p = &v_substrings;
cod.v_cof_p = &v_cof;
new_extra.callout_data = &cod;
if (extra == NULL) {
ret = pcre_exec(code, &new_extra, subj, len, ofs, opt, ovec,
subgroups3);
}
else {
new_extra.flags = PCRE_EXTRA_CALLOUT_DATA | extra->flags;
new_extra.study_data = extra->study_data;
new_extra.match_limit = extra->match_limit;
new_extra.tables = extra->tables;
#ifdef PCRE_CONFIG_MATCH_LIMIT_RECURSION
new_extra.match_limit_recursion = extra->match_limit_recursion;
#endif
ret = pcre_exec(code, &new_extra, subj, len, ofs, opt, ovec,
subgroups3);
}
free(subj);
End_roots();
if (ret < 0) {
free(ovec);
switch(ret) {
case PCRE_ERROR_NOMATCH : caml_raise_constant(*pcre_exc_Not_found);
case PCRE_ERROR_PARTIAL : caml_raise_constant(*pcre_exc_Partial);
case PCRE_ERROR_MATCHLIMIT :
caml_raise_constant(*pcre_exc_MatchLimit);
case PCRE_ERROR_BADPARTIAL :
caml_raise_constant(*pcre_exc_BadPartial);
case PCRE_ERROR_BADUTF8 : caml_raise_constant(*pcre_exc_BadUTF8);
case PCRE_ERROR_BADUTF8_OFFSET :
caml_raise_constant(*pcre_exc_BadUTF8Offset);
case PCRE_ERROR_CALLOUT : caml_raise(cod.v_exn);
default :
caml_raise_with_string(*pcre_exc_InternalError, "pcre_exec_stub");
}
}
else {
int *ovec_src = ovec + subgroups2_1;
long int *ovec_dst = &Field(v_ovec, 0) + subgroups2_1;
while (subgroups2--) {
*ovec_dst = Val_int(*ovec_src);
--ovec_src; --ovec_dst;
}
free(ovec);
}
}
}
return Val_unit;
}
/* Byte-code hook for pcre_exec_stub
Needed, because there are more than 5 arguments */
CAMLprim value pcre_exec_stub_bc(value *argv, int __unused argn)
{
return pcre_exec_stub(argv[0], argv[1], argv[2], argv[3],
argv[4], argv[5], argv[6]);
}
/* Generates a new set of chartables for the current locale (see man
page of PCRE */
CAMLprim value pcre_maketables_stub(value __unused v_unit)
{
/* GC will do a full cycle every 100 table set allocations
(one table set consumes 864 bytes -> maximum of 86400 bytes
unreclaimed table sets) */
const value v_res = caml_alloc_final(2, pcre_dealloc_tables, 864, 86400);
Field(v_res, 1) = (value) pcre_maketables();
return v_res;
}
/* Wraps around the isspace-function */
CAMLprim value pcre_isspace_stub(value v_c)
{
return Val_bool(isspace(Int_val(v_c)));
}
/* Returns number of substring associated with a name */
CAMLprim value pcre_get_stringnumber_stub(value v_rex, value v_name)
{
const int ret = pcre_get_stringnumber((pcre *) Field(v_rex, 1),
String_val(v_name));
if (ret == PCRE_ERROR_NOSUBSTRING)
caml_invalid_argument("Named string not found");
return Val_int(ret);
}
/* Returns array of names of named substrings in a regexp */
CAMLprim value pcre_names_stub(value v_rex)
{
CAMLparam0();
CAMLlocal1(v_res);
int name_count;
int entry_size;
const char *tbl_ptr;
int i;
int ret = pcre_fullinfo_stub(v_rex, PCRE_INFO_NAMECOUNT, &name_count);
if (ret != 0)
caml_raise_with_string(*pcre_exc_InternalError, "pcre_names_stub");
ret = pcre_fullinfo_stub(v_rex, PCRE_INFO_NAMEENTRYSIZE, &entry_size);
if (ret != 0)
caml_raise_with_string(*pcre_exc_InternalError, "pcre_names_stub");
ret = pcre_fullinfo_stub(v_rex, PCRE_INFO_NAMETABLE, &tbl_ptr);
if (ret != 0)
caml_raise_with_string(*pcre_exc_InternalError, "pcre_names_stub");
v_res = caml_alloc(name_count, 0);
for (i = 0; i < name_count; ++i) {
value v_name = caml_copy_string(tbl_ptr + 2);
Store_field(v_res, i, v_name);
tbl_ptr += entry_size;
}
CAMLreturn(v_res);
}
CAMLprim value mmdb_ml_lookup_path(value ip, value query_list, value mmdb)
{
CAMLparam3(ip, query_list, mmdb);
CAMLlocal3(iter_count, caml_clean_result, query_r);
int total_len = 0, copy_count = 0, gai_error = 0, mmdb_error = 0;
char *clean_result;
long int int_result;
iter_count = query_list;
unsigned int len = caml_string_length(ip);
char *as_string = caml_strdup(String_val(ip));
if (strlen(as_string) != (size_t)len) {
caml_failwith("Could not copy IP address properly");
}
MMDB_s *as_mmdb = (MMDB_s*)Data_custom_val(mmdb);
MMDB_lookup_result_s *result = caml_stat_alloc(sizeof(*result));
*result = MMDB_lookup_string(as_mmdb, as_string, &gai_error, &mmdb_error);
check_error(gai_error, mmdb_error);
caml_stat_free(as_string);
while (iter_count != Val_emptylist) {
total_len++;
iter_count = Field(iter_count, 1);
}
char **query = caml_stat_alloc(sizeof(char *) * (total_len + 1));
while (query_list != Val_emptylist) {
query[copy_count] = caml_strdup(String_val(Field(query_list, 0)));
copy_count++;
query_list = Field(query_list, 1);
}
query[total_len] = NULL;
MMDB_entry_data_s entry_data;
int status = MMDB_aget_value(&result->entry,
&entry_data,
(const char *const *const)query);
check_status(status);
check_data(entry_data);
caml_stat_free(result);
for (int i = 0; i < copy_count; caml_stat_free(query[i]), i++);
caml_stat_free(query);
query_r = caml_alloc(2, 0);
as_mmdb = NULL;
switch (entry_data.type) {
case MMDB_DATA_TYPE_BYTES:
clean_result = caml_stat_alloc(entry_data.data_size + 1);
memcpy(clean_result, entry_data.bytes, entry_data.data_size);
caml_clean_result = caml_copy_string(clean_result);
caml_stat_free(clean_result);
goto string_finish;
case MMDB_DATA_TYPE_UTF8_STRING:
clean_result = strndup(entry_data.utf8_string, entry_data.data_size);
caml_clean_result = caml_copy_string(clean_result);
free(clean_result);
goto string_finish;
case MMDB_DATA_TYPE_FLOAT:
Store_field(query_r, 0, polymorphic_variants.poly_float);
Store_field(query_r, 1, caml_copy_double(entry_data.float_value));
goto finish;
case MMDB_DATA_TYPE_BOOLEAN:
Store_field(query_r, 0, polymorphic_variants.poly_bool);
Store_field(query_r, 1, Val_true ? entry_data.boolean : Val_false);
goto finish;
case MMDB_DATA_TYPE_DOUBLE:
Store_field(query_r, 0, polymorphic_variants.poly_float);
Store_field(query_r, 1, caml_copy_double(entry_data.double_value));
goto finish;
case MMDB_DATA_TYPE_UINT16:
Store_field(query_r, 0, polymorphic_variants.poly_int);
int_result = Val_long(entry_data.uint16);
goto int_finish;
case MMDB_DATA_TYPE_UINT32:
Store_field(query_r, 0, polymorphic_variants.poly_int);
int_result = Val_long(entry_data.uint32);
goto int_finish;
case MMDB_DATA_TYPE_UINT64:
Store_field(query_r, 0, polymorphic_variants.poly_int);
int_result = Val_long(entry_data.uint32);
goto int_finish;
// look at /usr/bin/sed -n 1380,1430p src/maxminddb.c
case MMDB_DATA_TYPE_ARRAY:
case MMDB_DATA_TYPE_MAP:
caml_failwith("Can't return a Map or Array yet");
}
string_finish:
Store_field(query_r, 0, polymorphic_variants.poly_string);
Store_field(query_r, 1, caml_clean_result);
CAMLreturn(query_r);
int_finish:
Store_field(query_r, 1, int_result);
CAMLreturn(query_r);
finish:
CAMLreturn(query_r);
}
CAMLprim value wrapLALInferenceIFOData(value options) {
CAMLparam1(options);
CAMLlocal2(data, option);
LALInferenceIFOData *d = NULL;
ProcessParamsTable *ppt = NULL;
/* Set srate. */
option = Field(options, 0);
ppt = addCommandLineOption(ppt, "--srate", String_val(option));
/* Flow's */
option = Field(options, 1);
if (caml_string_length(option) == 0) {
/* Do nothing. */
} else {
ppt = addCommandLineOption(ppt, "--flow", String_val(option));
}
/* Fhigh's */
option = Field(options, 2);
if (caml_string_length(option) == 0) {
/* Do nothing. */
} else {
ppt = addCommandLineOption(ppt, "--fhigh", String_val(option));
}
option = Field(options, 3);
ppt = addCommandLineOption(ppt, "--cache", String_val(option));
option = Field(options, 4);
ppt = addCommandLineOption(ppt, "--IFO", String_val(option));
option = Field(options, 5);
ppt = addCommandLineOption(ppt, "--dataseed", String_val(option));
option = Field(options, 6);
ppt = addCommandLineOption(ppt, "--PSDstart", String_val(option));
option = Field(options, 7);
ppt = addCommandLineOption(ppt, "--trigtime", String_val(option));
option = Field(options, 8);
ppt = addCommandLineOption(ppt, "--PSDlength", String_val(option));
option = Field(options, 9);
ppt = addCommandLineOption(ppt, "--seglen", String_val(option));
option = Field(options, 10);
if (Is_block(option)) {
ppt = addCommandLineOption(ppt, "--injXML", String_val(Field(option,0)));
}
d = LALInferenceReadData(ppt);
LALInferenceInjectInspiralSignal(d,ppt);
LALInferenceIFOData *dElt = d;
while (dElt != NULL) {
/*If two IFOs have the same sampling rate, they should have the
same timeModelh*, freqModelh*, and modelParams variables to
avoid excess computation in model waveform generation in the
future*/
LALInferenceIFOData * dEltCompare=d;
int foundIFOwithSameSampleRate=0;
while (dEltCompare != NULL && dEltCompare!=dElt) {
if(dEltCompare->timeData->deltaT == dElt->timeData->deltaT){
dElt->timeModelhPlus=dEltCompare->timeModelhPlus;
dElt->freqModelhPlus=dEltCompare->freqModelhPlus;
dElt->timeModelhCross=dEltCompare->timeModelhCross;
dElt->freqModelhCross=dEltCompare->freqModelhCross;
dElt->modelParams=dEltCompare->modelParams;
foundIFOwithSameSampleRate=1;
break;
}
dEltCompare = dEltCompare->next;
}
if(!foundIFOwithSameSampleRate){
dElt->timeModelhPlus = XLALCreateREAL8TimeSeries("timeModelhPlus",
&(dElt->timeData->epoch),
0.0,
dElt->timeData->deltaT,
&lalDimensionlessUnit,
dElt->timeData->data->length);
dElt->timeModelhCross = XLALCreateREAL8TimeSeries("timeModelhCross",
&(dElt->timeData->epoch),
0.0,
dElt->timeData->deltaT,
&lalDimensionlessUnit,
dElt->timeData->data->length);
dElt->freqModelhPlus = XLALCreateCOMPLEX16FrequencySeries("freqModelhPlus",
&(dElt->freqData->epoch),
0.0,
dElt->freqData->deltaF,
&lalDimensionlessUnit,
dElt->freqData->data->length);
dElt->freqModelhCross = XLALCreateCOMPLEX16FrequencySeries("freqModelhCross",
&(dElt->freqData->epoch),
0.0,
dElt->freqData->deltaF,
&lalDimensionlessUnit,
dElt->freqData->data->length);
dElt->modelParams = calloc(1, sizeof(LALInferenceVariables));
}
dElt = dElt->next;
}
deletePPT(ppt);
data = alloc_ifo_data(d);
CAMLreturn(data);
}
static void extern_rec(value v)
{
struct code_fragment * cf;
struct extern_item * sp;
sp = extern_stack;
while(1) {
if (Is_long(v)) {
intnat n = Long_val(v);
if (n >= 0 && n < 0x40) {
Write(PREFIX_SMALL_INT + n);
} else if (n >= -(1 << 7) && n < (1 << 7)) {
writecode8(CODE_INT8, n);
} else if (n >= -(1 << 15) && n < (1 << 15)) {
writecode16(CODE_INT16, n);
#ifdef ARCH_SIXTYFOUR
} else if (n < -((intnat)1 << 31) || n >= ((intnat)1 << 31)) {
writecode64(CODE_INT64, n);
#endif
} else
writecode32(CODE_INT32, n);
goto next_item;
}
if (Is_in_value_area(v)) {
header_t hd = Hd_val(v);
tag_t tag = Tag_hd(hd);
mlsize_t sz = Wosize_hd(hd);
if (tag == Forward_tag) {
value f = Forward_val (v);
if (Is_block (f)
&& (!Is_in_value_area(f) || Tag_val (f) == Forward_tag
|| Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag)){
/* Do not short-circuit the pointer. */
}else{
v = f;
continue;
}
}
/* Atoms are treated specially for two reasons: they are not allocated
in the externed block, and they are automatically shared. */
if (sz == 0) {
if (tag < 16) {
Write(PREFIX_SMALL_BLOCK + tag);
} else {
writecode32(CODE_BLOCK32, hd);
}
goto next_item;
}
/* Check if already seen */
if (Color_hd(hd) == Caml_blue) {
uintnat d = obj_counter - (uintnat) Field(v, 0);
if (d < 0x100) {
writecode8(CODE_SHARED8, d);
} else if (d < 0x10000) {
writecode16(CODE_SHARED16, d);
} else {
writecode32(CODE_SHARED32, d);
}
goto next_item;
}
/* Output the contents of the object */
switch(tag) {
case String_tag: {
mlsize_t len = caml_string_length(v);
if (len < 0x20) {
Write(PREFIX_SMALL_STRING + len);
} else if (len < 0x100) {
writecode8(CODE_STRING8, len);
} else {
writecode32(CODE_STRING32, len);
}
writeblock(String_val(v), len);
size_32 += 1 + (len + 4) / 4;
size_64 += 1 + (len + 8) / 8;
extern_record_location(v);
break;
}
case Double_tag: {
if (sizeof(double) != 8)
extern_invalid_argument("output_value: non-standard floats");
Write(CODE_DOUBLE_NATIVE);
writeblock_float8((double *) v, 1);
size_32 += 1 + 2;
size_64 += 1 + 1;
extern_record_location(v);
break;
}
case Double_array_tag: {
mlsize_t nfloats;
if (sizeof(double) != 8)
extern_invalid_argument("output_value: non-standard floats");
nfloats = Wosize_val(v) / Double_wosize;
if (nfloats < 0x100) {
writecode8(CODE_DOUBLE_ARRAY8_NATIVE, nfloats);
} else {
writecode32(CODE_DOUBLE_ARRAY32_NATIVE, nfloats);
}
writeblock_float8((double *) v, nfloats);
size_32 += 1 + nfloats * 2;
size_64 += 1 + nfloats;
extern_record_location(v);
break;
}
case Abstract_tag:
extern_invalid_argument("output_value: abstract value (Abstract)");
break;
case Infix_tag:
writecode32(CODE_INFIXPOINTER, Infix_offset_hd(hd));
extern_rec(v - Infix_offset_hd(hd));
break;
case Custom_tag: {
uintnat sz_32, sz_64;
char * ident = Custom_ops_val(v)->identifier;
void (*serialize)(value v, uintnat * wsize_32,
uintnat * wsize_64)
= Custom_ops_val(v)->serialize;
if (serialize == NULL)
extern_invalid_argument("output_value: abstract value (Custom)");
Write(CODE_CUSTOM);
writeblock(ident, strlen(ident) + 1);
Custom_ops_val(v)->serialize(v, &sz_32, &sz_64);
size_32 += 2 + ((sz_32 + 3) >> 2); /* header + ops + data */
size_64 += 2 + ((sz_64 + 7) >> 3);
extern_record_location(v);
break;
}
default: {
value field0;
if (tag < 16 && sz < 8) {
Write(PREFIX_SMALL_BLOCK + tag + (sz << 4));
#ifdef ARCH_SIXTYFOUR
} else if (hd >= ((uintnat)1 << 32)) {
writecode64(CODE_BLOCK64, Whitehd_hd (hd));
#endif
} else {
writecode32(CODE_BLOCK32, Whitehd_hd (hd));
}
size_32 += 1 + sz;
size_64 += 1 + sz;
field0 = Field(v, 0);
extern_record_location(v);
/* Remember that we still have to serialize fields 1 ... sz - 1 */
if (sz > 1) {
sp++;
if (sp >= extern_stack_limit) sp = extern_resize_stack(sp);
sp->v = &Field(v,1);
sp->count = sz-1;
}
/* Continue serialization with the first field */
v = field0;
continue;
}
}
}
else if ((cf = extern_find_code((char *) v)) != NULL) {
if (!extern_closures)
extern_invalid_argument("output_value: functional value");
writecode32(CODE_CODEPOINTER, (char *) v - cf->code_start);
writeblock((char *) cf->digest, 16);
} else {
extern_invalid_argument("output_value: abstract value (outside heap)");
}
next_item:
/* Pop one more item to marshal, if any */
if (sp == extern_stack) {
/* We are done. Cleanup the stack and leave the function */
extern_free_stack();
return;
}
v = *((sp->v)++);
if (--(sp->count) == 0) sp--;
}
static void extern_rec_r(CAML_R, value v)
{
struct code_fragment * cf;
struct extern_item * sp;
sp = extern_stack;
while(1) {
//?????DUMP("QQQ 0x%lx, or %li ", v, v);
if (Is_long(v)) {
intnat n = Long_val(v);
if (n >= 0 && n < 0x40) {
Write(PREFIX_SMALL_INT + n);
} else if (n >= -(1 << 7) && n < (1 << 7)) {
writecode8_r(ctx, CODE_INT8, n);
} else if (n >= -(1 << 15) && n < (1 << 15)) {
writecode16_r(ctx, CODE_INT16, n);
#ifdef ARCH_SIXTYFOUR
} else if (n < -((intnat)1 << 31) || n >= ((intnat)1 << 31)) {
writecode64_r(ctx, CODE_INT64, n);
#endif
} else
writecode32_r(ctx, CODE_INT32, n);
goto next_item;
}
if (Is_in_value_area(v)) {
header_t hd = Hd_val(v);
tag_t tag = Tag_hd(hd);
mlsize_t sz = Wosize_hd(hd);
//DUMP("dumping %p, tag %i, size %i", (void*)v, (int)tag, (int)sz); // !!!!!!!!!!!!!!!
if (tag == Forward_tag) {
value f = Forward_val (v);
if (Is_block (f)
&& (!Is_in_value_area(f) || Tag_val (f) == Forward_tag
|| Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag)){
/* Do not short-circuit the pointer. */
}else{
v = f;
continue;
}
}
/* Atoms are treated specially for two reasons: they are not allocated
in the externed block, and they are automatically shared. */
if (sz == 0) {
if (tag < 16) {
Write(PREFIX_SMALL_BLOCK + tag);
} else {
writecode32_r(ctx, CODE_BLOCK32, hd);
}
goto next_item;
}
/* Check if already seen */
if (Color_hd(hd) == Caml_blue) {
uintnat d = obj_counter - (uintnat) Field(v, 0);
if (d < 0x100) {
writecode8_r(ctx, CODE_SHARED8, d);
} else if (d < 0x10000) {
writecode16_r(ctx, CODE_SHARED16, d);
} else {
writecode32_r(ctx, CODE_SHARED32, d);
}
goto next_item;
}
/* Output the contents of the object */
switch(tag) {
case String_tag: {
mlsize_t len = caml_string_length(v);
if (len < 0x20) {
Write(PREFIX_SMALL_STRING + len);
} else if (len < 0x100) {
writecode8_r(ctx, CODE_STRING8, len);
} else {
writecode32_r(ctx, CODE_STRING32, len);
}
writeblock_r(ctx, String_val(v), len);
size_32 += 1 + (len + 4) / 4;
size_64 += 1 + (len + 8) / 8;
extern_record_location_r(ctx, v);
break;
}
case Double_tag: {
if (sizeof(double) != 8)
extern_invalid_argument_r(ctx, "output_value: non-standard floats");
Write(CODE_DOUBLE_NATIVE);
writeblock_float8((double *) v, 1);
size_32 += 1 + 2;
size_64 += 1 + 1;
extern_record_location_r(ctx,v);
break;
}
case Double_array_tag: {
mlsize_t nfloats;
if (sizeof(double) != 8)
extern_invalid_argument_r(ctx, "output_value: non-standard floats");
nfloats = Wosize_val(v) / Double_wosize;
if (nfloats < 0x100) {
writecode8_r(ctx, CODE_DOUBLE_ARRAY8_NATIVE, nfloats);
} else {
writecode32_r(ctx, CODE_DOUBLE_ARRAY32_NATIVE, nfloats);
}
writeblock_float8((double *) v, nfloats);
size_32 += 1 + nfloats * 2;
size_64 += 1 + nfloats;
extern_record_location_r(ctx, v);
break;
}
case Abstract_tag:
extern_invalid_argument_r(ctx, "output_value: abstract value (Abstract)");
break;
case Infix_tag:
writecode32_r(ctx,CODE_INFIXPOINTER, Infix_offset_hd(hd));
extern_rec_r(ctx, v - Infix_offset_hd(hd));
break;
case Custom_tag: {
uintnat sz_32, sz_64;
char * ident = Custom_ops_val(v)->identifier;
void (*serialize)(value v, uintnat * wsize_32,
uintnat * wsize_64);
//printf("[object at %p, which is a %s custom: BEGIN\n", (void*)v, Custom_ops_val(v)->identifier);
if(extern_cross_context){
//printf("About the object at %p, which is a %s custom: USING a cross-context serializer\n", (void*)v, Custom_ops_val(v)->identifier);
serialize = Custom_ops_val(v)->cross_context_serialize;
}
else{
//printf("About the object at %p, which is a %s custom: NOT using a cross-context serializer\n", (void*)v, Custom_ops_val(v)->identifier);
serialize = Custom_ops_val(v)->serialize;
}
//printf("Still alive 100\n");
if (serialize == NULL){
//////
//struct custom_operations *o = Custom_ops_val(v);
//printf("About the object at %p, which is a %s custom\n", (void*)v, Custom_ops_val(v)->identifier); volatile int a = 1; a /= 0;
///////////
extern_invalid_argument_r(ctx, "output_value: abstract value (Custom)");
}
//printf("Still alive 200\n");
Write(CODE_CUSTOM);
//printf("Still alive 300\n");
writeblock_r(ctx, ident, strlen(ident) + 1);
//printf("Still alive 400\n");
serialize(v, &sz_32, &sz_64);
//printf("Still alive 500\n");
size_32 += 2 + ((sz_32 + 3) >> 2); /* header + ops + data */
size_64 += 2 + ((sz_64 + 7) >> 3);
//printf("Still alive 600\n");
extern_record_location_r(ctx,v); // This temporarily breaks the object, by replacing it with a forwarding pointer
//printf("object at %p, which is a custom: END\n", (void*)v);
break;
}
default: {
value field0;
if (tag < 16 && sz < 8) {
Write(PREFIX_SMALL_BLOCK + tag + (sz << 4));
#ifdef ARCH_SIXTYFOUR
} else if (hd >= ((uintnat)1 << 32)) {
writecode64_r(ctx, CODE_BLOCK64, Whitehd_hd (hd));
#endif
} else {
writecode32_r(ctx, CODE_BLOCK32, Whitehd_hd (hd));
}
size_32 += 1 + sz;
size_64 += 1 + sz;
field0 = Field(v, 0);
extern_record_location_r(ctx, v);
/* Remember that we still have to serialize fields 1 ... sz - 1 */
if (sz > 1) {
sp++;
if (sp >= extern_stack_limit) sp = extern_resize_stack_r(ctx, sp);
sp->v = &Field(v,1);
sp->count = sz-1;
}
/* Continue serialization with the first field */
v = field0;
continue;
}
}
}
else if ((cf = extern_find_code_r(ctx, (char *) v)) != NULL) {
if (!extern_closures){
extern_invalid_argument_r(ctx, "output_value: functional value"); // FIXME: this is the correct version. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
//DUMP("output_value: functional value"); {volatile int a = 1; a /= 0;}
}
//fprintf(stderr, "ZZZZ dumping a code pointer: BEGIN\n");
//DUMP("dumping a code pointer 0x%lx, or %li; code start is at %p", v, v, cf->code_start);
writecode32_r(ctx, CODE_CODEPOINTER, (char *) v - cf->code_start);
writeblock_r(ctx, (char *) cf->digest, 16);
//dump_digest(cf->digest);
//fprintf(stderr, "ZZZZ dumping a code pointer: END\n");
} else {
if(extern_cross_context){
fprintf(stderr, "ZZZZ working on the external pointer: %p, which is to say %li [cf is %p]\n", (void*)v, (long)v, cf);
//fprintf(stderr, "ZZZZ I'm doing a horrible, horrible thing: serializing the pointer as a tagged 0.\n");
DUMP("about to crash in the strange case I'm debugging");
/* DUMP("the object is 0x%lx, or %li ", v, v); */
/* DUMP("probably crashing now"); */
/* DUMP("tag is %i", (int)Tag_val(v)); */
/* DUMP("size is %i", (int)Wosize_val(v)); */
//volatile int a = 1; a /= 0;
//extern_rec_r(ctx, Val_int(0));
/* fprintf(stderr, "ZZZZ [This is probably wrong: I'm marshalling an out-of-heap pointer as an int64]\n"); */
/* writecode64_r(ctx, CODE_INT64, (v << 1) | 1); */
extern_invalid_argument_r(ctx, "output_value: abstract value (outside heap) [FIXME: implement]");
}
else
extern_invalid_argument_r(ctx, "output_value: abstract value (outside heap)");
}
next_item:
/* Pop one more item to marshal, if any */
if (sp == extern_stack) {
/* We are done. Cleanup the stack and leave the function */
extern_free_stack_r(ctx);
return;
}
v = *((sp->v)++);
if (--(sp->count) == 0) sp--;
}
static void hash_aux(value obj)
{
unsigned char * p;
mlsize_t i, j;
tag_t tag;
hash_univ_limit--;
if (hash_univ_count < 0 || hash_univ_limit < 0) return;
again:
if (Is_long(obj)) {
hash_univ_count--;
Combine(Long_val(obj));
return;
}
/* Pointers into the heap are well-structured blocks. So are atoms.
We can inspect the block contents. */
Assert (Is_block (obj));
if (Is_in_value_area(obj)) {
tag = Tag_val(obj);
switch (tag) {
case String_tag:
hash_univ_count--;
i = caml_string_length(obj);
for (p = &Byte_u(obj, 0); i > 0; i--, p++)
Combine_small(*p);
break;
case Double_tag:
/* For doubles, we inspect their binary representation, LSB first.
The results are consistent among all platforms with IEEE floats. */
hash_univ_count--;
#ifdef ARCH_BIG_ENDIAN
for (p = &Byte_u(obj, sizeof(double) - 1), i = sizeof(double);
i > 0;
p--, i--)
#else
for (p = &Byte_u(obj, 0), i = sizeof(double);
i > 0;
p++, i--)
#endif
Combine_small(*p);
break;
case Double_array_tag:
hash_univ_count--;
for (j = 0; j < Bosize_val(obj); j += sizeof(double)) {
#ifdef ARCH_BIG_ENDIAN
for (p = &Byte_u(obj, j + sizeof(double) - 1), i = sizeof(double);
i > 0;
p--, i--)
#else
for (p = &Byte_u(obj, j), i = sizeof(double);
i > 0;
p++, i--)
#endif
Combine_small(*p);
}
break;
case Abstract_tag:
/* We don't know anything about the contents of the block.
Better do nothing. */
break;
case Infix_tag:
hash_aux(obj - Infix_offset_val(obj));
break;
case Forward_tag:
obj = Forward_val (obj);
goto again;
case Object_tag:
hash_univ_count--;
Combine(Oid_val(obj));
break;
case Custom_tag:
/* If no hashing function provided, do nothing */
if (Custom_ops_val(obj)->hash != NULL) {
hash_univ_count--;
Combine(Custom_ops_val(obj)->hash(obj));
}
break;
default:
hash_univ_count--;
Combine_small(tag);
i = Wosize_val(obj);
while (i != 0) {
i--;
hash_aux(Field(obj, i));
}
break;
}
return;
}
/* Otherwise, obj is a pointer outside the heap, to an object with
a priori unknown structure. Use its physical address as hash key. */
Combine((intnat) obj);
}
extern "C" value ml_IGUIFont_getDimension(value v_font, value v_text) {
int text_size = caml_string_length(v_text);
wchar_t text[2 * (text_size + 1)];
mbstowcs(text, String_val(v_text), 2 * text_size);
return copy_dimension2d_u32(((IGUIFont*) v_font)->getDimension(text));
}
static intnat compare_val(value v1, value v2, int total)
{
struct compare_item * sp;
tag_t t1, t2;
if (!compare_stack) compare_init_stack();
sp = compare_stack;
while (1) {
if (v1 == v2 && total) goto next_item;
if (Is_long(v1)) {
if (v1 == v2) goto next_item;
if (Is_long(v2))
return Long_val(v1) - Long_val(v2);
/* Subtraction above cannot overflow and cannot result in UNORDERED */
switch (Tag_val(v2)) {
case Forward_tag:
v2 = Forward_val(v2);
continue;
case Custom_tag: {
int res;
int (*compare)(value v1, value v2) = Custom_ops_val(v2)->compare_ext;
if (compare == NULL) break; /* for backward compatibility */
caml_compare_unordered = 0;
res = compare(v1, v2);
if (caml_compare_unordered && !total) return UNORDERED;
if (res != 0) return res;
goto next_item;
}
default: /*fallthrough*/;
}
return LESS; /* v1 long < v2 block */
}
if (Is_long(v2)) {
switch (Tag_val(v1)) {
case Forward_tag:
v1 = Forward_val(v1);
continue;
case Custom_tag: {
int res;
int (*compare)(value v1, value v2) = Custom_ops_val(v1)->compare_ext;
if (compare == NULL) break; /* for backward compatibility */
caml_compare_unordered = 0;
res = compare(v1, v2);
if (caml_compare_unordered && !total) return UNORDERED;
if (res != 0) return res;
goto next_item;
}
default: /*fallthrough*/;
}
return GREATER; /* v1 block > v2 long */
}
t1 = Tag_val(v1);
t2 = Tag_val(v2);
if (t1 == Forward_tag) { v1 = Forward_val (v1); continue; }
if (t2 == Forward_tag) { v2 = Forward_val (v2); continue; }
if (t1 != t2) return (intnat)t1 - (intnat)t2;
switch(t1) {
case String_tag: {
mlsize_t len1, len2;
int res;
if (v1 == v2) break;
len1 = caml_string_length(v1);
len2 = caml_string_length(v2);
res = memcmp(String_val(v1), String_val(v2), len1 <= len2 ? len1 : len2);
if (res < 0) return LESS;
if (res > 0) return GREATER;
if (len1 != len2) return len1 - len2;
break;
}
case Double_tag: {
double d1 = Double_val(v1);
double d2 = Double_val(v2);
if (d1 < d2) return LESS;
if (d1 > d2) return GREATER;
if (d1 != d2) {
if (! total) return UNORDERED;
/* One or both of d1 and d2 is NaN. Order according to the
convention NaN = NaN and NaN < f for all other floats f. */
if (d1 == d1) return GREATER; /* d1 is not NaN, d2 is NaN */
if (d2 == d2) return LESS; /* d2 is not NaN, d1 is NaN */
/* d1 and d2 are both NaN, thus equal: continue comparison */
}
break;
}
case Double_array_tag: {
mlsize_t sz1 = Wosize_val(v1) / Double_wosize;
mlsize_t sz2 = Wosize_val(v2) / Double_wosize;
mlsize_t i;
if (sz1 != sz2) return sz1 - sz2;
for (i = 0; i < sz1; i++) {
double d1 = Double_field(v1, i);
double d2 = Double_field(v2, i);
if (d1 < d2) return LESS;
if (d1 > d2) return GREATER;
if (d1 != d2) {
if (! total) return UNORDERED;
/* See comment for Double_tag case */
if (d1 == d1) return GREATER;
if (d2 == d2) return LESS;
}
}
break;
}
case Abstract_tag:
compare_free_stack();
caml_invalid_argument("equal: abstract value");
case Closure_tag:
case Infix_tag:
compare_free_stack();
caml_invalid_argument("equal: functional value");
case Object_tag: {
intnat oid1 = Oid_val(v1);
intnat oid2 = Oid_val(v2);
if (oid1 != oid2) return oid1 - oid2;
break;
}
case Custom_tag: {
int res;
int (*compare)(value v1, value v2) = Custom_ops_val(v1)->compare;
/* Hardening against comparisons between different types */
if (compare != Custom_ops_val(v2)->compare) {
return strcmp(Custom_ops_val(v1)->identifier,
Custom_ops_val(v2)->identifier) < 0
? LESS : GREATER;
}
if (compare == NULL) {
compare_free_stack();
caml_invalid_argument("equal: abstract value");
}
caml_compare_unordered = 0;
res = compare(v1, v2);
if (caml_compare_unordered && !total) return UNORDERED;
if (res != 0) return res;
break;
}
default: {
mlsize_t sz1 = Wosize_val(v1);
mlsize_t sz2 = Wosize_val(v2);
/* Compare sizes first for speed */
if (sz1 != sz2) return sz1 - sz2;
if (sz1 == 0) break;
/* Remember that we still have to compare fields 1 ... sz - 1 */
if (sz1 > 1) {
sp++;
if (sp >= compare_stack_limit) sp = compare_resize_stack(sp);
sp->v1 = Op_val(v1) + 1;
sp->v2 = Op_val(v2) + 1;
sp->count = sz1 - 1;
}
/* Continue comparison with first field */
v1 = Field(v1, 0);
v2 = Field(v2, 0);
continue;
}
}
next_item:
/* Pop one more item to compare, if any */
if (sp == compare_stack) return EQUAL; /* we're done */
v1 = *((sp->v1)++);
v2 = *((sp->v2)++);
if (--(sp->count) == 0) sp--;
}
}
CAMLprim value ml_text_recode_string(value enc_src, value enc_dst, value str)
{
CAMLparam3(str, enc_src, enc_dst);
CAMLlocal1(result);
iconv_t cd = iconv_open(String_val(enc_dst), String_val(enc_src));
if (cd == (iconv_t)-1)
caml_failwith("Encoding.recode_string: invalid encoding");
/* Length of the output buffer. It is initialised to the length of
the input string, which should be a good
approximation: */
size_t len = caml_string_length(str);
/* Pointer to the beginning of the output buffer. The +1 is for the
NULL terminating byte. */
char *dst_buffer = malloc(len + 1);
if (dst_buffer == NULL)
caml_failwith("Encoding.recode_string: out of memory");
/* iconv arguments */
char *src_bytes = String_val(str);
char *dst_bytes = dst_buffer;
size_t src_remaining = len;
size_t dst_remaining = len;
while (src_remaining) {
size_t count = iconv (cd, &src_bytes, &src_remaining, &dst_bytes, &dst_remaining);
if (count == (size_t) -1) {
switch (errno) {
case EILSEQ:
free(dst_buffer);
iconv_close(cd);
caml_failwith("Encoding.recode_string: invalid multibyte sequence found in the input");
case EINVAL:
free(dst_buffer);
iconv_close(cd);
caml_failwith("Encoding.recode_string: incomplete multibyte sequence found in the input");
case E2BIG: {
/* Ouput offest relative to the beginning of the destination
buffer: */
size_t offset = dst_bytes - dst_buffer;
/* Try with a buffer 2 times bigger: */
len *= 2;
dst_buffer = realloc(dst_buffer, len + 1);
if (dst_buffer == NULL)
caml_failwith("Encoding.recode_string: out of memory");
dst_bytes = dst_buffer + offset;
dst_remaining += len;
break;
}
default:
free(dst_buffer);
iconv_close(cd);
caml_failwith("Encoding.recode_string: unknown error");
}
}
};
*dst_bytes = 0;
result = caml_alloc_string(dst_bytes - dst_buffer);
memcpy(String_val(result), dst_buffer, dst_bytes - dst_buffer);
/* Clean-up */
free(dst_buffer);
iconv_close(cd);
CAMLreturn(result);
}
CAMLprim value caml_string_get(value str, value index)
{
intnat idx = Long_val(index);
if (idx < 0 || idx >= caml_string_length(str)) caml_array_bound_error();
return Val_int(Byte_u(str, idx));
}
value caml_gr_draw_string(value str)
{
caml_gr_check_open();
caml_gr_draw_text(String_val(str), caml_string_length(str));
return Val_unit;
}
