int jl_array_isdefined(jl_value_t **args0, int nargs)
{
assert(jl_is_array(args0[0]));
jl_array_t *a = (jl_array_t*)args0[0];
jl_value_t **args = &args0[1];
size_t nidxs = nargs-1;
size_t i=0;
size_t k, stride=1;
size_t nd = jl_array_ndims(a);
for(k=0; k < nidxs; k++) {
if (!jl_is_long(args[k]))
jl_type_error("isdefined", (jl_value_t*)jl_long_type, args[k]);
size_t ii = jl_unbox_long(args[k])-1;
i += ii * stride;
size_t d = k>=nd ? 1 : jl_array_dim(a, k);
if (k < nidxs-1 && ii >= d)
return 0;
stride *= d;
}
for(; k < nd; k++)
stride *= jl_array_dim(a, k);
if (i >= stride)
return 0;
if (a->ptrarray)
return ((jl_value_t**)jl_array_data(a))[i] != NULL;
return 1;
}
JL_DLLEXPORT size_t jl_array_len_(jl_array_t *a)
{
size_t l = 1;
for(size_t i=0; i < jl_array_ndims(a); i++)
l *= jl_array_dim(a, i);
return l;
}
static size_t array_nbytes(jl_array_t *a)
{
if (jl_array_ndims(a)==1)
return a->elsize * a->maxsize;
else
return a->elsize * jl_array_len(a);
}
JL_DLLEXPORT jl_value_t *jl_array_to_string(jl_array_t *a)
{
size_t len = jl_array_len(a);
if (a->flags.how == 3 && a->offset == 0 && a->elsize == 1 &&
(jl_array_ndims(a) != 1 ||
((a->maxsize + sizeof(void*) + 1 <= GC_MAX_SZCLASS) == (len + sizeof(void*) + 1 <= GC_MAX_SZCLASS)))) {
jl_value_t *o = jl_array_data_owner(a);
if (jl_is_string(o)) {
a->flags.isshared = 1;
*(size_t*)o = len;
a->nrows = 0;
#ifdef STORE_ARRAY_LEN
a->length = 0;
#endif
a->maxsize = 0;
return o;
}
}
a->nrows = 0;
#ifdef STORE_ARRAY_LEN
a->length = 0;
#endif
a->maxsize = 0;
return jl_pchar_to_string((const char*)jl_array_data(a), len);
}
JL_DLLEXPORT jl_array_t *jl_array_copy(jl_array_t *ary)
{
size_t elsz = ary->elsize;
jl_array_t *new_ary = _new_array_(jl_typeof(ary), jl_array_ndims(ary),
&ary->nrows, !ary->flags.ptrarray, elsz);
memcpy(new_ary->data, ary->data, jl_array_len(ary) * elsz);
return new_ary;
}
static size_t array_nd_index(jl_array_t *a, jl_value_t **args, size_t nidxs,
const char *fname)
{
size_t i=0;
size_t k, stride=1;
size_t nd = jl_array_ndims(a);
for(k=0; k < nidxs; k++) {
if (!jl_is_long(args[k]))
jl_type_error(fname, (jl_value_t*)jl_long_type, args[k]);
size_t ii = jl_unbox_long(args[k])-1;
i += ii * stride;
size_t d = k>=nd ? 1 : jl_array_dim(a, k);
if (k < nidxs-1 && ii >= d)
jl_bounds_error_v((jl_value_t*)a, args, nidxs);
stride *= d;
}
for(; k < nd; k++)
stride *= jl_array_dim(a, k);
if (i >= stride)
jl_bounds_error_v((jl_value_t*)a, args, nidxs);
return i;
}
int jl_array_isdefined(jl_value_t **args0, int nargs)
{
assert(jl_is_array(args0[0]));
jl_value_t **depwarn_args;
JL_GC_PUSHARGS(depwarn_args, 3);
depwarn_args[0] = jl_get_global(jl_base_module, jl_symbol("depwarn"));
depwarn_args[1] = jl_cstr_to_string("isdefined(a::Array, i::Int) is deprecated, use isassigned(a, i) instead");
depwarn_args[2] = (jl_value_t*) jl_symbol("isdefined");
jl_apply(depwarn_args, 3);
JL_GC_POP();
jl_array_t *a = (jl_array_t*)args0[0];
jl_value_t **args = &args0[1];
size_t nidxs = nargs-1;
size_t i=0;
size_t k, stride=1;
size_t nd = jl_array_ndims(a);
for(k=0; k < nidxs; k++) {
if (!jl_is_long(args[k]))
jl_type_error("isdefined", (jl_value_t*)jl_long_type, args[k]);
size_t ii = jl_unbox_long(args[k])-1;
i += ii * stride;
size_t d = k>=nd ? 1 : jl_array_dim(a, k);
if (k < nidxs-1 && ii >= d)
return 0;
stride *= d;
}
for(; k < nd; k++)
stride *= jl_array_dim(a, k);
if (i >= stride)
return 0;
if (a->flags.ptrarray)
return ((jl_value_t**)jl_array_data(a))[i] != NULL;
return 1;
}
JL_DLLEXPORT int jl_array_rank(jl_value_t *a)
{
return jl_array_ndims(a);
}
size_t td_jl_get_ndims(void *v)
{
if (jl_is_array(v))
return jl_array_ndims(v);
return 0;
}
static SEXP Julia_R_MD_NA(jl_value_t *Var)
{
SEXP ans = R_NilValue;
char *strData = "Varname0tmp.data";
char *strNA = "bitunpack(Varname0tmp.na)";
jl_set_global(jl_main_module, jl_symbol("Varname0tmp"), (jl_value_t *)Var);
jl_value_t *retData = jl_eval_string(strData);
jl_value_t *retNA = jl_eval_string(strNA);
jl_value_t *val;
if (((jl_array_t *)retData)->ptrarray)
val = jl_cellref(retData, 0);
else
val = jl_arrayref((jl_array_t *)retData, 0);
int len = jl_array_len(retData);
if (len == 0)
return ans;
int ndims = jl_array_ndims(retData);
SEXP dims;
PROTECT(dims = allocVector(INTSXP, ndims));
for (size_t i = 0; i < ndims; i++)
INTEGER(dims)[i] = jl_array_dim(retData, i);
UNPROTECT(1);
//bool array
char *pNA = (char *) jl_array_data(retNA);
if (jl_is_bool(val))
{
char *p = (char *) jl_array_data(retData);
PROTECT(ans = allocArray(LGLSXP, dims));
for (size_t i = 0; i < len; i++)
if (pNA[i])
LOGICAL(ans)[i] = NA_LOGICAL;
else
LOGICAL(ans)[i] = p[i];
UNPROTECT(1);
}
else if (jl_is_int32(val))
{
int32_t *p = (int32_t *) jl_array_data(retData);
jlint_to_r_na;
}
//int64
else if (jl_is_int64(val))
{
int64_t *p = (int64_t *) jl_array_data(retData);
jlbiggerint_to_r_na;
}
//more integer type
else if (jl_is_int8(val))
{
int8_t *p = (int8_t *) jl_array_data(retData);
jlint_to_r_na;
}
else if (jl_is_int16(val))
{
int16_t *p = (int16_t *) jl_array_data(retData);
jlint_to_r_na;
}
else if (jl_is_uint8(val))
{
uint8_t *p = (uint8_t *) jl_array_data(retData);
jlint_to_r_na;
}
else if (jl_is_uint16(val))
{
uint16_t *p = (uint16_t *) jl_array_data(retData);
jlint_to_r_na;
}
else if (jl_is_uint32(val))
{
uint32_t *p = (uint32_t *) jl_array_data(retData);
jlbiggerint_to_r_na;
}
else if (jl_is_uint64(val))
{
uint64_t *p = (uint64_t *) jl_array_data(retData);
jlbiggerint_to_r_na;
}
//double
else if (jl_is_float64(val))
{
double *p = (double *) jl_array_data(retData);
jlfloat_to_r_na;
}
else if (jl_is_float32(val))
{
float *p = (float *) jl_array_data(retData);
jlfloat_to_r_na;
}
//convert string array to STRSXP
else if (jl_is_utf8_string(val))
{
PROTECT(ans = allocArray(STRSXP, dims));
for (size_t i = 0; i < len; i++)
if (pNA[i])
SET_STRING_ELT(ans, i, NA_STRING);
else
SET_STRING_ELT(ans, i, mkCharCE(jl_string_data(jl_cellref(retData, i)), CE_UTF8));
UNPROTECT(1);
}
else if (jl_is_ascii_string(val))
{
PROTECT(ans = allocArray(STRSXP, dims));
for (size_t i = 0; i < len; i++)
if (pNA[i])
SET_STRING_ELT(ans, i, NA_STRING);
else
SET_STRING_ELT(ans, i, mkChar(jl_string_data(jl_cellref(retData, i))));
UNPROTECT(1);
}
return ans;
}
static SEXP Julia_R_MD(jl_value_t *Var)
{
SEXP ans = R_NilValue;
jl_value_t *val;
if (((jl_array_t *)Var)->ptrarray)
val = jl_cellref(Var, 0);
else
val = jl_arrayref((jl_array_t *)Var, 0);
//get Julia dims and set R array Dims
int len = jl_array_len(Var);
if (len == 0)
return ans;
int ndims = jl_array_ndims(Var);
SEXP dims;
PROTECT(dims = allocVector(INTSXP, ndims));
for (size_t i = 0; i < ndims; i++)
{
INTEGER(dims)[i] = jl_array_dim(Var, i);
}
UNPROTECT(1);
if (jl_is_bool(val))
{
char *p = (char *) jl_array_data(Var);
PROTECT(ans = allocArray(LGLSXP, dims));
for (size_t i = 0; i < len; i++)
LOGICAL(ans)[i] = p[i];
UNPROTECT(1);
}
else if (jl_is_int32(val))
{
int32_t *p = (int32_t *) jl_array_data(Var);
jlint_to_r;
}
//int64
else if (jl_is_int64(val))
{
int64_t *p = (int64_t *) jl_array_data(Var);
jlbiggerint_to_r;
}
//more integer type
else if (jl_is_int8(val))
{
int8_t *p = (int8_t *) jl_array_data(Var);
jlint_to_r;
}
else if (jl_is_int16(val))
{
int16_t *p = (int16_t *) jl_array_data(Var);
jlint_to_r;
}
else if (jl_is_uint8(val))
{
uint8_t *p = (uint8_t *) jl_array_data(Var);
jlint_to_r;
}
else if (jl_is_uint16(val))
{
uint16_t *p = (uint16_t *) jl_array_data(Var);
jlint_to_r;
}
else if (jl_is_uint32(val))
{
uint32_t *p = (uint32_t *) jl_array_data(Var);
jlbiggerint_to_r;
}
else if (jl_is_uint64(val))
{
uint64_t *p = (uint64_t *) jl_array_data(Var);
jlbiggerint_to_r;
}
//double
else if (jl_is_float64(val))
{
double *p = (double *) jl_array_data(Var);
jlfloat_to_r;
}
else if (jl_is_float32(val))
{
float *p = (float *) jl_array_data(Var);
jlfloat_to_r;
}
//convert string array to STRSXP ,but not sure it is corret?
else if (jl_is_utf8_string(val))
{
PROTECT(ans = allocArray(STRSXP, dims));
for (size_t i = 0; i < len; i++)
SET_STRING_ELT(ans, i, mkCharCE(jl_string_data(jl_cellref(Var, i)), CE_UTF8));
UNPROTECT(1);
}
else if (jl_is_ascii_string(val))
{
PROTECT(ans = allocArray(STRSXP, dims));
for (size_t i = 0; i < len; i++)
SET_STRING_ELT(ans, i, mkChar(jl_string_data(jl_cellref(Var, i))));
UNPROTECT(1);
}
return ans;
}
static void gc_markval_(jl_value_t *v)
{
assert(v != NULL);
//assert(v != lookforme);
if (gc_marked_obj(v)) return;
jl_value_t *vt = (jl_value_t*)jl_typeof(v);
#ifdef OBJPROFILE
void **bp = ptrhash_bp(&obj_counts, vt);
if (*bp == HT_NOTFOUND)
*bp = (void*)2;
else
(*((ptrint_t*)bp))++;
#endif
jl_value_t *vtt = gc_typeof(vt);
gc_setmark_obj(v);
if (vtt==(jl_value_t*)jl_bits_kind) return;
// some values have special representations
if (vt == (jl_value_t*)jl_tuple_type) {
size_t i;
for(i=0; i < ((jl_tuple_t*)v)->length; i++) {
jl_value_t *elt = ((jl_tuple_t*)v)->data[i];
if (elt != NULL)
GC_Markval(elt);
}
}
else if (((jl_struct_type_t*)(vt))->name == jl_array_typename) {
jl_array_t *a = (jl_array_t*)v;
int ndims = jl_array_ndims(a);
int ndimwords = (ndims > 2 ? (ndims-2) : 0);
#ifndef __LP64__
// on 32-bit, ndimwords must be odd to preserve 8-byte alignment
ndimwords += (~ndimwords)&1;
#endif
void *data_area = &a->_space[0] + ndimwords*sizeof(size_t);
if (a->reshaped) {
GC_Markval(*((jl_value_t**)data_area));
}
else if (a->data) {
char *data = a->data;
if (ndims == 1) data -= a->offset*a->elsize;
if (data != data_area) {
gc_setmark(data);
}
}
jl_value_t *elty = jl_tparam0(vt);
if (gc_typeof(elty) != (jl_value_t*)jl_bits_kind) {
size_t i;
for(i=0; i < a->length; i++) {
jl_value_t *elt = ((jl_value_t**)a->data)[i];
if (elt != NULL) GC_Markval(elt);
}
}
}
else if (vt == (jl_value_t*)jl_module_type) {
gc_mark_module((jl_module_t*)v);
}
else if (vt == (jl_value_t*)jl_task_type) {
jl_task_t *ta = (jl_task_t*)v;
GC_Markval(ta->on_exit);
GC_Markval(ta->tls);
if (ta->start)
GC_Markval(ta->start);
if (ta->result)
GC_Markval(ta->result);
GC_Markval(ta->state.eh_task);
if (ta->stkbuf != NULL)
gc_setmark(ta->stkbuf);
#ifdef COPY_STACKS
ptrint_t offset;
if (ta == jl_current_task) {
offset = 0;
gc_mark_stack(jl_pgcstack, offset);
}
else {
offset = ta->stkbuf - (ta->stackbase-ta->ssize);
gc_mark_stack(ta->state.gcstack, offset);
}
jl_savestate_t *ss = &ta->state;
while (ss != NULL) {
GC_Markval(ss->ostream_obj);
ss = ss->prev;
if (ss != NULL)
ss = (jl_savestate_t*)((char*)ss + offset);
}
#else
gc_mark_stack(ta->state.gcstack, 0);
jl_savestate_t *ss = &ta->state;
while (ss != NULL) {
GC_Markval(ss->ostream_obj);
ss = ss->prev;
}
#endif
}
else if (vt == (jl_value_t*)jl_weakref_type) {
// don't mark contents
}
else {
assert(vtt == (jl_value_t*)jl_struct_kind);
size_t nf = ((jl_struct_type_t*)vt)->names->length;
size_t i=0;
if (vt == (jl_value_t*)jl_struct_kind ||
vt == (jl_value_t*)jl_function_type) {
i++; // skip fptr field
}
for(; i < nf; i++) {
jl_value_t *fld = ((jl_value_t**)v)[i+1];
if (fld)
GC_Markval(fld);
}
}
}
static void gc_mark_all()
{
while (mark_sp > 0) {
jl_value_t *v = mark_stack[--mark_sp];
jl_value_t *vt = (jl_value_t*)gc_typeof(v);
// some values have special representations
if (vt == (jl_value_t*)jl_tuple_type) {
size_t l = jl_tuple_len(v);
jl_value_t **data = ((jl_tuple_t*)v)->data;
for(size_t i=0; i < l; i++) {
jl_value_t *elt = data[i];
if (elt != NULL)
gc_push_root(elt);
}
}
else if (((jl_datatype_t*)(vt))->name == jl_array_typename) {
jl_array_t *a = (jl_array_t*)v;
char *data = a->data;
if (data == NULL) continue;
int ndims = jl_array_ndims(a);
char *data0 = data;
if (ndims == 1) data0 -= a->offset*a->elsize;
if (!a->isinline) {
jl_value_t *owner = jl_array_data_owner(a);
if (a->ismalloc) {
// jl_mallocptr_t
if (gc_marked(owner))
continue;
gc_setmark(owner);
}
else {
// an array
v = owner;
if (v != (jl_value_t*)a) {
gc_push_root(v);
continue;
}
}
}
if (a->ptrarray) {
size_t l = jl_array_len(a);
for(size_t i=0; i < l; i++) {
jl_value_t *elt = ((jl_value_t**)data)[i];
if (elt != NULL) gc_push_root(elt);
}
}
}
else if (vt == (jl_value_t*)jl_module_type) {
gc_mark_module((jl_module_t*)v);
}
else if (vt == (jl_value_t*)jl_task_type) {
jl_task_t *ta = (jl_task_t*)v;
if (ta->on_exit) gc_push_root(ta->on_exit);
gc_push_root(ta->last);
gc_push_root(ta->tls);
gc_push_root(ta->consumers);
if (ta->start) gc_push_root(ta->start);
if (ta->result) gc_push_root(ta->result);
if (ta->stkbuf != NULL || ta == jl_current_task) {
if (ta->stkbuf != NULL)
gc_setmark_buf(ta->stkbuf);
#ifdef COPY_STACKS
ptrint_t offset;
if (ta == jl_current_task) {
offset = 0;
gc_mark_stack(jl_pgcstack, offset);
}
else {
offset = (char *)ta->stkbuf - ((char *)ta->stackbase - ta->ssize);
gc_mark_stack(ta->gcstack, offset);
}
#else
gc_mark_stack(ta->gcstack, 0);
#endif
}
}
else {
jl_datatype_t *dt = (jl_datatype_t*)vt;
int nf = (int)jl_tuple_len(dt->names);
for(int i=0; i < nf; i++) {
if (dt->fields[i].isptr) {
jl_value_t *fld = *(jl_value_t**)((char*)v + dt->fields[i].offset + sizeof(void*));
if (fld)
gc_push_root(fld);
}
}
}
}
}
// adapted from https://github.com/armgong/RJulia/blob/master/src/R_Julia.c
SEXP jr_array(jl_value_t *tt)
{
SEXP ans = R_NilValue;
//get Julia dims and set R array Dims
int len = jl_array_len(tt);
if (len == 0)
return ans;
jl_datatype_t *ty = jl_array_eltype(tt);
int ndims = jl_array_ndims(tt);
SEXP dims;
PROTECT(dims = Rf_allocVector(INTSXP, ndims));
for (size_t i = 0; i < ndims; i++)
INTEGER(dims)[i] = jl_array_dim(tt, i);
UNPROTECT(1);
// again, float64, int32 and int64 are most common
if (ty == jl_float64_type)
{
double *p = (double *) jl_array_data(tt);
PROTECT(ans = Rf_allocArray(REALSXP, dims));
for (size_t i = 0; i < len; i++) REAL(ans)[i] = p[i];
UNPROTECT(1);;
}
else if (ty == jl_int32_type)
{
int32_t *p = (int32_t *) jl_array_data(tt);
PROTECT(ans = Rf_allocArray(INTSXP, dims));
for (size_t i = 0; i < len; i++) INTEGER(ans)[i] = p[i];
UNPROTECT(1);
}
else if (ty == jl_int64_type)
{
int is_int32 = 1;
int64_t *p = (int64_t *) jl_array_data(tt);
for (size_t i=0;i<len;i++)
{
if (p[i]>INT32_MAX || p[i]<INT32_MIN)
{
is_int32 = 0;
break;
}
}
if (is_int32)
{
PROTECT(ans = Rf_allocArray(INTSXP, dims));
for (size_t i = 0; i < len; i++) INTEGER(ans)[i] = p[i];
UNPROTECT(1);
}
else
{
PROTECT(ans = Rf_allocArray(REALSXP, dims));
for (size_t i = 0; i < len; i++) REAL(ans)[i] = p[i];
UNPROTECT(1);
}
}
else if (ty == jl_bool_type)
{
bool *p = (bool *) jl_array_data(tt);
PROTECT(ans = Rf_allocArray(LGLSXP, dims));
for (size_t i = 0; i < len; i++)
LOGICAL(ans)[i] = p[i];
UNPROTECT(1);
}
else if (ty == jl_int8_type)
{
int8_t *p = (int8_t *) jl_array_data(tt);
PROTECT(ans = Rf_allocArray(INTSXP, dims));
for (size_t i = 0; i < len; i++) INTEGER(ans)[i] = p[i];
UNPROTECT(1);
}
else if (ty == jl_uint8_type)
{
uint8_t *p = (uint8_t *) jl_array_data(tt);
PROTECT(ans = Rf_allocArray(INTSXP, dims));
for (size_t i = 0; i < len; i++) INTEGER(ans)[i] = p[i];
UNPROTECT(1);
}
else if (ty == jl_int16_type)
{
int16_t *p = (int16_t *) jl_array_data(tt);
PROTECT(ans = Rf_allocArray(INTSXP, dims));
for (size_t i = 0; i < len; i++) INTEGER(ans)[i] = p[i];
UNPROTECT(1);
}
else if (ty == jl_uint16_type)
{
uint16_t *p = (uint16_t *) jl_array_data(tt);
PROTECT(ans = Rf_allocArray(INTSXP, dims));
for (size_t i = 0; i < len; i++) INTEGER(ans)[i] = p[i];
UNPROTECT(1);
}
else if (ty == jl_uint32_type)
{
int is_int32 = 1;
uint32_t *p = (uint32_t *) jl_array_data(tt);
for (size_t i=0;i<len;i++)
{
if (p[i]>INT32_MAX || p[i]<INT32_MIN)
{
is_int32 = 0;
break;
}
}
if (is_int32)
{
PROTECT(ans = Rf_allocArray(INTSXP, dims));
for (size_t i = 0; i < len; i++) INTEGER(ans)[i] = p[i];
UNPROTECT(1);
}
else
{
PROTECT(ans = Rf_allocArray(REALSXP, dims));
for (size_t i = 0; i < len; i++) REAL(ans)[i] = p[i];
UNPROTECT(1);
}
}
else if (ty == jl_uint64_type)
{
int is_int32 = 1;
uint64_t *p = (uint64_t *) jl_array_data(tt);
for (size_t i=0;i<len;i++)
{
if (p[i]>INT32_MAX || p[i]<INT32_MIN)
{
is_int32 = 0;
break;
}
}
if (is_int32)
{
PROTECT(ans = Rf_allocArray(INTSXP, dims));
for (size_t i = 0; i < len; i++) INTEGER(ans)[i] = p[i];
UNPROTECT(1);
}
else
{
PROTECT(ans = Rf_allocArray(REALSXP, dims));
for (size_t i = 0; i < len; i++) REAL(ans)[i] = p[i];
UNPROTECT(1);
}
}
//double
else if (ty == jl_float32_type)
{
float *p = (float *) jl_array_data(tt);
PROTECT(ans = Rf_allocArray(REALSXP, dims));
for (size_t i = 0; i < len; i++) REAL(ans)[i] = p[i];
UNPROTECT(1);;
}
//utf8 string
else if (ty == jl_utf8_string_type)
{
PROTECT(ans = Rf_allocArray(STRSXP, dims));
for (size_t i = 0; i < len; i++)
SET_STRING_ELT(ans, i, Rf_mkCharCE(jl_string_data(jl_cellref(tt, i)), CE_UTF8));
UNPROTECT(1);
}
else if (ty == jl_ascii_string_type)
{
PROTECT(ans = Rf_allocArray(STRSXP, dims));
for (size_t i = 0; i < len; i++)
SET_STRING_ELT(ans, i, Rf_mkChar(jl_string_data(jl_cellref(tt, i))));
UNPROTECT(1);
}
return ans;
}
