PDL::PP(3)
PDL::PP(3) 💅 — bestie, it's the Perl Data Language preprocessor and she's serving source code
okay so this is PDL::PP(3) from the User Contributed Perl Documentation, and part 1 is literally the raw Perl guts. every single character is staying exactly where it is, no cap. ✨
🎀 first up: the $miscdocs situation
$miscdocs
XXX=cut
EOD
$baddoc_function_pod =~ s/^XXX=/=/gms;
$baddoc_function_pod;
}
),
okay so that's the opening move. then we get two PDL::PP::Rule::Returns::EmptyString rules — one for HdrCode, one for FtrCode. 💖
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'),
slay. now the big one: VarArgsXSHdr. this is the main character of part 1, lowkey. 👑
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;
}),
okay that was a lot, but we ate. next: the # globalnew implies internal usage, not XS comment, then FixArgsXSOtherOutDeclSV, XSOtherOutSet, and VarArgsXSReturn. 💅
# 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") : '';
}),
then we get NewXSHdr, RunFuncName, NewXSCHdrs, and the RunFuncCall/RunFuncHdr duo. 🦋
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)");
}),
and finally for part 1: IgnoreTypesOf, NewXSTypeCoerceNS, NewXSTypeCoerceSubd, NewXSRunTrans, and the StructDecl / ParamStructType situation. 👑
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);
}),and that's where part 1 ends, bestie. part 2 is loading…
okay bestie we're back and we are STILL deep in the rule table 💅 and honestly? this is my favourite genre of source code: a compiler writing down its own recipes. every single PDL::PP::Rule->new(...) down there is PDL::PP telling itself how to generate your glue code later. no cap, all of it ends up in your .xs file one way or another ✨
first up, the vfn factory — a do block that defines two subs and then calls itself, handing back a little pile of rules:
do { sub wrap_vfn {
my (
$code,$rout,$func_header,
$all_func_header,$sname,$pname,$ptype,$extra_args,
) = @_;
join "", PDL::PP::pp_line_numbers(__LINE__, qq[pdl_error
$rout(pdl_trans *$sname$extra_args) {
pdl_error PDL_err = {0, NULL, 0};]),
($ptype ? " $ptype *$pname = $sname->params; (void)$pname;\n" :
''),
indent(2, join '', grep $_, $all_func_header, $func_header, $code),
" return PDL_err;\n}"; } sub make_vfn_args {
my ($which, $extra_args) = @_;
("${which}Func",
["${which}CodeSubd","${which}FuncName","${which}FuncHeader?",
qw(AllFuncHeader? StructName ParamStructName ParamStructType),
],
sub {$_[1] eq 'NULL' ? '' : wrap_vfn(@_,$extra_args//'')}
); } ()},so wrap_vfn grabs $code, $rout, $func_header, $all_func_header, $sname, $pname, $ptype and $extra_args, and stitches a whole C function together out of them 💖 it opens with pdl_error $rout(pdl_trans *$sname$extra_args) { plus pdl_error PDL_err = {0, NULL, 0}; — wrapped in PDL::PP::pp_line_numbers(__LINE__, ...) so your compiler yells at the Perl line that made the mess, which is genuinely iconic 🫶 then, only if $ptype is truthy, it slips in $ptype *$pname = $sname->params; (void)$pname;, indents everything by 2 with indent(2, ...), and closes with return PDL_err;\n}. chef's kiss.
and make_vfn_args is the lil' helper that mints a rule literally named ${which}Func — for example ReadDataFunc — with the arg list ["${which}CodeSubd","${which}FuncName","${which}FuncHeader?", qw(AllFuncHeader? StructName ParamStructName ParamStructType)], and a sub that returns '' when $_[1] is 'NULL' and otherwise calls wrap_vfn(@_,$extra_args//''). btw notice all the ?s sprinkled on those names — the table has a whole convention for them, iykyk. 😌
next: the compiled-representation bits, and the glue that shuffles your ndarrays in and out of the trans struct 🌸
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;
}),so MakeCompOther builds the per-parameter getcopy for $_[1]->%s off the signature, MakeCompTotal just joins the non-empty bits with newlines, and MakeCompiledReprSubd is a Substitute rule that turns MakeCompTotal into MakeCompiledReprSubd. very "assemble the thing, then alias it" of them 💅
NewXSSetTransPDLs walks $sig->names_sorted_tuples, keeps the ones where !$_->[1], and emits $trans->pdls[$_->[0]] = $_->[2]; for each — that's loading your args into the trans. NewXSExtractTransPDLs is the mirror image: if $makecomp is falsy it returns '', otherwise it flips the assignment the other way, $_->[2] = $trans->pdls[$_->[0]];. 🦋
then the data-access virtual functions, both of which go through that make_vfn_args helper from up top:
(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")),for reading: a Substitute from ${_}ReadDataCodeUnparsed to ${_}Code (empty string as the default, 'Bad' as the... well, that's the third arg right there), a PDL::PP::Code->new(@_, undef, undef, 1) for the parsed form, ReadDataCodeSubd substituting into ReadDataCodeParsed, and an InsertName giving you pdl_%s_readdata. then the vfn. 🎀
for writing back: same shape, but ${_}WriteBackDataCodeUnparsed ← ${_}BackCode, PDL::PP::Code->new(@_, undef, 1, 1), WriteBackDataCodeSubd → WriteBackDataCodeParsed, and the function name is pdl_%s_writebackdata. there's a Returns::NULL rule that flattens WriteBackDataFuncName and Code to nothing, and then the vfn. 😭
RedoDims time, aka "how big is the output, actually":
# 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")),DefaultRedoDims emits PDL_RETERROR(PDL_err, PDL->redodims_default($_[0]));\n — and there's a # CORE21 note in the source saying this should move into pdlapi so that a RedoDims without Code can broadcast. DimsSetters is just $_[0]->dims_init off the signature. RedoDimsFuncName checks whether anything in RedoDims?, RedoDimsCode?, DimsSetters is truthy and non-whitespace, and if so names the function pdl_$_[0]_redodims, else 'NULL'.
the RedoDimsCode rule carries the description "Code that can be inserted to set the size of output ndarrays dynamically based on input ndarrays; is parsed" and an empty default — bestie, that's the whole point of this block, you get to compute output dims from your inputs 💖 it's parsed, so it's real PP code, not vibes. then RedoDims${_}Unparsed substitutes into RedoDims$_ with default '' and kind 'Code', the make_args rule turns the supplied RedoDimsCode into a parsed representation via PDL::PP::Code->new(@_, 1, undef, 0) — or '' if you gave nothing — and RedoDimsCodeParsed is a pass-through of RedoDimsUnparsed (sub {@_}). RedoDims itself glues DimsSetters, RedoDimsCodeParsed and DefaultRedoDims together with newlines, keeping only the lines that actually have content. RedoDimsCodeSubd aliases it, and the vfn closes the loop. periodt. 🌈
freeing stuff, because memory hygiene is self-care 🧚:
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")),CompFreeCode does what it says on the tin — "Free any OtherPars/Comp stuff, including user-supplied code (which is probably paired with own MakeComp)" — by concatenating $_[0]->getfree("COMP") with the optional CompFreeCodeComp?, keeping only the defined, non-empty bits. NTPrivFreeCode is the PrivObj twin, $_[0]->getfree("PRIV").
FreeCodeNS bundles StructName, CompFreeCode and NTPrivFreeCode into a PDL_FREE_CODE($_[0], destroy, $_[1], $_[2]) — but only if at least one of those pieces is truthy, otherwise you get ''. FreeCodeSubd aliases it, FreeFuncName names it pdl_$_[1]_free (or 'NULL'), and the vfn gets built with the extra args ", char destroy". so your free function signature literally ends in , char destroy and that's not a drill 💀
coercion, then the struct setup and the run function:
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"),NewXSCoerceMustNS takes the FTypes hash, sorts its keys, and for each one emits a line-numbered $_->datatype = $ftypes->{$_};. then Returns::EmptyString blanks out the rule name, and NewXSCoerceMustCompSubd substitutes it in. slay ✨
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";
}),NewXSStructInit0 is the "Rule to create and initialise the private trans structure" — it builds a 2-space-indented heredoc that bails with (pdl_error){PDL_EFATAL, "PDL core struct is NULL, can't continue",0} if PDL is NULL, then does pdl_trans *$sname = PDL->create_trans(&$vtable); and errors with PDL->make_error_simple(PDL_EFATAL, "Couldn't create trans") if that failed. and if you gave a $ptype, it tacks on $ptype *$pname = $sname->params;. 🫶
RunFunc is the big one — "Generate C function with idiomatic arg list to maybe call from XS" — and it chains RunFuncHdr, NewXSStructInit0, NewXSSetTransPDLs, NewXSTypeCoerceSubd, NewXSExtractTransPDLs, MakeCompiledReprSubd, NewXSCoerceMustCompSubd and NewXSRunTrans in that exact order. it wraps the whole thing in $xs_c_header {\n + pdl_error PDL_err = {0, NULL, 0}; and closes with return PDL_err; + }\n. the arg list is literally my ($xs_c_header, @bits) = @_; — cute. 🎀
the XS code rules, three of them, and there's a very important comment at the top:
# 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('','',@_)}),the first is marked # internal usage, not XS - NewXSCHdrs only set if GlobalNew and it's the "Non-varargs XS code when GlobalNew given" rule — it calls make_xs_code(' CODE:','',@_) and keeps [1..2], with undef out front. the second is "Non-varargs XS code when PMCode given", and the comment above it says # if PMCode supplied, no var-args stuff — it just calls make_xs_code(' CODE:','',@_[1..$#_]). the third is "Rule to print out XS code when variable argument list XS processing is enabled" and it calls make_xs_code('','',@_) with no ' CODE:' at all. 🙈
and now the crown jewel 👑 the VTableDef rule — this is the thing that literally writes out your pdl_transvtable:
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
}),okay so it pulls in the vtable name, the param struct type, all four vfn names, the signature, HaveBroadcasting, NoPthread, Name, GenericTypes, IsAffineFlag, TwoWayFlag, DefaultFlowFlag and BadFlag, and then computes everything. it counts $nparents as the params that aren't FlagW, $npdls as the total param count, and builds @op_flags by pushing PDL_TRANS_DO_BROADCAST if $havebroadcasting, PDL_TRANS_BADPROCESS if $badflag, PDL_TRANS_BADIGNORE if $badflag is defined and false, PDL_TRANS_NO_PARALLEL if $noPthreadFlag, and PDL_TRANS_OUTPUT_OTHERPAR if $sig->other_any_out — all joined with |, or '0'. 🦋
$iflags is $affflag, $revflag and $flowflag joined with | (or '0'), $gentypes_txt maps every generic type through PDL::Type->new($_)->sym and appends -1, @realdims counts the IndObjs per param, $parnames quotes the param names, $parflags joins each param's cflags with | (defaulting to '0') and separates entries with ,\n , and $partypes maps each param's Type to its sym (or -1). then @starts accumulates running offsets, @rd_inds grabs every index id, @indnames sorts the dims object's ind_names, and $sizeof is "sizeof($ptype)" or '0'. all of that pours into a heredoc that defines ${vname}_gentypes, ${vname}_realdims, ${vname}_parnames, ${vname}_parflags, ${vname}_partypes, ${vname}_realdims_starts, ${vname}_realdims_ind_ids and ${vname}_indnames arrays, and finally the pdl_transvtable $vname = { ... } — with that little NULL /*CORE21*/ sitting right in the middle, and "$::PDLMOD\::$name" as the last field. genuinely iconic, no notes 💅
last one, and it's a lil' baby:
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]
}
),PMFunc takes Name and is described as "Sets PMFunc to default symbol table manipulations" — it wraps '*'.$name.' = \&'.$::PDLOBJ.'::'.$name.";\n" in $::PDL_IFBEGINWRAP[0] and $::PDL_IFBEGINWRAP[1] so the alias lands inside the right conditional guard. short, sweet, does exactly one thing. periodt. 💜
...and the final rule slides in like it owns the place 👑 it's the Lvalue one, and it's literally the last thing this list does before the whole shebang wraps up:
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;bestie the 1; at the end is not optional, that's the whole "yes this module loaded successfully" moment 💅 iconic, required, periodt.
and that's the entire page, start to finish, no crumbs left behind 🍓✨ this beauty ships as part of perl v5.42.0, dated 2025-07-25 — so if you ever need to cite it, that's your source and your date right there 🫶 go build something unhinged with PDL::PP, you've got this 💖🦋
📦 where this page comes from
- fedora 43: perl-PDL 2.100.0-3.fc43 · GPL-1.0-or-later OR Artistic-1.0-Perl
- 💖 girlified by deepseek-ai/DeepSeek-V4.1-Flash on : a language model's rewrite of the original, under its terms