Skip to content

Commit

Permalink
change EQUIVCPOFFS from own $PP() to generalised phys-forcing $P()
Browse files Browse the repository at this point in the history
  • Loading branch information
mohawk2 committed Mar 3, 2024
1 parent d2f7be6 commit 191d565
Show file tree
Hide file tree
Showing 9 changed files with 27 additions and 54 deletions.
12 changes: 6 additions & 6 deletions Basic/Core/pdlaffine.c
Original file line number Diff line number Diff line change
Expand Up @@ -37,8 +37,8 @@ pp_def(
PDL_DECLARE_PARAMETER_BADVAL(ctype, (trans->vtable->per_pdl_flags[from_id]), from_pdl, (trans->pdls[from_id]), 1) \
PDL_Indx i, poffs=trans->offs, nd; \
for (i=0; i<trans->pdls[to_id]->nvals ; i++) { \
to_pdl_physdatap[i] = (trans->bvalflag && from_pdl_physdatap[poffs] == from_pdl_badval) \
? to_pdl_badval : from_pdl_physdatap[poffs]; \
to_pdl_datap[i] = (trans->bvalflag && from_pdl_datap[poffs] == from_pdl_badval) \
? to_pdl_badval : from_pdl_datap[poffs]; \
for (nd=0; nd<trans->pdls[to_id]->ndims ; nd++) { \
poffs += trans->incs[nd]; \
if ((nd<trans->pdls[to_id]->ndims -1 && \
Expand Down Expand Up @@ -235,9 +235,9 @@ pdl_error pdl_converttypei_redodims(pdl_trans *trans) {
{ \
PDL_Indx i; \
for(i=0; i<trans->pdls[1]->nvals; i++) { \
to_pdl ## _physdatap[i] = trans->bvalflag && from_pdl ## _physdatap[i] == from_pdl ## _badval \
to_pdl ## _datap[i] = trans->bvalflag && from_pdl ## _datap[i] == from_pdl ## _badval \
? to_pdl ## _badval \
: from_pdl ## _physdatap[i]; \
: from_pdl ## _datap[i]; \
; \
} \
}
Expand Down Expand Up @@ -277,8 +277,8 @@ static char pdl_converttypei_vtable_flags[] = {
static PDL_Indx pdl_converttypei_vtable_realdims[] = { 0, 0 };
static char *pdl_converttypei_vtable_parnames[] = { "PARENT","CHILD" };
static short pdl_converttypei_vtable_parflags[] = {
0,
PDL_PARAM_ISCREAT|PDL_PARAM_ISCREATEALWAYS|PDL_PARAM_ISIGNORE|PDL_PARAM_ISOUT|PDL_PARAM_ISWRITE
PDL_PARAM_ISPHYS,
PDL_PARAM_ISCREAT|PDL_PARAM_ISCREATEALWAYS|PDL_PARAM_ISIGNORE|PDL_PARAM_ISOUT|PDL_PARAM_ISPHYS|PDL_PARAM_ISWRITE
};
static pdl_datatypes pdl_converttypei_vtable_partypes[] = { -1, -1 };
static PDL_Indx pdl_converttypei_vtable_realdims_starts[] = { 0, 0 };
Expand Down
2 changes: 0 additions & 2 deletions Basic/Core/pdlcore.h
Original file line number Diff line number Diff line change
Expand Up @@ -188,10 +188,8 @@ typedef struct Core Core;

#define PDL_DECLARE_PARAMETER(type, flag, name, pdlname, nullcheck) \
type *name ## _datap = ((type *)(PDL_REPRP_TRANS(pdlname, flag))); \
type *name ## _physdatap = ((type *)(pdlname->data)); \
if ((nullcheck) && pdlname->nvals > 0 && !name ## _datap) \
return PDL_CORE_(make_error_simple)(PDL_EUSERERROR, "parameter " #name " got NULL data"); \
(void)name ## _physdatap;

#define PDL_DECLARE_PARAMETER_BADVAL(type, flag, name, pdlname, nullcheck) \
PDL_DECLARE_PARAMETER(type, flag, name, pdlname, nullcheck) \
Expand Down
27 changes: 8 additions & 19 deletions Basic/Gen/PP.pm
Original file line number Diff line number Diff line change
Expand Up @@ -375,7 +375,7 @@ sub dosubst_private {
PDLSTATESETGOOD => sub { ($sig->objs->{$_[0]}->do_pdlaccess//confess "Can't get PDLSTATESETGOOD for unknown ndarray '$_[0]'")."->state &= ~PDL_BADVAL" },
PDLSTATEISBAD => sub {badflag_isset(($sig->objs->{$_[0]}//confess "Can't get PDLSTATEISBAD for unknown ndarray '$_[0]'")->do_pdlaccess)},
PDLSTATEISGOOD => sub {"!".badflag_isset(($sig->objs->{$_[0]}//confess "Can't get PDLSTATEISGOOD for unknown ndarray '$_[0]'")->do_pdlaccess)},
PP => sub { ($sig->objs->{$_[0]}//confess "Can't get PP for unknown ndarray '$_[0]'")->do_physpointeraccess },
PP => sub { (my $o = ($sig->objs->{$_[0]}//confess "Can't get PP for unknown ndarray '$_[0]'"))->{FlagPhys} = 1; $o->do_pointeraccess; },
P => sub { (my $o = ($sig->objs->{$_[0]}//confess "Can't get P for unknown ndarray '$_[0]'"))->{FlagPhys} = 1; $o->do_pointeraccess; },
PDL => sub { ($sig->objs->{$_[0]}//confess "Can't get PDL for unknown ndarray '$_[0]'")->do_pdlaccess },
SIZE => sub { ($sig->ind_obj($_[0])//confess "Can't get SIZE of unknown dim '$_[0]'")->get_size },
Expand Down Expand Up @@ -1149,14 +1149,6 @@ $PDL::PP::deftbl =
$SETDELTABROADCASTIDS(0);
$PRIV(dims_redone) = 1;
'),
# NOTE: we use the same bit of code for all-good and bad data -
# see the Code rule
# we can NOT assume that PARENT and CHILD have the same type,
# hence the version for bad code
#
# NOTE: we use the same code for 'good' and 'bad' cases - it's
# just that when we use it for 'bad' data, we have to change the
# definition of the EQUIVCPOFFS macro - see the Code rule
PDL::PP::pp_line_numbers(__LINE__,
'PDL_Indx i;
for(i=0; i<$PDL(CHILD)->nvals; i++) {
Expand Down Expand Up @@ -1419,10 +1411,10 @@ EOD
my ($good) = @_;
$good =~ s/
\$EQUIVCPOFFS\(([^()]+),([^()]+)\)
/do { PDL_IF_BAD(if( \$PPISBAD(PARENT,[$2]) ) { \$PPSETBAD(CHILD,[$1]); } else,) { \$PP(CHILD)[$1] = \$PP(PARENT)[$2]; } } while (0)/gx;
/do { PDL_IF_BAD(if( \$PISBAD(PARENT,[$2]) ) { \$PSETBAD(CHILD,[$1]); } else,) { \$P(CHILD)[$1] = \$P(PARENT)[$2]; } } while (0)/gx;
$good =~ s/
\$EQUIVCPTRUNC\(([^()]+),([^()]+),([^()]+)\)
/do { if( ($3) PDL_IF_BAD(|| \$PPISBAD(PARENT,[$2]),) ) { PDL_IF_BAD(\$PPSETBAD(CHILD,[$1]),\$PP(CHILD)[$1] = 0); } else {\$PP(CHILD)[$1] = \$PP(PARENT)[$2]; } } while (0)/gx;
/do { if( ($3) PDL_IF_BAD(|| \$PISBAD(PARENT,[$2]),) ) { PDL_IF_BAD(\$PSETBAD(CHILD,[$1]),\$P(CHILD)[$1] = 0); } else {\$P(CHILD)[$1] = \$P(PARENT)[$2]; } } while (0)/gx;
$good;
}),

Expand All @@ -1444,16 +1436,13 @@ EOD
# parse 'good' code
$good =~ s/
\$EQUIVCPOFFS\(([^()]+),([^()]+)\)
/do { PDL_IF_BAD(if( \$PPISBAD(CHILD,[$1]) ) { \$PPSETBAD(PARENT,[$2]); } else,) { \$PP(PARENT)[$2] = \$PP(CHILD)[$1]; } } while (0)/gx;
/do { PDL_IF_BAD(if( \$PISBAD(CHILD,[$1]) ) { \$PSETBAD(PARENT,[$2]); } else,) { \$P(PARENT)[$2] = \$P(CHILD)[$1]; } } while (0)/gx;
$good =~ s/
\$EQUIVCPTRUNC\(([^()]+),([^()]+),([^()]+)\)
/do { if(!($3)) { PDL_IF_BAD(if( \$PPISBAD(CHILD,[$1]) ) { \$PPSETBAD(PARENT,[$2]); } else,) { \$PP(PARENT)[$2] = \$PP(CHILD)[$1]; } } } while (0)/gx;
/do { if(!($3)) { PDL_IF_BAD(if( \$PISBAD(CHILD,[$1]) ) { \$PSETBAD(PARENT,[$2]); } else,) { \$P(PARENT)[$2] = \$P(CHILD)[$1]; } } } while (0)/gx;
$good;
}),

PDL::PP::Rule::Returns::Zero->new("CanVaffine", "EquivCPOffsCode"),
PDL::PP::Rule::Returns::One->new("CanVaffine"),

PDL::PP::Rule::Returns::NULL->new("ReadDataFuncName", "AffinePriv"),
PDL::PP::Rule::Returns::NULL->new("WriteBackDataFuncName", "AffinePriv"),

Expand Down Expand Up @@ -1995,18 +1984,18 @@ EOF
PDL::PP::Rule->new("VTableDef",
["VTableName","ParamStructType","RedoDimsFuncName","ReadDataFuncName",
"WriteBackDataFuncName","FreeFuncName",
"SignatureObj","CanVaffine","HaveBroadcasting","NoPthread","Name",
"SignatureObj","HaveBroadcasting","NoPthread","Name",
"GenericTypes","IsAffineFlag","TwoWayFlag","DefaultFlowFlag",
"BadFlag"],
sub {
my($vname,$ptype,$rdname,$rfname,$wfname,$ffname,
$sig,$canvaffine,$havebroadcasting, $noPthreadFlag, $name, $gentypes,
$sig,$havebroadcasting, $noPthreadFlag, $name, $gentypes,
$affflag, $revflag, $flowflag, $badflag) = @_;
my ($pnames, $pobjs) = ($sig->names_sorted, $sig->objs);
my $nparents = 0 + grep !$pobjs->{$_}->{FlagW}, @$pnames;
my $npdls = scalar @$pnames;
my $join_flags = join(", ",
map $canvaffine && !$pobjs->{$pnames->[$_]}->{FlagPhys}
map !$pobjs->{$pnames->[$_]}->{FlagPhys}
? "PDL_TPDL_VAFFINE_OK" : 0, 0..$npdls-1) || '0';
my @op_flags;
push @op_flags, 'PDL_TRANS_DO_BROADCAST' if $havebroadcasting;
Expand Down
6 changes: 3 additions & 3 deletions Basic/Gen/PP/PDLCode.pm
Original file line number Diff line number Diff line change
Expand Up @@ -287,14 +287,14 @@ sub expand {
if($pdl =~ /^T/) {@add = PDL::PP::MacroAccess->new($pdl,$inds,
$this->{Generictypes},$this->{Name});}
elsif(my $c = $access2class{$pdl}) {@add = $c->new($pdl,$inds)}
elsif($pdl =~ /^(PP|)(ISBAD|ISGOOD|SETBAD)(VAR|)$/) {
elsif($pdl =~ /^(P|)(ISBAD|ISGOOD|SETBAD)(VAR|)$/) {
my ($opcode, $name) = ($2);
my $get = $1 || $3;
if (!$get) {
$inds =~ s/^\$?([a-zA-Z_]\w*)\s*//; # $ is optional
$name = $1;
$inds = substr $inds, 1, -1; # chop off brackets
} elsif ($get eq 'PP') {
} elsif ($get eq 'P') {
($name, $inds) = PDL::PP::Rule::Substitute::split_cpp($inds);
} else {
($inds, $name) = PDL::PP::Rule::Substitute::split_cpp($inds);
Expand Down Expand Up @@ -637,7 +637,7 @@ our %ops = (
);
my %getters = (
'' => sub {my ($obj, $inds, $context)=@_; $obj->do_access($inds,$context)},
PP => sub {my ($obj, $inds)=@_; $obj->do_physpointeraccess.$inds},
P => sub {my ($obj, $inds)=@_; $obj->do_pointeraccess.$inds},
VAR => sub {my ($obj, $inds)=@_; $inds},
);

Expand Down
5 changes: 0 additions & 5 deletions Basic/Gen/PP/PdlParObj.pm
Original file line number Diff line number Diff line change
Expand Up @@ -200,11 +200,6 @@ sub do_pointeraccess {
return $this->{Name}."_datap";
}

sub do_physpointeraccess {
my($this) = @_;
return $this->{Name}."_physdatap";
}

sub do_indterm { my($this,$pdl,$ind,$subst,$context) = @_;
my $substname = $this->get_substname($ind);
# See if substitutions
Expand Down
19 changes: 5 additions & 14 deletions Basic/Pod/PP.pod
Original file line number Diff line number Diff line change
Expand Up @@ -1049,7 +1049,7 @@ isn't bad.
To copy the bad value for an ndarray into a c variable, use
C<$SETBADVAR(foo,a)>.

I<TODO:> mention C<$PPISBAD()> etc macros.
I<TODO:> mention C<$PISBAD()> etc macros.

=head2 PDL STATE macros

Expand Down Expand Up @@ -1145,6 +1145,9 @@ The correct way of defining the PDL function is

The C<$P(>I<par>C<)> syntax returns a pointer to the first
element and the other elements are guaranteed to lie after that.
Using it in your C<Code> guarantees it will be "physicalised", so that
all the data is contiguous, because external C functions usually expect
that.

Notice that here it is possible to make many mistakes. First,
C<$SIZE(n)> must be used instead of C<n>. Second, you shouldn't put
Expand Down Expand Up @@ -1244,14 +1247,6 @@ on the type of the transformation):
There is a limitation that the comma-separated values cannot have
parentheses.

=head3 $PP

The C<$PP> macro is used for a so called I<physical pointer access>. The
I<physical> refers to some internal optimisations of PDL (for those who
are familiar with the PDL core we are talking about the vaffine
optimisations). This macro is mainly for internal use and you shouldn't
need to use it in any of your normal code.

=head3 $PPSYM

The C<$PPSYM()> macro is replaced by the value of L<PDL::Types/ppsym> for
Expand Down Expand Up @@ -2558,11 +2553,7 @@ replaced by the C type that is equal to the runtime type of the operation
=head3 $P(a)

a pointer to the data of the PDL named C<a> in the signature. Useful for
interfacing to C functions

=head3 $PP(a)

a physical pointer access to pdl C<a>; mainly for internal use
interfacing to C functions. Causes that PDL to have a C<[phys]> flag.

=head3 $TXYZ(AlternativeX,AlternativeY,AlternativeZ)

Expand Down
4 changes: 2 additions & 2 deletions Libtmp/GSL/SF/coulomb/gsl_sf_coulomb.pd
Original file line number Diff line number Diff line change
Expand Up @@ -47,7 +47,7 @@ pp_def('gsl_sf_coulomb_wave_FGp_array',
Pars=>'double x(); double [o]fc(n); double [o]fcp(n); double [o]gc(n); double [o]gcp(n); int [o]ovfw(); double [o]fe(n); double [o]ge(n);',
Code =>'
int s;
s = gsl_sf_coulomb_wave_FGp_array($COMP(lam_min),$COMP(kmax),$COMP(eta),$x(),$PP(fc),$PP(fcp),$PP(gc),$PP(gcp),$PP(fe),$PP(ge));
s = gsl_sf_coulomb_wave_FGp_array($COMP(lam_min),$COMP(kmax),$COMP(eta),$x(),$P(fc),$P(fcp),$P(gc),$P(gcp),$P(fe),$P(ge));
if (s==GSL_EOVRFLW) {
$ovfw()=1;
}
Expand All @@ -64,7 +64,7 @@ pp_def('gsl_sf_coulomb_wave_sphF_array',
Pars=>'double x(); double [o]fc(n); int [o]ovfw(); double [o]fe(n);',
Code =>'
int s;
s = gsl_sf_coulomb_wave_sphF_array($COMP(lam_min),$COMP(kmax),$COMP(eta),$x(),$PP(fc),$PP(fe));
s = gsl_sf_coulomb_wave_sphF_array($COMP(lam_min),$COMP(kmax),$COMP(eta),$x(),$P(fc),$P(fe));
if (s==GSL_EOVRFLW) {
$ovfw()=1;
}
Expand Down
2 changes: 1 addition & 1 deletion Libtmp/GSL/SF/elljac/gsl_sf_elljac.pd
Original file line number Diff line number Diff line change
Expand Up @@ -27,7 +27,7 @@ pp_def('gsl_sf_elljac',
GenericTypes => ['D'],
Pars=>'double u(); double m(); double [o]sn(); double [o]cn(); double [o]dn()',
Code =>'
if (gsl_sf_elljac_e($u(),$m(),$PP(sn),$PP(cn),$PP(dn))) {$CROAK("Error in gsl_sf_elljac");};
if (gsl_sf_elljac_e($u(),$m(),$P(sn),$P(cn),$P(dn))) {$CROAK("Error in gsl_sf_elljac");};
',
Doc =>'Jacobian elliptic functions sn, dn, cn by descending Landen transformations'
);
Expand Down
4 changes: 2 additions & 2 deletions t/01-pptest.t
Original file line number Diff line number Diff line change
Expand Up @@ -239,8 +239,8 @@ for (i = 0; i < $COMP(ins_count); i++) {
#define X_CAT_INNER(datatype_in, ctype_in, ppsym_in, ...) \
PDL_DECLARE_PARAMETER_BADVAL(ctype_in, 0, in, (in), 1) \
for(j=0; j<in->nvals; j++) { \
if ($PRIV(bvalflag) && PDL_ISBAD(in_physdatap[j], in_badval, ppsym_in)) continue; \
$out() += in_physdatap[j]; \
if ($PRIV(bvalflag) && PDL_ISBAD(in_datap[j], in_badval, ppsym_in)) continue; \
$out() += in_datap[j]; \
}
PDL_GENERICSWITCH(PDL_TYPELIST2_ALL, in->datatype, X_CAT_INNER, $CROAK("Not a known data type code=%d", in->datatype))
#undef X_CAT_INNER
Expand Down

0 comments on commit 191d565

Please sign in to comment.