|
$miscdocs XXX=cut EOD
PDL::PP::Rule::Returns::EmptyString->new("HdrCode", [],
'Code that will be inserted before the call to the RunFunc'),
PDL::PP::Rule::Returns::EmptyString->new("FtrCode", [],
'Code that will be inserted after the call to the RunFunc'),
PDL::PP::Rule->new("VarArgsXSHdr",
[qw(Name SignatureObj
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,
$otherdefaults,$argorder,$inplace) = @_;
my @args = @{ $sig->args_callorder };
my %other = map +($_=>1), @{$sig->othernames(1, 1)};
$otherdefaults ||= {};
my $ci = 2; # current indenting
my $optypes = $sig->otherobjs;
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 @inargs = grep !$outca{$_}, @args;
my %other_out = map +($_=>1), $sig->other_out;
my $nout = keys(%out) + keys(%other_out);
my $noutca = keys %outca;
my $ntot = @args;
my $nallout = $nout + $noutca;
my $ndefault = keys %$otherdefaults;
my %valid_itemcounts = ((my $nmaxonstack = $ntot - $noutca)=>1);
$valid_itemcounts{my $nin = $nmaxonstack - $nout} = 1;
$valid_itemcounts{my $nin_minus_default = "($nin-$ndefault)"} = 1 if $ndefault;
my $only_one = keys(%valid_itemcounts) == 1;
my $nretval = $argorder ? $nout :
$only_one ? $noutca :
"(items == $nmaxonstack) ? $noutca : $nallout";
my ($cnt, @preinit, @xsargs, %already_read, %name2cnts) = -1;
my @inputdecls = map "PDL_Indx ${_}_count=0;", grep $other{$_} && $optypes->{$_}->is_array, @inargs;
foreach my $x (@inargs) {
if (!$argorder && ($out{$x} || $other_out{$x} || exists $otherdefaults->{$x})) {
last if @xsargs + keys(%out) + $noutca != $ntot;
$argorder = 1; # remaining all output ndarrays, engage
}
$cnt++;
$name2cnts{$x} = [$cnt, $cnt];
$already_read{$x} = 1;
push @xsargs, $x.(!$argorder ? '' :
exists $otherdefaults->{$x} ? "=$otherdefaults->{$x}" :
!$out{$x} ? '' :
$inplace && $x eq $inplace->[1] ? "=$x" :
"=".callPerlInit($x."_SV")
);
push @inputdecls, "$ptypes{$x}$x".($inplace && $x eq $inplace->[1] ? "=NO_INIT" : '');
}
my $shortcnt = my $xs_arg_cnt = $cnt;
foreach my $x (@inargs[$cnt+1..$nmaxonstack-1]) {
$cnt++;
$name2cnts{$x} = [$cnt, undef];
$name2cnts{$x}[1] = ++$shortcnt if !($out{$x} || $other_out{$x});
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").";", grep $outca{$_}, @args;
my $defaults_rawcond = $ndefault ? "items == $nin_minus_default" : '';
my $svdecls = join '', map "\n $_",
(map "SV *${_}_SV = ".(
!$name2cnts{$_} ? 'NULL' :
($argorder || (defined $otherdefaults->{$_} && !$nout)) ? "items > $name2cnts{$_}[1] ? ST($name2cnts{$_}[1]) : ".($other_out{$_} ? "sv_newmortal()" : "NULL") :
$name2cnts{$_}[0] == ($name2cnts{$_}[1]//-1) ? "ST($name2cnts{$_}[0])" :
"(items == $nmaxonstack) ? ST($name2cnts{$_}[0]) : ".
(!defined $name2cnts{$_}[1] ? ($other_out{$_} ? "sv_newmortal()" : "NULL") :
defined $otherdefaults->{$_} ? "!($defaults_rawcond) ? ST($name2cnts{$_}[1]) : ".($other_out{$_} ? "sv_newmortal()" : "NULL") :
"ST($name2cnts{$_}[1])"
)
).";", (grep !$already_read{$_}, $sig->names_in), $sig->names_out, @{$sig->othernames(1, 1, \%already_read)}),
;
my $argcode =
indent(2, join '',
(map
"if (!${_}_SV) { $_ = ($otherdefaults->{$_}); } else ".
"{ ".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").";\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]}))
croak("Usage: ${main::PDLOBJ}::$name(@{[
join ",", map exists $otherdefaults->{$_} ? "$_=$otherdefaults->{$_}" :
$out{$_} || $other_out{$_} ? "[$_]" : $_, @inargs
]}) (you may leave [outputs] and values with =defaults out of list)");}
unless $only_one || $argorder || ($nmaxonstack == keys(%valid_itemcounts) + $xs_arg_cnt);
my $preamble = @preinit ? qq[\n PREINIT:@{[join "\n ", "", @preinit]}\n INPUT:\n] : '';
join '', qq[
\nNO_OUTPUT pdl_error
pdl_run_$name(@{[join ', ', @xsargs]})$svdecls
$preamble@{[join "\n ", "", @inputdecls]}
PPCODE:
], map "$_\n", $argcode;
}),
# globalnew implies internal usage, not XS
PDL::PP::Rule::Returns->new("VarArgsXSReturn","GlobalNew",undef),
PDL::PP::Rule->new("FixArgsXSOtherOutDeclSV",
["SignatureObj"],
"Generate XS to declare SVs for output OtherPars",
sub {
my ($sig) = @_;
my $optypes = $sig->otherobjs;
my @args = @{ $sig->allnames(1, 1) };
my %outca = map +($_=>1), $sig->names_oca;
my %other_output = map +($_=>1), my @other_output = ($sig->other_io, $sig->other_out);
my $ci = 2;
my $cnt = 0; my %outother2cnt;
foreach my $x (grep !$outca{$_}, @args) {
$outother2cnt{$x} = $cnt if $other_output{$x};
$cnt++;
}
join "\n", map indent($ci,qq{SV *${_}_SV = ST($outother2cnt{$_});}), @other_output;
}),
PDL::PP::Rule->new("XSOtherOutSet",
[qw(Name SignatureObj)],
"Generate XS to set SVs to output values for OtherPars",
sub {
my ($name, $sig) = @_;
my $clause1 = '';
my @other_output = ($sig->other_io, $sig->other_out);
my $optypes = $sig->otherobjs;
my %ptypes = map +($_=>$$optypes{$_}->get_decl('', {VarArrays2Ptrs=>1})), @other_output;
for my $x (@other_output) {
my ($setter, $type) = typemap($ptypes{$x}, 'get_outputmap');
$setter = typemap_eval($setter, {var=>$x, type=>$type, arg=>"tsv",
pname=>$name});
$clause1 .= <<EOF;
if (!${x}_SV)
PDL->pdl_barf("Internal error in $name: tried to output to NULL ${x}_SV");
{\n SV *tsv = sv_newmortal();
$setter
sv_setsv(${x}_SV, tsv);\n}
EOF
}
indent(2, $clause1);
}),
PDL::PP::Rule->new("VarArgsXSReturn",
["SignatureObj"],
"Generate XS trailer to return output variables or leave them as modified input variables",
sub {
my ($sig) = @_;
my $oc = my @outs = $sig->names_out; # output ndarrays in calling order
my @other_outputs = ($sig->other_io, $sig->other_out); # output OtherPars
my $clause1 = join ';', (map "ST($_) = $outs[$_]_SV", 0 .. $#outs),
(map "ST(@{[$_+$oc]}) = $other_outputs[$_]_SV", 0 .. $#other_outputs);
$clause1 ? indent(2,"PDL_XS_RETURN($clause1)\n") : '';
}),
PDL::PP::Rule->new("NewXSHdr", ["NewXSName","SignatureObj"],
sub {
my($name,$sig) = @_;
my $shortpars = join ',', @{ $sig->allnames(1, 1) };
my $optypes = $sig->otherobjs;
my @counts = map "PDL_Indx ${_}_count=0;", grep $optypes->{$_}->is_array, @{ $sig->othernames(1, 1) };
my $longpars = join "\n", map " $_", @counts, $sig->alldecls(1, 0, 1);
return<<END;
\nNO_OUTPUT pdl_error
$name($shortpars)
$longpars
END
}),
PDL::PP::Rule::InsertName->new("RunFuncName", 'pdl_run_%s'),
PDL::PP::Rule->new("NewXSCHdrs", ["RunFuncName","SignatureObj","GlobalNew"],
sub {
my($name,$sig,$gname) = @_;
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 ',', map $sig->other_is_output($_)?"&$_":$_, @{ $sig->allnames(0) };
my $longpars = join ",", $sig->alldecls(0, 1);
(indent(2,"RETVAL = $func_name($shortpars);\nPDL->barf_if_error(RETVAL);\n"),
"pdl_error $func_name($longpars)");
}),
PDL::PP::Rule->new("IgnoreTypesOf", ["FTypes","SignatureObj"], sub {
my ($ftypes, $sig) = @_;
my ($pnames, $pobjs) = ($sig->names_sorted, $sig->objs);
$_->{FlagIgnore} = 1 for grep $ftypes->{$_->{Name}}, @$pobjs{@$pnames};
+{map +($_,1), keys %$ftypes};
}),
PDL::PP::Rule::Returns->new("IgnoreTypesOf", {}),
PDL::PP::Rule->new("NewXSTypeCoerceNS", ["StructName"],
sub { " PDL_RETERROR(PDL_err, PDL->type_coerce($_[0]));\n" }),
PDL::PP::Rule::Substitute->new("NewXSTypeCoerceSubd", "NewXSTypeCoerceNS"),
PDL::PP::Rule->new("NewXSRunTrans", ["StructName"], sub {
my($trans) = @_;
" PDL_RETERROR(PDL_err, PDL->make_trans_mutual($trans));\n";
}),
PDL::PP::Rule->new(["StructDecl","ParamStructType"],
["CompStruct","Name"],
sub {
my($comp,$name) = @_;
return ('', '') if !$comp;
my $ptype = "pdl_params_$name";
(PDL::PP::pp_line_numbers(__LINE__-1, qq[typedef struct $ptype {\n]).qq[$comp\n} $ptype;],
$ptype);
}),
do { sub wrap_vfn {
PDL::PP::Rule->new("MakeCompOther", [qw(SignatureObj ParamStructName)], sub { $_[0]->getcopy("$_[1]->%s") }),
PDL::PP::Rule->new("MakeCompTotal", [qw(MakeCompOther MakeComp?)], sub { join "\n", grep $_, @_ }),
PDL::PP::Rule::Substitute->new("MakeCompiledReprSubd", "MakeCompTotal"),
PDL::PP::Rule->new("NewXSSetTransPDLs", ["SignatureObj","StructName"], sub {
my($sig,$trans) = @_;
join '',
map " $trans->pdls[$_->[0]] = $_->[2];\n",
grep !$_->[1], $sig->names_sorted_tuples;
}),
PDL::PP::Rule->new("NewXSExtractTransPDLs", [qw(SignatureObj StructName MakeComp?)], sub {
my($sig,$trans,$makecomp) = @_;
!$makecomp ? '' : join '',
map " $_->[2] = $trans->pdls[$_->[0]];\n",
grep !$_->[1], $sig->names_sorted_tuples;
}),
(map PDL::PP::Rule::Substitute->new("${_}ReadDataCodeUnparsed", "${_}Code"), '', 'Bad'),
PDL::PP::Rule->new(PDL::PP::Code::make_args(qw(ReadData)),
sub { PDL::PP::Code->new(@_, undef, undef, 1); }),
PDL::PP::Rule::Substitute->new("ReadDataCodeSubd", "ReadDataCodeParsed"),
PDL::PP::Rule::InsertName->new("ReadDataFuncName", 'pdl_%s_readdata'),
PDL::PP::Rule->new(make_vfn_args("ReadData")),
(map PDL::PP::Rule::Substitute->new("${_}WriteBackDataCodeUnparsed", "${_}BackCode"), '', 'Bad'),
PDL::PP::Rule->new(PDL::PP::Code::make_args(qw(WriteBackData)),
sub { PDL::PP::Code->new(@_, undef, 1, 1); }),
PDL::PP::Rule::Substitute->new("WriteBackDataCodeSubd", "WriteBackDataCodeParsed"),
PDL::PP::Rule::InsertName->new("WriteBackDataFuncName", "BackCode", 'pdl_%s_writebackdata'),
PDL::PP::Rule::Returns::NULL->new("WriteBackDataFuncName", "Code"),
PDL::PP::Rule->new(make_vfn_args("WriteBackData")),
# CORE21 move this into pdlapi so RedoDims without Code can broadcast
PDL::PP::Rule->new("DefaultRedoDims",
["StructName"],
sub { "PDL_RETERROR(PDL_err, PDL->redodims_default($_[0]));\n" }),
PDL::PP::Rule->new("DimsSetters",
["SignatureObj"],
sub { $_[0]->dims_init }),
PDL::PP::Rule->new("RedoDimsFuncName", [qw(Name RedoDims? RedoDimsCode? DimsSetters)],
sub { (scalar grep $_ && /\S/, @_[1..$#_]) ? "pdl_$_[0]_redodims" : 'NULL'}),
PDL::PP::Rule::Returns->new("RedoDimsCode", [],
'Code that can be inserted to set the size of output ndarrays dynamically based on input ndarrays; is parsed',
''),
(map PDL::PP::Rule::Substitute->new("RedoDims${_}Unparsed", "RedoDims$_"), '', 'Code'),
PDL::PP::Rule->new(PDL::PP::Code::make_args(qw(RedoDims)),
'makes the parsed representation from the supplied RedoDimsCode',
sub { return '' if !$_[0]; PDL::PP::Code->new(@_, 1, undef, 0); }),
PDL::PP::Rule->new("RedoDimsCodeParsed","RedoDimsUnparsed", sub {@_}),
PDL::PP::Rule->new("RedoDims",
["DimsSetters","RedoDimsCodeParsed","DefaultRedoDims"],
'makes the redodims function from the various bits and pieces',
sub { join "\n", grep $_ && /\S/, @_ }),
PDL::PP::Rule::Substitute->new("RedoDimsCodeSubd", "RedoDims"),
PDL::PP::Rule->new(make_vfn_args("RedoDims")),
PDL::PP::Rule->new("CompFreeCode", [qw(CompObj CompFreeCodeComp?)],
"Free any OtherPars/Comp stuff, including user-supplied code (which is probably paired with own MakeComp)",
sub {join '', grep defined() && length, $_[0]->getfree("COMP"), @_[1..$#_]},
),
PDL::PP::Rule->new("NTPrivFreeCode", "PrivObj", sub {$_[0]->getfree("PRIV")}),
PDL::PP::Rule->new("FreeCodeNS",
["StructName","CompFreeCode","NTPrivFreeCode"],
sub {
(grep $_, @_[1..$#_]) ? "PDL_FREE_CODE($_[0], destroy, $_[1], $_[2])" : ''}),
PDL::PP::Rule::Substitute->new("FreeCodeSubd", "FreeCodeNS"),
PDL::PP::Rule->new("FreeFuncName",
["FreeCodeSubd","Name"],
sub {$_[0] ? "pdl_$_[1]_free" : 'NULL'}),
PDL::PP::Rule->new(make_vfn_args("Free", ", char destroy")),
PDL::PP::Rule->new("NewXSCoerceMustNS", "FTypes",
sub {
my($ftypes) = @_;
join '', map
PDL::PP::pp_line_numbers(__LINE__, "$_->datatype = $ftypes->{$_};"),
sort keys %$ftypes;
}),
PDL::PP::Rule::Returns::EmptyString->new("NewXSCoerceMustNS"),
PDL::PP::Rule::Substitute->new("NewXSCoerceMustCompSubd", "NewXSCoerceMustNS"),
PDL::PP::Rule->new("NewXSStructInit0",
["StructName","VTableName","ParamStructName","ParamStructType"],
"Rule to create and initialise the private trans structure",
sub {
my( $sname, $vtable, $pname, $ptype ) = @_;
indent(2, <<EOF . ($ptype ? "$ptype *$pname = $sname->params;\n" : ""));
if (!PDL) return (pdl_error){PDL_EFATAL, "PDL core struct is NULL, can't continue",0};
pdl_trans *$sname = PDL->create_trans(&$vtable);
if (!$sname) return PDL->make_error_simple(PDL_EFATAL, "Couldn't create trans");
EOF
}),
PDL::PP::Rule->new(["RunFunc"],
["RunFuncHdr",
"NewXSStructInit0",
"NewXSSetTransPDLs",
"NewXSTypeCoerceSubd",
"NewXSExtractTransPDLs",
"MakeCompiledReprSubd",
"NewXSCoerceMustCompSubd",
"NewXSRunTrans",
],
"Generate C function with idiomatic arg list to maybe call from XS",
sub {
my ($xs_c_header, @bits) = @_;
my $opening = ' pdl_error PDL_err = {0, NULL, 0};';
my $closing = ' return PDL_err;';
join '', "$xs_c_header {\n$opening\n", @bits, "$closing\n}\n";
}),
# internal usage, not XS - NewXSCHdrs only set if GlobalNew
PDL::PP::Rule->new(["NewXSCode","BootSetNewXS","NewXSInPrelude"],
["NewXSHdr", "NewXSCHdrs", "RunFuncCall"],
"Non-varargs XS code when GlobalNew given",
sub {(undef,(make_xs_code(' CODE:','',@_))[1..2])}),
# if PMCode supplied, no var-args stuff
PDL::PP::Rule->new(["NewXSCode","BootSetNewXS","NewXSInPrelude"],
[qw(PMCode NewXSHdr NewXSCHdrs? FixArgsXSOtherOutDeclSV HdrCode RunFuncCall FtrCode XSOtherOutSet)],
"Non-varargs XS code when PMCode given",
sub {make_xs_code(' CODE:','',@_[1..$#_])}),
PDL::PP::Rule->new(["NewXSCode","BootSetNewXS","NewXSInPrelude"],
[qw(VarArgsXSHdr NewXSCHdrs? HdrCode InplaceCode RunFuncCall FtrCode XSOtherOutSet VarArgsXSReturn)],
"Rule to print out XS code when variable argument list XS processing is enabled",
sub {make_xs_code('','',@_)}),
PDL::PP::Rule->new("VTableDef",
["VTableName","ParamStructType","RedoDimsFuncName","ReadDataFuncName",
"WriteBackDataFuncName","FreeFuncName",
"SignatureObj","HaveBroadcasting","NoPthread","Name",
"GenericTypes","IsAffineFlag","TwoWayFlag","DefaultFlowFlag",
"BadFlag"],
sub {
my($vname,$ptype,$rdname,$rfname,$wfname,$ffname,
$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 @op_flags;
push @op_flags, 'PDL_TRANS_DO_BROADCAST' if $havebroadcasting;
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');
my @realdims = map 0+@{$_->{IndObjs}}, @$pobjs{@$pnames};
my $realdims = join(", ", @realdims) || '0';
my $parnames = join(",",map qq|"$_"|, @$pnames) || '""';
my $parflags = join(",\n ",map join('|', $_->cflags)||'0', @$pobjs{@$pnames}) || '0';
my $partypes = join(", ", map defined()?$_->sym:-1, map $_->{Type}, @$pobjs{@$pnames}) || '-1';
my $i = 0; my @starts = map { my $ci = $i; $i += $_; $ci } @realdims;
my $realdim_ind_start = join(", ", @starts) || '0';
my @rd_inds = map $_->get_index, map @{$_->{IndObjs}}, @$pobjs{@$pnames};
my $realdim_inds = join(", ", @rd_inds) || '0';
my @indnames = sort $sig->dims_obj->ind_names;
my $indnames = join(",", map qq|"$_"|, @indnames) || '""';
my $sizeof = $ptype ? "sizeof($ptype)" : '0';
<<EOF;
static pdl_datatypes ${vname}_gentypes[] = { $gentypes_txt };
static PDL_Indx ${vname}_realdims[] = { $realdims };
static char *${vname}_parnames[] = { $parnames };
static short ${vname}_parflags[] = {
$parflags
};
static pdl_datatypes ${vname}_partypes[] = { $partypes };
static PDL_Indx ${vname}_realdims_starts[] = { $realdim_ind_start };
static PDL_Indx ${vname}_realdims_ind_ids[] = { $realdim_inds };
static char *${vname}_indnames[] = { $indnames };
pdl_transvtable $vname = {
$op_flags, $iflags, ${vname}_gentypes, $nparents, $npdls, NULL /*CORE21*/,
${vname}_realdims, ${vname}_parnames,
${vname}_parflags, ${vname}_partypes,
${vname}_realdims_starts, ${vname}_realdims_ind_ids, @{[scalar @rd_inds]},
@{[scalar @indnames]}, ${vname}_indnames,
$rdname, $rfname, $wfname,
$ffname,
$sizeof,"$::PDLMOD\::$name"
};
EOF
}),
PDL::PP::Rule->new('PMFunc', 'Name',
'Sets PMFunc to default symbol table manipulations',
sub {
my ($name) = @_;
$::PDL_IFBEGINWRAP[0].'*'.$name.' = \&'.$::PDLOBJ.
'::'.$name.";\n".$::PDL_IFBEGINWRAP[1]
}
),
PDL::PP::Rule->new([], [qw(Lvalue Name)],
'If Lvalue key, make the XS routine be lvalue with CvLVALUE_on',
sub {
my (undef, $name) = @_;
push @::PDL_LVALUE_SUBS, $name;
();
}
),
]; } 1;
|