1#!/usr/bin/perl -w 2# 3# Regenerate (overwriting only if changed): 4# 5# opcode.h 6# opnames.h 7# pp_proto.h 8# lib/B/Op_private.pm 9# 10# from: 11# * information stored in regen/opcodes; 12# * information stored in regen/op_private (which is actually perl code); 13# * the values hardcoded into this script in @raw_alias. 14# 15# Accepts the standard regen_lib -q and -v args. 16# 17# This script is normally invoked from regen.pl. 18 19use strict; 20my $restrict_to_core = "if defined(PERL_CORE) || defined(PERL_EXT)"; 21 22BEGIN { 23 # Get function prototypes 24 require './regen/regen_lib.pl'; 25} 26 27my $oc = open_new('opcode.h', '>', 28 {by => 'regen/opcode.pl', from => 'its data', 29 file => 'opcode.h', style => '*', 30 copyright => [1993 .. 2007]}); 31 32my $on = open_new('opnames.h', '>', 33 { by => 'regen/opcode.pl', from => 'its data', style => '*', 34 file => 'opnames.h', copyright => [1999 .. 2008] }); 35 36my $oprivpm = open_new('lib/B/Op_private.pm', '>', 37 { by => 'regen/opcode.pl', 38 from => "data in\nregen/op_private " 39 ."and pod embedded in regen/opcode.pl", 40 style => '#', 41 file => 'lib/B/Op_private.pm', 42 copyright => [2014 .. 2014] }); 43 44# Read 'opcodes' data. 45 46my %seen; 47my (@ops, %desc, %check, %ckname, %flags, %args, %opnum); 48 49open OPS, '<', 'regen/opcodes' or die $!; 50 51while (<OPS>) { 52 chop; 53 next unless $_; 54 next if /^#/; 55 my ($key, $desc, $check, $flags, $args) = split(/\t+/, $_, 5); 56 $args = '' unless defined $args; 57 58 warn qq[Description "$desc" duplicates $seen{$desc}\n] 59 if $seen{$desc} and $key !~ "concat|transr|(?:intro|clone)cv|lvref"; 60 die qq[Opcode "$key" duplicates $seen{$key}\n] if $seen{$key}; 61 die qq[Opcode "freed" is reserved for the slab allocator\n] 62 if $key eq 'freed'; 63 $seen{$desc} = qq[description of opcode "$key"]; 64 $seen{$key} = qq[opcode "$key"]; 65 66 push(@ops, $key); 67 $opnum{$key} = $#ops; 68 $desc{$key} = $desc; 69 $check{$key} = $check; 70 $ckname{$check}++; 71 $flags{$key} = $flags; 72 $args{$key} = $args; 73} 74 75# Set up aliases 76 77my %alias; 78 79# Format is "this function" => "does these op names" 80my @raw_alias = ( 81 Perl_do_kv => [qw( keys values )], 82 Perl_unimplemented_op => [qw(padany custom)], 83 # All the ops with a body of { return NORMAL; } 84 Perl_pp_null => [qw(scalar regcmaybe lineseq scope)], 85 86 Perl_pp_goto => ['dump'], 87 Perl_pp_require => ['dofile'], 88 Perl_pp_untie => ['dbmclose'], 89 Perl_pp_sysread => {read => '', recv => '#ifdef HAS_SOCKET'}, 90 Perl_pp_sysseek => ['seek'], 91 Perl_pp_ioctl => ['fcntl'], 92 Perl_pp_ssockopt => {gsockopt => '#ifdef HAS_SOCKET'}, 93 Perl_pp_getpeername => {getsockname => '#ifdef HAS_SOCKET'}, 94 Perl_pp_stat => ['lstat'], 95 Perl_pp_ftrowned => [qw(fteowned ftzero ftsock ftchr ftblk 96 ftfile ftdir ftpipe ftsuid ftsgid 97 ftsvtx)], 98 Perl_pp_fttext => ['ftbinary'], 99 Perl_pp_gmtime => ['localtime'], 100 Perl_pp_semget => [qw(shmget msgget)], 101 Perl_pp_semctl => [qw(shmctl msgctl)], 102 Perl_pp_ghostent => [qw(ghbyname ghbyaddr)], 103 Perl_pp_gnetent => [qw(gnbyname gnbyaddr)], 104 Perl_pp_gprotoent => [qw(gpbyname gpbynumber)], 105 Perl_pp_gservent => [qw(gsbyname gsbyport)], 106 Perl_pp_gpwent => [qw(gpwnam gpwuid)], 107 Perl_pp_ggrent => [qw(ggrnam ggrgid)], 108 Perl_pp_ftis => [qw(ftsize ftmtime ftatime ftctime)], 109 Perl_pp_chown => [qw(unlink chmod utime kill)], 110 Perl_pp_link => ['symlink'], 111 Perl_pp_ftrread => [qw(ftrwrite ftrexec fteread ftewrite 112 fteexec)], 113 Perl_pp_shmwrite => [qw(shmread msgsnd msgrcv semop)], 114 Perl_pp_syswrite => {send => '#ifdef HAS_SOCKET'}, 115 Perl_pp_defined => [qw(dor dorassign)], 116 Perl_pp_and => ['andassign'], 117 Perl_pp_or => ['orassign'], 118 Perl_pp_ucfirst => ['lcfirst'], 119 Perl_pp_sle => [qw(slt sgt sge)], 120 Perl_pp_print => ['say'], 121 Perl_pp_index => ['rindex'], 122 Perl_pp_oct => ['hex'], 123 Perl_pp_shift => ['pop'], 124 Perl_pp_sin => [qw(cos exp log sqrt)], 125 Perl_pp_bit_or => ['bit_xor'], 126 Perl_pp_nbit_or => ['nbit_xor'], 127 Perl_pp_sbit_or => ['sbit_xor'], 128 Perl_pp_rv2av => ['rv2hv'], 129 Perl_pp_akeys => ['avalues'], 130 Perl_pp_trans => [qw(trans transr)], 131 Perl_pp_chop => [qw(chop chomp)], 132 Perl_pp_schop => [qw(schop schomp)], 133 Perl_pp_bind => {connect => '#ifdef HAS_SOCKET'}, 134 Perl_pp_preinc => ['i_preinc'], 135 Perl_pp_predec => ['i_predec'], 136 Perl_pp_postinc => ['i_postinc'], 137 Perl_pp_postdec => ['i_postdec'], 138 Perl_pp_ehostent => [qw(enetent eprotoent eservent 139 spwent epwent sgrent egrent)], 140 Perl_pp_shostent => [qw(snetent sprotoent sservent)], 141 Perl_pp_aelemfast => ['aelemfast_lex'], 142 Perl_pp_grepstart => ['mapstart'], 143 ); 144 145while (my ($func, $names) = splice @raw_alias, 0, 2) { 146 if (ref $names eq 'ARRAY') { 147 foreach (@$names) { 148 $alias{$_} = [$func, '']; 149 } 150 } else { 151 while (my ($opname, $cond) = each %$names) { 152 $alias{$opname} = [$func, $cond]; 153 } 154 } 155} 156 157foreach my $sock_func (qw(socket bind listen accept shutdown 158 ssockopt getpeername)) { 159 $alias{$sock_func} = ["Perl_pp_$sock_func", '#ifdef HAS_SOCKET'], 160} 161 162 163 164# ================================================================= 165# 166# Functions for processing regen/op_private data. 167# 168# Put them in a separate package so that croak() does the right thing 169 170package OP_PRIVATE; 171 172use Carp; 173 174 175# the vars holding the global state built up by all the calls to addbits() 176 177 178# map OPpLVAL_INTRO => LVINTRO 179my %LABELS; 180 181 182# the numeric values of flags - what will get output as a #define 183my %DEFINES; 184 185# %BITFIELDS: the various bit field types. The key is the concatenation of 186# all the field values that make up a bit field hash; the values are bit 187# field hash refs. This allows us to de-dup identical bit field defs 188# across different ops, and thus make the output tables more compact (esp 189# important for the C version) 190my %BITFIELDS; 191 192# %FLAGS: the main data structure. Indexed by op name, then bit index: 193# single bit flag: 194# $FLAGS{rv2av}{2} = 'OPpSLICEWARNING'; 195# bit field (bits 5 and 6): 196# $FLAGS{rv2av}{5} = $FLAGS{rv2av}{6} = { .... }; 197my %FLAGS; 198 199 200# do, with checking, $LABELS{$name} = $label 201 202sub add_label { 203 my ($name, $label) = @_; 204 if (exists $LABELS{$name} and $LABELS{$name} ne $label) { 205 croak "addbits(): label for flag '$name' redefined:\n" 206 . " was '$LABELS{$name}', now '$label'"; 207 } 208 $LABELS{$name} = $label; 209} 210 211# 212# do, with checking, $DEFINES{$name} = $val 213 214sub add_define { 215 my ($name, $val) = @_; 216 if (exists $DEFINES{$name} && $DEFINES{$name} != $val) { 217 croak "addbits(): value for flag '$name' redefined:\n" 218 . " was $DEFINES{$name}, now $val"; 219 } 220 $DEFINES{$name} = $val; 221} 222 223 224# intended to be called from regen/op_private; see that file for details 225 226sub ::addbits { 227 my @args = @_; 228 229 croak "too few arguments for addbits()" unless @args >= 3; 230 my $op = shift @args; 231 croak "invalid op name: '$op'" unless exists $opnum{$op}; 232 233 while (@args) { 234 my $bits = shift @args; 235 if ($bits =~ /^[0-7]$/) { 236 # single bit 237 croak "addbits(): too few arguments for single bit flag" 238 unless @args >= 2; 239 my $flag_name = shift @args; 240 my $flag_label = shift @args; 241 add_label($flag_name, $flag_label); 242 croak "addbits(): bit $bits of $op already specified ($FLAGS{$op}{$bits})" 243 if defined $FLAGS{$op}{$bits}; 244 $FLAGS{$op}{$bits} = $flag_name; 245 add_define($flag_name, (1 << $bits)); 246 } 247 elsif ($bits =~ /^([0-7])\.\.([0-7])$/) { 248 # bit range 249 my ($bitmin, $bitmax) = ($1,$2); 250 251 croak "addbits(): min bit > max bit in bit range '$bits'" 252 unless $bitmin <= $bitmax; 253 croak "addbits(): bit field argument missing" 254 unless @args >= 1; 255 256 my $arg_hash = shift @args; 257 croak "addbits(): arg to $bits must be a hash ref" 258 unless defined $arg_hash and ref($arg_hash) =~ /HASH/; 259 260 my %valid_keys; 261 @valid_keys{qw(baseshift_def bitcount_def mask_def label enum)} = (); 262 for (keys %$arg_hash) { 263 croak "addbits(): unrecognised bifield key: '$_'" 264 unless exists $valid_keys{$_}; 265 } 266 267 my $bitmask = 0; 268 $bitmask += (1 << $_) for $bitmin..$bitmax; 269 270 my $enum_id =''; 271 272 if (defined $arg_hash->{enum}) { 273 my $enum = $arg_hash->{enum}; 274 croak "addbits(): arg to enum must be an array ref" 275 unless defined $enum and ref($enum) =~ /ARRAY/; 276 croak "addbits(): enum list must be in triplets" 277 unless @$enum % 3 == 0; 278 279 my $max_id = (1 << ($bitmax - $bitmin + 1)) - 1; 280 281 my @e = @$enum; 282 while (@e) { 283 my $enum_ix = shift @e; 284 my $enum_name = shift @e; 285 my $enum_label = shift @e; 286 croak "addbits(): enum index must be a number: '$enum_ix'" 287 unless $enum_ix =~ /^\d+$/; 288 croak "addbits(): enum index too big: '$enum_ix'" 289 unless $enum_ix <= $max_id; 290 add_label($enum_name, $enum_label); 291 add_define($enum_name, $enum_ix << $bitmin); 292 $enum_id .= "($enum_ix:$enum_name:$enum_label)"; 293 } 294 } 295 296 # id is a fingerprint of all the content of the bit field hash 297 my $id = join ':', map defined() ? $_ : "-undef-", 298 $bitmin, $bitmax, 299 $arg_hash->{label}, 300 $arg_hash->{mask_def}, 301 $arg_hash->{baseshift_def}, 302 $arg_hash->{bitcount_def}, 303 $enum_id; 304 305 unless (defined $BITFIELDS{$id}) { 306 307 if (defined $arg_hash->{mask_def}) { 308 add_define($arg_hash->{mask_def}, $bitmask); 309 } 310 311 if (defined $arg_hash->{baseshift_def}) { 312 add_define($arg_hash->{baseshift_def}, $bitmin); 313 } 314 315 if (defined $arg_hash->{bitcount_def}) { 316 add_define($arg_hash->{bitcount_def}, $bitmax-$bitmin+1); 317 } 318 319 # create deep copy 320 321 my $copy = {}; 322 for (qw(baseshift_def bitcount_def mask_def label)) { 323 $copy->{$_} = $arg_hash->{$_} if defined $arg_hash->{$_}; 324 } 325 if (defined $arg_hash->{enum}) { 326 $copy->{enum} = [ @{$arg_hash->{enum}} ]; 327 } 328 329 # and add some extra fields 330 331 $copy->{bitmask} = $bitmask; 332 $copy->{bitmin} = $bitmin; 333 $copy->{bitmax} = $bitmax; 334 335 $BITFIELDS{$id} = $copy; 336 } 337 338 for my $bit ($bitmin..$bitmax) { 339 croak "addbits(): bit $bit of $op already specified ($FLAGS{$op}{$bit})" 340 if defined $FLAGS{$op}{$bit}; 341 $FLAGS{$op}{$bit} = $BITFIELDS{$id}; 342 } 343 } 344 else { 345 croak "addbits(): invalid bit specifier '$bits'"; 346 } 347 } 348} 349 350 351# intended to be called from regen/op_private; see that file for details 352 353sub ::ops_with_flag { 354 my $flag = shift; 355 return grep $flags{$_} =~ /\Q$flag/, sort keys %flags; 356} 357 358 359# intended to be called from regen/op_private; see that file for details 360 361sub ::ops_with_check { 362 my $c = shift; 363 return grep $check{$_} eq $c, sort keys %check; 364} 365 366 367# intended to be called from regen/op_private; see that file for details 368 369sub ::ops_with_arg { 370 my ($i, $arg_type) = @_; 371 my @ops; 372 for my $op (sort keys %args) { 373 my @args = split(' ',$args{$op}); 374 push @ops, $op if defined $args[$i] and $args[$i] eq $arg_type; 375 } 376 @ops; 377} 378 379 380# output '#define OPpLVAL_INTRO 0x80' etc 381 382sub print_defines { 383 my $fh = shift; 384 385 for (sort { $DEFINES{$a} <=> $DEFINES{$b} || $a cmp $b } keys %DEFINES) { 386 printf $fh "#define %-23s 0x%02x\n", $_, $DEFINES{$_}; 387 } 388} 389 390 391# Generate the content of B::Op_private 392 393sub print_B_Op_private { 394 my $fh = shift; 395 396 my $header = <<'EOF'; 397@=head1 NAME 398@ 399@B::Op_private - OP op_private flag definitions 400@ 401@=head1 SYNOPSIS 402@ 403@ use B::Op_private; 404@ 405@ # flag details for bit 7 of OP_AELEM's op_private: 406@ my $name = $B::Op_private::bits{aelem}{7}; # OPpLVAL_INTRO 407@ my $value = $B::Op_private::defines{$name}; # 128 408@ my $label = $B::Op_private::labels{$name}; # LVINTRO 409@ 410@ # the bit field at bits 5..6 of OP_AELEM's op_private: 411@ my $bf = $B::Op_private::bits{aelem}{6}; 412@ my $mask = $bf->{bitmask}; # etc 413@ 414@=head1 DESCRIPTION 415@ 416@This module provides four global hashes: 417@ 418@ %B::Op_private::bits 419@ %B::Op_private::defines 420@ %B::Op_private::labels 421@ %B::Op_private::ops_using 422@ 423@which contain information about the per-op meanings of the bits in the 424@op_private field. 425@ 426@=head2 C<%bits> 427@ 428@This is indexed by op name and then bit number (0..7). For single bit flags, 429@it returns the name of the define (if any) for that bit: 430@ 431@ $B::Op_private::bits{aelem}{7} eq 'OPpLVAL_INTRO'; 432@ 433@For bit fields, it returns a hash ref containing details about the field. 434@The same reference will be returned for all bit positions that make 435@up the bit field; so for example these both return the same hash ref: 436@ 437@ $bitfield = $B::Op_private::bits{aelem}{5}; 438@ $bitfield = $B::Op_private::bits{aelem}{6}; 439@ 440@The general format of this hash ref is 441@ 442@ { 443@ # The bit range and mask; these are always present. 444@ bitmin => 5, 445@ bitmax => 6, 446@ bitmask => 0x60, 447@ 448@ # (The remaining keys are optional) 449@ 450@ # The names of any defines that were requested: 451@ mask_def => 'OPpFOO_MASK', 452@ baseshift_def => 'OPpFOO_SHIFT', 453@ bitcount_def => 'OPpFOO_BITS', 454@ 455@ # If present, Concise etc will display the value with a 'FOO=' 456@ # prefix. If it equals '-', then Concise will treat the bit 457@ # field as raw bits and not try to interpret it. 458@ label => 'FOO', 459@ 460@ # If present, specifies the names of some defines and the 461@ # display labels that are used to assign meaning to particu- 462@ # lar integer values within the bit field; e.g. 3 is dis- 463@ # played as 'C'. 464@ enum => [ qw( 465@ 1 OPpFOO_A A 466@ 2 OPpFOO_B B 467@ 3 OPpFOO_C C 468@ )], 469@ 470@ }; 471@ 472@ 473@=head2 C<%defines> 474@ 475@This gives the value of every C<OPp> define, e.g. 476@ 477@ $B::Op_private::defines{OPpLVAL_INTRO} == 128; 478@ 479@=head2 C<%labels> 480@ 481@This gives the short display label for each define, as used by C<B::Concise> 482@and C<perl -Dx>, e.g. 483@ 484@ $B::Op_private::labels{OPpLVAL_INTRO} eq 'LVINTRO'; 485@ 486@If the label equals '-', then Concise will treat the bit as a raw bit and 487@not try to display it symbolically. 488@ 489@=head2 C<%ops_using> 490@ 491@For each define, this gives a reference to an array of op names that use 492@the flag. 493@ 494@ @ops_using_lvintro = @{ $B::Op_private::ops_using{OPp_LVAL_INTRO} }; 495@ 496@=cut 497 498package B::Op_private; 499 500our %bits; 501 502EOF 503 # remove podcheck.t-defeating leading char 504 $header =~ s/^\@//gm; 505 print $fh $header; 506 my $v = (::perl_version())[3]; 507 print $fh qq{\nour \$VERSION = "$v";\n\n}; 508 509 my %ops_using; 510 511 # for each flag/bit combination, find the ops which use it 512 my %combos; 513 for my $op (sort keys %FLAGS) { 514 my $entry = $FLAGS{$op}; 515 for my $bit (0..7) { 516 my $e = $entry->{$bit}; 517 next unless defined $e; 518 next if ref $e; # bit field, not flag 519 push @{$combos{$e}{$bit}}, $op; 520 push @{$ops_using{$e}}, $op; 521 } 522 } 523 524 # dump flags used by multiple ops 525 for my $flag (sort keys %combos) { 526 for my $bit (sort keys %{$combos{$flag}}) { 527 my $ops = $combos{$flag}{$bit}; 528 next unless @$ops > 1; 529 my @o = sort @$ops; 530 print $fh "\$bits{\$_}{$bit} = '$flag' for qw(@o);\n"; 531 } 532 } 533 534 # dump bit field definitions 535 536 my %bitfield_ix; 537 { 538 my %bitfields; 539 # stringified-ref to ref mapping 540 $bitfields{$_} = $_ for values %BITFIELDS; 541 my $ix = -1; 542 my $s = "\nmy \@bf = (\n"; 543 for my $bitfield_key (sort keys %BITFIELDS) { 544 my $bitfield = $BITFIELDS{$bitfield_key}; 545 $ix++; 546 $bitfield_ix{$bitfield} = $ix; 547 548 $s .= " {\n"; 549 for (qw(label mask_def baseshift_def bitcount_def)) { 550 next unless defined $bitfield->{$_}; 551 $s .= sprintf " %-9s => '%s',\n", 552 $_, $bitfield->{$_}; 553 } 554 for (qw(bitmin bitmax bitmask)) { 555 croak "panic" unless defined $bitfield->{$_}; 556 $s .= sprintf " %-9s => %d,\n", 557 $_, $bitfield->{$_}; 558 } 559 if (defined $bitfield->{enum}) { 560 $s .= " enum => [\n"; 561 my @enum = @{$bitfield->{enum}}; 562 while (@enum) { 563 my $i = shift @enum; 564 my $name = shift @enum; 565 my $label = shift @enum; 566 $s .= sprintf " %d, %-10s, %s,\n", 567 $i, "'$name'", "'$label'"; 568 } 569 $s .= " ],\n"; 570 } 571 $s .= " },\n"; 572 573 } 574 $s .= ");\n"; 575 print $fh "$s\n"; 576 } 577 578 # dump bitfields and remaining labels 579 580 for my $op (sort keys %FLAGS) { 581 my @indices; 582 my @vals; 583 my $entry = $FLAGS{$op}; 584 my $bit; 585 586 for ($bit = 7; $bit >= 0; $bit--) { 587 next unless defined $entry->{$bit}; 588 my $e = $entry->{$bit}; 589 if (ref $e) { 590 my $ix = $bitfield_ix{$e}; 591 for (reverse $e->{bitmin}..$e->{bitmax}) { 592 push @indices, $_; 593 push @vals, "\$bf[$ix]"; 594 } 595 $bit = $e->{bitmin}; 596 } 597 else { 598 next if @{$combos{$e}{$bit}} > 1; # already output 599 push @indices, $bit; 600 push @vals, "'$e'"; 601 } 602 } 603 if (@indices) { 604 my $s = ''; 605 $s = '@{' if @indices > 1; 606 $s .= "\$bits{$op}"; 607 $s .= '}' if @indices > 1; 608 $s .= '{' . join(',', @indices) . '} = '; 609 $s .= '(' if @indices > 1; 610 $s .= join ', ', @vals; 611 $s .= ')' if @indices > 1; 612 print $fh "$s;\n"; 613 } 614 } 615 616 # populate %defines and %labels 617 618 print $fh "\n\nour %defines = (\n"; 619 printf $fh " %-23s => %3d,\n", $_ , $DEFINES{$_} for sort keys %DEFINES; 620 print $fh ");\n\nour %labels = (\n"; 621 printf $fh " %-23s => '%s',\n", $_ , $LABELS{$_} for sort keys %LABELS; 622 print $fh ");\n"; 623 624 # %ops_using 625 print $fh "\n\nour %ops_using = (\n"; 626 # Save memory by using the same array wherever possible. 627 my %flag_by_op_list; 628 my $pending = ''; 629 for my $flag (sort keys %ops_using) { 630 my $op_list = $ops_using{$flag} = "@{$ops_using{$flag}}"; 631 if (!exists $flag_by_op_list{$op_list}) { 632 $flag_by_op_list{$op_list} = $flag; 633 printf $fh " %-23s => %s,\n", $flag , "[qw($op_list)]" 634 } 635 else { 636 $pending .= "\$ops_using{$flag} = " 637 . "\$ops_using{$flag_by_op_list{$op_list}};\n"; 638 } 639 } 640 print $fh ");\n\n$pending"; 641 642} 643 644 645 646# output the contents of the assorted PL_op_private_*[] tables 647 648sub print_PL_op_private_tables { 649 my $fh = shift; 650 651 my $PL_op_private_labels = ''; 652 my $PL_op_private_valid = ''; 653 my $PL_op_private_bitdef_ix = ''; 654 my $PL_op_private_bitdefs = ''; 655 my $PL_op_private_bitfields = ''; 656 657 my %label_ix; 658 my %bitfield_ix; 659 660 # generate $PL_op_private_labels 661 662 { 663 my %labs; 664 $labs{$_} = 1 for values %LABELS; # de-duplicate labels 665 # add in bit field labels 666 for (values %BITFIELDS) { 667 next unless defined $_->{label}; 668 $labs{$_->{label}} = 1; 669 } 670 671 my $labels = ''; 672 for my $lab (sort keys %labs) { 673 $label_ix{$lab} = length $labels; 674 $labels .= "$lab\0"; 675 $PL_op_private_labels .= 676 " " 677 . join(',', map("'$_'", split //, $lab)) 678 . ",'\\0',\n"; 679 } 680 } 681 682 683 # generate PL_op_private_bitfields 684 685 { 686 my %bitfields; 687 # stringified-ref to ref mapping 688 $bitfields{$_} = $_ for values %BITFIELDS; 689 690 my $ix = 0; 691 for my $bitfield_key (sort keys %BITFIELDS) { 692 my $bf = $BITFIELDS{$bitfield_key}; 693 $bitfield_ix{$bf} = $ix; 694 695 my @b; 696 push @b, $bf->{bitmin}, 697 defined $bf->{label} ? $label_ix{$bf->{label}} : -1; 698 my $enum = $bf->{enum}; 699 if (defined $enum) { 700 my @enum = @$enum; 701 while (@enum) { 702 my $i = shift @enum; 703 my $name = shift @enum; 704 my $label = shift @enum; 705 push @b, $i, $label_ix{$label}; 706 } 707 } 708 push @b, -1; # terminate enum list 709 710 $PL_op_private_bitfields .= " " . join(', ', @b) .",\n"; 711 $ix += @b; 712 } 713 } 714 715 716 # generate PL_op_private_bitdefs, PL_op_private_bitdef_ix 717 718 { 719 my $bitdef_count = 0; 720 721 my %not_seen = %FLAGS; 722 my @seen_bitdefs; 723 my %seen_bitdefs; 724 725 my $opnum = -1; 726 for my $op (sort { $opnum{$a} <=> $opnum{$b} } keys %opnum) { 727 $opnum++; 728 die "panic: opnum misorder: opnum=$opnum opnum{op}=$opnum{$op}" 729 unless $opnum == $opnum{$op}; 730 delete $not_seen{$op}; 731 732 my @bitdefs; 733 my $entry = $FLAGS{$op}; 734 my $bit; 735 my $index; 736 737 for ($bit = 7; $bit >= 0; $bit--) { 738 my $e = $entry->{$bit}; 739 next unless defined $e; 740 741 my $ix; 742 if (ref $e) { 743 $ix = $bitfield_ix{$e}; 744 die "panic: \$bit =\= $e->{bitmax}" 745 unless $bit == $e->{bitmax}; 746 747 push @bitdefs, ( ($ix << 5) | ($bit << 2) | 2 ); 748 $bit = $e->{bitmin}; 749 } 750 else { 751 $ix = $label_ix{$LABELS{$e}}; 752 die "panic: no label ix for '$e'" unless defined $ix; 753 push @bitdefs, ( ($ix << 5) | ($bit << 2)); 754 } 755 if ($ix > 2047) { 756 die "Too many labels or bitfields (ix=$ix): " 757 . "maybe the type of PL_op_private_bitdefs needs " 758 . "expanding from U16 to U32???"; 759 } 760 } 761 if (@bitdefs) { 762 $bitdefs[-1] |= 1; # stop bit 763 my $key = join(', ', map(sprintf("0x%04x", $_), @bitdefs)); 764 if (!$seen_bitdefs{$key}) { 765 $index = $bitdef_count; 766 $bitdef_count += @bitdefs; 767 push @seen_bitdefs, 768 $seen_bitdefs{$key} = [$index, $key]; 769 } 770 else { 771 $index = $seen_bitdefs{$key}[0]; 772 } 773 push @{$seen_bitdefs{$key}}, $op; 774 } 775 else { 776 $index = -1; 777 } 778 $PL_op_private_bitdef_ix .= sprintf " %4d, /* %s */\n", $index, $op; 779 } 780 if (%not_seen) { 781 die "panic: unprocessed ops: ". join(',', keys %not_seen); 782 } 783 for (@seen_bitdefs) { 784 local $" = ", "; 785 $PL_op_private_bitdefs .= " $$_[1], /* @$_[2..$#$_] */\n"; 786 } 787 } 788 789 790 # generate PL_op_private_valid 791 792 for my $op (@ops) { 793 my $last; 794 my @flags; 795 for my $bit (0..7) { 796 next unless exists $FLAGS{$op}; 797 my $entry = $FLAGS{$op}{$bit}; 798 next unless defined $entry; 799 if (ref $entry) { 800 # skip later entries for the same bit field 801 next if defined $last and $last == $entry; 802 $last = $entry; 803 push @flags, 804 defined $entry->{mask_def} 805 ? $entry->{mask_def} 806 : $entry->{bitmask}; 807 } 808 else { 809 push @flags, $entry; 810 } 811 } 812 813 # all bets are off 814 @flags = '0xff' if $op eq 'null' or $op eq 'custom'; 815 816 $PL_op_private_valid .= sprintf " /* %-10s */ (%s),\n", uc($op), 817 @flags ? join('|', @flags): '0'; 818 } 819 820 print $fh <<EOF; 821START_EXTERN_C 822 823#ifndef DOINIT 824 825/* data about the flags in op_private */ 826 827EXTCONST I16 PL_op_private_bitdef_ix[]; 828EXTCONST U16 PL_op_private_bitdefs[]; 829EXTCONST char PL_op_private_labels[]; 830EXTCONST I16 PL_op_private_bitfields[]; 831EXTCONST U8 PL_op_private_valid[]; 832 833#else 834 835 836/* PL_op_private_labels[]: the short descriptions of private flags. 837 * All labels are concatenated into a single char array 838 * (separated by \\0's) for compactness. 839 */ 840 841EXTCONST char PL_op_private_labels[] = { 842$PL_op_private_labels 843}; 844 845 846 847/* PL_op_private_bitfields[]: details about each bit field type. 848 * Each definition consists of the following list of words: 849 * bitmin 850 * label (index into PL_op_private_labels[]; -1 if no label) 851 * repeat for each enum entry (if any): 852 * enum value 853 * enum label (index into PL_op_private_labels[]) 854 * -1 855 */ 856 857EXTCONST I16 PL_op_private_bitfields[] = { 858$PL_op_private_bitfields 859}; 860 861 862/* PL_op_private_bitdef_ix[]: map an op number to a starting position 863 * in PL_op_private_bitdefs. If -1, the op has no bits defined */ 864 865EXTCONST I16 PL_op_private_bitdef_ix[] = { 866$PL_op_private_bitdef_ix 867}; 868 869 870 871/* PL_op_private_bitdefs[]: given a starting position in this array (as 872 * supplied by PL_op_private_bitdef_ix[]), each word (until a stop bit is 873 * seen) defines the meaning of a particular op_private bit for a 874 * particular op. Each word consists of: 875 * bit 0: stop bit: this is the last bit def for the current op 876 * bit 1: bitfield: if set, this defines a bit field rather than a flag 877 * bits 2..4: unsigned number in the range 0..7 which is the bit number 878 * bits 5..15: unsigned number in the range 0..2047 which is an index 879 * into PL_op_private_labels[] (for a flag), or 880 * into PL_op_private_bitfields[] (for a bit field) 881 */ 882 883EXTCONST U16 PL_op_private_bitdefs[] = { 884$PL_op_private_bitdefs 885}; 886 887 888/* PL_op_private_valid: for each op, indexed by op_type, indicate which 889 * flags bits in op_private are legal */ 890 891EXTCONST U8 PL_op_private_valid[] = { 892$PL_op_private_valid 893}; 894 895#endif /* !DOINIT */ 896 897END_EXTERN_C 898 899 900EOF 901 902} 903 904 905# ================================================================= 906 907 908package main; 909 910# read regen/op_private data 911# 912# This file contains Perl code that builds up some data structures 913# which define what bits in op_private have what meanings for each op. 914# It populates %LABELS, %DEFINES, %FLAGS, %BITFIELDS. 915 916require './regen/op_private'; 917 918#use Data::Dumper; 919#print Dumper \%LABELS, \%DEFINES, \%FLAGS, \%BITFIELDS; 920 921print $oc "#$restrict_to_core\n\n"; 922 923# Emit defines. 924 925{ 926 my $last_cond = ''; 927 my @unimplemented; 928 929 sub unimplemented { 930 if (@unimplemented) { 931 print $oc "#else\n"; 932 foreach (@unimplemented) { 933 print $oc "#define $_ Perl_unimplemented_op\n"; 934 } 935 print $oc "#endif\n"; 936 @unimplemented = (); 937 } 938 939 } 940 941 for (@ops) { 942 my ($impl, $cond) = @{$alias{$_} || ["Perl_pp_$_", '']}; 943 my $op_func = "Perl_pp_$_"; 944 945 if ($cond ne $last_cond) { 946 # A change in condition. (including to or from no condition) 947 unimplemented(); 948 $last_cond = $cond; 949 if ($last_cond) { 950 print $oc "$last_cond\n"; 951 } 952 } 953 push @unimplemented, $op_func if $last_cond; 954 print $oc "#define $op_func $impl\n" if $impl ne $op_func; 955 } 956 # If the last op was conditional, we need to close it out: 957 unimplemented(); 958} 959print $oc "\n#endif /* End of $restrict_to_core */\n\n"; 960 961print $on "typedef enum opcode {\n"; 962 963my $i = 0; 964for (@ops) { 965 print $on "\t", tab(3,"OP_\U$_"), " = ", $i++, ",\n"; 966} 967print $on "\t", tab(3,"OP_max"), "\n"; 968print $on "} opcode;\n"; 969print $on "\n#define MAXO ", scalar @ops, "\n"; 970print $on "#define OP_FREED MAXO\n"; 971 972# Emit op names and descriptions. 973 974print $oc <<'END'; 975START_EXTERN_C 976 977#ifndef DOINIT 978EXTCONST char* const PL_op_name[]; 979#else 980EXTCONST char* const PL_op_name[] = { 981END 982 983for (@ops) { 984 print $oc qq(\t"$_",\n); 985} 986 987print $oc <<'END'; 988 "freed", 989}; 990#endif 991 992#ifndef DOINIT 993EXTCONST char* const PL_op_desc[]; 994#else 995EXTCONST char* const PL_op_desc[] = { 996END 997 998for (@ops) { 999 my($safe_desc) = $desc{$_}; 1000 1001 # Have to escape double quotes and escape characters. 1002 $safe_desc =~ s/([\\"])/\\$1/g; 1003 1004 print $oc qq(\t"$safe_desc",\n); 1005} 1006 1007print $oc <<'END'; 1008 "freed op", 1009}; 1010#endif 1011 1012END_EXTERN_C 1013END 1014 1015# Emit ppcode switch array. 1016 1017print $oc <<'END'; 1018 1019START_EXTERN_C 1020 1021EXT Perl_ppaddr_t PL_ppaddr[] /* or perlvars.h */ 1022#if defined(DOINIT) 1023= { 1024END 1025 1026for (@ops) { 1027 my $op_func = "Perl_pp_$_"; 1028 my $name = $alias{$_}; 1029 if ($name && $name->[0] ne $op_func) { 1030 print $oc "\t$op_func,\t/* implemented by $name->[0] */\n"; 1031 } 1032 else { 1033 print $oc "\t$op_func,\n"; 1034 } 1035} 1036 1037print $oc <<'END'; 1038} 1039#endif 1040; 1041 1042EXT Perl_check_t PL_check[] /* or perlvars.h */ 1043#if defined(DOINIT) 1044= { 1045END 1046 1047for (@ops) { 1048 print $oc "\t", tab(3, "Perl_$check{$_},"), "\t/* $_ */\n"; 1049} 1050 1051print $oc <<'END'; 1052} 1053#endif 1054; 1055 1056#ifndef DOINIT 1057EXTCONST U32 PL_opargs[]; 1058#else 1059EXTCONST U32 PL_opargs[] = { 1060END 1061 1062# Emit allowed argument types. 1063 1064my $ARGBITS = 32; 1065 1066my %argnum = ( 1067 'S', 1, # scalar 1068 'L', 2, # list 1069 'A', 3, # array value 1070 'H', 4, # hash value 1071 'C', 5, # code value 1072 'F', 6, # file value 1073 'R', 7, # scalar reference 1074); 1075 1076my %opclass = ( 1077 '0', 0, # baseop 1078 '1', 1, # unop 1079 '2', 2, # binop 1080 '|', 3, # logop 1081 '@', 4, # listop 1082 '/', 5, # pmop 1083 '$', 6, # svop_or_padop 1084 '#', 7, # padop 1085 '"', 8, # pvop_or_svop 1086 '{', 9, # loop 1087 ';', 10, # cop 1088 '%', 11, # baseop_or_unop 1089 '-', 12, # filestatop 1090 '}', 13, # loopexop 1091 '.', 14, # methop 1092 '+', 15, # unop_aux 1093); 1094 1095my %opflags = ( 1096 'm' => 1, # needs stack mark 1097 'f' => 2, # fold constants 1098 's' => 4, # always produces scalar 1099 't' => 8, # needs target scalar 1100 'T' => 8 | 16, # ... which may be lexical 1101 'i' => 0, # always produces integer (unused since e7311069) 1102 'I' => 32, # has corresponding int op 1103 'd' => 64, # danger, make temp copy in list assignment 1104 'u' => 128, # defaults to $_ 1105); 1106 1107my %OP_IS_SOCKET; # /Fs/ 1108my %OP_IS_FILETEST; # /F-/ 1109my %OP_IS_FT_ACCESS; # /F-+/ 1110my %OP_IS_NUMCOMPARE; # /S</ 1111my %OP_IS_DIRHOP; # /Fd/ 1112my %OP_IS_INFIX_BIT; # /S\|/ 1113 1114my $OCSHIFT = 8; 1115my $OASHIFT = 12; 1116 1117for my $op (@ops) { 1118 my $argsum = 0; 1119 my $flags = $flags{$op}; 1120 for my $flag (keys %opflags) { 1121 if ($flags =~ s/$flag//) { 1122 die "Flag collision for '$op' ($flags{$op}, $flag)\n" 1123 if $argsum & $opflags{$flag}; 1124 $argsum |= $opflags{$flag}; 1125 } 1126 } 1127 die qq[Opcode '$op' has no class indicator ($flags{$op} => $flags)\n] 1128 unless exists $opclass{$flags}; 1129 $argsum |= $opclass{$flags} << $OCSHIFT; 1130 my $argshift = $OASHIFT; 1131 for my $arg (split(' ',$args{$op})) { 1132 if ($arg =~ s/^D//) { 1133 # handle 1st, just to put D 1st. 1134 $OP_IS_DIRHOP{$op} = $opnum{$op}; 1135 } 1136 if ($arg =~ /^F/) { 1137 # record opnums of these opnames 1138 $OP_IS_SOCKET{$op} = $opnum{$op} if $arg =~ s/s//; 1139 $OP_IS_FILETEST{$op} = $opnum{$op} if $arg =~ s/-//; 1140 $OP_IS_FT_ACCESS{$op} = $opnum{$op} if $arg =~ s/\+//; 1141 } 1142 elsif ($arg =~ /^S./) { 1143 $OP_IS_NUMCOMPARE{$op} = $opnum{$op} if $arg =~ s/<//; 1144 $OP_IS_INFIX_BIT {$op} = $opnum{$op} if $arg =~ s/\|//; 1145 } 1146 my $argnum = ($arg =~ s/\?//) ? 8 : 0; 1147 die "op = $op, arg = $arg\n" 1148 unless exists $argnum{$arg}; 1149 $argnum += $argnum{$arg}; 1150 die "Argument overflow for '$op'\n" 1151 if $argshift >= $ARGBITS || 1152 $argnum > ((1 << ($ARGBITS - $argshift)) - 1); 1153 $argsum += $argnum << $argshift; 1154 $argshift += 4; 1155 } 1156 $argsum = sprintf("0x%08x", $argsum); 1157 print $oc "\t", tab(3, "$argsum,"), "/* $op */\n"; 1158} 1159 1160print $oc <<'END'; 1161}; 1162#endif 1163 1164END_EXTERN_C 1165END 1166 1167# Emit OP_IS_* macros 1168 1169print $on <<'EO_OP_IS_COMMENT'; 1170 1171/* the OP_IS_* macros are optimized to a simple range check because 1172 all the member OPs are contiguous in regen/opcodes table. 1173 opcode.pl verifies the range contiguity, or generates an OR-equals 1174 expression */ 1175EO_OP_IS_COMMENT 1176 1177gen_op_is_macro( \%OP_IS_SOCKET, 'OP_IS_SOCKET'); 1178gen_op_is_macro( \%OP_IS_FILETEST, 'OP_IS_FILETEST'); 1179gen_op_is_macro( \%OP_IS_FT_ACCESS, 'OP_IS_FILETEST_ACCESS'); 1180gen_op_is_macro( \%OP_IS_NUMCOMPARE, 'OP_IS_NUMCOMPARE'); 1181gen_op_is_macro( \%OP_IS_DIRHOP, 'OP_IS_DIRHOP'); 1182gen_op_is_macro( \%OP_IS_INFIX_BIT, 'OP_IS_INFIX_BIT'); 1183 1184sub gen_op_is_macro { 1185 my ($op_is, $macname) = @_; 1186 if (keys %$op_is) { 1187 1188 # get opnames whose numbers are lowest and highest 1189 my ($first, @rest) = sort { 1190 $op_is->{$a} <=> $op_is->{$b} 1191 } keys %$op_is; 1192 1193 my $last = pop @rest; # @rest slurped, get its last 1194 die "Invalid range of ops: $first .. $last\n" unless $last; 1195 1196 print $on "\n#define $macname(op) \\\n\t("; 1197 1198 # verify that op-ct matches 1st..last range (and fencepost) 1199 # (we know there are no dups) 1200 if ( $op_is->{$last} - $op_is->{$first} == scalar @rest + 1) { 1201 1202 # contiguous ops -> optimized version 1203 print $on "(op) >= OP_" . uc($first) 1204 . " && (op) <= OP_" . uc($last); 1205 } 1206 else { 1207 print $on join(" || \\\n\t ", 1208 map { "(op) == OP_" . uc() } sort keys %$op_is); 1209 } 1210 print $on ")\n"; 1211 } 1212} 1213 1214my $pp = open_new('pp_proto.h', '>', 1215 { by => 'opcode.pl', from => 'its data' }); 1216 1217{ 1218 my %funcs; 1219 for (@ops) { 1220 my $name = $alias{$_} ? $alias{$_}[0] : "Perl_pp_$_"; 1221 ++$funcs{$name}; 1222 } 1223 print $pp "PERL_CALLCONV OP *$_(pTHX);\n" foreach sort keys %funcs; 1224} 1225 1226print $oc "\n\n"; 1227OP_PRIVATE::print_defines($oc); 1228OP_PRIVATE::print_PL_op_private_tables($oc); 1229 1230OP_PRIVATE::print_B_Op_private($oprivpm); 1231 1232foreach ($oc, $on, $pp, $oprivpm) { 1233 read_only_bottom_close_and_rename($_); 1234} 1235 1236