Skip to content

Commit 0f590aa

Browse files
leonerdleonerd
committed
Create new OP_MULTIPARAM to implement subroutine signatures
Creates a new UNOP_AUX op type, `OP_MULTIPARAM`, that handles all of the initial behaviour of assigning values to parameters of a subroutine signature out of values passed by the caller. This is created in a similar style to other multi-ops like `OP_MULTIDEREF` and `OP_MULTICONCAT` where the op's aux structure contains a sub-program of sorts, which describes all of the small details of operation. Also adds a LOGOP, `OP_PARAMTEST` and UNOP `OP_PARAMSTORE` which are responsible for implementing the default expressions of optional parameters. These use the `SvPADSTALE` flag set on pad lexicals used as parameters to remember whether assignment has happened, ensuring that missing vs present-but-undef can be detected in a way that does not depend on counting arguments on the stack. This change is carefully designed to support two future ideas: * Named parameters as per PPC0024 https://github.com/Perl/PPCs/blob/main/ppcs/ppc0024-signature-named-parameters.md * "no-snails"; the performance optimisation that avoids storing incoming argument values in the `@_` AV and instead consumes them directly from the stack
1 parent 126bf84 commit 0f590aa

File tree

19 files changed

+645
-86
lines changed

19 files changed

+645
-86
lines changed

‎dump.c‎

Lines changed: 30 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1663,6 +1663,7 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o,
16631663
case OP_ENTERWHEN:
16641664
case OP_ENTERTRY:
16651665
case OP_ONCE:
1666+
case OP_PARAMTEST:
16661667
S_opdump_indent(aTHX_ o, level, bar, file, "OTHER");
16671668
S_opdump_link(aTHX_ o, cLOGOPo->op_other, file);
16681669
break;
@@ -1780,6 +1781,35 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o,
17801781
break;
17811782
}
17821783

1784+
case OP_MULTIPARAM:
1785+
{
1786+
struct op_multiparam_aux *aux = (struct op_multiparam_aux *)cUNOP_AUXo->op_aux;
1787+
UV min_args = aux->min_args;
1788+
UV n_positional = aux->n_positional;
1789+
if(n_positional > min_args)
1790+
S_opdump_indent(aTHX_ o, level, bar, file, "ARGS = %" UVuf " .. %" UVuf "\n",
1791+
min_args, n_positional);
1792+
else
1793+
S_opdump_indent(aTHX_ o, level, bar, file, "ARGS = %" UVuf "\n",
1794+
min_args);
1795+
1796+
for(Size_t i = 0; i < n_positional; i++) {
1797+
PADOFFSET padix = aux->param_padix[i];
1798+
if(padix)
1799+
S_opdump_indent(aTHX_ o, level, bar, file, " PARAM [%zd] PADIX = %" UVuf "%s\n",
1800+
i, aux->param_padix[i], i >= min_args ? " OPT" : "");
1801+
else
1802+
S_opdump_indent(aTHX_ o, level, bar, file, " PARAM [%zd] ANON\n",
1803+
i);
1804+
}
1805+
1806+
if(aux->slurpy)
1807+
S_opdump_indent(aTHX_ o, level, bar, file, "SLURPY = '%c' PADIX = %" UVuf "\n",
1808+
aux->slurpy, aux->slurpy_padix);
1809+
1810+
break;
1811+
}
1812+
17831813
case OP_CUSTOM:
17841814
{
17851815
void (*custom_dumper)(pTHX_ const OP *o, struct Perl_OpDumpContext *ctx) =

‎ext/B/B.pm‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -20,7 +20,7 @@ sub import {
2020
# walkoptree comes from B.xs
2121

2222
BEGIN {
23-
$B::VERSION = '1.89';
23+
$B::VERSION = '1.90';
2424
@B::EXPORT_OK = ();
2525

2626
# Our BOOT code needs $VERSION set, and will append to @EXPORT_OK.

‎ext/B/B.xs‎

Lines changed: 14 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1393,6 +1393,20 @@ aux_list(o, cv)
13931393
XSRETURN(len);
13941394

13951395
} /* OP_MULTIDEREF */
1396+
1397+
case OP_MULTIPARAM:
1398+
{
1399+
struct op_multiparam_aux *p = (struct op_multiparam_aux *)aux;
1400+
UV nparams = p->n_positional;
1401+
EXTEND(SP, (IV)(3 + nparams + 1));
1402+
mPUSHu(p->min_args);
1403+
mPUSHu(p->n_positional);
1404+
PUSHs(sv_2mortal(p->slurpy ? newSVpvf("%c", p->slurpy) : &PL_sv_no));
1405+
for(UV parami = 0; parami < nparams; parami++)
1406+
mPUSHu(p->param_padix[parami]);
1407+
mPUSHu(p->slurpy_padix);
1408+
XSRETURN(3 + nparams + 1);
1409+
}
13961410
} /* switch */
13971411

13981412

‎ext/Opcode/Opcode.pm‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,4 @@
1-
package Opcode 1.69;
1+
package Opcode 1.70;
22

33
use strict;
44

@@ -309,6 +309,7 @@ invert_opset function.
309309
310310
rv2hv helem hslice kvhslice each values keys exists delete
311311
aeach akeys avalues multideref argelem argdefelem argcheck
312+
multiparam paramtest paramstore
312313
313314
preinc i_preinc predec i_predec postinc i_postinc
314315
postdec i_postdec int hex oct abs pow multiply i_multiply

‎ext/XS-APItest/APItest.xs‎

Lines changed: 23 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1200,6 +1200,29 @@ static OP *THX_parse_keyword_subsignature(pTHX)
12001200
newSVpvf(kid->op_flags & OPf_KIDS ? "argelem:%s:d" : "argelem:%s", namepv)));
12011201
break;
12021202
}
1203+
case OP_MULTIPARAM: {
1204+
struct op_multiparam_aux *p =
1205+
(struct op_multiparam_aux *)(cUNOP_AUXx(kid)->op_aux);
1206+
PADNAMELIST *names = PadlistNAMES(CvPADLIST(find_runcv(0)));
1207+
SV *retsv = newSVpvf("multiparam:%" UVuf "..%" UVuf ":%c",
1208+
p->min_args, p->n_positional, p->slurpy ? p->slurpy : '-');
1209+
for (UV paramidx = 0; paramidx < p->n_positional; paramidx++) {
1210+
char *namepv = PadnamePV(padnamelist_fetch(names, p->param_padix[paramidx]));
1211+
if(namepv)
1212+
sv_catpvf(retsv, ":%s=%" UVf, namepv, paramidx);
1213+
else
1214+
sv_catpvf(retsv, ":(anon)=%" UVf, paramidx);
1215+
if(paramidx >= p->min_args)
1216+
sv_catpvs(retsv, "?");
1217+
}
1218+
if (p->slurpy_padix)
1219+
sv_catpvf(retsv, ":%s=*",
1220+
PadnamePV(padnamelist_fetch(names, p->slurpy_padix)));
1221+
retop = op_append_list(OP_LIST, retop, newSVOP(OP_CONST, 0, retsv));
1222+
break;
1223+
}
1224+
case OP_PARAMTEST:
1225+
break;
12031226
default:
12041227
fprintf(stderr, "TODO: examine kid %p (optype=%s)\n", kid, PL_op_name[kid->op_type]);
12051228
break;

‎ext/XS-APItest/t/subsignature.t‎

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -19,11 +19,11 @@ eval q{
1919
};
2020
is $@, "";
2121
is_deeply \@t, [
22-
['nextstate:4', 'argcheck:2:0:-', 'argelem:$x', 'argelem:$y'],
23-
['nextstate:5', 'argcheck:2:0:-', 'argelem:$z',],
24-
['nextstate:6', 'argcheck:0:0:@', 'argelem:@rest'],
25-
['nextstate:7', 'argcheck:0:0:%', 'argelem:%rest'],
26-
['nextstate:8', 'argcheck:1:1:-', 'argelem:$one:d'],
22+
['nextstate:4', 'multiparam:2..2:-:$x=0:$y=1' ],
23+
['nextstate:5', 'multiparam:2..2:-:$z=0:(anon)=1',],
24+
['nextstate:6', 'multiparam:0..0:@:@rest=*'],
25+
['nextstate:7', 'multiparam:0..0:%:%rest=*'],
26+
['nextstate:8', 'multiparam:0..1:-:$one=0?'],
2727
];
2828

2929
done_testing;

‎lib/B/Deparse.pm‎

Lines changed: 91 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -26,6 +26,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
2626
OPpMULTICONCAT_APPEND OPpMULTICONCAT_STRINGIFY OPpMULTICONCAT_FAKE
2727
OPpTRUEBOOL OPpINDEX_BOOLNEG OPpDEFER_FINALLY
2828
OPpARG_IF_UNDEF OPpARG_IF_FALSE
29+
OPpPARAM_IF_UNDEF OPpPARAM_IF_FALSE
2930
SVf_IOK SVf_NOK SVf_ROK SVf_POK SVf_FAKE SVs_RMG SVs_SMG
3031
SVs_PADTMP
3132
CVf_NOWARN_AMBIGUOUS CVf_LVALUE CVf_IsMETHOD
@@ -1180,6 +1181,94 @@ sub pad_subs {
11801181
}
11811182

11821183

1184+
# deparse_multiparam(): deparse, if possible, a sequence of ops into a
1185+
# subroutine signature. If possible, returns a string representing the
1186+
# signature syntax, minus the surrounding parentheses.
1187+
1188+
sub deparse_multiparam {
1189+
my ($self, $topop, $cv) = @_;
1190+
1191+
$topop = $topop->first;
1192+
return unless $$topop and $topop->name eq 'lineseq';
1193+
1194+
# last op should be nextstate
1195+
my $last = $topop->last;
1196+
return unless $$last
1197+
and ( _op_is_or_was($last, OP_NEXTSTATE)
1198+
or _op_is_or_was($last, OP_DBSTATE));
1199+
1200+
# first OP_NEXTSTATE
1201+
1202+
my $o = $topop->first;
1203+
return unless $$o;
1204+
return if $o->label;
1205+
1206+
# OP_MULTIPARAM
1207+
1208+
$o = $o->sibling;
1209+
return unless $$o and $o->name eq 'multiparam';
1210+
1211+
my ($min_args, $max_args, $slurpy, @rest) = $o->aux_list($cv);
1212+
my $nparams = $max_args;
1213+
my @param_padix = splice @rest, 0, $nparams, ();
1214+
my ($slurpy_padix) = @rest;
1215+
1216+
my @sig;
1217+
my %parami_for_padix;
1218+
1219+
# Initial scalars
1220+
foreach my $parami ( 0 .. $max_args-1 ) {
1221+
my $padix = $param_padix[$parami];
1222+
$sig[$parami] = $self->padname($padix) || '$';
1223+
$parami_for_padix{$padix} = $parami;
1224+
}
1225+
1226+
$o = $o->sibling;
1227+
for (; $o and !null $o; $o = $o->sibling) {
1228+
# Look for OP_NULL[OP_PARAMTEST[OP_PARAMSTORE]]
1229+
my $ofirst;
1230+
if ($o->name eq 'null' and $o->flags & OPf_KIDS and
1231+
($ofirst = $o->first)->name eq 'paramtest' and
1232+
$ofirst->first->name eq 'paramstore') {
1233+
# A defaulting expression
1234+
1235+
my $parami = $parami_for_padix{$ofirst->targ};
1236+
1237+
my $assign = "=";
1238+
$assign = "//=" if $ofirst->private == OPpPARAM_IF_UNDEF;
1239+
$assign = "||=" if $ofirst->private == OPpPARAM_IF_FALSE;
1240+
1241+
length $sig[$parami] > 1 ?
1242+
( $sig[$parami] .= ' ' ) :
1243+
( $sig[$parami] = '$' ); # intentionally no trailing space
1244+
1245+
my $defop = $ofirst->first->first;
1246+
if ($defop->name eq "stub") {
1247+
$sig[$parami] .= "$assign";
1248+
}
1249+
else {
1250+
my $def = $self->deparse($defop, 7);
1251+
$def = "($def)" if $defop->flags & OPf_PARENS;
1252+
1253+
$sig[$parami] .= "$assign $def";
1254+
}
1255+
}
1256+
}
1257+
1258+
if ($cv->CvFLAGS & CVf_IsMETHOD) {
1259+
# Remove the implied `$self` argument
1260+
warn "Expected first signature argument to be named \$self"
1261+
unless @sig and $sig[0] eq '$self';
1262+
shift @sig;
1263+
}
1264+
1265+
if ($slurpy) {
1266+
push @sig, $slurpy_padix ? $self->padname($slurpy_padix) : $slurpy;
1267+
}
1268+
1269+
return join(", ", @sig);
1270+
}
1271+
11831272
# deparse_argops(): deparse, if possible, a sequence of argcheck + argelem
11841273
# ops into a subroutine signature. If successful, return the first op
11851274
# following the signature ops plus the signature string; else return the
@@ -1377,7 +1466,8 @@ Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
13771466
and $firstop->name eq 'null'
13781467
and $firstop->targ == OP_ARGCHECK
13791468
) {
1380-
my ($mysig) = $self->deparse_argops($firstop, $cv);
1469+
my ($mysig) = $self->deparse_multiparam($firstop, $cv) //
1470+
$self->deparse_argops($firstop, $cv);
13811471
if (defined $mysig) {
13821472
$sig = $mysig;
13831473
$firstop = $is_list ? $firstop->sibling : undef;

‎lib/B/Op_private.pm‎

Lines changed: 9 additions & 0 deletions
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

0 commit comments

Comments
 (0)