![]() |
![]()
| ![]() |
![]()
$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;
|