"Fossies" - the Fresh Open Source Software Archive  

Source code changes of the file "Basic/Gen/PP/PDLCode.pm" between
PDL-2.081.tar.gz and PDL-2.082.tar.gz

About: PDL (Perl Data Language) aims to turn perl into an efficient numerical language for scientific computing (similar to IDL and MatLab).

[ To the main PDL source changes report ]

PDLCode.pm  (PDL-2.081):PDLCode.pm  (PDL-2.082)
skipping to change at line 132 skipping to change at line 132
if defined $str and $str ne $bad_str; if defined $str and $str ne $bad_str;
$$sizeprivs{$bad_key} = $bad_str; # copy over $$sizeprivs{$bad_key} = $bad_str; # copy over
} }
} # if: $handlebad } # if: $handlebad
print "SIZEPRIVSX: ",(join ',',%$sizeprivs),"\n" if $::PP_VERBOSE; print "SIZEPRIVSX: ",(join ',',%$sizeprivs),"\n" if $::PP_VERBOSE;
# Enclose it all in a genericloop. # Enclose it all in a genericloop.
my $nc = $coderef; my $nc = $coderef;
my $if_gentype = ($code.($badcode//'')) =~ /PDL_IF_GENTYPE_/;
$coderef = PDL::PP::GenericSwitch->new($generictypes, undef, $coderef = PDL::PP::GenericSwitch->new($generictypes, undef,
[grep {!$extrageneric->{$_}} @$parnames],'$PRIV(__datatype)'); [grep {!$extrageneric->{$_}} @$parnames],'$PRIV(__datatype)',$if_gentyp e);
push @{$coderef},$nc; push @{$coderef},$nc;
# Do we have extra generic loops? # Do we have extra generic loops?
# If we do, first reverse the hash: # If we do, first reverse the hash:
my %glh; my %glh;
for(sort keys %$extrageneric) { for(sort keys %$extrageneric) {
push @{$glh{$extrageneric->{$_}}},$_; push @{$glh{$extrageneric->{$_}}},$_;
} }
my $no = 0; my $no = 0;
for(sort keys %glh) { for(sort keys %glh) {
my $nc = $coderef; my $nc = $coderef;
$coderef = PDL::PP::GenericSwitch->new($generictypes,$no++, $coderef = PDL::PP::GenericSwitch->new($generictypes,$no++,
$glh{$_},$_); $glh{$_},$_,$if_gentype);
push @$coderef,$nc; push @$coderef,$nc;
} }
my $pobjs = $sig->objs; my $pobjs = $sig->objs;
# Then, in this form, put it together what we want the code to actually do. # Then, in this form, put it together what we want the code to actually do.
print "SIZEPRIVS: ",(join ',',%$sizeprivs),"\n" if $::PP_VERBOSE; print "SIZEPRIVS: ",(join ',',%$sizeprivs),"\n" if $::PP_VERBOSE;
$this->{Code} = (join '',sort values %$sizeprivs). $this->{Code} = (join '',sort values %$sizeprivs).
($dont_add_brcloop?'':PDL::PP::pp_line_numbers __LINE__, join "\n", ($dont_add_brcloop?'':PDL::PP::pp_line_numbers __LINE__, join "\n",
'PDL_COMMENT("broadcastloop declarations")', 'PDL_COMMENT("broadcastloop declarations")',
'int __brcloopval;', 'int __brcloopval;',
'register PDL_Indx __tind0,__tind1; PDL_COMMENT("counters along dim")', 'register PDL_Indx __tind0,__tind1; PDL_COMMENT("counters along dim")',
'register PDL_Indx __tnpdls = $PRIV(broadcast).npdls;', 'register PDL_Indx __tnpdls = $PRIV(broadcast).npdls;',
'PDL_COMMENT("dims here are how many steps along those dims")', 'PDL_COMMENT("dims here are how many steps along those dims")',
(map "register PDL_Indx __tinc0_$parnames->[$_] = PDL_BRC_INC(\$PRIV(bro adcast).incs,__tnpdls,$_,0);", 0..$#$parnames), (map "register PDL_Indx __tinc0_$parnames->[$_] = PDL_BRC_INC(\$PRIV(bro adcast).incs,__tnpdls,$_,0);", 0..$#$parnames),
(map "register PDL_Indx __tinc1_$parnames->[$_] = PDL_BRC_INC(\$PRIV(bro adcast).incs,__tnpdls,$_,1);", 0..$#$parnames), (map "register PDL_Indx __tinc1_$parnames->[$_] = PDL_BRC_INC(\$PRIV(bro adcast).incs,__tnpdls,$_,1);", 0..$#$parnames),
eol_protect(
"#define ".$this->broadcastloop_macroname($backcode, 'START') . " " .
$this->broadcastloop_start($this->func_name($backcode))
)."\n",
eol_protect(
"#define ".$this->broadcastloop_macroname($backcode, 'END') . " " .
$this->broadcastloop_end
)."\n",
join('',map $_->get_incregisters, @$pobjs{sort keys %$pobjs}),
). ).
$this->params_declare. $this->params_declare.
join('',map $_->get_incregisters, @$pobjs{sort keys %$pobjs}).
$coderef->get_str($this,[]) $coderef->get_str($this,[])
; ;
$this->{Code}; $this->{Code};
} # new() } # new()
sub eol_protect {
my ($text) = @_;
join " \\\n", split /\n/, $text;
}
sub params_declare { sub params_declare {
my ($this) = @_; my ($this) = @_;
my ($ord,$pdls) = $this->get_pdls; my ($ord,$pdls) = $this->get_pdls;
my @decls = map $_->get_xsdatapdecl("PDL_PARAMTYPE_".$_->name, $this->{NullD ataCheck}), my @decls = map $_->get_xsdatapdecl("PDL_PARAMTYPE_".$_->name, $this->{NullD ataCheck}),
map $pdls->{$_}, @$ord; map $pdls->{$_}, @$ord;
my @param_names = map "PDL_PARAMTYPE_$_", @$ord; my @param_names = map "PDL_PARAMTYPE_$_", @$ord;
PDL::PP::pp_line_numbers(__LINE__, <<EOF); PDL::PP::pp_line_numbers(__LINE__, <<EOF);
#ifndef PDL_DECLARE_PARAMS_$this->{Name}_$this->{NullDataCheck} #ifndef PDL_DECLARE_PARAMS_$this->{Name}_$this->{NullDataCheck}
#define PDL_DECLARE_PARAMS_$this->{Name}_$this->{NullDataCheck}(@{[join ',', @pa ram_names]}) \\ #define PDL_DECLARE_PARAMS_$this->{Name}_$this->{NullDataCheck}(@{[join ',', @pa ram_names]}) \\
@{[join " \\\n", @decls]} @{[join " \\\n", @decls]}
#endif #endif
EOF EOF
} }
sub func_name { $_[1] ? "writebackdata" : "readdata" } sub func_name { $_[1] ? "writebackdata" : "readdata" }
sub broadcastloop_macroname {
my ($this, $backcode, $which) = @_;
"PDL_BROADCASTLOOP_${which}_$this->{Name}_".$this->func_name($backcode);
}
sub broadcastloop_start { sub broadcastloop_start {
my ($this, $funcname) = @_; my ($this, $funcname) = @_;
my ($ord,$pdls) = $this->get_pdls; my ($ord,$pdls) = $this->get_pdls;
<<EOF; <<EOF;
PDL_BROADCASTLOOP_START( PDL_BROADCASTLOOP_START(
$funcname, $funcname,
\$PRIV(broadcast), \$PRIV(broadcast),
\$PRIV(vtable), \$PRIV(vtable),
@{[ join "", map "\t".$pdls->{$ord->[$_]}->do_pointeraccess." += __offsp[$_];\n" , 0..$#$ord ]}, @{[ join "", map "\t".$pdls->{$ord->[$_]}->do_pointeraccess." += __offsp[$_];\n" , 0..$#$ord ]},
(@{[ join "", map "\t,".$pdls->{$ord->[$_]}->do_pointeraccess." += __tinc1_$ord- >[$_] - __tinc0_$ord->[$_] * __tdims0\n", 0..$#$ord ]}), (@{[ join "", map "\t,".$pdls->{$ord->[$_]}->do_pointeraccess." += __tinc1_$ord- >[$_] - __tinc0_$ord->[$_] * __tdims0\n", 0..$#$ord ]}),
skipping to change at line 480 skipping to change at line 499
# make the typetable from info in PDL::Types # make the typetable from info in PDL::Types
use PDL::Types ':All'; use PDL::Types ':All';
my @typetable = map [$_->ppsym, $_], types(); my @typetable = map [$_->ppsym, $_], types();
sub get_generictyperecs { my($types) = @_; sub get_generictyperecs { my($types) = @_;
my %wanted; @wanted{@$types} = (); my %wanted; @wanted{@$types} = ();
[ map $_->[1], grep exists $wanted{$_->[0]}, @typetable ]; [ map $_->[1], grep exists $wanted{$_->[0]}, @typetable ];
} }
# Types: BSULFD # Types: BSULFD
sub new { sub new {
my ($type,$types,$name,$varnames,$whattype) = @_; my ($type,$types,$name,$varnames,$whattype,$if_gentype) = @_;
my %vars; @vars{@$varnames} = (); my %vars; @vars{@$varnames} = ();
bless [get_generictyperecs($types), $name, \%vars, $whattype], $type; bless [get_generictyperecs($types), $name, \%vars, $whattype, $if_gentype], $type;
} }
sub myoffs {4} sub myoffs {5}
sub myprelude { sub myprelude {
my ($this,$parent,$context) = @_; my ($this,$parent,$context) = @_;
push @{$parent->{Gencurtype}}, undef; # so that $GENERIC can get at it push @{$parent->{Gencurtype}}, undef; # so that $GENERIC can get at it
die "ERROR: need to rethink NaN support in GenericSwitch\n" die "ERROR: need to rethink NaN support in GenericSwitch\n"
if defined $this->[1] and $parent->{ftypes_type}; if defined $this->[1] and $parent->{ftypes_type};
qq[PDL_COMMENT("Start generic loop")\n\tswitch($this->[3]) {\n]; qq[PDL_COMMENT("Start generic loop")\n\tswitch($this->[3]) {\n];
} }
my @GENTYPE_ATTRS = qw(integer real unsigned); my @GENTYPE_ATTRS = qw(integer real unsigned);
skipping to change at line 507 skipping to change at line 526
my ($this,$parent,$nth) = @_; my ($this,$parent,$nth) = @_;
my $item = $this->[0][$nth] || return ""; my $item = $this->[0][$nth] || return "";
$parent->{Gencurtype}[-1] = $item; $parent->{Gencurtype}[-1] = $item;
@$parent{qw(ftypes_type ftypes_vars)} = ($item, $this->[2]) if defined $this ->[1]; @$parent{qw(ftypes_type ftypes_vars)} = ($item, $this->[2]) if defined $this ->[1];
my ($ord,$pdls) = $parent->get_pdls; my ($ord,$pdls) = $parent->get_pdls;
my @param_ctypes = map $pdls->{$_}->adjusted_type($item)->ctype, @$ord; my @param_ctypes = map $pdls->{$_}->adjusted_type($item)->ctype, @$ord;
my $decls = keys %{$this->[2]} == @$ord my $decls = keys %{$this->[2]} == @$ord
? PDL::PP::pp_line_numbers(__LINE__-1, "\t\tPDL_DECLARE_PARAMS_$parent->{N ame}_$parent->{NullDataCheck}(@{[join ',', @param_ctypes]})\n") ? PDL::PP::pp_line_numbers(__LINE__-1, "\t\tPDL_DECLARE_PARAMS_$parent->{N ame}_$parent->{NullDataCheck}(@{[join ',', @param_ctypes]})\n")
: join '', map $_->get_xsdatapdecl($_->adjusted_type($item)->ctype, $paren t->{NullDataCheck}), : join '', map $_->get_xsdatapdecl($_->adjusted_type($item)->ctype, $paren t->{NullDataCheck}),
map $parent->{ParObjs}{$_}, sort keys %{$this->[2]}; map $parent->{ParObjs}{$_}, sort keys %{$this->[2]};
my @gentype_decls = map "#define PDL_IF_GENTYPE_".uc($_)."(t,f) ". my @gentype_decls = !$this->[4] ? () : map "#define PDL_IF_GENTYPE_".uc($_). "(t,f) ".
($item->$_ ? 't' : 'f')."\n", ($item->$_ ? 't' : 'f')."\n",
@GENTYPE_ATTRS; @GENTYPE_ATTRS;
join '', join '',
PDL::PP::pp_line_numbers(__LINE__-1, "case @{[$item->sym]}: {\n"), PDL::PP::pp_line_numbers(__LINE__-1, "case @{[$item->sym]}: {\n"),
@gentype_decls, @gentype_decls,
$decls; $decls;
} }
sub myitemend { sub myitemend {
my ($this,$parent,$nth) = @_; my ($this,$parent,$nth) = @_;
my $item = $this->[0][$nth] || return ""; my $item = $this->[0][$nth] || return "";
join '', join '',
"\n", "\n",
(map "#undef PDL_IF_GENTYPE_".uc($_)."\n", @GENTYPE_ATTRS), (!$this->[4] ? () : map "#undef PDL_IF_GENTYPE_".uc($_)."\n", @GENTYPE_AT TRS),
PDL::PP::pp_line_numbers(__LINE__-1, "} break;\n"); PDL::PP::pp_line_numbers(__LINE__-1, "} break;\n");
} }
sub mypostlude { sub mypostlude {
my($this,$parent,$context) = @_; my($this,$parent,$context) = @_;
pop @{$parent->{Gencurtype}}; # and clean up the Gentype stack pop @{$parent->{Gencurtype}}; # and clean up the Gentype stack
$parent->{ftypes_type} = undef if defined $this->[1]; $parent->{ftypes_type} = undef if defined $this->[1];
my $supported = join '', map $_->ppsym, @{$this->[0]}; my $supported = join '', map $_->ppsym, @{$this->[0]};
"\n\tdefault:return PDL->make_error(PDL_EUSERERROR, \"PP INTERNAL ERROR in $ parent->{Name}: unhandled datatype(%d), only handles ($supported)! PLEASE MAKE A BUG REPORT\\n\", $this->[3]);}\n"; "\n\tdefault:return PDL->make_error(PDL_EUSERERROR, \"PP INTERNAL ERROR in $ parent->{Name}: unhandled datatype(%d), only handles ($supported)! PLEASE MAKE A BUG REPORT\\n\", $this->[3]);}\n";
} }
skipping to change at line 548 skipping to change at line 567
package PDL::PP::BroadcastLoop; package PDL::PP::BroadcastLoop;
use Carp; use Carp;
our @ISA = "PDL::PP::Block"; our @ISA = "PDL::PP::Block";
sub new { sub new {
my $type = shift; my $type = shift;
bless [],$type; bless [],$type;
} }
sub myoffs { return 0; } sub myoffs { return 0; }
sub myprelude { sub myprelude {
my($this,$parent,$context, $backcode) = @_; my($this,$parent,$context,$backcode) = @_;
$parent->broadcastloop_start($parent->func_name($backcode)); $parent->broadcastloop_macroname($backcode, 'START') . "\n";
} }
sub mypostlude {my($this,$parent,$context) = @_; sub mypostlude {my($this,$parent,$context,$backcode) = @_;
$parent->broadcastloop_end; $parent->broadcastloop_macroname($backcode, 'END') . "\n";
} }
# Simple subclass of BroadcastLoop to implement writeback code # Simple subclass of BroadcastLoop to implement writeback code
# #
# #
package PDL::PP::BackCodeBroadcastLoop; package PDL::PP::BackCodeBroadcastLoop;
use Carp; use Carp;
our @ISA = "PDL::PP::BroadcastLoop"; our @ISA = "PDL::PP::BroadcastLoop";
sub myprelude { sub myprelude {
my($this,$parent,$context, $backcode) = @_; my($this,$parent,$context,$backcode) = @_;
# Set backcode flag if not defined. This will make the parent # Set backcode flag if not defined. This will make the parent
# myprelude emit proper writeback code # myprelude emit proper writeback code
$backcode = 1 unless defined($backcode); $this->SUPER::myprelude($parent, $context, $backcode // 1);
}
$this->SUPER::myprelude($parent, $context, $backcode); sub mypostlude {
my($this,$parent,$context,$backcode) = @_;
# Set backcode flag if not defined. This will make the parent
# mypostlude emit proper writeback code
$this->SUPER::mypostlude($parent, $context, $backcode // 1);
} }
########################### ###########################
# #
# Encapsulate a types() switch # Encapsulate a types() switch
# #
package PDL::PP::Types; package PDL::PP::Types;
use Carp; use Carp;
use PDL::Types ':All'; use PDL::Types ':All';
our @ISA = "PDL::PP::Block"; our @ISA = "PDL::PP::Block";
skipping to change at line 707 skipping to change at line 730
package PDL::PP::PpsymAccess; package PDL::PP::PpsymAccess;
use Carp; use Carp;
sub new { my($type,$pdl,$inds) = @_; bless [$inds],$type; } sub new { my($type,$pdl,$inds) = @_; bless [$inds],$type; }
sub get_str {my($this,$parent,$context) = @_; sub get_str {my($this,$parent,$context) = @_;
confess "generic type access outside a generic loop" confess "generic type access outside a generic loop"
unless defined(my $type = $parent->{Gencurtype}[-1]); unless defined(my $type = $parent->{Gencurtype}[-1]);
return $type->ppsym if !$this->[0]; return $type->ppsym if !$this->[0];
my $pobj = $parent->{ParObjs}{$this->[0]} // confess "not a defined parname"; my $pobj = $parent->{ParObjs}{$this->[0]} // confess "not a defined parname";
$pobj->adjusted_type($type)->ctype; $pobj->adjusted_type($type)->ppsym;
} }
1; 1;
 End of changes. 18 change blocks. 
17 lines changed or deleted 40 lines changed or added
To the Perl Modules section of the PDL source changes report or the top of this page
Mainly generated by pkgdiff using rfcdiff
Home  |  About  |  Features  |  All  |  Newest  |  Dox  |  Diffs  |  RSS Feeds  |  Screenshots  |  Comments  |  Imprint  |  Privacy  |  HTTP(S)