allow [o] on OtherPars - #362

PDLPorters · Aug 7, 2022 · e029251 · e029251
1 parent 90ba5a0
commit e029251
Show file tree

Hide file tree

Showing 8 changed files with 120 additions and 18 deletions.
diff --git a/Basic/Core/pdl.h.PL b/Basic/Core/pdl.h.PL
@@ -319,6 +319,7 @@ PDL_TYPELIST_ALL(X)
 #define         PDL_TRANS_BADPROCESS       0x0002
 #define         PDL_TRANS_BADIGNORE        0x0004
 #define         PDL_TRANS_NO_PARALLEL      0x0008
+#define         PDL_TRANS_OUTPUT_OTHERPAR  0x0010
 
 #define PDL_LIST_FLAGS_PDLVTABLE(X) \
   X(PDL_TRANS_DO_BROADCAST) \

diff --git a/Basic/Core/pdlapi.c b/Basic/Core/pdlapi.c
@@ -1180,5 +1180,12 @@ pdl_error pdl_trans_check_pdls(pdl_trans *trans) {
     if (!pdls[i])
       return pdl_make_error(PDL_EFATAL, "%s got NULL pointer on param %s", vtable->name, vtable->par_names[i]);
   }
+  if (vtable->flags & PDL_TRANS_OUTPUT_OTHERPAR)
+    for (i = 0; i < vtable->npdls; i++)
+      if (!(trans->pdls[i]->state & PDL_NOMYDIMS) && trans->pdls[i]->ndims > vtable->par_realdims[i])
+        return pdl_make_error(PDL_EUSERERROR,
+          "Can't broadcast with output OtherPars but par '%s' has %"IND_FLAG" dims, > %"IND_FLAG"!",
+          vtable->par_names[i], trans->pdls[i]->ndims, vtable->par_realdims[i]
+        );
   return PDL_err;
 }
diff --git a/Basic/Gen/PP.pm b/Basic/Gen/PP.pm
@@ -1573,6 +1573,7 @@ EOD
         my %ptypes = map +($_=>$$optypes{$_} ? $$optypes{$_}->get_decl('', {VarArrays2Ptrs=>1}) : 'pdl *'), @args;
         my %out = map +($_=>1), $sig->names_out_nca;
         my %outca = map +($_=>1), $sig->names_oca;
+        my %other_out = map +($_=>1), $sig->other_out;
         my %tmp = map +($_=>1), $sig->names_tmp;
         # remember, otherpars *are* input vars
         my $nout   = grep $_, values %out;
@@ -1590,25 +1591,28 @@ EOD
         # These are used in creating output variables.  One variable (ex: SV * outvar1_SV;)
         # is needed for each output and output create always argument
         my $svdecls = join "\n", map indent("SV *${_}_SV = NULL;",$ci), $sig->names_out;
-        my ($xsargs, $xsdecls) = ('', ''); my %already_read;
+        my ($xsargs, $xsdecls) = ('', ''); my %already_read; my $cnt = 0; my %outother2cnt;
         foreach my $x (@args) {
             next if $outca{$x};
             last if $out{$x} || ($other{$x} && exists $defaults->{$x});
             $already_read{$x} = 1;
             $xsargs .= "$x, "; $xsdecls .= "\n\t$ptypes{$x}$x";
+            $outother2cnt{$x} = $cnt if $other{$x} && $other_out{$x};
+            $cnt++;
         }
-        my $pars = join "\n",map indent("$_;",$ci), $sig->alldecls(0, \%already_read);
+        my $pars = join "\n",map indent("$_;",$ci), $sig->alldecls(0, 0, \%already_read);
+        $svdecls = join "\n", grep length, $svdecls, map indent(qq{SV *${_}_SV = @{[defined($outother2cnt{$_})?"ST($outother2cnt{$_})":'NULL']};},$ci), $sig->other_out;
         my @create = ();  # The names of variables which need to be created by calling
                           # the 'initialize' perl routine from the correct package.
         $ci = '    ';  # Current indenting
         # clause for reading in all variables
-        my $clause1 = $inplacecheck; my $cnt = 0;
+        my $clause1 = $inplacecheck; $cnt = 0;
         foreach my $x (@args) {
             if ($outca{$x}) {
                 push @create, $x;
             } else {
                 my ($setter, $type) = typemap($ptypes{$x}, 'get_inputmap');
-                $setter = typemap_eval($setter, {var=>$x, type=>$type, arg=>($out{$x} ? "${x}_SV = " : '')."ST($cnt)"});
+                $setter = typemap_eval($setter, {var=>$x, type=>$type, arg=>($out{$x}||$other_out{$x} ? "${x}_SV = " : '')."ST($cnt)"});
                 $setter =~ s/.*?(?=$x\s*=\s*)//s; # zap any declarations like whichdims_count
                 $clause1 .= indent("$setter;\n",$ci) if !$already_read{$x};
                 $cnt++;
@@ -1626,7 +1630,7 @@ EOD
                 push @create, $x;
             } else {
                 my ($setter, $type) = typemap($ptypes{$x}, 'get_inputmap');
-                $setter = typemap_eval($setter, {var=>$x, type=>$type, arg=>"ST($cnt)"});
+                $setter = typemap_eval($setter, {var=>$x, type=>$type, arg=>($other_out{$x} ? "${x}_SV = " : '')."ST($cnt)"});
                 $setter =~ s/^(.*?)=\s*//s, $setter = "$x = ($defaults_rawcond) ? ($defaults->{$x}) : ($setter)" if exists $defaults->{$x};
                 $clause3 .= indent("$setter;\n",$ci) if !$already_read{$x};
                 $cnt++;
@@ -1672,14 +1676,26 @@ END
         my @outs = $sig->names_out; # names of output ndarrays in calling order
         my $clause1 = join ';', map "ST($_) = $outs[$_]_SV", 0 .. $#outs;
         $clause1 = PDL::PP::pp_line_numbers(__LINE__-1, "PDL_XS_RETURN($clause1)");
+        my @other_out = $sig->other_out;
+        my $optypes = $sig->otherobjs;
+        my %ptypes = map +($_=>$$optypes{$_}->get_decl('', {VarArrays2Ptrs=>1})), @other_out;
+        for my $x (@other_out) {
+          my ($setter, $type) = typemap($ptypes{$x}, 'get_outputmap');
+          $setter = typemap_eval($setter, {var=>$x, type=>$type, arg=>"tsv"});
+          $clause1 = <<EOF . $clause1;
+{ SV *tsv = NULL;
+$setter
+sv_setsv(${x}_SV, tsv); sv_2mortal(tsv); }
+EOF
+        }
         $clause1;
       }),
 
    PDL::PP::Rule->new("NewXSHdr", ["NewXSName","SignatureObj"],
       sub {
         my($name,$sig) = @_;
         my $shortpars = join ',', @{ $sig->allnames(1) };
-        my $longpars = join "\n", map "\t$_", $sig->alldecls(1);
+        my $longpars = join "\n", map "\t$_", $sig->alldecls(1, 0);
         return<<END;
 \nvoid
 $name($shortpars)
@@ -1690,16 +1706,16 @@ END
    PDL::PP::Rule->new("NewXSCHdrs", ["RunFuncName","SignatureObj","GlobalNew"],
       sub {
         my($name,$sig,$gname) = @_;
-        my $longpars = join ",", $sig->alldecls(0);
+        my $longpars = join ",", $sig->alldecls(0, 1);
         my $opening = 'pdl_error PDL_err = {0, NULL, 0};';
         my $closing = 'return PDL_err;';
         return ["pdl_error $name($longpars) {$opening","$closing}",
                 "PDL->$gname = $name;"];
       }),
    PDL::PP::Rule->new(["RunFuncCall","RunFuncHdr"],["RunFuncName","SignatureObj"], sub {
         my ($func_name,$sig) = @_;
-        my $shortpars = join ',', @{ $sig->allnames(0) };
-        my $longpars = join ",", $sig->alldecls(0);
+        my $shortpars = join ',', map $sig->other_is_out($_)?"&$_":$_, @{ $sig->allnames(0) };
+        my $longpars = join ",", $sig->alldecls(0, 1);
         (PDL::PP::pp_line_numbers(__LINE__-1, "PDL->barf_if_error($func_name($shortpars));"),
           "pdl_error $func_name($longpars)");
       }),
@@ -1782,6 +1798,8 @@ sub make_vfn_args {
    PDL::PP::Rule->new("MakeCompOther", "SignatureObj", sub { $_[0]->getcopy }),
    PDL::PP::Rule->new("MakeCompTotal", ["MakeCompOther", \"MakeComp"], sub { join "\n", grep $_, @_ }),
    PDL::PP::Rule::Substitute->new("MakeCompiledReprSubd", "MakeCompTotal"),
+   PDL::PP::Rule->new("CopyBackOutputOtherPars", "SignatureObj", sub { $_[0]->getcopy(1) }),
+   PDL::PP::Rule::Substitute->new("CopyBackOutputOtherParsSubd", "CopyBackOutputOtherPars"),
 
    (map PDL::PP::Rule::Substitute->new("${_}ReadDataCodeUnparsed", "${_}Code"), '', 'Bad'),
    PDL::PP::Rule->new(PDL::PP::Code::make_args(qw(ReadData)),
@@ -1908,6 +1926,7 @@ EOF
         "NewXSCoerceMustCompSubd",
         "NewXSRunTrans",
         "NewXSCopyBadStatusSubd",
+        "CopyBackOutputOtherParsSubd",
       ],
       "Generate C function with idiomatic arg list to maybe call from XS",
       sub {
@@ -1954,6 +1973,7 @@ EOF
         push @op_flags, 'PDL_TRANS_BADPROCESS' if $badflag;
         push @op_flags, 'PDL_TRANS_BADIGNORE' if defined $badflag and !$badflag;
         push @op_flags, 'PDL_TRANS_NO_PARALLEL' if $noPthreadFlag;
+        push @op_flags, 'PDL_TRANS_OUTPUT_OTHERPAR' if $sig->other_any_out;
         my $op_flags = join('|', @op_flags) || '0';
         my $iflags = join('|', grep $_, $affflag, $revflag, $flowflag) || '0';
         my $gentypes_txt = join(", ", (map PDL::Type->new($_)->sym, @$gentypes), '-1');

diff --git a/Basic/Gen/PP/CType.pm b/Basic/Gen/PP/CType.pm
@@ -50,6 +50,7 @@ sub get_decl {
 			}
 		} else { confess("Invalid decl @$_") }
 	}
+	$name = "*$name" if $opts->{AddIndirect};
 	return "$this->{Base} $name";
 }
 

diff --git a/Basic/Gen/PP/Signature.pm b/Basic/Gen/PP/Signature.pm
@@ -47,15 +47,22 @@ sub new {
   my $i=0; my %ind2index = map +($_=>$i++), @{$this->{IndNamesSorted}};
   $this->{Ind2Index} = \%ind2index;
   $ind2obj{$_}->set_index($ind2index{$_}) for sort keys %ind2index;
-  @$this{qw(OtherNames OtherObjs)} = $this->_otherPars_nft($otherpars||'');
+  @$this{qw(OtherNames OtherObjs OtherAnyOut OtherFlags)} = $this->_otherPars_nft($otherpars||'');
   $this;
 }
 
 sub _otherPars_nft {
     my ($sig,$otherpars) = @_;
     my $dimobjs = $sig && $sig->dims_obj;
-    my (@names,%types,$type);
+    my (@names,%types,$type,$any_out,%allflags);
     for (nospacesplit(';',$otherpars)) {
+	my (%flags);
+	if (s/^\s*$PDL::PP::PdlParObj::sqbr_re\s*//) {
+	  %flags = my %lflags = map +($_=>1), split /\s*,\s*/, my $opts = $1;
+	  my $this_out = delete $lflags{o};
+	  die "Invalid options '$opts' in '$_'" if keys %lflags;
+	  $any_out ||= $this_out;
+	}
 	if (/^\s*([^=]+?)\s*=>\s*(\S+)\s*$/) {
 	    # support 'int ndim => n;' syntax
 	    my ($ctype,$dim) = ($1,$2);
@@ -73,8 +80,9 @@ sub _otherPars_nft {
 	push @names,$name;
 	$types{$name} = $type;
 	$types{"${name}_count"} = PDL::PP::CType->new("PDL_Indx ${name}_count") if $type->is_array;
+	$allflags{$name} = \%flags;
     }
-    return (\@names,\%types);
+    (\@names,\%types,$any_out,\%allflags);
 }
 
 =head1 AUTHOR
@@ -122,6 +130,9 @@ sub othernames {
   \@raw_names;
 }
 sub otherobjs { $_[0]{OtherObjs} }
+sub other_any_out { $_[0]{OtherAnyOut} }
+sub other_is_out { $_[0]{OtherFlags}{$_[1]} && $_[0]{OtherFlags}{$_[1]}{o} }
+sub other_out { grep $_[0]->other_is_out($_), @{$_[0]{OtherNames}} }
 
 sub allnames { [
   (grep +(!$_[2] || !$_[2]{$_}) && !$_[0]{Objects}{$_}{FlagTemp}, @{$_[0]{Names}}),
@@ -132,9 +143,11 @@ sub allobjs {
   +{ ( map +($_,$pdltype), @{$_[0]{Names}} ), %{$_[0]->otherobjs} };
 }
 sub alldecls {
-  my ($self, $omit_count, $except) = @_;
+  my ($self, $omit_count, $indirect, $except) = @_;
   my $objs = $self->allobjs;
-  map $objs->{$_}->get_decl($_, {VarArrays2Ptrs=>1}), @{$self->allnames($omit_count, $except)};
+  my @names = @{$self->allnames($omit_count, $except)};
+  $indirect = $indirect ? { map +($_=>$self->other_is_out($_)), @names } : {};
+  map $objs->{$_}->get_decl($_, {VarArrays2Ptrs=>1,AddIndirect=>$indirect->{$_}}), @names;
 }
 sub getcomp {
   my ($self) = @_;
@@ -148,11 +161,11 @@ sub getfree {
     { VarArrays2Ptrs => 1 }), @{$self->othernames(0)};
 }
 sub getcopy {
-  my ($self) = @_;
+  my ($self, $copyback) = @_;
   my $objs = $self->otherobjs;
-  PDL::PP::pp_line_numbers(__LINE__,
-    join '', map $objs->{$_}->get_copy($_,"\$COMP($_)"), @{$self->othernames(0)}
-  );
+  return join '', map $objs->{$_}->get_copy($self->other_is_out($_)?"*$_":$_,"\$COMP($_)"), @{$self->othernames(0)} if !$copyback;
+  join '', map $objs->{$_}->get_copy("\$COMP($_)", "*$_"),
+    grep $self->other_is_out($_), @{$self->othernames(0)};
 }
 
 sub realdims {

diff --git a/Basic/Pod/PP.pod b/Basic/Pod/PP.pod
@@ -1626,6 +1626,36 @@ and use it in the code:
 where I have removed a macro wrapper call, but that would obscure the
 discussion.
 
+=head3 OtherPars as outputs
+
+As of 2.081, you can specify an C<OtherPar> as an output. This looks like:
+
+    pp_def('output_op',
+      Pars => 'in(n=2)',
+      OtherPars => '[o] PDL_Anyval v0; [o] PDL_Anyval v1',
+      Code => '
+        pdl_datatypes dt = $PDL(in)->datatype;
+        ANYVAL_FROM_CTYPE($COMP(v0), dt, $in(n=>0));
+        ANYVAL_FROM_CTYPE($COMP(v1), dt, $in(n=>1));
+      ',
+    );
+
+The passed-in stack SV will be mutated in place, so this code will then work:
+
+    output_op([5,7], my $v0, my $v1);
+    is_deeply [$v0,$v1], [5,7], 'output OtherPars work';
+
+An operation with output C<OtherPars> cannot broadcast, since that would
+cause undefined results. A runtime check is generated that throws an
+exception if any C<Par> would cause broadcasting.
+
+Note the syntax for C<OtherPars> has C<[o]> go I<before> the type, while
+it goes I<after> the type in C<Pars>. It was felt this was the best way
+to avoid ambiguity given C types can have C<[]> in them.
+
+This relies on the relevant C<OtherPar> having an C<OUTPUT> entry in an
+XS typemap.
+
 =head2 Other useful PP keys in data operation definitions
 
 You have already heard about the C<OtherPars> key. Currently, there are not

diff --git a/Changes b/Changes
@@ -3,6 +3,7 @@
 - fix MatrixOps::inv failing on native-complex (#403) - thanks @KJ7LNW for report
 - fix MatrixOps::identity losing class of invocant if ndarray (#401) - thanks @pryrt for report
 - change PP-generated XS PROTOTYPES to DISABLE
+- allow [o] on OtherPars (#362)
 
 2.080 2022-05-28
 - make IO::STL work on big-endian systems (#394) - thanks @sebastic for report

diff --git a/t/01-pptest.t b/t/01-pptest.t
@@ -241,6 +241,25 @@ pp_deft("rice_compress",
         Code => ';', # do nothing
 );
 
+pp_deft('output_op',
+  Pars => 'in(n=2)',
+  OtherPars => '[o] PDL_Anyval v0; [o] PDL_Anyval v1',
+  Code => '
+    pdl_datatypes dt = $PDL(in)->datatype;
+    ANYVAL_FROM_CTYPE($COMP(v0), dt, $in(n=>0));
+    ANYVAL_FROM_CTYPE($COMP(v1), dt, $in(n=>1));
+  ',
+);
+pp_deft('output_op2',
+  Pars => 'in(n=2); [o] out()',
+  OtherPars => '[o] PDL_Anyval v0; [o] PDL_Anyval v1',
+  Code => '
+    pdl_datatypes dt = $PDL(in)->datatype;
+    ANYVAL_FROM_CTYPE($COMP(v0), dt, $in(n=>0));
+    ANYVAL_FROM_CTYPE($COMP(v1), dt, $in(n=>1));
+  ',
+);
+
 pp_done;
 
 # this tests the bug with a trailing comment and *no* newline
@@ -368,6 +387,16 @@ test_polyfill_pp(zeroes(5,5), ones(2,3), 1);
 
 is test_succ(2)."", 3, 'test pp_add_macros works';
 
+test_output_op([5,7], my $v0, my $v1);
+is_deeply [$v0,$v1], [5,7], 'output OtherPars work';
+eval { test_output_op(sequence(2,3), my $v0, my $v1) };
+isnt $@, '', 'broadcast with output OtherPars throws';
+
+test_output_op2([5,7], my $v0_2, my $v1_2);
+is_deeply [$v0_2,$v1_2], [5,7], 'output OtherPars work 2';
+eval { test_output_op2(sequence(2,3), my $v0_2, my $v1_2) };
+isnt $@, '', 'broadcast with output OtherPars throws 2';
+
 done_testing;
 EOF