X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/2febb45ac8fe9a31602934af3d9c14587543a3d9..6985230a6e9dafc0b356186a2513961407efe2da:/regen/opcode.pl diff --git a/regen/opcode.pl b/regen/opcode.pl index ee71935..edb9f4d 100755 --- a/regen/opcode.pl +++ b/regen/opcode.pl @@ -55,7 +55,7 @@ while () { $args = '' unless defined $args; warn qq[Description "$desc" duplicates $seen{$desc}\n] - if $seen{$desc} and $key !~ "transr|(?:intro|clone)cv"; + if $seen{$desc} and $key !~ "transr|(?:intro|clone)cv|lvref"; die qq[Opcode "$key" duplicates $seen{$key}\n] if $seen{$key}; die qq[Opcode "freed" is reserved for the slab allocator\n] if $key eq 'freed'; @@ -71,14 +71,14 @@ while () { $args{$key} = $args; } -# Set up aliases +# Set up aliases, and alternative funcs -my %alias; +my (%alias, %alts); # Format is "this function" => "does these op names" my @raw_alias = ( Perl_do_kv => [qw( keys values )], - Perl_unimplemented_op => [qw(padany mapstart custom)], + Perl_unimplemented_op => [qw(padany custom)], # All the ops with a body of { return NORMAL; } Perl_pp_null => [qw(scalar regcmaybe lineseq scope)], @@ -122,29 +122,42 @@ my @raw_alias = ( Perl_pp_shift => ['pop'], Perl_pp_sin => [qw(cos exp log sqrt)], Perl_pp_bit_or => ['bit_xor'], + Perl_pp_nbit_or => ['nbit_xor'], + Perl_pp_sbit_or => ['sbit_xor'], Perl_pp_rv2av => ['rv2hv'], Perl_pp_akeys => ['avalues'], - Perl_pp_rkeys => [qw(rvalues reach)], Perl_pp_trans => [qw(trans transr)], Perl_pp_chop => [qw(chop chomp)], Perl_pp_schop => [qw(schop schomp)], Perl_pp_bind => {connect => '#ifdef HAS_SOCKET'}, - Perl_pp_preinc => ['i_preinc', 'predec', 'i_predec'], - Perl_pp_postinc => ['i_postinc', 'postdec', 'i_postdec'], + Perl_pp_preinc => ['i_preinc'], + Perl_pp_predec => ['i_predec'], + Perl_pp_postinc => ['i_postinc'], + Perl_pp_postdec => ['i_postdec'], Perl_pp_ehostent => [qw(enetent eprotoent eservent spwent epwent sgrent egrent)], Perl_pp_shostent => [qw(snetent sprotoent sservent)], Perl_pp_aelemfast => ['aelemfast_lex'], + Perl_pp_grepstart => ['mapstart'], + + # 2 i_modulo mappings: 2nd is alt, needs 1st (explicit default) to not override the default + Perl_pp_i_modulo => ['i_modulo'], + Perl_pp_i_modulo_glibc_bugfix => { + 'i_modulo' => + '#if defined(__GLIBC__) && IVSIZE == 8 '. + ' && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8))' }, ); while (my ($func, $names) = splice @raw_alias, 0, 2) { if (ref $names eq 'ARRAY') { foreach (@$names) { - $alias{$_} = [$func, '']; + defined $alias{$_} + ? $alts{$_} : $alias{$_} = [$func, '']; } } else { while (my ($opname, $cond) = each %$names) { - $alias{$opname} = [$func, $cond]; + defined $alias{$opname} + ? $alts{$opname} : $alias{$opname} = [$func, $cond]; } } } @@ -408,11 +421,12 @@ sub print_B_Op_private { @ @=head1 DESCRIPTION @ -@This module provides three global hashes: +@This module provides four global hashes: @ @ %B::Op_private::bits @ %B::Op_private::defines @ %B::Op_private::labels +@ %B::Op_private::ops_using @ @which contain information about the per-op meanings of the bits in the @op_private field. @@ -480,6 +494,13 @@ sub print_B_Op_private { @If the label equals '-', then Concise will treat the bit as a raw bit and @not try to display it symbolically. @ +@=head2 C<%ops_using> +@ +@For each define, this gives a reference to an array of op names that use +@the flag. +@ +@ @ops_using_lvintro = @{ $B::Op_private::ops_using{OPp_LVAL_INTRO} }; +@ @=cut package B::Op_private; @@ -490,6 +511,10 @@ EOF # remove podcheck.t-defeating leading char $header =~ s/^\@//gm; print $fh $header; + my $v = (::perl_version())[3]; + print $fh qq{\nour \$VERSION = "$v";\n\n}; + + my %ops_using; # for each flag/bit combination, find the ops which use it my %combos; @@ -500,6 +525,7 @@ EOF next unless defined $e; next if ref $e; # bit field, not flag push @{$combos{$e}{$bit}}, $op; + push @{$ops_using{$e}}, $op; } } @@ -603,6 +629,24 @@ EOF printf $fh " %-23s => '%s',\n", $_ , $LABELS{$_} for sort keys %LABELS; print $fh ");\n"; + # %ops_using + print $fh "\n\nour %ops_using = (\n"; + # Save memory by using the same array wherever possible. + my %flag_by_op_list; + my $pending = ''; + for my $flag (sort keys %ops_using) { + my $op_list = $ops_using{$flag} = "@{$ops_using{$flag}}"; + if (!exists $flag_by_op_list{$op_list}) { + $flag_by_op_list{$op_list} = $flag; + printf $fh " %-23s => %s,\n", $flag , "[qw($op_list)]" + } + else { + $pending .= "\$ops_using{$flag} = " + . "\$ops_using{$flag_by_op_list{$op_list}};\n"; + } + } + print $fh ");\n\n$pending"; + } @@ -683,6 +727,8 @@ sub print_PL_op_private_tables { my $bitdef_count = 0; my %not_seen = %FLAGS; + my @seen_bitdefs; + my %seen_bitdefs; my $opnum = -1; for my $op (sort { $opnum{$a} <=> $opnum{$b} } keys %opnum) { @@ -722,11 +768,17 @@ sub print_PL_op_private_tables { } if (@bitdefs) { $bitdefs[-1] |= 1; # stop bit - $index = $bitdef_count; - $bitdef_count += @bitdefs; - $PL_op_private_bitdefs .= sprintf " /* %-13s */ %s,\n", - $op, - join(', ', map(sprintf("0x%04x", $_), @bitdefs)); + my $key = join(', ', map(sprintf("0x%04x", $_), @bitdefs)); + if (!$seen_bitdefs{$key}) { + $index = $bitdef_count; + $bitdef_count += @bitdefs; + push @seen_bitdefs, + $seen_bitdefs{$key} = [$index, $key]; + } + else { + $index = $seen_bitdefs{$key}[0]; + } + push @{$seen_bitdefs{$key}}, $op; } else { $index = -1; @@ -736,6 +788,10 @@ sub print_PL_op_private_tables { if (%not_seen) { die "panic: unprocessed ops: ". join(',', keys %not_seen); } + for (@seen_bitdefs) { + local $" = ", "; + $PL_op_private_bitdefs .= " $$_[1], /* @$_[2..$#$_] */\n"; + } } @@ -799,7 +855,7 @@ $PL_op_private_labels /* PL_op_private_bitfields[]: details about each bit field type. - * Each defintition consists of the following list of words: + * Each definition consists of the following list of words: * bitmin * label (index into PL_op_private_labels[]; -1 if no label) * repeat for each enum entry (if any): @@ -1069,6 +1125,8 @@ my %opclass = ( '%', 11, # baseop_or_unop '-', 12, # filestatop '}', 13, # loopexop + '.', 14, # methop + '+', 15, # unop_aux ); my %opflags = ( @@ -1079,7 +1137,7 @@ my %opflags = ( 'T' => 8 | 16, # ... which may be lexical 'i' => 0, # always produces integer (unused since e7311069) 'I' => 32, # has corresponding int op - 'd' => 64, # danger, unknown side effects + 'd' => 64, # danger, make temp copy in list assignment 'u' => 128, # defaults to $_ ); @@ -1088,6 +1146,7 @@ my %OP_IS_FILETEST; # /F-/ my %OP_IS_FT_ACCESS; # /F-+/ my %OP_IS_NUMCOMPARE; # /S', ++$funcs{$name}; } print $pp "PERL_CALLCONV OP *$_(pTHX);\n" foreach sort keys %funcs; + + print $pp "\n/* alternative functions */\n" if keys %alts; + for my $fn (sort keys %alts) { + my ($x, $cond) = @{$alts{$fn}}; + print $pp "$cond\n" if $cond; + print $pp "PERL_CALLCONV OP *$x(pTHX);\n"; + print $pp "#endif\n" if $cond; + } } print $oc "\n\n"; @@ -1211,58 +1280,3 @@ foreach ($oc, $on, $pp, $oprivpm) { read_only_bottom_close_and_rename($_); } -# Some comments about 'T' opcode classifier: - -# Safe to set if the ppcode uses: -# tryAMAGICbin, tryAMAGICun, SETn, SETi, SETu, PUSHn, PUSHTARG, SETTARG, -# SETs(TARG), XPUSHn, XPUSHu, - -# Unsafe to set if the ppcode uses dTARG or [X]RETPUSH[YES|NO|UNDEF] - -# lt and friends do SETs (including ncmp, but not scmp) - -# Additional mode of failure: the opcode can modify TARG before it "used" -# all the arguments (or may call an external function which does the same). -# If the target coincides with one of the arguments ==> kaboom. - -# pp.c pos substr each not OK (RETPUSHUNDEF) -# substr vec also not OK due to LV to target (are they???) -# ref not OK (RETPUSHNO) -# trans not OK (dTARG; TARG = sv_newmortal();) -# ucfirst etc not OK: TMP arg processed inplace -# quotemeta not OK (unsafe when TARG == arg) -# each repeat not OK too due to list context -# pack split - unknown whether they are safe -# sprintf: is calling do_sprintf(TARG,...) which can act on TARG -# before other args are processed. - -# Suspicious wrt "additional mode of failure" (and only it): -# schop, chop, postinc/dec, bit_and etc, negate, complement. - -# Also suspicious: 4-arg substr, sprintf, uc/lc (POK_only), reverse, pack. - -# substr/vec: doing TAINT_off()??? - -# pp_hot.c -# readline - unknown whether it is safe -# match subst not OK (dTARG) -# grepwhile not OK (not always setting) -# join not OK (unsafe when TARG == arg) - -# Suspicious wrt "additional mode of failure": concat (dealt with -# in ck_sassign()), join (same). - -# pp_ctl.c -# mapwhile flip caller not OK (not always setting) - -# pp_sys.c -# backtick glob warn die not OK (not always setting) -# warn not OK (RETPUSHYES) -# open fileno getc sysread syswrite ioctl accept shutdown -# ftsize(etc) readlink telldir fork alarm getlogin not OK (RETPUSHUNDEF) -# umask select not OK (XPUSHs(&PL_sv_undef);) -# fileno getc sysread syswrite tell not OK (meth("FILENO" "GETC")) -# sselect shm* sem* msg* syscall - unknown whether they are safe -# gmtime not OK (list context) - -# Suspicious wrt "additional mode of failure": warn, die, select.