Skip to content

Commit

Permalink
replace CallCopy mechanism with initialize called also as instance me…
Browse files Browse the repository at this point in the history 
…thod
  • Loading branch information
@mohawk2
mohawk2 committed Oct 24, 2024
1 parent b50bf21 commit 952a657
Show file tree
Hide file tree
Showing 5 changed files with 30 additions and 93 deletions.
10 changes: 2 additions & 8 deletions Basic/Core/pdlperl.h.PL
View file
Original file line number Diff line number Diff line change
Expand Up @@ -62,14 +62,8 @@ static inline pdl *PDL_XS_pdlinit(pTHX_ char *objname, HV *bless_stash, SV *to_p
}
return ret;
}
#define PDL_XS_PERLINIT_init() \
PDL_XS_pdlinit(aTHX_ objname, bless_stash, parent ? parent : sv_2mortal(newSVpv(objname, 0)), "initialize", NULL, PDL)
#define PDL_XS_PERLINIT_initsv(sv) \
PDL_XS_pdlinit(aTHX_ objname, bless_stash, parent ? parent : sv_2mortal(newSVpv(objname, 0)), "initialize", &sv, PDL)
#define PDL_XS_PERLINIT_copy() \
PDL_XS_pdlinit(aTHX_ objname, bless_stash, parent, "copy", NULL, PDL)
#define PDL_XS_PERLINIT_copysv(sv) \
PDL_XS_pdlinit(aTHX_ objname, bless_stash, parent, "copy", &sv, PDL)
#define PDL_XS_RETURN(clause1) \
if (nreturn) { \
Expand All @@ -81,7 +75,7 @@ static inline pdl *PDL_XS_pdlinit(pTHX_ char *objname, HV *bless_stash, SV *to_p
}
#define PDL_IS_INPLACE(in) ((in)->state & PDL_INPLACE)
#define PDL_XS_INPLACE(in, out, whichinit) \
#define PDL_XS_INPLACE(in, out) \
if (PDL_IS_INPLACE(in)) { \
if (out ## _SV) barf("inplace input but different output given"); \
out ## _SV = sv_newmortal(); \
Expand All @@ -90,7 +84,7 @@ static inline pdl *PDL_XS_pdlinit(pTHX_ char *objname, HV *bless_stash, SV *to_p
PDL->SetSV_PDL(out ## _SV,out); \
} else \
out = out ## _SV ? PDL_CORE_(SvPDLV)(out ## _SV) : \
PDL_XS_PERLINIT_ ## whichinit ## sv(out ## _SV);
PDL_XS_PERLINIT_initsv(out ## _SV);
#define PDL_XS_SCALAR(thistype, ppsym, val) \
PDL_Anyval av = {PDL_CLD, {.H=0 + 0I}}; /* guarantee all bits set */ \
Expand Down
40 changes: 13 additions & 27 deletions Basic/Gen/PP.pm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -999,8 +999,9 @@ sub indent($$) {
# This subroutine generates the XS code needed to call the perl 'initialize'
# routine in order to create new output PDLs
sub callPerlInit {
my ($sv, $callcopy) = @_;
"PDL_XS_PERLINIT_".($callcopy ? "copy" : "init").($sv ? "sv($sv)" : "()");
my ($sv) = @_;
confess "callPerlInit error: \$sv must be defined" if !defined $sv;
"PDL_XS_PERLINIT_initsv($sv)";
}

sub callTypemap {
Expand Down Expand Up @@ -1280,11 +1281,11 @@ EOD
PDL::PP::Rule->new("HaveBroadcasting","HaveThreading", sub {@_}), # compat
PDL::PP::Rule::Croak->new([qw(P2Child GenericTypes)],
'Cannot have both P2Child and GenericTypes defined'),
PDL::PP::Rule->new([qw(Pars HaveBroadcasting CallCopy GenericTypes DefaultFlow AllFuncHeader RedoDimsFuncHeader)],
PDL::PP::Rule->new([qw(Pars HaveBroadcasting GenericTypes DefaultFlow AllFuncHeader RedoDimsFuncHeader)],
["P2Child","Name","StructName"],
sub {
my (undef,$name,$sname) = @_;
("PARENT(); [oca]CHILD();",0,0,[PDL::Types::ppdefs_all()],1,
("PARENT(); [oca]CHILD();",0,[PDL::Types::ppdefs_all()],1,
"pdl *__it = $sname->pdls[1]; (void) __it;\n",
"PDL->hdr_childcopy($sname); $sname->dims_redone = 1;\n",
);
Expand Down Expand Up @@ -1398,21 +1399,6 @@ EOD
sub { PDL::PP::Signature->new('', @_[0,1], join(';', grep defined() && /[^\s;]/, @_[2..$#_])) }),
PDL::PP::Rule->new("CompStruct", ["CompObj"], sub {$_[0]->getcomp}),

# Set CallCopy flag for simple functions (2-arg with 0-dim signatures)
# This will copy the $object->copy method, instead of initialize
# for PDL-subclassed objects
#
PDL::PP::Rule->new("CallCopy", ["SignatureObj", "Name"],
sub {
my ($sig, $Name, $hasp2c) = @_;
my $noDimmedArgs = $sig->dims_obj->ind_names;
my $noArgs = @{$sig->names};
# Check for 2-arg function with 0-dim signatures
return 0 if !($noDimmedArgs == 0 and $noArgs == 2);
# Check to see if output arg is _not_ explicitly typed:
!$sig->objs->{$sig->names->[1]}{FlagTypeOverride};
}),

PDL::PP::Rule->new("InplaceNormalised", ["SignatureObj","Inplace"],
'interpret Inplace and Signature to get input/output',
# Inplace can be supplied several values
Expand Down Expand Up @@ -1457,15 +1443,15 @@ EOD
}
[$in, $out];
}),
PDL::PP::Rule->new(["InplaceCode"], [qw(InplaceNormalised CallCopy)],
PDL::PP::Rule->new(["InplaceCode"], [qw(InplaceNormalised)],
'code to implement working inplace',
# insert code, after the autogenerated xs argument processing code
# produced by VarArgsXSHdr and AFTER any in HdrCode
# - this code flags the routine as working inplace,
sub {
my ($arg, $callcopy) = @_;
my ($arg) = @_;
my ($in, $out) = @$arg;
" PDL_XS_INPLACE($in, $out, @{[$callcopy ? 'copy' : 'init']})\n";
" PDL_XS_INPLACE($in, $out)\n";
}),
PDL::PP::Rule::Returns::EmptyString->new("InplaceCode", []),

Expand Down Expand Up @@ -1513,11 +1499,11 @@ EOD
}),
PDL::PP::Rule->new("VarArgsXSHdr",
[qw(Name SignatureObj
CallCopy? OtherParsDefaults? ArgOrder? InplaceNormalised?)],
OtherParsDefaults? ArgOrder? InplaceNormalised?)],
'XS code to process input arguments based on supplied Pars argument to pp_def; not done if GlobalNew or PMCode supplied',
sub {
my($name,$sig,
$callcopy,$otherdefaults,$argorder,$inplace) = @_;
$otherdefaults,$argorder,$inplace) = @_;
$argorder = [reorder_args($sig, $otherdefaults)] if $argorder and !ref $argorder;
my $optypes = $sig->otherobjs;
my @args = @{ $argorder || $sig->allnames(1, 1) };
Expand Down Expand Up @@ -1555,7 +1541,7 @@ EOD
exists $otherdefaults->{$x} ? "=$otherdefaults->{$x}" :
!$out{$x} ? '' :
$inplace && $x eq $inplace->[1] ? "=$x" :
"=".callPerlInit($x."_SV", $callcopy)
"=".callPerlInit($x."_SV")
);
push @inputdecls, "$ptypes{$x}$x".($inplace && $x eq $inplace->[1] ? "=NO_INIT" : '');
}
Expand All @@ -1567,7 +1553,7 @@ EOD
push @xsargs, "$x=$x";
push @inputdecls, "$ptypes{$x}$x".($other{$x} && !exists $otherdefaults->{$x} ? "; { ".callTypemap($x, $ptypes{$x}, $name)."; }" : "=NO_INIT");
}
push @inputdecls, map "$ptypes{$_}$_=".callPerlInit($_."_SV", $callcopy).";", grep $outca{$_}, @args;
push @inputdecls, map "$ptypes{$_}$_=".callPerlInit($_."_SV").";", grep $outca{$_}, @args;
my $defaults_rawcond = $ndefault ? "items == $nin_minus_default" : '';
my $svdecls = join '', map "\n $_",
(map "SV *${_}_SV = ".(
Expand All @@ -1588,7 +1574,7 @@ EOD
"{ ".callTypemap($_, $ptypes{$_}, $name)."; }\n",
grep !$argorder && exists $otherdefaults->{$_}, @{$sig->othernames(1, 1)}),
(map callTypemap($_, $ptypes{$_}, $name).";\n", grep !$already_read{$_}, $sig->names_in),
(map +("if (${_}_SV) { ".($argorder ? '' : callTypemap($_, $ptypes{$_}, $name))."; } else ")."$_ = ".callPerlInit($_."_SV", $callcopy).";\n", grep $out{$_} && !$already_read{$_} && !($inplace && $_ eq $inplace->[1]), @args)
(map +("if (${_}_SV) { ".($argorder ? '' : callTypemap($_, $ptypes{$_}, $name))."; } else ")."$_ = ".callPerlInit($_."_SV").";\n", grep $out{$_} && !$already_read{$_} && !($inplace && $_ eq $inplace->[1]), @args)
);
push @preinit, qq[PDL_XS_PREAMBLE($nretval);] if $nallout;
push @preinit, qq{if (!(@{[join ' || ', map "(items == $_)", sort keys %valid_itemcounts]}))
Expand Down
50 changes: 12 additions & 38 deletions Basic/Pod/Objects.pod
View file
Original file line number Diff line number Diff line change
Expand Up @@ -101,21 +101,21 @@ with a C<PDL> member. Make that package inherit from C<PDL>, and
redefine the method C<initialize>.

package FOO;
our ISA = qw(PDL);
our ISA = qw(PDL::Hash);
sub initialize {
my $class = shift;
my $self = {
creation_time => time(), # necessary extension :-)
PDL => $class->SUPER::initialize, # used to store PDL object
};
bless $self, ref $class || $class;
my $self = $class->SUPER::initialize(@_);
$self->{creation_time} = time(); # necessary extension :-)
$self;
}

All PDL constructors will call initialize() to make sure that your
extensions are added by I<all> PDL constructors automatically.

Do remember that if you subclass a class that is subclassed from an ndarray,
you need to call C<SUPER::initialize>.
you need to call C<SUPER::initialize>. Make sure it is callable as
an instance method, e.g. by copying data from C<$class> if C<ref
$class> is true.

=head2 Examples

Expand All @@ -124,44 +124,18 @@ test-case files. Look in F<t/subclass.t>.

=head2 Output Auto-Creation and Subclassed Objects

For PDL Functions where the output is created and returned, PDL will either
call the subclassed object's C<initialize> or C<copy> method to create the
For PDL Functions where the output is created and returned, PDL will
call the subclassed object's C<initialize> method on either instance
or class to create the
output object. (See L<PDL::Indexing|PDL::Indexing/"Output auto-creation and PP-function calling conventions">
for a discussion on Output Auto-Creation.) This behavior is summarized as follows:

=over

=item *

For I<simple> functions, defined as having a signature of

func( a(), [o]b() )

PDL will call C<< $a->copy >> to create the output object.

PDL will call C<initialize> on the first input argument if it is
an object, else on C<PDL> to create the output object.
In the spirit of the Perl philosophy of making I<Easy Things Easy>,
this behavior enables PDL-subclassed objects to be written without having to
overload the many simple PDL functions in this category.

The file F<t/subclass.t> in the PDL Distribution tests for this behavior.
See that file for an example.

=item *

For other functions, PDL will call C<< $class->initialize >> to
create the output object. Where C<$class> is the class name of the
first argument supplied to the function.

For these more complex cases, it is difficult to second-guess the
subclassed object's designer to know if a C<copy> or a C<initialize>
is appropriate. So for these cases, C<< $class->initialize >> is
called by default. If this is not appropriate for you, overload the
function in your subclass and do whatever is appropriate in the
overloaded function's code.

=back


=head1 AUTHOR

Copyright (C) Karl Glazebrook ([email protected]), Tuomas J. Lukka,
Expand Down
1 change: 1 addition & 0 deletions Changes
View file
Original file line number Diff line number Diff line change
Expand Up @@ -16,6 +16,7 @@
- if $pdl->{PDL} is code ref, $pdl now passed as arg
- add PDL::Hash to simplify hash-based PDL subclasses
- now an error to pass any undefined values to PDL constructors
- replace CallCopy mechanism with initialize called also as instance method

2.093 2024-09-29
- PDL.set_datatype now doesn't physicalise input, PDL.convert_type does
Expand Down
22 changes: 2 additions & 20 deletions t/subclass.t
View file
Original file line number Diff line number Diff line change
Expand Up @@ -88,13 +88,6 @@ sub initialize {
$self->{someThingElse} = ref $class ? $class->{someThingElse} : 42;
$self;
}
###### Derived3 Object Needs to supply its own copy #####
sub copy {
my $self = shift;
my $new = $self->initialize;
$new->{PDL} = $self->{PDL}->SUPER::copy;
$new;
}
}
## Now check to see if the different categories of primitive operations
## return the PDL::Derived3 type.
Expand Down Expand Up @@ -177,15 +170,6 @@ sub initialize {
$self;
}

###### Derived4 Object Needs to supply its own copy #####
sub copy {
$::COPY_CALLED = 1;
my $self = shift;
my $new = $self->initialize;
$new->{PDL} = $self->{PDL}->SUPER::copy;
return $new;
}

### Check of over-riding sumover
### This sumover should be called from PDL->sum.
### If the result is different from the normal sumover by $self->{SomethingElse} (42) then
Expand Down Expand Up @@ -253,14 +237,12 @@ isa_ok $im->clip(5,7), "PDL::Derived4", "clip returns derived object";
isa_ok $im->hclip(5), "PDL::Derived4", "hclip returns derived object";
isa_ok $im->lclip(5), "PDL::Derived4", "lclip returns derived object";

$::COPY_CALLED = $::INIT_CALLED = 0;
$::INIT_CALLED = 0;
my $im2 = $im + 1;
ok !$::COPY_CALLED, 'no copy';
ok $::INIT_CALLED, 'yes init';

$::COPY_CALLED = $::INIT_CALLED = 0;
$::INIT_CALLED = 0;
$im++;
ok !$::COPY_CALLED, 'no copy';
ok !$::INIT_CALLED, 'no init';

######## Test of Subclassed-object copying for simple function cases ########
Expand Down

0 comments on commit 952a657

Please sign in to comment.