BEGIN {
# Get function prototypes
- require 'regen/regen_lib.pl';
+ require './regen/regen_lib.pl';
}
my $oc = open_new('opcode.h', '>',
my %seen;
my (@ops, %desc, %check, %ckname, %flags, %args, %opnum);
-open OPS, 'regen/opcodes' or die $!;
+open OPS, '<', 'regen/opcodes' or die $!;
while (<OPS>) {
chop;
$args = '' unless defined $args;
warn qq[Description "$desc" duplicates $seen{$desc}\n]
- if $seen{$desc} and $key !~ "transr|(?:intro|clone)cv|lvref";
+ if $seen{$desc} and $key !~ "concat|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];
}
}
}
my $flag_name = shift @args;
my $flag_label = shift @args;
add_label($flag_name, $flag_label);
- croak "addbits(): bit $bits of $op already specified"
+ croak "addbits(): bit $bits of $op already specified ($FLAGS{$op}{$bits})"
if defined $FLAGS{$op}{$bits};
$FLAGS{$op}{$bits} = $flag_name;
add_define($flag_name, (1 << $bits));
}
for my $bit ($bitmin..$bitmax) {
- croak "addbits(): bit $bit of $op already specified"
+ croak "addbits(): bit $bit of $op already specified ($FLAGS{$op}{$bit})"
if defined $FLAGS{$op}{$bit};
$FLAGS{$op}{$bit} = $BITFIELDS{$id};
}
@
@=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.
@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;
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;
for my $op (sort keys %FLAGS) {
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";
+ }
}
# which define what bits in op_private have what meanings for each op.
# It populates %LABELS, %DEFINES, %FLAGS, %BITFIELDS.
-require 'regen/op_private';
+require './regen/op_private';
#use Data::Dumper;
#print Dumper \%LABELS, \%DEFINES, \%FLAGS, \%BITFIELDS;
#ifdef PERL_GLOBAL_STRUCT_INIT
# define PERL_PPADDR_INITED
static const Perl_ppaddr_t Gppaddr[]
-#else
-# ifndef PERL_GLOBAL_STRUCT
-# define PERL_PPADDR_INITED
+#elif !defined(PERL_GLOBAL_STRUCT)
+# define PERL_PPADDR_INITED
EXT Perl_ppaddr_t PL_ppaddr[] /* or perlvars.h */
-# endif
#endif /* PERL_GLOBAL_STRUCT */
#if (defined(DOINIT) && !defined(PERL_GLOBAL_STRUCT)) || defined(PERL_GLOBAL_STRUCT_INIT)
# define PERL_PPADDR_INITED
#ifdef PERL_GLOBAL_STRUCT_INIT
# define PERL_CHECK_INITED
static const Perl_check_t Gcheck[]
-#else
-# ifndef PERL_GLOBAL_STRUCT
-# define PERL_CHECK_INITED
+#elif !defined(PERL_GLOBAL_STRUCT)
+# define PERL_CHECK_INITED
EXT Perl_check_t PL_check[] /* or perlvars.h */
-# endif
#endif
#if (defined(DOINIT) && !defined(PERL_GLOBAL_STRUCT)) || defined(PERL_GLOBAL_STRUCT_INIT)
# define PERL_CHECK_INITED
'-', 12, # filestatop
'}', 13, # loopexop
'.', 14, # methop
+ '+', 15, # unop_aux
);
my %opflags = (
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";
https://perl5.git.perl.org / perl5.git / blobdiff