3
# - needed since we allow bad pixel handling to be switched off
9
use File::Basename qw(&basename &dirname);
11
# check for bad value support
12
use vars qw( $bvalflag $usenan );
13
require "badsupport.p";
15
# are we big or little endian?
16
require PDL::Core::Dev;
17
my $isbigendian = PDL::Core::Dev::isbigendian();
19
# This forces PL files to create target in same directory as PL file.
20
# This is so that make depend always knows where to find PL derivatives.
23
($file = basename($0)) =~ s/\.PL$//;
25
if ($Config{'osname'} eq 'VMS' or
26
$Config{'osname'} eq 'OS2'); # "case-forgiving"
29
print "Extracting $file (WITH bad value support)\n";
31
print "Extracting $file (NO bad value support)\n";
33
open OUT,">$file" or die "Can't create $file: $!";
36
print OUT <<"!WITH!SUBS!";
40
- automatically generated by Core.xs.PL
41
- bad value support = $bvalflag
45
print OUT <<'!NO!SUBS!';
54
#include "EXTERN.h" /* std perl include */
55
#include "perl.h" /* std perl include */
56
#include "XSUB.h" /* XSUB include */
62
#define PDL_CORE /* For certain ifdefs */
63
#include "pdl.h" /* Data structure declarations */
64
#include "pdlcore.h" /* Core declarations */
69
print OUT "#include <float.h>\n" unless $usenan;
70
print OUT "#include <limits.h>\n";
72
# set up the NaN value, if necessary
73
# based on the GNU version of /usr/include/bits/nan.h
74
# - need to work out whether we're big/little endian here
78
"static union { unsigned char __c[4]; float __d; } __pdl_nan = { ";
80
print OUT "{ 0x7f, 0xc0, 0, 0 } };\n\n";
82
print OUT "{ 0, 0, 0xc0, 0x7f } };\n\n";
87
print OUT <<'!NO!SUBS!';
89
/* Return a integer or numeric scalar as approroate */
91
#define setflag(reg,flagval,val) (val?(reg |= flagval):(reg &= ~flagval))
93
#define SET_RETVAL_NV(x) x->datatype<PDL_F ? (RETVAL=newSViv( (IV)result )) : (RETVAL=newSVnv( result ))
95
Core PDL; /* Struct holding pointers to shared C routines */
98
Core *pdl__Core_get_Core() /* INTERNAL TO CORE! DON'T CALL FROM OUTSIDE */
106
#define CHECKP(p) if ((p) == NULL) croak("Out of memory")
108
static int* pdl_packint( SV* sv, int *ndims ) {
115
if (!(SvROK(sv) && SvTYPE(SvRV(sv))==SVt_PVAV)) /* Test */
117
array = (AV *) SvRV(sv); /* dereference */
118
*ndims = (int) av_len(array) + 1; /* Number of dimensions */
120
dims = (int *) pdl_malloc( (*ndims) * sizeof(*dims) );
123
for(i=0; i<(*ndims); i++) {
124
bar = *(av_fetch( array, i, 0 )); /* Fetch */
125
dims[i] = (int) SvIV(bar);
130
static SV* pdl_unpackint ( PDL_Long *dims, int ndims ) {
137
for(i=0; i<ndims; i++) /* if ndims == 0, nothing stored -> ok */
138
av_store( array, i, newSViv( (IV)dims[i] ) );
146
print OUT <<'!NO!SUBS!';
148
#ifdef FOOFOO_PROPOGATE_BADFLAG
151
* this seems to cause an infinite loop in between tests 42 & 43 of
154
* $a = sequence( byte, 2, 3 );
155
* $b = $a->slice("(1),:");
156
* my $mask = sequence( byte, 2, 3 );
157
* $mask = $mask->setbadif( ($mask % 3) == 2 );
158
* print "a,b == ", $a->badflag, ",", $b->badflag, "\n";
159
* $a->inplace->copybad( $mask ); <-- think this is the call
160
* print "a,b == ", $a->badflag, ",", $b->badflag, "\n";
162
* ok( $b->badflag, 1 );
166
/* used by propogate_badflag() */
168
void propogate_badflag_children( pdl *it, int newval ) {
169
PDL_DECL_CHILDLOOP(it)
170
PDL_START_CHILDLOOP(it)
172
pdl_trans *trans = PDL_CHILDLOOP_THISCHILD(it);
175
for( i = trans->vtable->nparents;
176
i < trans->vtable->npdls;
179
pdl *child = trans->pdls[i];
181
if ( newval ) child->state |= PDL_BADVAL;
182
else child->state &= ~PDL_BADVAL;
184
/* make sure we propogate to grandchildren, etc */
185
propogate_badflag_children( child, newval );
189
PDL_END_CHILDLOOP(it)
190
} /* propogate_badflag_children */
192
/* used by propogate_badflag() */
194
void propogate_badflag_parents( pdl *it ) {
195
PDL_DECL_CHILDLOOP(it)
196
PDL_START_CHILDLOOP(it)
198
pdl_trans *trans = PDL_CHILDLOOP_THISCHILD(it);
202
i < trans->vtable->nparents;
205
pdl *parent = trans->pdls[i];
207
/* only sets allowed here */
208
parent->state |= PDL_BADVAL;
210
/* make sure we propogate to grandparents, etc */
211
propogate_badflag_parents( parent );
215
PDL_END_CHILDLOOP(it)
216
} /* propogate_badflag_parents */
219
* we want to change the bad flag of the children
220
* (newval = 1 means set flag, 0 means clear it).
221
* If newval == 1, then we also loop through the
222
* parents, setting their bad flag
224
* thanks to Christian Soeller for this
227
void propogate_badflag( pdl *it, int newval ) {
228
/* only do anything if the flag has changed - do we need this check ? */
230
if ( (it->state & PDL_BADVAL) == 0 ) {
231
propogate_badflag_parents( it );
232
propogate_badflag_children( it, newval );
235
if ( (it->state & PDL_BADVAL) > 0 ) {
236
propogate_badflag_children( it, newval );
241
} /* propogate_badflag */
243
#else /* FOOFOO_PROPOGATE_BADFLAG */
245
/* newval = 1 means set flag, 0 means clear it */
246
/* thanks to Christian Soeller for this */
248
void propogate_badflag( pdl *it, int newval ) {
249
PDL_DECL_CHILDLOOP(it)
250
PDL_START_CHILDLOOP(it)
252
pdl_trans *trans = PDL_CHILDLOOP_THISCHILD(it);
255
for( i = trans->vtable->nparents;
256
i < trans->vtable->npdls; i++ ) {
258
pdl *child = trans->pdls[i];
260
if ( newval ) child->state |= PDL_BADVAL;
261
else child->state &= ~PDL_BADVAL;
263
/* make sure we propogate to grandchildren, etc */
264
propogate_badflag( child, newval );
268
PDL_END_CHILDLOOP(it)
269
} /* propogate_badflag */
271
#endif /* FOOFOO_PROPOGATE_BADFLAG */
274
/* this is horrible - the routines from bad should perhaps be here instead ? */
275
double pdl_get_badvalue( int datatype ) {
277
switch ( datatype ) {
278
case 0: retval = PDL.bvals.Byte; break;
279
case 1: retval = PDL.bvals.Short; break;
280
case 2: retval = PDL.bvals.Ushort; break;
281
case 3: retval = PDL.bvals.Long; break;
282
case 4: retval = PDL.bvals.Float; break;
283
case 5: retval = PDL.bvals.Double; break;
286
croak("Unknown type sent to pdl_get_badvalue\n");
289
} /* pdl_get_badvalue() */
295
print OUT <<'!NO!SUBS!';
297
MODULE = PDL::Core PACKAGE = PDL
300
# Destroy a PDL - note if a hash do nothing, the $$x{PDL} component
301
# will be destroyed anyway on a separate call
308
if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVHV)
312
PDLDEBUG_f(printf("DESTROYING %d\n",self);)
317
# Return the transformation object or an undef otherwise.
323
ST(0) = sv_newmortal();
325
sv_setref_pv(ST(0), "PDL::Trans", (void*)(self->trans));
327
ST(0) = &PL_sv_undef;
330
# This will change in the future, as can be seen from the name ;)
331
# the argument passing is a real quick hack: you can pass 3 integers
334
MODULE = PDL::Core PACKAGE = PDL::Trans
336
call_trans_foomethod(trans,i1,i2,i3)
342
PDL_TR_CHKMAGIC(trans);
343
pdl_trans_changesoon(trans,PDL_PARENTDIMSCHANGED|PDL_PARENTDATACHANGED);
344
if(trans->vtable->foomethod == NULL) {
345
croak("This transformation doesn't have a foomethod!");
347
(trans->vtable->foomethod)(trans,i1,i2,i3);
348
pdl_trans_changed(trans,PDL_PARENTDIMSCHANGED|PDL_PARENTDATACHANGED);
350
MODULE = PDL::Core PACKAGE = PDL
357
pdl_make_physvaffine( x );
360
printf("vaff check...\n");
361
for (i=0;i<x->ndims;i++) {
362
if (PDL_REPRINC(x,i) != inc) {
374
# access (read, if set is true then write as well)
380
hdrcpy => { set => 1 },
381
fflows => { FLAG => "DATAFLOW_F" },
382
bflows => { FLAG => "DATAFLOW_B" },
383
is_inplace => { FLAG => "INPLACE" },
384
donttouch => { FLAG => "DONTTOUCHDATA" },
386
vaffine => { FLAG => "OPT_VAFFTRANSOK" },
387
anychgd => { FLAG => "ANYCHANGED" },
388
dimschgd => { FLAG => "PARENTDIMSCHANGED" },
392
#if ( $bvalflag ) { $flags{baddata} = { set => 1, FLAG => "BADVAL" }; }
394
foreach my $name ( keys %flags ) {
395
my $flag = "PDL_" . ($flags{$name}{FLAG} || uc($name));
396
if ( $flags{$name}{set} ) {
397
print OUT <<"!WITH!SUBS!";
404
{ setflag(x->state,$flag,mode); }
405
RETVAL = ((x->state & $flag) > 0);
412
print OUT <<"!WITH!SUBS!";
417
RETVAL = ((self->state & $flag) > 0);
425
} # foreach: keys %flags
427
print OUT <<'!NO!SUBS!';
430
set_inplace(self,val)
434
setflag(self->state,PDL_INPLACE,val);
453
pdl_make_physvaffine(src);
454
pdl_destroytransform(src->trans,1);
461
set_data_by_mmap(it,fname,len,writable,shared,creat,mode,trunc)
474
fd = open(fname,(writable && shared ? O_RDWR : O_RDONLY)|
475
(creat ? O_CREAT : 0),mode);
477
croak("Error opening file");
480
ftruncate(fd,0); /* Clear all previous data */
481
ftruncate(fd,len); /* And make it long enough */
484
it->data = mmap(0,len,PROT_READ | (writable ?
486
(shared ? MAP_SHARED : MAP_PRIVATE),
489
croak("Error mmapping!");
491
/* Special case: zero-length file */
494
PDLDEBUG_f(printf("PDL::MMap: mapped to %d\n",it->data);)
495
it->state |= PDL_DONTTOUCHDATA | PDL_ALLOCATED;
496
pdl_add_deletedata_magic(it, pdl_delete_mmapped_data, len);
499
croak("mmap not supported on this architecture");
507
set_data_by_offset(it,orig,offset)
513
it->data = ((char *) orig->data) + offset;
514
it->state |= PDL_DONTTOUCHDATA | PDL_ALLOCATED;
523
pdl_make_physdims(x);
528
# Convert PDL to new datatype (called by float(), int() etc.)
531
# convert(a,datatype)
536
# pdl_make_physical(a);
537
# RETVAL = pdl_copy(a,""); /* Init value to return */
538
# b = SvPDLV(RETVAL); /* Map */
539
# pdl_converttype( &b, datatype, PDL_PERM );
540
# PDLDEBUG_f(printf("converted %d, %d, %d, %d\n",a, b, a->datatype, b->datatype));
546
# Call my howbig function
552
RETVAL = pdl_howbig(datatype);
556
MODULE = PDL::Core PACKAGE = PDL::Core
562
RETVAL = pdl_debugging;
577
/* get the first element of a piddle and return as
578
* Perl double scalar (NV)
580
pdl_make_physvaffine( it );
582
croak("piddle must have at least one element");
583
/* offs = PDL_REPROFFS(it); */
584
/* result = pdl_get_offs(PDL_REPRP(it),offs); */
585
result=pdl_at(PDL_REPRP(it), it->datatype, &nullp, &dummyd,
586
&dummyi, PDL_REPROFFS(it),1);
596
PDL_Long * pos = NO_INIT
601
pdl_make_physvaffine( x );
603
pos = pdl_packdims( ST(1), &npos);
605
if (pos == NULL || npos < x->ndims)
606
croak("Invalid position");
608
/* allow additional trailing indices
609
* which must be all zero, i.e. a
610
* [3,1,5] piddle is treated as an [3,1,5,1,1,1,....]
611
* infinite dim piddle
613
for (ipos=x->ndims; ipos<npos; ipos++)
615
croak("Invalid position");
617
result=pdl_at(PDL_REPRP(x), x->datatype, pos, x->dims,
618
(PDL_VAFFOK(x) ? x->vafftrans->incs : x->dimincs), PDL_REPROFFS(x),
630
PDL_Long *inds,*incs,offs;
634
pdl_make_physvaffine( x );
635
inds = pdl_malloc(sizeof(PDL_Long) * x->ndims); /* GCC -> on stack :( */
638
incs = (PDL_VAFFOK(x) ? x->vafftrans->incs : x->dimincs);
639
offs = PDL_REPROFFS(x);
641
for(ind=0; ind < x->ndims; ind++) inds[ind] = 0;
643
PUSHs(sv_2mortal(newSVnv(pdl_at( data, x->datatype,
644
inds, x->dims, incs, offs, x->ndims))));
646
for(ind = 0; ind < x->ndims; ind++)
647
if(++(inds[ind]) >= x->dims[ind])
653
# returns the string 'BAD' if an element is bad
660
PDL_Long *inds,*incs,offs;
670
# the badvalue is stored in a double, but that's what pdl_at()
676
double pdl_val, pdl_badval;
677
int badflag = (x->state & PDL_BADVAL) > 0;
681
# do we have to bother about NaN's?
685
if ( badflag && x->datatype < 4 ) {
686
pdl_badval = pdl_get_badvalue( x->datatype );
693
pdl_badval = pdl_get_badvalue( x->datatype );
700
print OUT <<'!NO!SUBS!';
702
pdl_make_physvaffine( x );
703
inds = pdl_malloc(sizeof(PDL_Long) * x->ndims); /* GCC -> on stack :( */
705
incs = (PDL_VAFFOK(x) ? x->vafftrans->incs : x->dimincs);
706
offs = PDL_REPROFFS(x);
708
av_extend(av,x->nvals);
710
for(ind=0; ind < x->ndims; ind++) inds[ind] = 0;
719
$condition = '( (x->datatype < 4 && pdl_val == pdl_badval) ||
720
(x->datatype >= 4 && finite(pdl_val) == 0) )';
722
$condition = 'pdl_val == pdl_badval';
725
print OUT <<"!WITH!SUBS!";
726
pdl_val = pdl_at( data, x->datatype, inds, x->dims, incs, offs, x->ndims );
727
if ( badflag && $condition ) {
728
sv = newSVpvn( "BAD", 3 );
730
sv = newSVnv( pdl_val );
732
av_store( av, lind, sv );
737
print OUT <<'!NO!SUBS!';
739
newSVnv( pdl_at( data, x->datatype,
740
inds, x->dims, incs, offs, x->ndims ) )
746
print OUT <<'!NO!SUBS!';
750
for(ind = 0; ind < x->ndims; ind++) {
751
if(++(inds[ind]) >= x->dims[ind]) {
758
RETVAL = newRV_noinc((SV *)av);
763
set_c(x,position,value)
765
PDL_Long * pos = NO_INIT
770
pdl_make_physvaffine( x );
772
pos = pdl_packdims( ST(1), &npos);
773
if (pos == NULL || npos < x->ndims)
774
croak("Invalid position");
776
/* allow additional trailing indices
777
* which must be all zero, i.e. a
778
* [3,1,5] piddle is treated as an [3,1,5,1,1,1,....]
779
* infinite dim piddle
781
for (ipos=x->ndims; ipos<npos; ipos++)
783
croak("Invalid position");
785
pdl_children_changesoon( x , PDL_PARENTDATACHANGED );
786
pdl_set(PDL_REPRP(x), x->datatype, pos, x->dims,
787
(PDL_VAFFOK(x) ? x->vafftrans->incs : x->dimincs), PDL_REPROFFS(x),
790
pdl_vaffinechanged(x, PDL_PARENTDATACHANGED);
792
pdl_changed( x , PDL_PARENTDATACHANGED , 0 );
796
/* Initialise structure of pointers to core C routines */
798
PDL.Version = PDL_CORE_VERSION;
800
PDL.SetSV_PDL = SetSV_PDL;
801
PDL.create = pdl_create;
802
PDL.pdlnew = pdl_external_new;
803
PDL.tmp = pdl_external_tmp;
804
PDL.destroy = pdl_destroy;
807
PDL.converttype = pdl_converttype;
809
PDL.smalloc = pdl_malloc;
810
PDL.howbig = pdl_howbig;
811
PDL.packdims = pdl_packdims;
812
PDL.unpackdims = pdl_unpackdims;
813
PDL.setdims = pdl_setdims;
815
PDL.flushcache = NULL;
816
PDL.reallocdims = pdl_reallocdims;
817
PDL.reallocthreadids = pdl_reallocthreadids;
818
PDL.resize_defaultincs = pdl_resize_defaultincs;
819
PDL.get_threadoffsp = pdl_get_threadoffsp;
820
PDL.thread_copy = pdl_thread_copy;
821
PDL.clearthreadstruct = pdl_clearthreadstruct;
822
PDL.initthreadstruct = pdl_initthreadstruct;
823
PDL.startthreadloop = pdl_startthreadloop;
824
PDL.iterthreadloop = pdl_iterthreadloop;
825
PDL.freethreadloop = pdl_freethreadloop;
826
PDL.thread_create_parameter = pdl_thread_create_parameter;
827
PDL.add_deletedata_magic = pdl_add_deletedata_magic;
829
PDL.setdims_careful = pdl_setdims_careful;
830
PDL.put_offs = pdl_put_offs;
831
PDL.get_offs = pdl_get_offs;
833
PDL.set_trans_childtrans = pdl_set_trans_childtrans;
834
PDL.set_trans_parenttrans = pdl_set_trans_parenttrans;
835
PDL.make_now = pdl_make_now;
837
PDL.get_convertedpdl = pdl_get_convertedpdl;
839
PDL.make_trans_mutual = pdl_make_trans_mutual;
840
PDL.trans_mallocfreeproc = pdl_trans_mallocfreeproc;
841
PDL.make_physical = pdl_make_physical;
842
PDL.make_physdims = pdl_make_physdims;
843
PDL.make_physvaffine = pdl_make_physvaffine;
844
PDL.pdl_barf = pdl_barf;
845
PDL.allocdata = pdl_allocdata;
846
PDL.safe_indterm = pdl_safe_indterm;
851
print OUT <<'!NO!SUBS!';
853
PDL.propogate_badflag = propogate_badflag;
855
PDL.bvals.Byte = PDL.bvals.default_Byte = UCHAR_MAX;
856
PDL.bvals.Short = PDL.bvals.default_Short = SHRT_MIN;
857
PDL.bvals.Ushort = PDL.bvals.default_Ushort = USHRT_MAX;
858
PDL.bvals.Long = PDL.bvals.default_Long = INT_MIN;
861
# note: no defaults if usenan
865
PDL.bvals.Float = __pdl_nan.__d;
866
PDL.bvals.Double = (double) __pdl_nan.__d;
871
PDL.bvals.Float = PDL.bvals.default_Float = -FLT_MAX;
872
PDL.bvals.Double = PDL.bvals.default_Double = -DBL_MAX;
878
print OUT <<'!NO!SUBS!';
880
"Publish" pointer to this structure in perl variable for use
884
sv_setiv(perl_get_sv("PDL::SHARE",TRUE), (IV) (void*) &PDL);
886
# version of eval() which propogates errors encountered in
887
# any internal eval(). Must be passed a code reference - could
888
# be use perl_eval_sv() but that is still buggy. This subroutine is
889
# primarily for the perlDL shell to use.
891
# Thanks to Sarathy (gsar@engin.umich.edu) for suggesting this, though
892
# it needs to be wrapped up in the stack stuff to avoid certain SEGVs!
900
perl_call_sv(code, G_EVAL|G_KEEPERR|GIMME);
903
MODULE = PDL::Core PACKAGE = PDL
905
# pdl_null is created/imported with no PREFIX as pdl_null.
906
# 'null' is supplied in Core.pm that calls 'initialize' which calls
913
MODULE = PDL::Core PACKAGE = PDL::Core PREFIX = pdl_
916
pdl_pthreads_enabled()
918
MODULE = PDL::Core PACKAGE = PDL PREFIX = pdl_
924
RETVAL= !!(self->state & PDL_NOMYDIMS);
932
pdl_make_physical(self);
938
make_physvaffine(self)
941
pdl_make_physvaffine(self);
951
pdl_make_physdims(self);
961
pdl_add_threading_magic(it,nthdim,nthreads)
967
pdl_remove_threading_magic(it)
970
pdl_add_threading_magic(it,-1,-1);
972
MODULE = PDL::Core PACKAGE = PDL
981
if (SvROK(class)) { /* a reference to a class */
982
bless_stash = SvSTASH(SvRV(class));
983
} else { /* a class name */
984
bless_stash = gv_stashsv(class, 0);
986
ST(0) = sv_newmortal();
987
SetSV_PDL(ST(0),pdl_null()); /* set a null PDL to this SV * */
988
ST(0) = sv_bless(ST(0), bless_stash); /* bless appropriately */
995
if(self->state & PDL_DONTTOUCHDATA) {
996
croak("Trying to get dataref to magical (mmaped?) pdl");
998
pdl_make_physical(self); /* XXX IS THIS MEMLEAK WITHOUT MORTAL? */
999
RETVAL = (newRV(self->datasv));
1007
RETVAL = self->datatype;
1016
if(self->state & PDL_DONTTOUCHDATA) {
1017
croak("Trying to touch dataref of magical (mmaped?) pdl");
1019
self->data = SvPV((SV*)self->datasv,n_a);
1023
set_dataflow_f(self,value)
1028
self->state |= PDL_DATAFLOW_F;
1030
self->state &= ~PDL_DATAFLOW_F;
1033
set_dataflow_b(self,value)
1038
self->state |= PDL_DATAFLOW_B;
1040
self->state &= ~PDL_DATAFLOW_B;
1048
pdl_make_physdims(x);
1060
pdl_make_physdims(x);
1061
if (y < 0) y = x->ndims + y;
1062
if (y < 0) croak("negative dim index too large");
1064
RETVAL = x->dims[y];
1066
RETVAL = 1; /* return size 1 for all other dims */
1074
pdl_make_physdims(x);
1075
RETVAL = x->nthreadids;
1084
RETVAL = x->threadids[y];
1091
PDL_Long *dims = NO_INIT
1095
pdl_children_changesoon(x,PDL_PARENTDIMSCHANGED|PDL_PARENTDATACHANGED);
1096
dims = pdl_packdims(ST(1),&ndims);
1097
pdl_reallocdims(x,ndims);
1098
for(i=0; i<ndims; i++) x->dims[i] = dims[i];
1099
pdl_resize_defaultincs(x);
1100
x->threadids[0] = ndims;
1101
/* make null != dims = [0] */
1102
#ifndef ELIFJELFIJSEJIF
1103
x->state &= ~PDL_NOMYDIMS;
1105
if(ndims == 1 && dims[0] == 0) {
1106
x->state |= PDL_NOMYDIMS;
1108
x->state &= ~PDL_NOMYDIMS;
1111
pdl_changed(x,PDL_PARENTDIMSCHANGED|PDL_PARENTDATACHANGED,0);
1117
pdl_run_delayed_magic();
1126
pdl_add_svmagic(p,c);
1135
if(p->hdrsv == NULL) {
1136
p->hdrsv = (void*) newSViv(0);
1138
if (!SvROK(h) || SvTYPE(SvRV(h)) != SVt_PVHV)
1139
croak("Not a HASH reference");
1140
p->hdrsv = (void*) newRV( (SV*) SvRV(h) );
1146
pdl_make_physdims(p);
1148
RETVAL = newRV( (SV*) SvRV((SV*)p->hdrsv) );
1156
set_datatype(a,datatype)
1160
pdl_make_physical(a);
1162
pdl_destroytransform(a->trans,1);
1163
/* if(! (a->state && PDL_NOMYDIMS)) { */
1164
pdl_converttype( &a, datatype, PDL_PERM );
1171
int npdls = items - 1;
1173
croak("Usage: threadover_n(pdl[,pdl...],sub)");
1176
pdl **pdls = malloc(sizeof(pdl *) * npdls);
1177
int *realdims = malloc(sizeof(int) * npdls);
1179
SV *code = ST(items-1);
1180
for(i=0; i<npdls; i++) {
1181
pdls[i] = SvPDLV(ST(i));
1183
pdl_make_physical(pdls[i]);
1186
pdl_initthreadstruct(0,pdls,realdims,realdims,npdls,NULL,&pdl_thr,NULL);
1187
pdl_startthreadloop(&pdl_thr,NULL,NULL);
1193
PUSHs(sv_2mortal(newSViv((sd-1))));
1194
for(i=0; i<npdls; i++) {
1195
PUSHs(sv_2mortal(newSVnv(
1196
pdl_get_offs(pdls[i],pdl_thr.offs[i]))));
1199
perl_call_sv(code,G_DISCARD);
1200
} while(sd = pdl_iterthreadloop(&pdl_thr,0));
1201
pdl_freethreadloop(&pdl_thr);
1211
int npdls, nothers = -1;
1212
int targs = items - 4;
1213
if (items > 0) nothers = SvIV(ST(0));
1214
if(targs <= 0 || nothers < 0 || nothers >= targs)
1215
croak("Usage: threadover(nothers,pdl[,pdl...][,otherpars..],realdims,creating,sub)");
1216
npdls = targs-nothers;
1218
int i,j,nd1,nd2,dtype=0,nc=npdls;
1219
SV* rdimslist = ST(items-3);
1220
SV* cdimslist = ST(items-2);
1221
SV *code = ST(items-1);
1223
pdl **pdls = malloc(sizeof(pdl *) * npdls);
1224
pdl **child = malloc(sizeof(pdl *) * npdls);
1225
SV **csv = malloc(sizeof(SV *) * npdls);
1226
SV **dims = malloc(sizeof(SV *) * npdls);
1227
SV **incs = malloc(sizeof(SV *) * npdls);
1228
SV **others = malloc(sizeof(SV *) * nothers);
1229
int *creating = pdl_packint(cdimslist,&nd2);
1230
int *realdims = pdl_packint(rdimslist,&nd1);
1231
CHECKP(pdls); CHECKP(child); CHECKP(dims);
1232
CHECKP(incs); CHECKP(csv);
1234
if (nd1 != npdls || nd2 < npdls)
1235
croak("threadover: need one realdim and creating flag "
1237
for(i=0; i<npdls; i++) {
1238
pdls[i] = SvPDLV(ST(i+1));
1242
pdl_make_physical(pdls[i]); /* is this what we want?XXX */
1243
dtype = PDLMAX(dtype,pdls[i]->datatype);
1246
for (i=npdls+1; i<=targs; i++)
1247
others[i-npdls-1] = ST(i);
1249
croak("Not enough dimension info to create pdls");
1250
#ifdef DEBUG_PTHREAD
1251
for (i=0;i<npdls;i++) { /* just for debugging purposes */
1252
printf("pdl %d Dims: [",i);
1253
for (j=0;j<realdims[i];j++)
1254
printf("%d ",pdls[i]->dims[j]);
1255
printf("] Incs: [");
1256
for (j=0;j<realdims[i];j++)
1257
printf("%d ",PDL_REPRINC(pdls[i],j));
1261
pdl_initthreadstruct(0,pdls,realdims,creating,npdls,
1262
NULL,&pdl_thr,NULL);
1263
for(i=0, nc=npdls; i<npdls; i++) /* create as necessary */
1265
int *cp = creating+nc;
1266
pdls[i]->datatype = dtype;
1267
pdl_thread_create_parameter(&pdl_thr,i,cp,0);
1269
pdl_make_physical(pdls[i]);
1270
PDLDEBUG_f(pdl_dump(pdls[i]));
1271
/* And make it nonnull, now that we've created it */
1272
pdls[i]->state &= (~PDL_NOMYDIMS);
1274
pdl_startthreadloop(&pdl_thr,NULL,NULL);
1275
for(i=0; i<npdls; i++) { /* will the SV*'s be properly freed? */
1276
dims[i] = newRV(pdl_unpackint(pdls[i]->dims,realdims[i]));
1277
incs[i] = newRV(pdl_unpackint(PDL_VAFFOK(pdls[i]) ?
1278
pdls[i]->vafftrans->incs: pdls[i]->dimincs,realdims[i]));
1279
/* need to make sure we get the vaffine (grand)parent */
1280
if (PDL_VAFFOK(pdls[i]))
1281
pdls[i] = pdls[i]->vafftrans->from;
1282
child[i]=pdl_null();
1283
/* instead of pdls[i] its vaffine parent !!!XXX */
1284
PDL.affine_new(pdls[i],child[i],pdl_thr.offs[i],dims[i],
1286
pdl_make_physical(child[i]); /* make sure we can get at
1288
csv[i] = sv_newmortal();
1289
SetSV_PDL(csv[i], child[i]); /* pdl* into SV* */
1291
do { /* the actual threadloop */
1292
pdl_trans_affine *traff;
1296
for(i=0; i<npdls; i++) {
1297
/* just twiddle the offset - quick and dirty */
1298
/* we must twiddle both !! */
1299
traff = (pdl_trans_affine *) child[i]->trans;
1300
traff->offs = pdl_thr.offs[i];
1301
child[i]->vafftrans->offs = pdl_thr.offs[i];
1302
child[i]->state |= PDL_PARENTDATACHANGED;
1305
for (i=0; i<nothers; i++)
1306
PUSHs(others[i]); /* pass the OtherArgs onto the stack */
1308
perl_call_sv(code,G_DISCARD);
1309
} while (pdl_iterthreadloop(&pdl_thr,0));
1310
pdl_freethreadloop(&pdl_thr);
1311
free(pdls); /* should all these be done with pdl_malloc */
1312
free(dims); /* in case the sub barfs ? XXXX */
added
removed
Basic/Core/Core.xs.PL
