Skip to content
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
30 changes: 30 additions & 0 deletions dump.c
Original file line number Diff line number Diff line change
Expand Up @@ -1665,6 +1665,7 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o,
case OP_ENTERWHEN:
case OP_ENTERTRY:
case OP_ONCE:
case OP_PARAMTEST:
S_opdump_indent(aTHX_ o, level, bar, file, "OTHER");
S_opdump_link(aTHX_ o, cLOGOPo->op_other, file);
break;
Expand Down Expand Up @@ -1782,6 +1783,35 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o,
break;
}

case OP_MULTIPARAM:
{
struct op_multiparam_aux *aux = (struct op_multiparam_aux *)cUNOP_AUXo->op_aux;
UV min_args = aux->min_args;
UV n_positional = aux->n_positional;
if(n_positional > min_args)
S_opdump_indent(aTHX_ o, level, bar, file, "ARGS = %" UVuf " .. %" UVuf "\n",
min_args, n_positional);
else
S_opdump_indent(aTHX_ o, level, bar, file, "ARGS = %" UVuf "\n",
min_args);

for(Size_t i = 0; i < n_positional; i++) {
PADOFFSET padix = aux->param_padix[i];
if(padix)
S_opdump_indent(aTHX_ o, level, bar, file, " PARAM [%zd] PADIX = %" UVuf "%s\n",
i, aux->param_padix[i], i >= min_args ? " OPT" : "");
else
S_opdump_indent(aTHX_ o, level, bar, file, " PARAM [%zd] ANON\n",
i);
}

if(aux->slurpy)
S_opdump_indent(aTHX_ o, level, bar, file, "SLURPY = '%c' PADIX = %" UVuf "\n",
aux->slurpy, aux->slurpy_padix);

break;
}

case OP_CUSTOM:
{
void (*custom_dumper)(pTHX_ const OP *o, struct Perl_OpDumpContext *ctx) =
Expand Down
2 changes: 1 addition & 1 deletion ext/B/B.pm
Original file line number Diff line number Diff line change
Expand Up @@ -20,7 +20,7 @@ sub import {
# walkoptree comes from B.xs

BEGIN {
$B::VERSION = '1.89';
$B::VERSION = '1.90';
@B::EXPORT_OK = ();

# Our BOOT code needs $VERSION set, and will append to @EXPORT_OK.
Expand Down
14 changes: 14 additions & 0 deletions ext/B/B.xs
Original file line number Diff line number Diff line change
Expand Up @@ -1393,6 +1393,20 @@ aux_list(o, cv)
XSRETURN(len);

} /* OP_MULTIDEREF */

case OP_MULTIPARAM:
{
struct op_multiparam_aux *p = (struct op_multiparam_aux *)aux;
UV nparams = p->n_positional;
EXTEND(SP, (IV)(3 + nparams + 1));
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Add the MEXTEND mortal stack stretcher macro here too.

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

The other cases (OP_MULTIDEREF, OP_MULTICONCAT) don't do those either; I was following similar structure. Perhaps in a separate commit we could add that later. Though this is only during B's inspection, it's not a hot performance path. I think the slight performance cost is fine for the simpler code.

Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Just because bad code exists elsewhere in core already, is not a reason to copy the bad code to new code in new places and cite the bad code as proof your new code is correct because nobody had to time to refactor the bad code over the years.

Write new code correctly to the Perl C API the first time so nobody has to clean it up after you.

nparams is a fixed known ahead length. realloc() the mortal stack ONCE with MEXTEND() and don't bounds check and then possibly grow the stack in units of 1 SV* at a time, on every iteration through the loop.

Its as silly as writing this in C.

STRLEN i=1;
STRLEN nparams;
char * pv = SvPV(sv, nparams);
char * ptr = malloc(1);
while (i <= nparams) {
    ptr = realloc(ptr, i++);
}

mPUSHu(p->min_args);
mPUSHu(p->n_positional);
PUSHs(sv_2mortal(p->slurpy ? newSVpvf("%c", p->slurpy) : &PL_sv_no));
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Why run a 1 byte long string through a printf engine?

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Because offhand I don't believe we have a newSVpvc function. Can you suggest an alternative?

Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

newSVpvn(&p->slurpy, 1)?

Also, why are we mortalizing PL_sv_no? Couldn't we do this (warning: untested code, written in the browser):

PUSHs(p->slurpy ? newSVpvn_flags(&p->slurpy, 1, SVs_TEMP) : &PL_sv_no);

Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Very true, there is missing Perl in C infrastructure in this area. I've seen various builds from various decades of Spidermonkey/V8 having all 1 char long string objects, fo all of low 7 bit printable ASCII or 0x00-0x7F ,pre-generated burned into HW RO memory as C structs. Perl 5 calls it a SvIMMORTAL. Its funny because demerphq very quietly added something similar for all of 1 char long, 0x00-0xff, to Perl 5, like 8 years ago, but its always # define off by default and nobody has paid attention to the feature ever since. And Configure/config.h doesn't know about it.

So currently in perl 5, there are 2 normalish ways to do this. and maybe 1 @bulk88 high-speed way to do this, I'd have to research if the cpan visible exported constant array I'm thinking could be inside libperl actually exists.

I'd say option 1 is see 60% of the time, option 2 is 40% in core.

normal option 1

char c = 'z';
sv = newpvn(&c, 1);

normal option 2

sv = newpvn(" ", STRLENs(" ")); // or sv = newpvn("\0", STRLENs("\0"));
SvPVX(sv)[0] = 'z'; // safe b/c we know the above isn't going to do
// COW tricks on us (and if it does it probably needs another dedicated name)
// ive personally smoke tested with only 2 lines SEGVing after a make test
//  in all of blead where newSVpvs("some hw const c str");
// doesn't make a Newx() block inside SvPVX() but a
// SvLEN() == 0 no cow or SvLEN() == 0  with COW
// POSIX::.pm's 2000+ newCONSTSUB_flags() calls on initial load
//  badly needs this for `SvPVX(cv)`'s buffer which is always 1 byte long string `""`
// not 2000 16 byte Newx() blocks with CUR=0 and LEN=16.

bulk option that probably doesn't exist inside libperl, lack of infrastructure

    // below probably needs to be CPAN visible, if the fantasy wishlist feature
    // of nukeing a module's *main::MyPkg:: and then de-mmaping the
    // XS .so and .dll files from address space at any time actually was
    // safe, we'd rather not have CPAN shared libs creating this kind of
    // SV * POK with a "dbl quote" hardware literal string from their .rodata
    // instead of libperl's .rodata if we can help it

    const char ** PL_1_ch_strs[256] = {..... ,"1", "2", "3", ....   "a", "b", "c", ,,,,};
    sv = newSVtype(SVt_PV);
    //calling this below is really bad, this whole sequence needs a dedicated Perl_newSV*() func
    // or some more secret bitfield flags for Perl_newSVpvn_flags();
    // or don't be scared and just use SvPV_set(); SvCUR_set(); yourself
    // SvLEN_set(,0); i belive is redundant, the body allocators zero out
    // SV body all non ghost fields IME
    usepvn(sv, PL_1_ch_strs[c], 1, SV_I_DID_ADD_THE_NUL_CHAR);
    SvLEN(sv, 0);
    SvFLAGS(sv) |= (SVf_ISCOW | SVs_STATIC);

Copy link
Contributor

@bulk88 bulk88 Aug 15, 2025

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

For better infrastructure, most or all src code instance of "abcd", "abc", "ab", "a" need to be exterminated. Those are not strings, they are call integers or CPU registers.

sv = newSVpvc('exit');
sv = newSVpvc('INIT');

See what I did?

All LE CPU will need a secret byte order flipper macro inside the #define newSVpvc(_chrs) macro.

The real .i machine code decl of the above is

extern SV* Perl_newSVpvc_x(pTHX_ U32 chrs);
sv = newSVpvc('exitexit');

isn't ISO C and way too rare as a vendor extension to pretend that (a U64 multi char literal) exists anywhere on any C compiler Perl can target now, historically, or in the future.

sv = newSVpvc8('exit','exit');

is possible, day code we have such rapid short string comparison/parsing macros. newSVpvc8 internally on i386 is

extern SV* Perl_newSVpvc8u32x2_x(pTHX_ U32 chrlo, U32 chrhi);

and on x64

extern SV* Perl_newSVpvc8u64_x(pTHX_ U64 chrs);

https://www.altium.com/ 's ISO C99 compliant compiler for ARM32/64 has uint2_t, uint3_t, uint7_t, and a whole bunch of funny stuff built into its official C grammar/BNF notation file. Its non-ISO extensions are all GCC-style syntax.

https://valhalla.altium.com/Learning-Guides/GU0122%20C-to-Hardware%20Compiler%20User%20Manual.pdf

I want to crack a joke after reading its entire manual, if Perl 5 was compiled with that C compiler, the output will binary describing transistor gates. There is now a Perl CPU executing the Perl ISA. The Perl CPU's socket pins are an RS-232 serial port called STDIN.

I'm not sure after reading that C compiler's manual and IDE, if Altium can generate an ELF/EFI binary of ARM machine code or not or it only generates transistor gates for random unmodified desktop POSIX software, and that transistor gate language can only execute in BOCHS or QEMU, or be emailed to Taiwan to get back as an actual microchip (big $$$).

Altium's C99 compiler has USA and EU govt certificates to generate GUI-aware binaries that draw automobile digital speedometers and aircraft pilot LCD GUIs. Enough said who their customers are. The last time I rented a Nissan, I found out the radio was a 5 year old no-Google Android 6.0 OS, on a "this year" 4 month old car.

Nissan bought the cheapest android SOC chips they could find, that were heading to be melted or burned anyway, because they were obsolete, and nobody, not at any cost, will solder them into a phone, not even a $40 phone.

The Nissans's dashboard has a 1 way serial port that pushes data to Android 6 (tire pressure icon, etc), the radio has absolutely no electrical way to talk back to the GUI on the instrument console. Proper design IMO.

for(UV parami = 0; parami < nparams; parami++)
mPUSHu(p->param_padix[parami]);
mPUSHu(p->slurpy_padix);
XSRETURN(3 + nparams + 1);
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

replace with PUTBACK; return;

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Again, just following similarity with the other cases.

Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This is dangerous C code.

XSRETURN() is only for use with with the ST(1234) absolute index assignment macro.
or these macros

#define XST_mIV(i,v)  (ST(i) = sv_2mortal(newSViv(v))  )
#define XST_mUV(i,v)  (ST(i) = sv_2mortal(newSVuv(v))  )
#define XST_mNV(i,v)  (ST(i) = sv_2mortal(newSVnv(v))  )
#define XST_mPV(i,v)  (ST(i) = sv_2mortal(newSVpv(v,0)))
#define XST_mPVN(i,v,n)  (ST(i) = newSVpvn_flags(v,n, SVs_TEMP))
#define XST_mNO(i)    (ST(i) = &PL_sv_no   )
#define XST_mYES(i)   (ST(i) = &PL_sv_yes  )
#define XST_mUNDEF(i) (ST(i) = &PL_sv_undef)

_*_PUSH_*_() class macros are already tracking the number of SV*you wrote to your portion of the stack.

You"ve never read
https://perldoc.perl.org/perlxs#Returning-SVs,-AVs-and-HVs-through-RETVAL
or
https://perldoc.perl.org/perlguts#Subroutines
before writing this huge commit.

I wouldn't blame anyone for saying those 2 sections are unreadable, because the first time I read them a long time ago they were unreadable to me. In 2025 they are still unreadable for me. They confuse new people more than they help new people.

So if after reading the official API docs, you still don't understand, go watch my videos on how to use the Perl Stack https://www.youtube.com/results?search_query=%22Writing+XS+in+Plain+C%22

I included graphics explaining it.

}
} /* switch */


Expand Down
3 changes: 2 additions & 1 deletion ext/Opcode/Opcode.pm
Original file line number Diff line number Diff line change
@@ -1,4 +1,4 @@
package Opcode 1.69;
package Opcode 1.70;

use strict;

Expand Down Expand Up @@ -309,6 +309,7 @@ invert_opset function.
rv2hv helem hslice kvhslice each values keys exists delete
aeach akeys avalues multideref argelem argdefelem argcheck
multiparam paramtest paramstore
preinc i_preinc predec i_predec postinc i_postinc
postdec i_postdec int hex oct abs pow multiply i_multiply
Expand Down
2 changes: 1 addition & 1 deletion ext/XS-APItest/APItest.pm
Original file line number Diff line number Diff line change
Expand Up @@ -4,7 +4,7 @@ use strict;
use warnings;
use Carp;

our $VERSION = '1.44';
our $VERSION = '1.45';

require XSLoader;

Expand Down
23 changes: 23 additions & 0 deletions ext/XS-APItest/APItest.xs
Original file line number Diff line number Diff line change
Expand Up @@ -1200,6 +1200,29 @@ static OP *THX_parse_keyword_subsignature(pTHX)
newSVpvf(kid->op_flags & OPf_KIDS ? "argelem:%s:d" : "argelem:%s", namepv)));
break;
}
case OP_MULTIPARAM: {
struct op_multiparam_aux *p =
(struct op_multiparam_aux *)(cUNOP_AUXx(kid)->op_aux);
PADNAMELIST *names = PadlistNAMES(CvPADLIST(find_runcv(0)));
SV *retsv = newSVpvf("multiparam:%" UVuf "..%" UVuf ":%c",
p->min_args, p->n_positional, p->slurpy ? p->slurpy : '-');
for (UV paramidx = 0; paramidx < p->n_positional; paramidx++) {
char *namepv = PadnamePV(padnamelist_fetch(names, p->param_padix[paramidx]));
if(namepv)
sv_catpvf(retsv, ":%s=%" UVf, namepv, paramidx);
else
sv_catpvf(retsv, ":(anon)=%" UVf, paramidx);
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

#define PadnamePV(pn)		(pn)->xpadn_pv
#define PadnameLEN(pn)		(pn)->xpadn_len
#define PadnameUTF8(pn)		1
#define PadnameSV(pn) newSVpvn_flags(PadnamePV(pn), PadnameLEN(pn), SVs_TEMP|SVf_UTF8)

":(anon)=%" can be de-duped to 1 branch above with ":(%s)=%". "anon",

in theory PadnameLEN(pn) and sv_catXXX() family calls should be taken advantage of here, rather than repeatedly going through the printf engine.

IDK and IDC enough, and probably its impossible to write a bug ticket with a failure/defect demo, about it, but I see UTF8 flag is perma-on in the data source API, but we arent propagating it to the higher level. And this is XS::APItest anyways, so perfection isnt critical. but someone might look at this in the future for "best practices" ideas, and then copy paste quicky hacky code into a more visible API.

if(paramidx >= p->min_args)
sv_catpvs(retsv, "?");
}
if (p->slurpy_padix)
sv_catpvf(retsv, ":%s=*",
PadnamePV(padnamelist_fetch(names, p->slurpy_padix)));
retop = op_append_list(OP_LIST, retop, newSVOP(OP_CONST, 0, retsv));
break;
}
case OP_PARAMTEST:
break;
default:
fprintf(stderr, "TODO: examine kid %p (optype=%s)\n", kid, PL_op_name[kid->op_type]);
break;
Expand Down
10 changes: 5 additions & 5 deletions ext/XS-APItest/t/subsignature.t
Original file line number Diff line number Diff line change
Expand Up @@ -19,11 +19,11 @@ eval q{
};
is $@, "";
is_deeply \@t, [
['nextstate:4', 'argcheck:2:0:-', 'argelem:$x', 'argelem:$y'],
['nextstate:5', 'argcheck:2:0:-', 'argelem:$z',],
['nextstate:6', 'argcheck:0:0:@', 'argelem:@rest'],
['nextstate:7', 'argcheck:0:0:%', 'argelem:%rest'],
['nextstate:8', 'argcheck:1:1:-', 'argelem:$one:d'],
['nextstate:4', 'multiparam:2..2:-:$x=0:$y=1' ],
['nextstate:5', 'multiparam:2..2:-:$z=0:(anon)=1',],
['nextstate:6', 'multiparam:0..0:@:@rest=*'],
['nextstate:7', 'multiparam:0..0:%:%rest=*'],
['nextstate:8', 'multiparam:0..1:-:$one=0?'],
];

done_testing;
94 changes: 92 additions & 2 deletions lib/B/Deparse.pm
Original file line number Diff line number Diff line change
Expand Up @@ -7,7 +7,7 @@
# This is based on the module of the same name by Malcolm Beattie,
# but essentially none of his code remains.

package B::Deparse 1.86;
package B::Deparse 1.87;
use strict;
use Carp;
use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
Expand All @@ -26,6 +26,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
OPpMULTICONCAT_APPEND OPpMULTICONCAT_STRINGIFY OPpMULTICONCAT_FAKE
OPpTRUEBOOL OPpINDEX_BOOLNEG OPpDEFER_FINALLY
OPpARG_IF_UNDEF OPpARG_IF_FALSE
OPpPARAM_IF_UNDEF OPpPARAM_IF_FALSE
SVf_IOK SVf_NOK SVf_ROK SVf_POK SVf_FAKE SVs_RMG SVs_SMG
SVs_PADTMP
CVf_NOWARN_AMBIGUOUS CVf_LVALUE CVf_IsMETHOD
Expand Down Expand Up @@ -1180,6 +1181,94 @@ sub pad_subs {
}


# deparse_multiparam(): deparse, if possible, a sequence of ops into a
# subroutine signature. If possible, returns a string representing the
# signature syntax, minus the surrounding parentheses.

sub deparse_multiparam {
my ($self, $topop, $cv) = @_;

$topop = $topop->first;
return unless $$topop and $topop->name eq 'lineseq';

# last op should be nextstate
my $last = $topop->last;
return unless $$last
and ( _op_is_or_was($last, OP_NEXTSTATE)
or _op_is_or_was($last, OP_DBSTATE));

# first OP_NEXTSTATE

my $o = $topop->first;
return unless $$o;
return if $o->label;

# OP_MULTIPARAM

$o = $o->sibling;
return unless $$o and $o->name eq 'multiparam';

my ($min_args, $max_args, $slurpy, @rest) = $o->aux_list($cv);
my $nparams = $max_args;
my @param_padix = splice @rest, 0, $nparams, ();
my ($slurpy_padix) = @rest;

my @sig;
my %parami_for_padix;

# Initial scalars
foreach my $parami ( 0 .. $max_args-1 ) {
my $padix = $param_padix[$parami];
$sig[$parami] = $self->padname($padix) || '$';
$parami_for_padix{$padix} = $parami;
}

$o = $o->sibling;
for (; $o and !null $o; $o = $o->sibling) {
# Look for OP_NULL[OP_PARAMTEST[OP_PARAMSTORE]]
my $ofirst;
if ($o->name eq 'null' and $o->flags & OPf_KIDS and
($ofirst = $o->first)->name eq 'paramtest' and
$ofirst->first->name eq 'paramstore') {
# A defaulting expression

my $parami = $parami_for_padix{$ofirst->targ};

my $assign = "=";
$assign = "//=" if $ofirst->private == OPpPARAM_IF_UNDEF;
$assign = "||=" if $ofirst->private == OPpPARAM_IF_FALSE;

length $sig[$parami] > 1 ?
( $sig[$parami] .= ' ' ) :
( $sig[$parami] = '$' ); # intentionally no trailing space
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

dont look up same thing over and over in an array, do a $sref = \$sig[$parami]; or $s = $sig[$parami];. probably the first is easier in this sub.

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

The performance improvement of that indirection will be absolutely miniscule given this is deparse of a signatured sub; hardly a hot path. I prefer the clarity of the code as written.

Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

ok, you can click close / hide on your side for this bubble.


my $defop = $ofirst->first->first;
if ($defop->name eq "stub") {
$sig[$parami] .= "$assign";
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

y the ""s?

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Symmetry with the other case below.

Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Quoting poorly written old doesn't make it right.

You don't need "Name $name\n" interpolation here so don't use "dbl" quotes. Perl Parser/yylex/toke.c have to do more work on startup to parse a "" string lit vs a '' string lit. Perl 5 doesn't have AOT compilation.

I have no idea how $sig[$parami] .= "$assign"; is any different from $sig[$parami] .= $assign;. It looks like a bug.

If .= "$assign"; has a technical rational like XSS/bobby drop tables/GetMagic/overload.pm/taint -T, you need to document it the technical reason for future people to know.

}
else {
my $def = $self->deparse($defop, 7);
$def = "($def)" if $defop->flags & OPf_PARENS;

$sig[$parami] .= "$assign $def";
}
}
}

if ($cv->CvFLAGS & CVf_IsMETHOD) {
# Remove the implied `$self` argument
warn "Expected first signature argument to be named \$self"
unless @sig and $sig[0] eq '$self';
shift @sig;
}

if ($slurpy) {
push @sig, $slurpy_padix ? $self->padname($slurpy_padix) : $slurpy;
}

return join(", ", @sig);
}

# deparse_argops(): deparse, if possible, a sequence of argcheck + argelem
# ops into a subroutine signature. If successful, return the first op
# following the signature ops plus the signature string; else return the
Expand Down Expand Up @@ -1377,7 +1466,8 @@ Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
and $firstop->name eq 'null'
and $firstop->targ == OP_ARGCHECK
) {
my ($mysig) = $self->deparse_argops($firstop, $cv);
my ($mysig) = $self->deparse_multiparam($firstop, $cv) //
$self->deparse_argops($firstop, $cv);
if (defined $mysig) {
$sig = $mysig;
$firstop = $is_list ? $firstop->sibling : undef;
Expand Down
9 changes: 9 additions & 0 deletions lib/B/Op_private.pm

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

Loading
Loading