$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';
$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)],
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];
}
}
}
@
@=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.
@ # field as raw bits and not try to interpret it.
@ label => 'FOO',
@
-@ # If present, specifies the names of some defines and the dis-
-@ # play labels that are used to assign meaning to particular inte-
-@ # ger values within the bit field; e.g. 3 is displayed as 'C'.
+@ # If present, specifies the names of some defines and the
+@ # display labels that are used to assign meaning to particu-
+@ # lar integer values within the bit field; e.g. 3 is dis-
+@ # played as 'C'.
@ enum => [ qw(
@ 1 OPpFOO_A A
@ 2 OPpFOO_B B
@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;
# 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;
next unless defined $e;
next if ref $e; # bit field, not flag
push @{$combos{$e}{$bit}}, $op;
+ push @{$ops_using{$e}}, $op;
}
}
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";
+
}
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) {
}
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;
if (%not_seen) {
die "panic: unprocessed ops: ". join(',', keys %not_seen);
}
+ for (@seen_bitdefs) {
+ local $" = ", ";
+ $PL_op_private_bitdefs .= " $$_[1], /* @$_[2..$#$_] */\n";
+ }
}
/* 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):
'%', 11, # baseop_or_unop
'-', 12, # filestatop
'}', 13, # loopexop
+ '.', 14, # methop
+ '+', 15, # unop_aux
);
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 $_
);
my %OP_IS_FT_ACCESS; # /F-+/
my %OP_IS_NUMCOMPARE; # /S</
my %OP_IS_DIRHOP; # /Fd/
+my %OP_IS_INFIX_BIT; # /S\|/
my $OCSHIFT = 8;
my $OASHIFT = 12;
$OP_IS_FILETEST{$op} = $opnum{$op} if $arg =~ s/-//;
$OP_IS_FT_ACCESS{$op} = $opnum{$op} if $arg =~ s/\+//;
}
- elsif ($arg =~ /^S</) {
+ elsif ($arg =~ /^S./) {
$OP_IS_NUMCOMPARE{$op} = $opnum{$op} if $arg =~ s/<//;
+ $OP_IS_INFIX_BIT {$op} = $opnum{$op} if $arg =~ s/\|//;
}
my $argnum = ($arg =~ s/\?//) ? 8 : 0;
die "op = $op, arg = $arg\n"
gen_op_is_macro( \%OP_IS_FT_ACCESS, 'OP_IS_FILETEST_ACCESS');
gen_op_is_macro( \%OP_IS_NUMCOMPARE, 'OP_IS_NUMCOMPARE');
gen_op_is_macro( \%OP_IS_DIRHOP, 'OP_IS_DIRHOP');
+gen_op_is_macro( \%OP_IS_INFIX_BIT, 'OP_IS_INFIX_BIT');
sub gen_op_is_macro {
my ($op_is, $macname) = @_;
++$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";
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.
https://perl5.git.perl.org / perl5.git / blobdiff