Skip to content

Commit 4fa0684

Browse files
committed
add OP_ARGELEM, OP_ARGDEFELEM, OP_ARGCHECK ops
Currently subroutine signature parsing emits many small discrete ops to implement arg handling. This commit replaces them with a couple of ops per signature element, plus an initial signature check op. These new ops are added to the OP tree during parsing, so will be visible to hooks called up to and including peephole optimisation. It is intended soon that the peephole optimiser will take these per-element ops, and replace them with a single OP_SIGNATURE op which handles the whole signature in a single go. So normally these ops wont actually get executed much. But adding these intermediate-level ops gives three advantages: 1) it allows the parser to efficiently generate subtrees containing individual signature elements, which can't be done if only OP_SIGNATURE or discrete ops are available; 2) prior to optimisation, it provides a simple and straightforward representation of the signature; 3) hooks can mess with the signature OP subtree in ways that make it no longer possible to optimise into an OP_SIGNATURE, but which can still be executed, deparsed etc (if less efficiently). This code: use feature "signatures"; sub f($a, $, $b = 1, @c) {$a} under 'perl -MO=Concise,f' now gives: d <1> leavesub[1 ref] K/REFC,1 ->(end) - <@> lineseq KP ->d 1 <;> nextstate(main 84 foo:6) v:%,469762048 ->2 2 <+> argcheck(3,1,@) v ->3 3 <;> nextstate(main 81 foo:6) v:%,469762048 ->4 4 <+> argelem(0)[$a:81,84] v/SV ->5 5 <;> nextstate(main 82 foo:6) v:%,469762048 ->6 8 <+> argelem(2)[$b:82,84] vKS/SV ->9 6 <|> argdefelem(other->7)[2] sK ->8 7 <$> const(IV 1) s ->8 9 <;> nextstate(main 83 foo:6) v:%,469762048 ->a a <+> argelem(3)[@c:83,84] v/AV ->b - <;> ex-nextstate(main 84 foo:6) v:%,469762048 ->b b <;> nextstate(main 84 foo:6) v:%,469762048 ->c c <0> padsv[$a:81,84] s ->d The argcheck(3,1,@) op knows the number of positional params (3), the number of optional params (1), and whether it has an array / hash slurpy element at the end. This op is responsible for checking that @_ contains the right number of args. A simple argelem(0)[$a] op does the equivalent of 'my $a = $_[0]'. Similarly, argelem(3)[@c] is equivalent to 'my @c = @_[3..$#_]'. If it has a child, it gets its arg from the stack rather than using $_[N]. Currently the only used child is the logop argdefelem. argdefelem(other->7)[2] is equivalent to '@_ > 2 ? $_[2] : other'. [ These ops currently assume that the lexical var being introduced is undef/empty and non-magival etc. This is an incorrect assumption and is fixed in a few commits' time ]
1 parent 6cb4123 commit 4fa0684

25 files changed

+1031
-785
lines changed

dump.c

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -2514,6 +2514,7 @@ Perl_debop(pTHX_ const OP *o)
25142514
case OP_PADSV:
25152515
case OP_PADAV:
25162516
case OP_PADHV:
2517+
case OP_ARGELEM:
25172518
S_deb_padvar(aTHX_ o->op_targ, 1, 1);
25182519
break;
25192520

embed.fnc

Lines changed: 2 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -298,6 +298,7 @@ Anprd |void |croak_xs_usage |NN const CV *const cv \
298298
|NN const char *const params
299299
npr |void |croak_no_mem
300300
nprX |void |croak_popstack
301+
fnrp |void |croak_caller|NULLOK const char* pat|...
301302
fnprx |void |noperl_die|NN const char* pat|...
302303
#if defined(WIN32)
303304
norx |void |win32_croak_not_implemented|NN const char * fname
@@ -2533,7 +2534,7 @@ s |int |intuit_more |NN char *s
25332534
s |I32 |lop |I32 f|int x|NN char *s
25342535
rs |void |missingterm |NULLOK char *s
25352536
s |void |no_op |NN const char *const what|NULLOK char *s
2536-
s |int |pending_ident
2537+
s |int |pending_ident |bool is_sig
25372538
sR |I32 |sublex_done
25382539
sR |I32 |sublex_push
25392540
sR |I32 |sublex_start
@@ -2990,6 +2991,4 @@ XEop |void |dtrace_probe_op |NN const OP *op
29902991
XEop |void |dtrace_probe_phase|enum perl_phase phase
29912992
#endif
29922993

2993-
xpo |OP* |check_arity |int arity |bool max
2994-
29952994
: ex: set ts=8 sts=4 sw=4 noet:

embed.h

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1202,6 +1202,7 @@
12021202
#define core_prototype(a,b,c,d) Perl_core_prototype(aTHX_ a,b,c,d)
12031203
#define coresub_op(a,b,c) Perl_coresub_op(aTHX_ a,b,c)
12041204
#define create_eval_scope(a,b) Perl_create_eval_scope(aTHX_ a,b)
1205+
#define croak_caller Perl_croak_caller
12051206
#define croak_no_mem Perl_croak_no_mem
12061207
#define croak_popstack Perl_croak_popstack
12071208
#define custom_op_get_field(a,b) Perl_custom_op_get_field(aTHX_ a,b)
@@ -1786,7 +1787,7 @@
17861787
#define missingterm(a) S_missingterm(aTHX_ a)
17871788
#define no_op(a,b) S_no_op(aTHX_ a,b)
17881789
#define parse_ident(a,b,c,d,e,f) S_parse_ident(aTHX_ a,b,c,d,e,f)
1789-
#define pending_ident() S_pending_ident(aTHX)
1790+
#define pending_ident(a) S_pending_ident(aTHX_ a)
17901791
#define scan_const(a) S_scan_const(aTHX_ a)
17911792
#define scan_formline(a) S_scan_formline(aTHX_ a)
17921793
#define scan_heredoc(a) S_scan_heredoc(aTHX_ a)

ext/B/B.pm

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -15,7 +15,7 @@ require Exporter;
1515
# walkoptree comes from B.xs
1616

1717
BEGIN {
18-
$B::VERSION = '1.62';
18+
$B::VERSION = '1.63';
1919
@B::EXPORT_OK = ();
2020

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

ext/B/B.xs

Lines changed: 32 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1325,14 +1325,30 @@ string(o, cv)
13251325
B::CV cv
13261326
PREINIT:
13271327
SV *ret;
1328+
UNOP_AUX_item *aux;
13281329
PPCODE:
1330+
aux = cUNOP_AUXo->op_aux;
13291331
switch (o->op_type) {
13301332
case OP_MULTIDEREF:
13311333
ret = multideref_stringify(o, cv);
13321334
break;
1335+
1336+
case OP_ARGELEM:
1337+
ret = sv_2mortal(Perl_newSVpvf(aTHX_ "%"UVuf,
1338+
PTR2UV(aux)));
1339+
break;
1340+
1341+
case OP_ARGCHECK:
1342+
ret = Perl_newSVpvf(aTHX_ "%"UVuf",%"UVuf, aux[0].uv, aux[1].uv);
1343+
if (aux[2].iv)
1344+
Perl_sv_catpvf(aTHX_ ret, ",%c", (char)aux[2].iv);
1345+
ret = sv_2mortal(ret);
1346+
break;
1347+
13331348
default:
13341349
ret = sv_2mortal(newSVpvn("", 0));
13351350
}
1351+
13361352
ST(0) = ret;
13371353
XSRETURN(1);
13381354

@@ -1346,12 +1362,28 @@ void
13461362
aux_list(o, cv)
13471363
B::OP o
13481364
B::CV cv
1365+
PREINIT:
1366+
UNOP_AUX_item *aux;
13491367
PPCODE:
13501368
PERL_UNUSED_VAR(cv); /* not needed on unthreaded builds */
1369+
aux = cUNOP_AUXo->op_aux;
13511370
switch (o->op_type) {
13521371
default:
13531372
XSRETURN(0); /* by default, an empty list */
13541373

1374+
case OP_ARGELEM:
1375+
XPUSHs(sv_2mortal(newSVuv(PTR2UV(aux))));
1376+
XSRETURN(1);
1377+
break;
1378+
1379+
case OP_ARGCHECK:
1380+
EXTEND(SP, 3);
1381+
PUSHs(sv_2mortal(newSVuv(aux[0].uv)));
1382+
PUSHs(sv_2mortal(newSVuv(aux[1].uv)));
1383+
PUSHs(sv_2mortal(aux[2].iv ? Perl_newSVpvf(aTHX_ "%c",
1384+
(char)aux[2].iv) : &PL_sv_no));
1385+
break;
1386+
13551387
case OP_MULTIDEREF:
13561388
#ifdef USE_ITHREADS
13571389
# define ITEM_SV(item) *av_fetch(comppad, (item)->pad_offset, FALSE);

ext/B/B/Concise.pm

Lines changed: 7 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -14,7 +14,7 @@ use warnings; # uses #3 and #4, since warnings uses Carp
1414

1515
use Exporter (); # use #5
1616

17-
our $VERSION = "0.996";
17+
our $VERSION = "0.997";
1818
our @ISA = qw(Exporter);
1919
our @EXPORT_OK = qw( set_style set_style_standard add_callback
2020
concise_subref concise_cv concise_main
@@ -820,6 +820,7 @@ sub concise_op {
820820
$h{targarg} = join '; ', @targarg;
821821
$h{targarglife} = join '; ', @targarglife;
822822
}
823+
823824
$h{arg} = "";
824825
$h{svclass} = $h{svaddr} = $h{svval} = "";
825826
if ($h{class} eq "PMOP") {
@@ -884,6 +885,11 @@ sub concise_op {
884885
undef $lastnext;
885886
$h{arg} = "(other->" . seq($op->other) . ")";
886887
$h{otheraddr} = sprintf("%#x", $ {$op->other});
888+
if ($h{name} eq "argdefelem") {
889+
# targ used for element index
890+
$h{targarglife} = $h{targarg} = "";
891+
$h{arg} .= "[" . $op->targ . "]";
892+
}
887893
}
888894
elsif ($h{class} eq "SVOP" or $h{class} eq "PADOP") {
889895
unless ($h{name} eq 'aelemfast' and $op->flags & OPf_SPECIAL) {

ext/Opcode/Opcode.pm

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -6,7 +6,7 @@ use strict;
66

77
our($VERSION, @ISA, @EXPORT_OK);
88

9-
$VERSION = "1.35";
9+
$VERSION = "1.36";
1010

1111
use Carp;
1212
use Exporter ();
@@ -312,7 +312,7 @@ invert_opset function.
312312
av2arylen
313313
314314
rv2hv helem hslice kvhslice each values keys exists delete
315-
aeach akeys avalues multideref
315+
aeach akeys avalues multideref argelem argdefelem argcheck
316316
317317
preinc i_preinc predec i_predec postinc i_postinc
318318
postdec i_postdec int hex oct abs pow multiply i_multiply

lib/B/Deparse.pm

Lines changed: 61 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -46,7 +46,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
4646
MDEREF_SHIFT
4747
);
4848

49-
$VERSION = '1.37';
49+
$VERSION = '1.38';
5050
use strict;
5151
use vars qw/$AUTOLOAD/;
5252
use warnings ();
@@ -1256,6 +1256,11 @@ Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
12561256
push @ops, $o;
12571257
}
12581258
$body = $self->lineseq(undef, 0, @ops).";";
1259+
if ($ops[-1]->name =~ /^(next|db)state$/) {
1260+
# this handles void context in
1261+
# use feature signatures; sub ($=1) {}
1262+
$body .= "\n()";
1263+
}
12591264
my $scope_en = $self->find_scope_en($lineseq);
12601265
if (defined $scope_en) {
12611266
my $subs = join"", $self->seq_subs($scope_en);
@@ -5772,6 +5777,61 @@ sub pp_lvavref {
57725777
: &pp_padsv) . ')'
57735778
}
57745779

5780+
5781+
sub pp_argcheck {
5782+
my $self = shift;
5783+
my($op, $cx) = @_;
5784+
my ($params, $opt_params, $slurpy) = $op->aux_list($self->{curcv});
5785+
my $mandatory = $params - $opt_params;
5786+
my $check = '';
5787+
5788+
$check .= <<EOF if !$slurpy;
5789+
die sprintf("Too many arguments for subroutine at %s line %d.\\n", (caller)[1, 2]) unless \@_ <= $params;
5790+
EOF
5791+
5792+
$check .= <<EOF if $mandatory > 0;
5793+
die sprintf("Too few arguments for subroutine at %s line %d.\\n", (caller)[1, 2]) unless \@_ >= $mandatory;
5794+
EOF
5795+
5796+
my $cond = ($params & 1) ? 'unless' : 'if';
5797+
$check .= <<EOF if $slurpy eq '%';
5798+
die sprintf("Odd name/value argument for subroutine at %s line %d.\\n", (caller)[1, 2]) if \@_ > $params && ((\@_ - $params) & 1);
5799+
EOF
5800+
5801+
$check =~ s/;\n\z//;
5802+
return $check;
5803+
}
5804+
5805+
5806+
sub pp_argelem {
5807+
my $self = shift;
5808+
my($op, $cx) = @_;
5809+
my $var = $self->padname($op->targ);
5810+
my $ix = $op->string($self->{curcv});
5811+
my $expr;
5812+
if ($op->flags & OPf_KIDS) {
5813+
$expr = $self->deparse($op->first, 7);
5814+
}
5815+
elsif ($var =~ /^[@%]/) {
5816+
$expr = $ix ? "\@_[$ix .. \$#_]" : '@_';
5817+
}
5818+
else {
5819+
$expr = "\$_[$ix]";
5820+
}
5821+
return "my $var = $expr";
5822+
}
5823+
5824+
5825+
sub pp_argdefelem {
5826+
my $self = shift;
5827+
my($op, $cx) = @_;
5828+
my $ix = $op->targ;
5829+
my $expr = "\@_ >= " . ($ix+1) . " ? \$_[$ix] : ";
5830+
$expr .= $self->deparse($op->first, $cx);
5831+
return $expr;
5832+
}
5833+
5834+
57755835
1;
57765836
__END__
57775837

lib/B/Op_private.pm

Lines changed: 29 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -207,6 +207,17 @@ my @bf = (
207207
bitmax => 7,
208208
bitmask => 255,
209209
},
210+
{
211+
mask_def => 'OPpARGELEM_MASK',
212+
bitmin => 1,
213+
bitmax => 2,
214+
bitmask => 6,
215+
enum => [
216+
0, 'OPpARGELEM_SV', 'SV',
217+
1, 'OPpARGELEM_AV', 'AV',
218+
2, 'OPpARGELEM_HV', 'HV',
219+
],
220+
},
210221
{
211222
mask_def => 'OPpDEREF',
212223
bitmin => 4,
@@ -237,7 +248,7 @@ $bits{abs}{0} = $bf[0];
237248
@{$bits{accept}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
238249
@{$bits{add}}{1,0} = ($bf[1], $bf[1]);
239250
$bits{aeach}{0} = $bf[0];
240-
@{$bits{aelem}}{5,4,1,0} = ($bf[7], $bf[7], $bf[1], $bf[1]);
251+
@{$bits{aelem}}{5,4,1,0} = ($bf[8], $bf[8], $bf[1], $bf[1]);
241252
@{$bits{aelemfast}}{7,6,5,4,3,2,1,0} = ($bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6]);
242253
@{$bits{aelemfast_lex}}{7,6,5,4,3,2,1,0} = ($bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6]);
243254
$bits{akeys}{0} = $bf[0];
@@ -247,6 +258,9 @@ $bits{andassign}{0} = $bf[0];
247258
$bits{anonconst}{0} = $bf[0];
248259
@{$bits{anonhash}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
249260
@{$bits{anonlist}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
261+
$bits{argcheck}{0} = $bf[0];
262+
$bits{argdefelem}{0} = $bf[0];
263+
@{$bits{argelem}}{2,1,0} = ($bf[7], $bf[7], $bf[0]);
250264
@{$bits{atan2}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
251265
$bits{av2arylen}{0} = $bf[0];
252266
$bits{avalues}{0} = $bf[0];
@@ -290,7 +304,7 @@ $bits{each}{0} = $bf[0];
290304
@{$bits{entereval}}{5,4,3,2,1,0} = ('OPpEVAL_RE_REPARSING', 'OPpEVAL_COPHH', 'OPpEVAL_BYTES', 'OPpEVAL_UNICODE', 'OPpEVAL_HAS_HH', $bf[0]);
291305
$bits{entergiven}{0} = $bf[0];
292306
$bits{enteriter}{3} = 'OPpITER_DEF';
293-
@{$bits{entersub}}{5,4,0} = ($bf[7], $bf[7], 'OPpENTERSUB_INARGS');
307+
@{$bits{entersub}}{5,4,0} = ($bf[8], $bf[8], 'OPpENTERSUB_INARGS');
294308
$bits{entertry}{0} = $bf[0];
295309
$bits{enterwhen}{0} = $bf[0];
296310
@{$bits{enterwrite}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
@@ -361,7 +375,7 @@ $bits{grepwhile}{0} = $bf[0];
361375
@{$bits{gsockopt}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
362376
@{$bits{gt}}{1,0} = ($bf[1], $bf[1]);
363377
$bits{gv}{5} = 'OPpEARLY_CV';
364-
@{$bits{helem}}{5,4,1,0} = ($bf[7], $bf[7], $bf[1], $bf[1]);
378+
@{$bits{helem}}{5,4,1,0} = ($bf[8], $bf[8], $bf[1], $bf[1]);
365379
$bits{hex}{0} = $bf[0];
366380
@{$bits{i_add}}{1,0} = ($bf[1], $bf[1]);
367381
@{$bits{i_divide}}{1,0} = ($bf[1], $bf[1]);
@@ -409,7 +423,7 @@ $bits{log}{0} = $bf[0];
409423
$bits{lstat}{0} = $bf[0];
410424
@{$bits{lt}}{1,0} = ($bf[1], $bf[1]);
411425
$bits{lvavref}{0} = $bf[0];
412-
@{$bits{lvref}}{5,4,0} = ($bf[8], $bf[8], $bf[0]);
426+
@{$bits{lvref}}{5,4,0} = ($bf[9], $bf[9], $bf[0]);
413427
$bits{mapstart}{0} = $bf[0];
414428
$bits{mapwhile}{0} = $bf[0];
415429
$bits{method}{0} = $bf[0];
@@ -443,7 +457,7 @@ $bits{orassign}{0} = $bf[0];
443457
$bits{ord}{0} = $bf[0];
444458
@{$bits{pack}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
445459
@{$bits{padrange}}{6,5,4,3,2,1,0} = ($bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5]);
446-
@{$bits{padsv}}{5,4} = ($bf[7], $bf[7]);
460+
@{$bits{padsv}}{5,4} = ($bf[8], $bf[8]);
447461
@{$bits{pipe_op}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
448462
$bits{pop}{0} = $bf[0];
449463
$bits{pos}{0} = $bf[0];
@@ -464,7 +478,7 @@ $bits{readlink}{0} = $bf[0];
464478
@{$bits{recv}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]);
465479
$bits{redo}{0} = $bf[0];
466480
$bits{ref}{0} = $bf[0];
467-
@{$bits{refassign}}{5,4,1,0} = ($bf[8], $bf[8], $bf[1], $bf[1]);
481+
@{$bits{refassign}}{5,4,1,0} = ($bf[9], $bf[9], $bf[1], $bf[1]);
468482
$bits{refgen}{0} = $bf[0];
469483
$bits{regcmaybe}{0} = $bf[0];
470484
$bits{regcomp}{0} = $bf[0];
@@ -480,9 +494,9 @@ $bits{rewinddir}{0} = $bf[0];
480494
$bits{rmdir}{0} = $bf[0];
481495
$bits{rv2av}{0} = $bf[0];
482496
@{$bits{rv2cv}}{7,5,0} = ('OPpENTERSUB_NOPAREN', 'OPpMAY_RETURN_CONSTANT', $bf[0]);
483-
@{$bits{rv2gv}}{6,5,4,2,0} = ('OPpALLOW_FAKE', $bf[7], $bf[7], 'OPpDONT_INIT_GV', $bf[0]);
497+
@{$bits{rv2gv}}{6,5,4,2,0} = ('OPpALLOW_FAKE', $bf[8], $bf[8], 'OPpDONT_INIT_GV', $bf[0]);
484498
$bits{rv2hv}{0} = $bf[0];
485-
@{$bits{rv2sv}}{5,4,0} = ($bf[7], $bf[7], $bf[0]);
499+
@{$bits{rv2sv}}{5,4,0} = ($bf[8], $bf[8], $bf[0]);
486500
@{$bits{sassign}}{7,6,1,0} = ('OPpASSIGN_CV_TO_GV', 'OPpASSIGN_BACKWARDS', $bf[1], $bf[1]);
487501
@{$bits{sbit_and}}{1,0} = ($bf[1], $bf[1]);
488502
@{$bits{sbit_or}}{1,0} = ($bf[1], $bf[1]);
@@ -571,6 +585,10 @@ our %defines = (
571585
OPpARG2_MASK => 3,
572586
OPpARG3_MASK => 7,
573587
OPpARG4_MASK => 15,
588+
OPpARGELEM_AV => 2,
589+
OPpARGELEM_HV => 4,
590+
OPpARGELEM_MASK => 6,
591+
OPpARGELEM_SV => 0,
574592
OPpASSIGN_BACKWARDS => 64,
575593
OPpASSIGN_COMMON_AGG => 16,
576594
OPpASSIGN_COMMON_RC1 => 32,
@@ -665,6 +683,9 @@ our %defines = (
665683

666684
our %labels = (
667685
OPpALLOW_FAKE => 'FAKE',
686+
OPpARGELEM_AV => 'AV',
687+
OPpARGELEM_HV => 'HV',
688+
OPpARGELEM_SV => 'SV',
668689
OPpASSIGN_BACKWARDS => 'BKWARD',
669690
OPpASSIGN_COMMON_AGG => 'COM_AGG',
670691
OPpASSIGN_COMMON_RC1 => 'COM_RC1',

0 commit comments

Comments
 (0)