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