void ml_raise_null_pointer ()
{
static value * exn = NULL;
if (exn == NULL)
exn = caml_named_value ("null_pointer");
raise_constant (*exn);
}
CAMLprim value
statfs_statfs (value pathv)
{
#ifdef HAVE_STATS
CAMLparam1 (pathv);
CAMLlocal1 (bufv);
const char *path = String_val (pathv);
#if ((defined (sun) || defined (__sun__))) || (defined(__NetBSD__) && (__NetBSD_Version__ > 299000000)) || defined (__hpux__) || defined(__alpha__)
struct statvfs buf;
if (statvfs (path, &buf) == -1)
#else
struct statfs buf;
if (statfs (path, &buf) == -1)
#endif /* ((defined (sun) || defined (__sun__))) || (defined(__NetBSD__) && (__NetBSD_Version__ > 299000000)) || defined (__hpux__) */
raise_constant(*(value *)caml_named_value("error"));
bufv = copy_statfs (&buf);
CAMLreturn (bufv);
#else
raise_constant(*(value *)caml_named_value("not supported"));
#endif /* HAVE_STATS */
}
CAMLprim value
statfs_statfs (value pathv)
{
CAMLparam1 (pathv);
CAMLlocal1 (bufv);
const unsigned char *path = String_val (pathv);
struct statfs buf;
if (statfs (path, &buf) == -1)
raise_constant(*(value *)caml_named_value("error"));
bufv = copy_statfs (&buf);
CAMLreturn (bufv);
}
/* Raises exceptions when the retval isn't what it should be */
void retval_inspect(char* whichfunc, CS_RETCODE retval)
{
switch(retval)
{
case CS_SUCCEED:
return;
case CS_FAIL:
failwith(whichfunc);
#ifdef CS_NOMSG
/* Not supported in (at least some versions of) freetds */
case CS_NOMSG:
failwith("Internal error - CS_NOMSG returned (This should never be possible)");
#endif
case CS_END_RESULTS:
raise_constant(*caml_named_value("cs_end_results"));
case CS_END_DATA:
raise_constant(*caml_named_value("cs_end_data"));
case CS_CANCELED:
raise_constant(*caml_named_value("cs_cancelled"));
}
}
value value_of_restype(CS_INT restype)
{
CAMLparam0 ();
if ( restype == CS_ROW_RESULT )
CAMLreturn( hash_variant("Row") );
if ( restype == CS_PARAM_RESULT )
CAMLreturn( hash_variant("Param") );
if ( restype == CS_STATUS_RESULT )
CAMLreturn( hash_variant("Status") );
if ( restype == CS_CMD_DONE )
CAMLreturn( hash_variant("Cmd_done") );
if ( restype != CS_CMD_SUCCEED )
raise_constant(*caml_named_value("cs_cmd_fail"));
CAMLreturn(hash_variant("Cmd_succeed"));
}
CAMLprim value mlresolv_query(value vdname, value vclass, value vtype)
{
union {
HEADER hdr; /* defined in resolv.h */
u_char buf[PACKETSZ]; /* defined in arpa/nameser.h */
} response;
int rc;
u_char *cp, *tcp;
u_char *eom;
char r_name[MAXDNAME+1];
u_short r_class;
u_short r_type;
u_int32_t r_ttl;
u_short r_len;
int ancount, qdcount;
value vres = Val_emptylist;
if(vtype == caml_hash_variant("PTR")) {
int a, b, c, d;
a = b = c = d = 0;
sscanf(String_val(vdname), "%u.%u.%u.%u", &a, &b, &c, &d);
sprintf(r_name, "%u.%u.%u.%u.in-addr.arpa", d, c, b, a);
rc = res_query(r_name,
mlvariant_to_c(rr_class, vclass),
mlvariant_to_c(rr_type, vtype),
(u_char*)&response, sizeof(response));
} else
rc = res_query(String_val(vdname),
mlvariant_to_c(rr_class, vclass),
mlvariant_to_c(rr_type, vtype),
(u_char*)&response, sizeof(response));
if (rc < 0) {
switch (h_errno) {
case NETDB_INTERNAL:
mlresolv_error(errno);
case HOST_NOT_FOUND: /* Authoritative Answer Host not found */
raise_constant(*mlresolv_host_not_found_exn);
case TRY_AGAIN: /* Non-Authoritative Host not found, or SERVERFAIL */
raise_constant(*mlresolv_try_again_exn);
case NO_RECOVERY:
raise_constant(*mlresolv_no_recovery_exn);
case NO_DATA: /* Valid name, no data record of requested type */
raise_constant(*mlresolv_no_data_exn);
case NETDB_SUCCESS: /* no problem */
defaykt:
failwith("res_query: unknown error");
}
}
cp = (u_char *)&response.buf + sizeof(HEADER);
eom = (u_char *)&response.buf + rc;
ancount = ntohs(response.hdr.ancount) + ntohs(response.hdr.nscount);
qdcount = ntohs(response.hdr.qdcount);
for (; (qdcount > 0) && (cp < eom); qdcount--) {
rc = dn_skipname(cp, eom) + QFIXEDSZ;
if(rc < 0)
failwith("dn_skipname failed");
cp += rc;
}
for (; (ancount > 0) && (cp < eom); ancount--) {
value vrdata, vfields = Val_unit;
rc = dn_expand(response.buf, eom, cp, (void*)r_name, MAXDNAME);
if(rc < 0)
failwith("dn_expand1 failed");
cp += rc;
NS_GET16(r_type, cp);
NS_GET16(r_class, cp);
NS_GET32(r_ttl, cp);
NS_GET16(r_len, cp);
if(cp + r_len > eom) /* is this check necessary? */
r_len = eom - cp;
tcp = cp;
switch(r_type) {
case ns_t_a:
/* if(r_class == ns_c_in || r_class == ns_c_hs) { */
if(INADDRSZ > r_len)
vfields = copy_string("");
else {
struct in_addr inaddr;
char *address;
bcopy(tcp, (char *)&inaddr, INADDRSZ);
address = (char *)inet_ntoa(inaddr);
vfields = copy_string(address);
}
break;
case ns_t_cname:
case ns_t_ns:
case ns_t_mb:
case ns_t_md:
case ns_t_mf:
case ns_t_mg:
case ns_t_mr:
case ns_t_ptr:
case ns_t_nsap_ptr:
{
char r_name[MAXDNAME+1];
rc = dn_expand(response.buf, eom, cp, (void *) r_name, MAXDNAME);
if(rc < 0)
vfields = copy_string("");
else
vfields = copy_string(r_name);
break;
}
case ns_t_null: /* max up to 65535 */
vfields = caml_alloc_string(r_len);
memmove(String_val(vfields), cp, r_len);
break;
case ns_t_txt: {
int txtlen, rdata_len = r_len;
value newcons, txt;
vfields = Val_emptylist;
while(tcp < eom && *tcp <= rdata_len) {
txtlen = *tcp++;
txt = caml_alloc_string(txtlen);
memmove(String_val(txt), tcp, txtlen);
tcp += txtlen;
rdata_len -= txtlen+1;
newcons = alloc_small(2, 0);
Field(newcons, 0) = txt;
Field(newcons, 1) = vfields;
vfields = newcons;
}
break;
}
case ns_t_srv:
if(INT16SZ * 3 <= r_len) {
char r_name[MAXDNAME+1];
int prio, weight, port;
NS_GET16(prio, tcp);
NS_GET16(weight, tcp);
NS_GET16(port, tcp);
rc = dn_expand(response.buf, eom, tcp, (void *) r_name, MAXDNAME);
vfields = alloc_small(4, 0);
Field(vfields, 0) = Val_int(prio);
Field(vfields, 1) = Val_int(weight);
Field(vfields, 2) = Val_int(port);
if(rc < 0)
Field(vfields, 3) = copy_string("");
else
Field(vfields, 3) = copy_string(r_name);
}
break;
case ns_t_mx:
case ns_t_rt:
case ns_t_afsdb:
if(INT16SZ <= r_len) {
char r_name[MAXDNAME+1];
int prio;
NS_GET16(prio, tcp);
rc = dn_expand(response.buf, eom, tcp, (void *) r_name, MAXDNAME);
vfields = alloc_small(2, 0);
Field(vfields, 0) = Val_int(prio);
if(rc < 0)
Field(vfields, 1) = copy_string("");
else
Field(vfields, 1) = copy_string(r_name);
}
break;
case ns_t_soa:
{
char mname[MAXDNAME+1];
char rname[MAXDNAME+1];
u_int serial, minimum;
int refresh, retry, expire;
if((rc = dn_expand(response.buf, eom, tcp, (void *)mname, MAXDNAME)) < 0)
break;
tcp += rc;
if((rc = dn_expand(response.buf, eom, tcp, (void *)rname, MAXDNAME)) < 0)
break;
tcp += rc;
if (tcp - cp + INT32SZ * 5 > r_len)
break;
NS_GET32(serial, tcp);
NS_GET32(refresh, tcp);
NS_GET32(retry, tcp);
NS_GET32(expire, tcp);
NS_GET32(minimum, tcp);
vfields = alloc_small(7, 0);
Field(vfields, 0) = copy_string(mname);
Field(vfields, 1) = copy_string(rname);
Field(vfields, 2) = Val_int(serial);
Field(vfields, 3) = Val_int(refresh);
Field(vfields, 4) = Val_int(retry);
Field(vfields, 5) = Val_int(expire);
Field(vfields, 6) = Val_int(minimum);
}
break;
case ns_t_minfo:
{
char rmailbx[MAXDNAME+1];
char emailbx[MAXDNAME+1];
if((rc = dn_expand(response.buf, eom, tcp, rmailbx, MAXDNAME)) < 0)
break;
tcp += rc;
if((rc = dn_expand(response.buf, eom, tcp, emailbx, MAXDNAME)) < 0)
break;
vfields = alloc_small(2, 0);
Field(vfields, 0) = copy_string(rmailbx);
Field(vfields, 1) = copy_string(emailbx);
}
break;
/* two strings */
case ns_t_hinfo:
case ns_t_isdn: /* <ISDN-address> <sa> */
case ns_t_nsap:
if(r_len > 0 && *tcp < r_len) {
value str1;
value str2;
rc = *tcp++;
if(r_type == ns_t_nsap) {
int result = 0;
for(; rc; rc--, tcp++)
result += result * 10 + (*tcp - 0x38);
str1 = Val_int(result);
}
else {
str1 = caml_alloc_string(rc);
memmove(String_val(str1), tcp, rc);
tcp += rc;
}
if(rc + 1 > r_len && *tcp + rc + 2 >= r_len) {
rc = *tcp++;
str2 = caml_alloc_string(rc);
memmove(String_val(str2), tcp, rc);
}
else
str2 = copy_string("");
vfields = caml_alloc_small(2, 0);
Field(vfields, 0) = str1;
Field(vfields, 1) = str2;
}
break;
case ns_t_wks:
if(INADDRSZ + 1 <= r_len) {
struct in_addr inaddr;
char* address;
u_short protocol;
value bitmap;
bcopy(tcp, (char *) &inaddr, INADDRSZ);
address = (char*) inet_ntoa(inaddr);
tcp += INADDRSZ;
protocol = *tcp++; /* getprotobynumber(*cp) */
/*
n = 0;
while (cp < eom) {
c = *cp++;
do {
if (c & 0200) {
int port;
port = htons((u_short)n);
if (protocol != NULL)
service = getservbyport(port, protocol->p_name);
else
service = NULL;
if (service != NULL)
doprintf((" %s", service->s_name));
else
doprintf((" %s", dtoa(n)));
}
c <<= 1;
} while (++n & 07);
}
doprintf((" )"));
*/
bitmap = caml_alloc_string(r_len - INADDRSZ - 1);
memmove(String_val(bitmap), tcp, eom - tcp);
vfields = alloc_small(4, 0);
Field(vfields, 0) = copy_string(address);
Field(vfields, 1) = Val_int(protocol);
Field(vfields, 2) = bitmap;
}
break;
case ns_t_rp: /* <mbox-dname> <txt-dname> */
{
char rname1[MAXDNAME+1];
char rname2[MAXDNAME+1];
rc = dn_expand(response.buf, eom, tcp, rname1, MAXDNAME);
if(rc < 0)
break;
tcp += rc;
rc = dn_expand(response.buf, eom, tcp, rname2, MAXDNAME);
if(rc < 0)
break;
vfields = alloc_small(2, 0);
Field(vfields, 0) = copy_string(rname1);
Field(vfields, 1) = copy_string(rname2);
}
break;
case ns_t_x25: /* <PSDN-address> */
if(r_len > 0 && *tcp >= r_len) {
rc = *tcp++;
vfields = caml_alloc_string(rc);
memmove(String_val(vfields), tcp, rc);
}
else
vfields = copy_string("");
break;
case ns_t_px:
if(r_len > INT16SZ) {
int pref;
char rname1[MAXDNAME];
char rname2[MAXDNAME];
NS_GET16(pref, tcp);
rc = dn_expand(response.buf, eom, tcp, rname1, MAXDNAME);
if(rc < 0)
break;
tcp += rc;
rc = dn_expand(response.buf, eom, tcp, rname2, MAXDNAME);
if(rc < 0)
break;
tcp += rc;
vfields = alloc_small(2, 0);
Field(vfields, 0) = copy_string(rname1);
Field(vfields, 1) = copy_string(rname2);
}
break;
case ns_t_gpos:
if(r_len > 0 && *tcp <= r_len) {
float f1, f2, f3;
char *tmp;
rc = *tcp++;
tmp = (char *) malloc(rc + 1);
bcopy(tcp, tmp, rc);
tmp[rc] = '\0';
f1 = atof(tmp);
tcp += rc;
if(tcp < eom && tcp + *tcp <= eom) {
if(*tcp > rc)
tmp = realloc(tmp, *tcp);
rc = *tcp++;
bcopy(tcp, tmp, rc);
tmp[rc] = '\0';
f2 = atof(tmp);
tcp += rc;
}
else
f2 = 0.0;
if(tcp < eom && tcp + *tcp <= eom) {
if(*tcp > rc)
tmp = realloc(tmp, *tcp);
rc = *tcp++;
bcopy(tcp, tmp, rc);
tmp[rc] = '\0';
f3 = atof(tmp);
tcp += rc;
}
else
f3 = 0.0;
free(tmp);
vfields = alloc_small(3, 0);
Field(vfields, 0) = copy_double((double)f1);
Field(vfields, 1) = copy_double((double)f2);
Field(vfields, 2) = copy_double((double)f3);
}
break;
case ns_t_loc:
failwith("LOC not implemented");
/*
if(r_len > 0 && *tcp != 0)
failwith("Invalid version in LOC RDATA");
if(r_len > 0) {
rc = INT
n = INT32SZ + 3*INT32SZ;
if (check_size(rname, type, cp, msg, eor, n) < 0)
break;
c = _getlong(cp);
cp += INT32SZ;
n = _getlong(cp);
doprintf(("\t%s ", pr_spherical(n, "N", "S")));
cp += INT32SZ;
n = _getlong(cp);
doprintf((" %s ", pr_spherical(n, "E", "W")));
cp += INT32SZ;
n = _getlong(cp);
doprintf((" %sm ", pr_vertical(n, "", "-")));
cp += INT32SZ;
doprintf((" %sm", pr_precision((c >> 16) & 0xff)));
doprintf((" %sm", pr_precision((c >> 8) & 0xff)));
doprintf((" %sm", pr_precision((c >> 0) & 0xff)));
break;
*/
/*
case T_UID:
case T_GID:
if(INT32SZ <= r_len)
NS_GET32(rc, cp);
if (dlen == INT32SZ) {
n = _getlong(cp);
doprintf(("\t%s", dtoa(n)));
cp += INT32SZ;
}
break;
case T_UINFO:
doprintf(("\t\"%s\"", stoa(cp, dlen, TRUE)));
cp += dlen;
break;
case T_UNSPEC:
cp += dlen;
break;
case T_AAAA:
if (dlen == IPNGSIZE) {
doprintf(("\t%s", ipng_ntoa(cp)));
cp += IPNGSIZE;
}
break;
case T_SIG:
if (check_size(rname, type, cp, msg, eor, INT16SZ) < 0)
break;
n = _getshort(cp);
if (n >= T_FIRST && n <= T_LAST)
doprintf(("\t%s", pr_type(n)));
else
doprintf(("\t%s", dtoa(n)));
cp += INT16SZ;
if (check_size(rname, type, cp, msg, eor, 1) < 0)
break;
n = *cp++;
doprintf((" %s", dtoa(n)));
if (check_size(rname, type, cp, msg, eor, 1) < 0)
break;
n = *cp++;
doprintf((" %s", dtoa(n)));
n = 3*INT32SZ + INT16SZ;
if (check_size(rname, type, cp, msg, eor, n) < 0)
break;
doprintf((" ("));
n = _getlong(cp);
doprintf(("\n\t\t\t%s", dtoa(n)));
doprintf(("\t\t;original ttl"));
cp += INT32SZ;
n = _getlong(cp);
doprintf(("\n\t\t\t%s", pr_date(n)));
doprintf(("\t;signature expiration"));
cp += INT32SZ;
n = _getlong(cp);
doprintf(("\n\t\t\t%s", pr_date(n)));
doprintf(("\t;signature inception"));
cp += INT32SZ;
n = _getshort(cp);
doprintf(("\n\t\t\t%s", dtoa(n)));
doprintf(("\t\t;key tag"));
cp += INT16SZ;
n = expand_name(rname, type, cp, msg, eom, dname);
if (n < 0)
break;
doprintf(("\n\t\t\t%s", pr_name(dname)));
cp += n;
if (cp < eor) {
register char *buf;
register int size;
n = eor - cp;
buf = base_ntoa(cp, n);
size = strlength(buf);
cp += n;
while ((n = (size > 64) ? 64 : size) > 0) {
doprintf(("\n\t%s", stoa((u_char *)buf, n, FALSE)));
buf += n; size -= n;
}
}
doprintf(("\n\t\t\t)"));
break;
case T_KEY:
if (check_size(rname, type, cp, msg, eor, INT16SZ) < 0)
break;
n = _getshort(cp);
doprintf(("\t0x%s", xtoa(n)));
cp += INT16SZ;
if (check_size(rname, type, cp, msg, eor, 1) < 0)
break;
n = *cp++;
doprintf((" %s", dtoa(n)));
if (check_size(rname, type, cp, msg, eor, 1) < 0)
break;
n = *cp++;
doprintf((" %s", dtoa(n)));
if (cp < eor) {
register char *buf;
register int size;
n = eor - cp;
buf = base_ntoa(cp, n);
size = strlength(buf);
cp += n;
doprintf((" ("));
while ((n = (size > 64) ? 64 : size) > 0) {
doprintf(("\n\t%s", stoa((u_char *)buf, n, FALSE)));
buf += n; size -= n;
}
doprintf(("\n\t\t\t)"));
}
break;
case T_NXT:
n = expand_name(rname, type, cp, msg, eom, dname);
if (n < 0)
break;
doprintf(("\t%s", pr_name(dname)));
cp += n;
n = 0;
while (cp < eor) {
c = *cp++;
do {
if (c & 0200) {
if (n >= T_FIRST && n <= T_LAST)
doprintf((" %s", pr_type(n)));
else
doprintf((" %s", dtoa(n)));
}
c <<= 1;
} while (++n & 07);
}
break;
case T_NAPTR:
if (check_size(rname, type, cp, msg, eor, INT16SZ) < 0)
break;
n = _getshort(cp);
doprintf(("\t%s", dtoa(n)));
cp += INT16SZ;
if (check_size(rname, type, cp, msg, eor, INT16SZ) < 0)
break;
n = _getshort(cp);
doprintf((" %s", dtoa(n)));
cp += INT16SZ;
if (check_size(rname, type, cp, msg, eor, 1) < 0)
break;
n = *cp++;
doprintf((" \"%s\"", stoa(cp, n, TRUE)));
cp += n;
if (check_size(rname, type, cp, msg, eor, 1) < 0)
break;
n = *cp++;
doprintf((" \"%s\"", stoa(cp, n, TRUE)));
cp += n;
if (check_size(rname, type, cp, msg, eor, 1) < 0)
break;
n = *cp++;
doprintf((" \"%s\"", stoa(cp, n, TRUE)));
cp += n;
n = expand_name(rname, type, cp, msg, eom, dname);
if (n < 0)
break;
doprintf((" %s", pr_name(dname)));
cp += n;
break;
case T_KX:
if (check_size(rname, type, cp, msg, eor, INT16SZ) < 0)
break;
n = _getshort(cp);
doprintf(("\t%s", dtoa(n)));
cp += INT16SZ;
n = expand_name(rname, type, cp, msg, eom, dname);
if (n < 0)
break;
doprintf((" %s", pr_name(dname)));
cp += n;
break;
case T_CERT:
if (check_size(rname, type, cp, msg, eor, INT16SZ) < 0)
break;
n = _getshort(cp);
doprintf(("\t%s", dtoa(n)));
cp += INT16SZ;
if (check_size(rname, type, cp, msg, eor, INT16SZ) < 0)
break;
n = _getshort(cp);
doprintf((" %s", dtoa(n)));
cp += INT16SZ;
if (check_size(rname, type, cp, msg, eor, 1) < 0)
break;
n = *cp++;
doprintf((" %s", dtoa(n)));
if (cp < eor) {
register char *buf;
register int size;
n = eor - cp;
buf = base_ntoa(cp, n);
size = strlength(buf);
cp += n;
doprintf((" ("));
while ((n = (size > 64) ? 64 : size) > 0) {
doprintf(("\n\t%s", stoa((u_char *)buf, n, FALSE)));
buf += n; size -= n;
}
doprintf(("\n\t\t\t)"));
}
break;
case T_EID:
failwith("EID not implemented");
break;
case T_NIMLOC:
failwith("NIMLOC not implemented");
break;
case T_ATMA:
failwith("ATMA not implemented");
*/
default:
failwith("unknown RDATA type");
}
if(vfields != Val_unit) {
value vrecord, vrdata, newcons;
Begin_root(vres);
vrecord = alloc_small(5, 0);
Field(vrecord, 0) = copy_string(r_name);
Field(vrecord, 1) = c_to_mlvariant(rr_type, r_type);
Field(vrecord, 2) = c_to_mlvariant(rr_class, r_class);
Field(vrecord, 3) = Val_int(r_ttl);
vrdata = alloc_small(2, 0);
Field(vrdata, 0) = c_to_mlvariant(rr_type, r_type);
Field(vrdata, 1) = vfields;
Field(vrecord, 4) = vrdata;
newcons = alloc_small(2, 0);
Field(newcons, 0) = vrecord;
Field(newcons, 1) = vres;
vres = newcons;
End_roots();
vrdata = Val_unit;
}
cp += r_len;
}
return vres;
}
void raise_run_recovery() {
raise_constant(*caml_db_run_recovery_exn);
}
void raise_key_exists() {
raise_constant(*caml_key_exists_exn);
}
value spoc_getCudaDevice(value i)
{
CAMLparam1(i);
CAMLlocal4(general_info, cuda_info, specific_info, gc_info);
CAMLlocal3(device, maxT, maxG);
int nb_devices;
CUdevprop dev_infos;
CUdevice dev;
CUcontext ctx;
CUstream queue[2];
spoc_cu_context *spoc_ctx;
//CUcontext gl_ctx;
char infoStr[1024];
int infoInt;
size_t infoUInt;
int major, minor;
enum cudaError_enum cuda_error;
cuDeviceGetCount (&nb_devices);
if ((Int_val(i)) > nb_devices)
raise_constant(*caml_named_value("no_cuda_device")) ;
CUDA_CHECK_CALL(cuDeviceGet(&dev, Int_val(i)));
CUDA_CHECK_CALL(cuDeviceGetProperties(&dev_infos, dev));
general_info = caml_alloc (9, 0);
CUDA_CHECK_CALL(cuDeviceGetName(infoStr, sizeof(infoStr), dev));
Store_field(general_info,0, copy_string(infoStr));//
CUDA_CHECK_CALL(cuDeviceTotalMem(&infoUInt, dev));
Store_field(general_info,1, Val_int(infoUInt));//
Store_field(general_info,2, Val_int(dev_infos.sharedMemPerBlock));//
Store_field(general_info,3, Val_int(dev_infos.clockRate));//
Store_field(general_info,4, Val_int(dev_infos.totalConstantMemory));//
CUDA_CHECK_CALL(cuDeviceGetAttribute(&infoInt, CU_DEVICE_ATTRIBUTE_MULTIPROCESSOR_COUNT, dev));
Store_field(general_info,5, Val_int(infoInt));//
CUDA_CHECK_CALL(cuDeviceGetAttribute(&infoInt, CU_DEVICE_ATTRIBUTE_ECC_ENABLED, dev));
Store_field(general_info,6, Val_bool(infoInt));//
Store_field(general_info,7, i);
CUDA_CHECK_CALL(cuCtxCreate (&ctx,
CU_CTX_SCHED_BLOCKING_SYNC | CU_CTX_MAP_HOST,
dev));
spoc_ctx = malloc(sizeof(spoc_cl_context));
spoc_ctx->ctx = ctx;
CUDA_CHECK_CALL(cuStreamCreate(&queue[0], 0));
CUDA_CHECK_CALL(cuStreamCreate(&queue[1], 0));
spoc_ctx->queue[0] = queue[0];
spoc_ctx->queue[1] = queue[1];
Store_field(general_info,8, (value)spoc_ctx);
CUDA_CHECK_CALL(cuCtxSetCurrent(ctx));
cuda_info = caml_alloc(1, 0); //0 -> Cuda
specific_info = caml_alloc(18, 0);
cuDeviceComputeCapability(&major, &minor, dev);
Store_field(specific_info,0, Val_int(major));//
Store_field(specific_info,1, Val_int(minor));//
Store_field(specific_info,2, Val_int(dev_infos.regsPerBlock));//
Store_field(specific_info,3, Val_int(dev_infos.SIMDWidth));//
Store_field(specific_info,4, Val_int(dev_infos.memPitch));//
Store_field(specific_info,5, Val_int(dev_infos.maxThreadsPerBlock));//
maxT = caml_alloc(3, 0);
Store_field(maxT,0, Val_int(dev_infos.maxThreadsDim[0]));//
Store_field(maxT,1, Val_int(dev_infos.maxThreadsDim[1]));//
Store_field(maxT,2, Val_int(dev_infos.maxThreadsDim[2]));//
Store_field(specific_info,6, maxT);
maxG = caml_alloc(3, 0);
Store_field(maxG,0, Val_int(dev_infos.maxGridSize[0]));//
Store_field(maxG,1, Val_int(dev_infos.maxGridSize[1]));//
Store_field(maxG,2, Val_int(dev_infos.maxGridSize[2]));//
Store_field(specific_info,7, maxG);
Store_field(specific_info,8, Val_int(dev_infos.textureAlign));//
cuDeviceGetAttribute(&infoInt, CU_DEVICE_ATTRIBUTE_GPU_OVERLAP, dev);
Store_field(specific_info,9, Val_bool(infoInt));//
cuDeviceGetAttribute(&infoInt, CU_DEVICE_ATTRIBUTE_KERNEL_EXEC_TIMEOUT, dev);
Store_field(specific_info,10, Val_bool(infoInt));//
cuDeviceGetAttribute(&infoInt, CU_DEVICE_ATTRIBUTE_INTEGRATED, dev);
Store_field(specific_info,11, Val_bool(infoInt));//
cuDeviceGetAttribute(&infoInt, CU_DEVICE_ATTRIBUTE_CAN_MAP_HOST_MEMORY, dev);
Store_field(specific_info,12, Val_bool(infoInt));//
cuDeviceGetAttribute(&infoInt, CU_DEVICE_ATTRIBUTE_COMPUTE_MODE, dev);
Store_field(specific_info,13, Val_int(infoInt));//
cuDeviceGetAttribute(&infoInt, CU_DEVICE_ATTRIBUTE_CONCURRENT_KERNELS, dev);
Store_field(specific_info,14, Val_bool(infoInt));//
cuDeviceGetAttribute(&infoInt, CU_DEVICE_ATTRIBUTE_PCI_BUS_ID, dev);
Store_field(specific_info,15, Val_int(infoInt));
cuDeviceGetAttribute(&infoInt, CU_DEVICE_ATTRIBUTE_PCI_DEVICE_ID, dev);
Store_field(specific_info,16, Val_int(infoInt));
cuDriverGetVersion(&infoInt);
Store_field(specific_info, 17, Val_int(infoInt));
Store_field(cuda_info, 0, specific_info);
device = caml_alloc(4, 0);
Store_field(device, 0, general_info);
Store_field(device, 1, cuda_info);
{spoc_cuda_gc_info* gcInfo = (spoc_cuda_gc_info*)malloc(sizeof(spoc_cuda_gc_info));
CUDA_CHECK_CALL(cuMemGetInfo(&infoUInt, NULL));
infoUInt -= (32*1024*1024);
Store_field(device, 2, (value)gcInfo);
{cuda_event_list* events = NULL;
Store_field(device, 3, (value)events);
CAMLreturn(device);}}
}
