view release on metacpan or  search on metacpan

lib/PDL/Core.xs  view on Meta::CPAN

  SV *self
  CODE:
    pdl *p = pdl_SvPDLV(self);
    if (!p) barf("Failed to get PDL from arg");
    p->state |= PDL_DATAFLOW_F;
    SvREFCNT_inc(RETVAL = self);
  OUTPUT:
    RETVAL

SV *
topdl(klass, arg1, ...)
  SV *klass;
  SV *arg1;
  CODE:
    if (items > 2 ||
      (!SvROK(arg1) && SvTYPE(arg1) < SVt_PVAV) ||
      (SvROK(arg1) && SvTYPE(SvRV(arg1)) == SVt_PVAV)
    ) {
      PUSHMARK(SP - items); /* this passes current set of args on */
      int retvals = perl_call_method("new", G_SCALAR);
      SPAGAIN;
      if (retvals != 1) barf("new returned no values");
      RETVAL = POPs;
    } else if (SvROK(arg1) && SvOBJECT(SvRV(arg1))) {
      RETVAL = arg1;
    } else {
      barf("Can not convert a %s to a %s", sv_reftype(arg1, 1), SvPV_nolen(klass));
    }
    SvREFCNT_inc(RETVAL);
  OUTPUT:
    RETVAL

int
has_vafftrans(self)
	pdl *self;
	CODE:
	RETVAL = !!self->vafftrans;
	OUTPUT:
	RETVAL

int
has_badvalue(self)
	pdl *self;
	CODE:
	RETVAL = !!self->has_badvalue;
	OUTPUT:
	RETVAL

# Return the transformation object or an undef otherwise.
pdl_trans *
trans_parent(self)
	pdl *self;
	CODE:
	RETVAL = self->trans_parent;
	OUTPUT:
	RETVAL

void
trans_children(self)
  pdl *self
  PPCODE:
    U8 gimme = GIMME_V;
    if (gimme == G_SCALAR)
      mXPUSHu(self->ntrans_children);
    else if (gimme == G_ARRAY) {
      EXTEND(SP, self->ntrans_children);
      PDL_Indx i;
      for (i = 0; i < self->ntrans_children_allocated; i++) {
        pdl_trans *t = self->trans_children[i];
        if (!t) continue;
        SV *sv = sv_newmortal();
        sv_setref_pv(sv, "PDL::Trans", (void*)t);
        PUSHs(sv);
      }
    }

INCLUDE_COMMAND: $^X -e "require q{./Core/Dev.pm}; PDL::Core::Dev::generate_core_flags()"

IV
address(self)
  pdl *self;
  CODE:
    RETVAL = PTR2IV(self);
  OUTPUT:
    RETVAL

IV
address_data(self)
  pdl *self;
CODE:
  RETVAL = PTR2IV(self->data);
OUTPUT:
  RETVAL

IV
address_datasv(p)
  pdl *p
CODE:
  RETVAL = PTR2IV(p->datasv);
OUTPUT:
  RETVAL

PDL_Indx
nelem_nophys(x)
  pdl *x
  CODE:
    RETVAL = x->nvals;
  OUTPUT:
    RETVAL

# only returns list, not context-aware
void
dimincs_nophys(x)
  pdl *x
  PPCODE:
    EXTEND(SP, x->ndims);
    PDL_Indx i;
    for(i=0; i<x->ndims; i++) mPUSHi(PDL_REPRINC(x,i));

# only returns list, not context-aware
void
dims_nophys(x)
  pdl *x
  PPCODE:
    EXTEND(SP, x->ndims);
    PDL_Indx i;
    for(i=0; i<x->ndims; i++) mPUSHi(x->dims[i]);

# only returns list, not context-aware
void
broadcastids_nophys(x)
  pdl *x
  PPCODE:
    EXTEND(SP, x->nbroadcastids);
    PDL_Indx i;
    for(i=0; i<x->nbroadcastids; i++) mPUSHi(x->broadcastids[i]);

void
firstvals_nophys(x)
  pdl *x
  PPCODE:
    if (!(x->state & PDL_ALLOCATED)) barf("firstvals_nophys called on non-ALLOCATED %p", x);
    PDL_Indx i, maxvals = PDLMIN(10, x->nvals);
    EXTEND(SP, maxvals);
    for(i=0; i<maxvals; i++) {
      PDL_Anyval anyval = { PDL_INVALID, {0} };
      ANYVAL_FROM_CTYPE_OFFSET(anyval, x->datatype, PDL_REPRP(x), PDL_REPROFFS(x)+i);
      if (anyval.type < 0) barf("Error getting value, type=%d", anyval.type);
      SV *sv = sv_newmortal();
      ANYVAL_TO_SV(sv, anyval);
      PUSHs(sv);
      PUTBACK;
    }

IV
vaffine_from(self)
  pdl *self;
  CODE:
    if (!self->vafftrans) barf("vaffine_from called on %p with NULL vafftrans", self);
    RETVAL = PTR2IV(self->vafftrans->from);
  OUTPUT:
    RETVAL

void
flags(x)
  pdl *x
  PPCODE:
    PDL_FLAG_DUMP(PDL_LIST_FLAGS_PDLSTATE, x->state)

int
set_donttouchdata(it,size=-1)
      pdl *it
      IV size
      CODE:
            it->state |= PDL_DONTTOUCHDATA | PDL_ALLOCATED;
            if (size >= 0) it->nbytes = size;
            RETVAL = 1;
      OUTPUT:
            RETVAL

IV
nbytes(self)
  pdl *self;
  CODE:
    RETVAL = self->nbytes;
  OUTPUT:
    RETVAL

IV
datasv_refcount(p)
  pdl *p
  CODE:
    if (!p->datasv) barf("NULL datasv");
    RETVAL = SvREFCNT((SV*)p->datasv);
  OUTPUT:
    RETVAL

PDL_Indx
nelem(x)
  pdl *x
 CODE:
  pdl_barf_if_error(pdl_make_physvaffine( x ));
  PDLDEBUG_f(printf("Core::nelem calling ")); pdl_barf_if_error(pdl_make_physdims(x));
  RETVAL = x->nvals;
 OUTPUT:
  RETVAL


# Call my howbig function

int
howbig_c(datatype)
   int	datatype
   CODE:
     RETVAL = pdl_howbig(datatype);
   OUTPUT:
     RETVAL


int
set_autopthread_targ(i)
	int i;
	CODE:
	RETVAL = i;
	pdl_autopthread_targ = i;
	OUTPUT:
	RETVAL

int
get_autopthread_targ()
	CODE:
	RETVAL = pdl_autopthread_targ;
	OUTPUT:
	RETVAL


int
set_autopthread_size(i)
	int i;
	CODE:
	RETVAL = i;
	pdl_autopthread_size = i;
	OUTPUT:
	RETVAL

int
get_autopthread_size()
	CODE:
	RETVAL = pdl_autopthread_size;
	OUTPUT:
	RETVAL

int
get_autopthread_actual()
	CODE:
	RETVAL = pdl_autopthread_actual;
	OUTPUT:
	RETVAL

int
get_autopthread_dim()
	CODE:
	RETVAL = pdl_autopthread_dim;
	OUTPUT:
	RETVAL

void
_ci(...)
 PPCODE:
  PDL_XS_SCALAR(PDL_CD, C, 0 + I)

void
_nan(...)
 PPCODE:
  PDL_XS_SCALAR(PDL_D, D, NAN)

void
_inf(...)
 PPCODE:
  PDL_XS_SCALAR(PDL_D, D, INFINITY)

MODULE = PDL::Core     PACKAGE = PDL::Trans

void
parents(trans)
  pdl_trans *trans
  PPCODE:
    TRANS_PDLS(0, vtable->nparents)

void
children(trans)
  pdl_trans *trans
  PPCODE:
    TRANS_PDLS(vtable->nparents, vtable->npdls)

IV
address(self)
  pdl_trans *self;
  CODE:
    RETVAL = PTR2IV(self);
  OUTPUT:
    RETVAL

IV
bvalflag(x)
  pdl_trans *x
  CODE:
    RETVAL = x->bvalflag;
  OUTPUT:
    RETVAL

void
flags(x)
  pdl_trans *x
  PPCODE:
    PDL_FLAG_DUMP(PDL_LIST_FLAGS_PDLTRANS, x->flags)

pdl_transvtable *
vtable(x)
  pdl_trans *x
  CODE:
    if (!x->vtable) barf("%p has NULL vtable", x);
    RETVAL = x->vtable;
  OUTPUT:
    RETVAL

int
affine(x)
  pdl_trans *x
  CODE:
    RETVAL= !!(x->flags & PDL_ITRANS_ISAFFINE);
  OUTPUT:
    RETVAL

IV
offs(self)
  pdl_trans *self;
  CODE:
    RETVAL = PTR2IV(self->offs);
  OUTPUT:
    RETVAL

void
incs(x)
  pdl_trans *x;
  PPCODE:
    if (!(x->flags & PDL_ITRANS_ISAFFINE)) barf("incs called on non-vaffine trans %p", x);
    PDL_Indx i, max = x->incs ? x->pdls[1]->ndims : 0;
    EXTEND(SP, max);
    for(i=0; i<max; i++) mPUSHi(x->incs[i]);

# CORE21 hook up to own data
void
trans_children_indices(x)
  pdl_trans *x;
  PPCODE:
    PDL_Indx i, max = x->vtable->ninds + x->vtable->nparents;
    EXTEND(SP, max);
    for(i=x->vtable->ninds; i<max; i++) mPUSHi(x->ind_sizes[i]);

void
ind_sizes(x)
  pdl_trans *x;
  PPCODE:
    PDL_Indx i, max = x->vtable->ninds;
    EXTEND(SP, max);
    for(i=0; i<max; i++) mPUSHi(x->ind_sizes[i]);

void
inc_sizes(x)
  pdl_trans *x;
PPCODE:
  PDL_Indx i, max = x->vtable->nind_ids; /* CORE21 rename nind_ids */
  EXTEND(SP, max);
  for(i=0; i<max; i++) mPUSHi(x->inc_sizes[i]);

MODULE = PDL::Core     PACKAGE = PDL::Trans::VTable

char *
name(x)
  pdl_transvtable *x;
  CODE:
    RETVAL = x->name;
  OUTPUT:
    RETVAL

void
flags(x)
  pdl_transvtable *x
  PPCODE:
    PDL_FLAG_DUMP(PDL_LIST_FLAGS_PDLVTABLE, x->flags)

void
par_names(x)
  pdl_transvtable *x
  PPCODE:
    EXTEND(SP, 2);
    PDL_Indx i;
    for (i=0; i < 2; i++) {
      AV *av = (AV *)sv_2mortal((SV *)newAV());
      if (!av) barf("Failed to create AV");
      mPUSHs(newRV_inc((SV *)av));
      PDL_Indx start = i==0 ? 0 : x->nparents, j, max = i==0 ? x->nparents : x->npdls;
      av_extend(av, max-start);
      for (j = start; j < max; j++) {
        SV *sv = newSVpv(x->par_names[j], 0);
        if (!sv) barf("Failed to create SV");
        if (!av_store( av, j-start, sv )) {
          SvREFCNT_dec(sv);
          barf("Failed to store SV");
        }
      }
    }

void
dump(x)
  pdl_transvtable *x;
  CODE:
    pdl_dump_transvtable(x, 0);

MODULE = PDL::Core     PACKAGE = PDL::Core

IV
seed()
  CODE:
    RETVAL = pdl_pdl_seed();
  OUTPUT:
    RETVAL

int
online_cpus()
  CODE:
    RETVAL = pdl_online_cpus();
  OUTPUT:
    RETVAL

unsigned int
is_scalar_SvPOK(arg)
	SV* arg;
	CODE:
	RETVAL = SvPOK(arg);
	OUTPUT:
	RETVAL


int
set_debugging(i)
	int i;
	CODE:
	RETVAL = pdl_debugging;
	pdl_debugging = i;
	OUTPUT:
	RETVAL


SV *

lib/PDL/Core.xs  view on Meta::CPAN

  } else if (self->datasv) {
    PDLDEBUG_f(printf("upd_data zap datasv\n"));
    Size_t svsize = SvCUR((SV*)self->datasv);
    if (svsize != self->nbytes)
      croak("Trying to upd_data but datasv now length %zu instead of %td", svsize, self->nbytes);
    memmove(self->data, SvPV_nolen((SV*)self->datasv), self->nbytes);
    SvREFCNT_dec(self->datasv);
    self->datasv = NULL;
  } else {
    PDLDEBUG_f(printf("upd_data datasv gone, maybe reshaped\n"));
  }
  pdl_barf_if_error(pdl_changed(self, PDL_PARENTDATACHANGED, 0));
  PDLDEBUG_f(printf("upd_data end: "); pdl_dump(self));

void
update_data_from(self, sv)
  pdl *self
  SV *sv
CODE:
  PDLDEBUG_f(printf("update_data_from: "); pdl_dump(self));
  pdl_barf_if_error(pdl_make_physvaffine(self));
  Size_t svsize = SvCUR(sv);
  if (svsize != self->nbytes)
    croak("Trying to update_data_from but sv length %zu instead of %td", svsize, self->nbytes);
  memmove(self->data, SvPV_nolen(sv), self->nbytes);
  pdl_barf_if_error(pdl_changed(self, PDL_PARENTDATACHANGED, 0));
  PDLDEBUG_f(printf("update_data_from end: "); pdl_dump(self));

int
badflag(x,newval=0)
    pdl *x
    int newval
  CODE:
    if (items>1) {
      if (x->trans_parent)
        pdl_propagate_badflag_dir(x, newval, 0, 1);
      pdl_propagate_badflag_dir(x, newval, 1, 1);
    }
    RETVAL = ((x->state & PDL_BADVAL) > 0);
  OUTPUT:
    RETVAL

PDL_Indx
getndims(x)
	pdl *x
	ALIAS:
	     PDL::ndims = 1
	CODE:
		(void)ix;
		PDLDEBUG_f(printf("Core::getndims calling ")); pdl_barf_if_error(pdl_make_physdims(x));
		RETVAL = x->ndims;
	OUTPUT:
		RETVAL

void
dims(x)
	pdl *x
	PREINIT:
		PDL_Indx i;
		U8 gimme = GIMME_V;
	PPCODE:
		PDLDEBUG_f(printf("Core::dims calling ")); pdl_barf_if_error(pdl_make_physdims(x));
		if (gimme == G_ARRAY) {
			EXTEND(SP, x->ndims);
			for(i=0; i<x->ndims; i++) mPUSHi(x->dims[i]);
		}
		else if (gimme == G_SCALAR) {
			mXPUSHu(x->ndims);
		}

# only returns list, not context-aware
void
dimincs(x)
  pdl *x
PREINIT:
  PDL_Indx i;
PPCODE:
  pdl_barf_if_error(pdl_make_physvaffine(x));
  EXTEND(SP, x->ndims);
  for (i=0; i<x->ndims; i++) mPUSHi(PDL_REPRINC(x,i));

PDL_Indx
getdim(x,y)
	pdl *x
	PDL_Indx y
	ALIAS:
	     PDL::dim = 1
	CODE:
		(void)ix;
		PDLDEBUG_f(printf("Core::getdim calling ")); pdl_barf_if_error(pdl_make_physdims(x));
		if (y < 0) y += x->ndims;
		if (y < 0) croak("negative dim index too large");
		RETVAL = y < x->ndims ? x->dims[y] : 1; /* all other dims=1 */
	OUTPUT:
		RETVAL

PDL_Indx
getnbroadcastids(x)
	pdl *x
	CODE:
		PDLDEBUG_f(printf("Core::getnbroadcastids calling ")); pdl_barf_if_error(pdl_make_physdims(x));
		RETVAL = x->nbroadcastids;
	OUTPUT:
		RETVAL

void
broadcastids(x)
	pdl *x
	PREINIT:
		PDL_Indx i;
		U8 gimme = GIMME_V;
	PPCODE:
		PDLDEBUG_f(printf("Core::broadcastids calling ")); pdl_barf_if_error(pdl_make_physdims(x));
		if (gimme == G_ARRAY) {
			EXTEND(SP, x->nbroadcastids);
			for(i=0; i<x->nbroadcastids; i++) mPUSHi(x->broadcastids[i]);
		}
		else if (gimme == G_SCALAR) {
			mXPUSHu(x->nbroadcastids);
		}

PDL_Indx
getbroadcastid(x,y)
	pdl *x
	PDL_Indx y
	CODE:
		if (y < 0 || y >= x->nbroadcastids) barf("requested invalid broadcastid %"IND_FLAG", nbroadcastids=%"IND_FLAG, y, x->nbroadcastids);
		RETVAL = x->broadcastids[y];
	OUTPUT:
		RETVAL

void
setdims(x,dims)
	pdl *x
	PDL_Indx dims_count=0;
	PDL_Indx *dims
	CODE:
		pdl_barf_if_error(pdl_setdims(x,dims,dims_count));

void
dowhenidle()
	CODE:
		pdl_run_delayed_magic();
		XSRETURN(0);

void
bind(p,c)
	pdl *p
	SV *c
	PROTOTYPE: $&
	CODE:
		if (!pdl_add_svmagic(p,c)) croak("Failed to add magic");
		XSRETURN(0);

void
sethdr(p,h)
	pdl *p
	SV *h
      PREINIT:
	CODE:
		if(p->hdrsv == NULL) {
		      p->hdrsv =  &PL_sv_undef; /*(void*) newSViv(0);*/
		}

		/* Throw an error if we're not either undef or hash */
                if ( (h != &PL_sv_undef && h != NULL) &&
		     ( !SvROK(h) || SvTYPE(SvRV(h)) != SVt_PVHV )
		   )
		      croak("Not a HASH reference");

		/* Clear the old header */
		SvREFCNT_dec(p->hdrsv);

		/* Put the new header (or undef) in place */
		if(h == &PL_sv_undef || h == NULL)
		   p->hdrsv = NULL;
		else
		   p->hdrsv = (void*) newRV( (SV*) SvRV(h) );

SV *
hdr(p)
	pdl *p
CODE:
  PDLDEBUG_f(printf("Core::hdr calling ")); pdl_barf_if_error(pdl_make_physdims(p));
  /* Make sure that in the undef case we return not */
  /* undef but an empty hash ref. */
  if((p->hdrsv==NULL) || (p->hdrsv == &PL_sv_undef)) {
    p->hdrsv = (void*) newRV_noinc( (SV*)newHV() );
  }
  RETVAL = newRV( (SV*) SvRV((SV*)p->hdrsv) );
OUTPUT:
  RETVAL

SV *
gethdr(p)
  pdl *p
CODE:
  PDLDEBUG_f(printf("Core::gethdr calling ")); pdl_barf_if_error(pdl_make_physdims(p));
  if((p->hdrsv==NULL) || (p->hdrsv == &PL_sv_undef)) {
      RETVAL = &PL_sv_undef;
  } else {
      RETVAL = newRV( (SV*) SvRV((SV*)p->hdrsv) );
  }
OUTPUT:
  RETVAL

SV *
unpdl(x)
  pdl *x
CODE:
  pdl_barf_if_error(pdl_make_physvaffine( x ));
  RETVAL = pdl2avref(x, 0);
OUTPUT:
  RETVAL

void
dog(x, opt=sv_2mortal(newRV_noinc((SV *)newHV())))
  pdl *x
  SV *opt
PPCODE:
  HV *opt_hv = NULL;
  if (!(SvROK(opt) && SvTYPE(opt_hv = (HV*)SvRV(opt)) == SVt_PVHV))
    barf("Usage: $pdl->dog([\\%%opt])");
  PDLDEBUG_f(printf("Core::dog calling ")); pdl_barf_if_error(pdl_make_physdims(x));
  if (x->ndims <= 0) barf("dog: must have at least one dim");
  SV **svp = hv_fetchs(opt_hv, "Break", 0);
  char dobreak = (svp && *svp && SvOK(*svp));
  PDL_Indx *thesedims = x->dims, *theseincs = PDL_REPRINCS(x), ndimsm1 = x->ndims-1;
  PDL_Indx i, howmany = x->dims[ndimsm1], thisoffs = 0, topinc = x->dimincs[ndimsm1];
  EXTEND(SP, howmany);
  pdl_barf_if_error(pdl_prealloc_trans_children(x, x->ntrans_children_allocated + howmany));
  for (i = 0; i < howmany; i++, thisoffs += topinc) {
    pdl *childpdl = pdl_pdlnew();
    if (!childpdl) pdl_pdl_barf("Error making null pdl");
    pdl_barf_if_error(pdl_affine_new(x,childpdl,thisoffs,
      thesedims,ndimsm1,theseincs,ndimsm1));
    SV *childsv = sv_newmortal();
    pdl_SetSV_PDL(childsv, childpdl); /* do before sever so .sv true */
    if (dobreak) pdl_barf_if_error(pdl_sever(childpdl));
    PUSHs(childsv);
  }
  XSRETURN(howmany);

void
broadcastover_n(code, pdl1, ...)
    SV *code;
    pdl *pdl1;
   CODE:
    PDL_Indx npdls = items - 1;
    PDL_Indx i,sd;
    pdl *pdls[npdls];
    PDL_Indx realdims[npdls];
    pdl_broadcast pdl_brc;
    pdls[0] = pdl1;
    for(i=1; i<npdls; i++)
	pdls[i] = pdl_SvPDLV(ST(i+1));
    for(i=0; i<npdls; i++) {
	pdl_barf_if_error(pdl_make_physical(pdls[i]));
	realdims[i] = 0;
    }
    PDL_CLRMAGIC(&pdl_brc);
    pdl_brc.gflags = 0; /* avoid uninitialised value use below */
    pdl_barf_if_error(pdl_initbroadcaststruct(0,pdls,realdims,realdims,npdls,NULL,&pdl_brc,NULL,NULL,NULL, 1));
    pdl_error error_ret = {0, NULL, 0};
    if (pdl_startbroadcastloop(&pdl_brc,NULL,NULL,&error_ret) < 0) croak("Error starting broadcastloop");
    pdl_barf_if_error(error_ret);
    sd = pdl_brc.ndims;
    ENTER; SAVETMPS;
    do {
	dSP;
	PUSHMARK(SP);
	EXTEND(SP,items);
	PUSHs(sv_2mortal(newSViv((sd-1))));
	for(i=0; i<npdls; i++) {
            PDL_Anyval anyval = { PDL_INVALID, {0} };
            ANYVAL_FROM_CTYPE_OFFSET(anyval, pdls[i]->datatype, PDL_REPRP(pdls[i]), pdl_brc.offs[i]);
            if (anyval.type < 0) die("Error getting value from ndarray");
            SV *sv = sv_newmortal();
            ANYVAL_TO_SV(sv, anyval);
            PUSHs(sv);