CAMLprim value pcre_firstbyte_stub(value v_rex)
{
int firstbyte;
const int ret = pcre_fullinfo_stub(v_rex, PCRE_INFO_FIRSTBYTE, &firstbyte);
if (ret != 0) caml_raise_with_string(*pcre_exc_InternalError,
"pcre_firstbyte_stub");
switch (firstbyte) {
case -1 : return var_Start_only; break; /* [`Start_only] */
case -2 : return var_ANCHORED; break; /* [`ANCHORED] */
default :
if (firstbyte < 0 ) /* Should not happen */
caml_raise_with_string(*pcre_exc_InternalError, "pcre_firstbyte_stub");
else {
value v_firstbyte;
/* Allocates the non-constant constructor [`Char of char] and fills
in the appropriate value */
v_firstbyte = caml_alloc_small(2, 0);
Field(v_firstbyte, 0) = var_Char;
Field(v_firstbyte, 1) = Val_int(firstbyte);
return v_firstbyte;
}
}
}
CAMLprim value pcre_firsttable_stub(value v_rex)
{
const unsigned char *ftable;
int ret =
pcre_fullinfo_stub(v_rex, PCRE_INFO_FIRSTTABLE, (void *) &ftable);
if (ret != 0) caml_raise_with_string(*pcre_exc_InternalError,
"pcre_firsttable_stub");
if (ftable == NULL) return None;
else {
value v_res, v_res_str;
char *ptr;
int i;
Begin_roots1(v_rex);
v_res_str = caml_alloc_string(32);
End_roots();
ptr = String_val(v_res_str);
for (i = 0; i <= 31; ++i) { *ptr = *ftable; ++ptr; ++ftable; }
Begin_roots1(v_res_str);
/* Allocates [Some string] from firsttable */
v_res = caml_alloc_small(1, 0);
End_roots();
Field(v_res, 0) = v_res_str;
return v_res;
}
}
CAMLexport void caml_invalid_argument (char const *msg)
{
if (caml_global_data == 0) {
fprintf(stderr, "Fatal error: exception Invalid_argument(\"%s\")\n", msg);
exit(2);
}
caml_raise_with_string(Field(caml_global_data, INVALID_EXN), msg);
}
CAMLexport void caml_failwith (char const *msg)
{
if (caml_global_data == 0) {
fprintf(stderr, "Fatal error: exception Failure(\"%s\")\n", msg);
exit(2);
}
caml_raise_with_string(Field(caml_global_data, FAILURE_EXN), msg);
}
CAMLprim value pcre_lastliteral_stub(value v_rex)
{
int lastliteral;
const int ret = pcre_fullinfo_stub(v_rex, PCRE_INFO_LASTLITERAL,
&lastliteral);
if (ret != 0) caml_raise_with_string(*pcre_exc_InternalError,
"pcre_lastliteral_stub");
if (lastliteral == -1) return None;
if (lastliteral < 0) caml_raise_with_string(*pcre_exc_InternalError,
"pcre_lastliteral_stub");
else {
/* Allocates [Some char] */
value v_res = caml_alloc_small(1, 0);
Field(v_res, 0) = Val_int(lastliteral);
return v_res;
}
}
static void raise_sqlite3_misuse_stmt(const char *fmt, ...)
{
char buf[1024];
va_list args;
va_start(args, fmt);
vsnprintf(buf, sizeof buf, fmt, args);
va_end(args);
caml_raise_with_string(*caml_sqlite3_Error, buf);
}
static
void RAISE(const char *error)
{
static value *exception_handler = NULL;
if (exception_handler == NULL) {
exception_handler = caml_named_value("kyotocabinet.error");
if (exception_handler == NULL) {
caml_failwith(error);
}
}
caml_raise_with_string(*exception_handler, error);
}
static void failwith_xc(xc_interface *xch)
{
static char error_str[ERROR_STRLEN];
if (xch) {
const xc_error *error = xc_get_last_error(xch);
if (error->code == XC_ERROR_NONE)
snprintf(error_str, ERROR_STRLEN, "%d: %s", errno, strerror(errno));
else
snprintf(error_str, ERROR_STRLEN, "%d: %s: %s",
error->code,
xc_error_code_to_desc(error->code),
error->message);
} else {
snprintf(error_str, ERROR_STRLEN, "Unable to open XC interface");
}
caml_raise_with_string(*caml_named_value("xc.error"), error_str);
}
CAMLexport void caml_failwith (char const *msg)
{
caml_raise_with_string(Field(caml_global_data, FAILURE_EXN), msg);
}
void caml_invalid_argument (char const *msg)
{
caml_raise_with_string((value) caml_exn_Invalid_argument, msg);
}
void caml_failwith (char const *msg)
{
caml_raise_with_string((value) caml_exn_Failure, msg);
}
CAMLprim value stub_nvml_open(value unit) {
CAMLparam1(unit);
CAMLlocal1(ml_interface);
nvmlInterface *interface;
value *exn;
interface = malloc(sizeof(nvmlInterface));
// Open the library.
interface->handle = dlopen("libnvidia-ml.so.1", RTLD_LAZY);
if (!interface->handle) {
free(interface);
exn = caml_named_value("Library_not_loaded");
if (exn) {
caml_raise_with_string(*exn, dlerror());
}
else {
caml_failwith(dlerror());
}
}
// Load nvmlErrorString.
interface->errorString = dlsym(interface->handle, "nvmlErrorString");
if (!interface->errorString) {
goto SymbolError;
}
// Load nvmlInit.
interface->init = dlsym(interface->handle, "nvmlInit");
if (!interface->init) {
goto SymbolError;
}
// Load nvmlShutdown.
interface->shutdown = dlsym(interface->handle, "nvmlShutdown");
if (!interface->shutdown) {
goto SymbolError;
}
// Load nvmlDeviceGetCount.
interface->deviceGetCount = dlsym(interface->handle, "nvmlDeviceGetCount");
if (!interface->deviceGetCount) {
goto SymbolError;
}
// Load nvmlDeviceGetHandleByIndex.
interface->deviceGetHandleByIndex =
dlsym(interface->handle, "nvmlDeviceGetHandleByIndex");
if(!interface->deviceGetHandleByIndex) {
goto SymbolError;
}
// Load nvmlDeviceGetMemoryInfo.
interface->deviceGetMemoryInfo =
dlsym(interface->handle, "nvmlDeviceGetMemoryInfo");
if(!interface->deviceGetMemoryInfo) {
goto SymbolError;
}
// Load nvmlDeviceGetPciInfo.
interface->deviceGetPciInfo =
dlsym(interface->handle, "nvmlDeviceGetPciInfo");
if(!interface->deviceGetPciInfo) {
goto SymbolError;
}
// Load nvmlDeviceGetPowerUsage.
interface->deviceGetPowerUsage =
dlsym(interface->handle, "nvmlDeviceGetPowerUsage");
if(!interface->deviceGetPowerUsage) {
goto SymbolError;
}
// Load nvmlDeviceGetTemperature.
interface->deviceGetTemperature =
dlsym(interface->handle, "nvmlDeviceGetTemperature");
if(!interface->deviceGetTemperature) {
goto SymbolError;
}
// Load nvmlDeviceGetUtilizationRates.
interface->deviceGetUtilizationRates =
dlsym(interface->handle, "nvmlDeviceGetUtilizationRates");
if(!interface->deviceGetUtilizationRates) {
goto SymbolError;
}
ml_interface = (value)interface;
CAMLreturn(ml_interface);
SymbolError:
free(interface);
exn = caml_named_value("Symbol_not_loaded");
if (exn) {
caml_raise_with_string(*exn, dlerror());
}
else {
caml_failwith(dlerror());
}
}
static inline void raise_sqlite3_InternalError(char *msg)
{
caml_raise_with_string(*caml_sqlite3_InternalError, msg);
}
void raise_error (char *msg) {
caml_raise_with_string (*caml_named_value ("mpcap_exn"), msg);
}
/* 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);
}
CAMLexport void caml_invalid_argument (char const *msg)
{
caml_raise_with_string(Field(caml_global_data, INVALID_EXN), msg);
}
static void
spf_error(const char *err)
{
caml_raise_with_string(*caml_named_value("Error"), err);
}
void failwith_xl(char *fname, struct caml_logger *lg)
{
char *s;
s = (lg) ? lg->log_buf : fname;
caml_raise_with_string(*caml_named_value("xl.error"), s);
}
