1#!/usr/bin/perl -w 2# 3# Regenerate (overwriting only if changed): 4# 5# opcode.h 6# opnames.h 7# pp_proto.h 8# 9# from information stored in regen/opcodes, plus the 10# values hardcoded into this script in @raw_alias. 11# 12# Accepts the standard regen_lib -q and -v args. 13# 14# This script is normally invoked from regen.pl. 15 16use strict; 17 18BEGIN { 19 # Get function prototypes 20 require 'regen/regen_lib.pl'; 21} 22 23my $oc = open_new('opcode.h', '>', 24 {by => 'regen/opcode.pl', from => 'its data', 25 file => 'opcode.h', style => '*', 26 copyright => [1993 .. 2007]}); 27 28my $on = open_new('opnames.h', '>', 29 { by => 'regen/opcode.pl', from => 'its data', style => '*', 30 file => 'opnames.h', copyright => [1999 .. 2008] }); 31 32# Read data. 33 34my %seen; 35my (@ops, %desc, %check, %ckname, %flags, %args, %opnum); 36 37open OPS, 'regen/opcodes' or die $!; 38 39while (<OPS>) { 40 chop; 41 next unless $_; 42 next if /^#/; 43 my ($key, $desc, $check, $flags, $args) = split(/\t+/, $_, 5); 44 $args = '' unless defined $args; 45 46 warn qq[Description "$desc" duplicates $seen{$desc}\n] 47 if $seen{$desc} and $key !~ "transr|(?:intro|clone)cv"; 48 die qq[Opcode "$key" duplicates $seen{$key}\n] if $seen{$key}; 49 die qq[Opcode "freed" is reserved for the slab allocator\n] 50 if $key eq 'freed'; 51 $seen{$desc} = qq[description of opcode "$key"]; 52 $seen{$key} = qq[opcode "$key"]; 53 54 push(@ops, $key); 55 $opnum{$key} = $#ops; 56 $desc{$key} = $desc; 57 $check{$key} = $check; 58 $ckname{$check}++; 59 $flags{$key} = $flags; 60 $args{$key} = $args; 61} 62 63# Set up aliases 64 65my %alias; 66 67# Format is "this function" => "does these op names" 68my @raw_alias = ( 69 Perl_do_kv => [qw( keys values )], 70 Perl_unimplemented_op => [qw(padany mapstart custom)], 71 # All the ops with a body of { return NORMAL; } 72 Perl_pp_null => [qw(scalar regcmaybe lineseq scope)], 73 74 Perl_pp_goto => ['dump'], 75 Perl_pp_require => ['dofile'], 76 Perl_pp_untie => ['dbmclose'], 77 Perl_pp_sysread => {read => '', recv => '#ifdef HAS_SOCKET'}, 78 Perl_pp_sysseek => ['seek'], 79 Perl_pp_ioctl => ['fcntl'], 80 Perl_pp_ssockopt => {gsockopt => '#ifdef HAS_SOCKET'}, 81 Perl_pp_getpeername => {getsockname => '#ifdef HAS_SOCKET'}, 82 Perl_pp_stat => ['lstat'], 83 Perl_pp_ftrowned => [qw(fteowned ftzero ftsock ftchr ftblk 84 ftfile ftdir ftpipe ftsuid ftsgid 85 ftsvtx)], 86 Perl_pp_fttext => ['ftbinary'], 87 Perl_pp_gmtime => ['localtime'], 88 Perl_pp_semget => [qw(shmget msgget)], 89 Perl_pp_semctl => [qw(shmctl msgctl)], 90 Perl_pp_ghostent => [qw(ghbyname ghbyaddr)], 91 Perl_pp_gnetent => [qw(gnbyname gnbyaddr)], 92 Perl_pp_gprotoent => [qw(gpbyname gpbynumber)], 93 Perl_pp_gservent => [qw(gsbyname gsbyport)], 94 Perl_pp_gpwent => [qw(gpwnam gpwuid)], 95 Perl_pp_ggrent => [qw(ggrnam ggrgid)], 96 Perl_pp_ftis => [qw(ftsize ftmtime ftatime ftctime)], 97 Perl_pp_chown => [qw(unlink chmod utime kill)], 98 Perl_pp_link => ['symlink'], 99 Perl_pp_ftrread => [qw(ftrwrite ftrexec fteread ftewrite 100 fteexec)], 101 Perl_pp_shmwrite => [qw(shmread msgsnd msgrcv semop)], 102 Perl_pp_syswrite => {send => '#ifdef HAS_SOCKET'}, 103 Perl_pp_defined => [qw(dor dorassign)], 104 Perl_pp_and => ['andassign'], 105 Perl_pp_or => ['orassign'], 106 Perl_pp_ucfirst => ['lcfirst'], 107 Perl_pp_sle => [qw(slt sgt sge)], 108 Perl_pp_print => ['say'], 109 Perl_pp_index => ['rindex'], 110 Perl_pp_oct => ['hex'], 111 Perl_pp_shift => ['pop'], 112 Perl_pp_sin => [qw(cos exp log sqrt)], 113 Perl_pp_bit_or => ['bit_xor'], 114 Perl_pp_rv2av => ['rv2hv'], 115 Perl_pp_akeys => ['avalues'], 116 Perl_pp_rkeys => [qw(rvalues reach)], 117 Perl_pp_trans => [qw(trans transr)], 118 Perl_pp_chop => [qw(chop chomp)], 119 Perl_pp_schop => [qw(schop schomp)], 120 Perl_pp_bind => {connect => '#ifdef HAS_SOCKET'}, 121 Perl_pp_preinc => ['i_preinc', 'predec', 'i_predec'], 122 Perl_pp_postinc => ['i_postinc', 'postdec', 'i_postdec'], 123 Perl_pp_ehostent => [qw(enetent eprotoent eservent 124 spwent epwent sgrent egrent)], 125 Perl_pp_shostent => [qw(snetent sprotoent sservent)], 126 Perl_pp_aelemfast => ['aelemfast_lex'], 127 ); 128 129while (my ($func, $names) = splice @raw_alias, 0, 2) { 130 if (ref $names eq 'ARRAY') { 131 foreach (@$names) { 132 $alias{$_} = [$func, '']; 133 } 134 } else { 135 while (my ($opname, $cond) = each %$names) { 136 $alias{$opname} = [$func, $cond]; 137 } 138 } 139} 140 141foreach my $sock_func (qw(socket bind listen accept shutdown 142 ssockopt getpeername)) { 143 $alias{$sock_func} = ["Perl_pp_$sock_func", '#ifdef HAS_SOCKET'], 144} 145 146# Emit defines. 147 148print $oc "#ifndef PERL_GLOBAL_STRUCT_INIT\n\n"; 149 150{ 151 my $last_cond = ''; 152 my @unimplemented; 153 154 sub unimplemented { 155 if (@unimplemented) { 156 print $oc "#else\n"; 157 foreach (@unimplemented) { 158 print $oc "#define $_ Perl_unimplemented_op\n"; 159 } 160 print $oc "#endif\n"; 161 @unimplemented = (); 162 } 163 164 } 165 166 for (@ops) { 167 my ($impl, $cond) = @{$alias{$_} || ["Perl_pp_$_", '']}; 168 my $op_func = "Perl_pp_$_"; 169 170 if ($cond ne $last_cond) { 171 # A change in condition. (including to or from no condition) 172 unimplemented(); 173 $last_cond = $cond; 174 if ($last_cond) { 175 print $oc "$last_cond\n"; 176 } 177 } 178 push @unimplemented, $op_func if $last_cond; 179 print $oc "#define $op_func $impl\n" if $impl ne $op_func; 180 } 181 # If the last op was conditional, we need to close it out: 182 unimplemented(); 183} 184 185print $on "typedef enum opcode {\n"; 186 187my $i = 0; 188for (@ops) { 189 print $on "\t", tab(3,"OP_\U$_"), " = ", $i++, ",\n"; 190} 191print $on "\t", tab(3,"OP_max"), "\n"; 192print $on "} opcode;\n"; 193print $on "\n#define MAXO ", scalar @ops, "\n"; 194print $on "#define OP_FREED MAXO\n"; 195 196# Emit op names and descriptions. 197 198print $oc <<'END'; 199START_EXTERN_C 200 201#ifndef DOINIT 202EXTCONST char* const PL_op_name[]; 203#else 204EXTCONST char* const PL_op_name[] = { 205END 206 207for (@ops) { 208 print $oc qq(\t"$_",\n); 209} 210 211print $oc <<'END'; 212 "freed", 213}; 214#endif 215 216#ifndef DOINIT 217EXTCONST char* const PL_op_desc[]; 218#else 219EXTCONST char* const PL_op_desc[] = { 220END 221 222for (@ops) { 223 my($safe_desc) = $desc{$_}; 224 225 # Have to escape double quotes and escape characters. 226 $safe_desc =~ s/([\\"])/\\$1/g; 227 228 print $oc qq(\t"$safe_desc",\n); 229} 230 231print $oc <<'END'; 232 "freed op", 233}; 234#endif 235 236END_EXTERN_C 237 238#endif /* !PERL_GLOBAL_STRUCT_INIT */ 239END 240 241# Emit ppcode switch array. 242 243print $oc <<'END'; 244 245START_EXTERN_C 246 247#ifdef PERL_GLOBAL_STRUCT_INIT 248# define PERL_PPADDR_INITED 249static const Perl_ppaddr_t Gppaddr[] 250#else 251# ifndef PERL_GLOBAL_STRUCT 252# define PERL_PPADDR_INITED 253EXT Perl_ppaddr_t PL_ppaddr[] /* or perlvars.h */ 254# endif 255#endif /* PERL_GLOBAL_STRUCT */ 256#if (defined(DOINIT) && !defined(PERL_GLOBAL_STRUCT)) || defined(PERL_GLOBAL_STRUCT_INIT) 257# define PERL_PPADDR_INITED 258= { 259END 260 261for (@ops) { 262 my $op_func = "Perl_pp_$_"; 263 my $name = $alias{$_}; 264 if ($name && $name->[0] ne $op_func) { 265 print $oc "\t$op_func,\t/* implemented by $name->[0] */\n"; 266 } 267 else { 268 print $oc "\t$op_func,\n"; 269 } 270} 271 272print $oc <<'END'; 273} 274#endif 275#ifdef PERL_PPADDR_INITED 276; 277#endif 278 279#ifdef PERL_GLOBAL_STRUCT_INIT 280# define PERL_CHECK_INITED 281static const Perl_check_t Gcheck[] 282#else 283# ifndef PERL_GLOBAL_STRUCT 284# define PERL_CHECK_INITED 285EXT Perl_check_t PL_check[] /* or perlvars.h */ 286# endif 287#endif 288#if (defined(DOINIT) && !defined(PERL_GLOBAL_STRUCT)) || defined(PERL_GLOBAL_STRUCT_INIT) 289# define PERL_CHECK_INITED 290= { 291END 292 293for (@ops) { 294 print $oc "\t", tab(3, "Perl_$check{$_},"), "\t/* $_ */\n"; 295} 296 297print $oc <<'END'; 298} 299#endif 300#ifdef PERL_CHECK_INITED 301; 302#endif /* #ifdef PERL_CHECK_INITED */ 303 304#ifndef PERL_GLOBAL_STRUCT_INIT 305 306#ifndef DOINIT 307EXTCONST U32 PL_opargs[]; 308#else 309EXTCONST U32 PL_opargs[] = { 310END 311 312# Emit allowed argument types. 313 314my $ARGBITS = 32; 315 316my %argnum = ( 317 'S', 1, # scalar 318 'L', 2, # list 319 'A', 3, # array value 320 'H', 4, # hash value 321 'C', 5, # code value 322 'F', 6, # file value 323 'R', 7, # scalar reference 324); 325 326my %opclass = ( 327 '0', 0, # baseop 328 '1', 1, # unop 329 '2', 2, # binop 330 '|', 3, # logop 331 '@', 4, # listop 332 '/', 5, # pmop 333 '$', 6, # svop_or_padop 334 '#', 7, # padop 335 '"', 8, # pvop_or_svop 336 '{', 9, # loop 337 ';', 10, # cop 338 '%', 11, # baseop_or_unop 339 '-', 12, # filestatop 340 '}', 13, # loopexop 341); 342 343my %opflags = ( 344 'm' => 1, # needs stack mark 345 'f' => 2, # fold constants 346 's' => 4, # always produces scalar 347 't' => 8, # needs target scalar 348 'T' => 8 | 16, # ... which may be lexical 349 'i' => 0, # always produces integer (unused since e7311069) 350 'I' => 32, # has corresponding int op 351 'd' => 64, # danger, unknown side effects 352 'u' => 128, # defaults to $_ 353); 354 355my %OP_IS_SOCKET; # /Fs/ 356my %OP_IS_FILETEST; # /F-/ 357my %OP_IS_FT_ACCESS; # /F-+/ 358my %OP_IS_NUMCOMPARE; # /S</ 359my %OP_IS_DIRHOP; # /Fd/ 360 361my $OCSHIFT = 8; 362my $OASHIFT = 12; 363 364for my $op (@ops) { 365 my $argsum = 0; 366 my $flags = $flags{$op}; 367 for my $flag (keys %opflags) { 368 if ($flags =~ s/$flag//) { 369 die "Flag collision for '$op' ($flags{$op}, $flag)\n" 370 if $argsum & $opflags{$flag}; 371 $argsum |= $opflags{$flag}; 372 } 373 } 374 die qq[Opcode '$op' has no class indicator ($flags{$op} => $flags)\n] 375 unless exists $opclass{$flags}; 376 $argsum |= $opclass{$flags} << $OCSHIFT; 377 my $argshift = $OASHIFT; 378 for my $arg (split(' ',$args{$op})) { 379 if ($arg =~ s/^D//) { 380 # handle 1st, just to put D 1st. 381 $OP_IS_DIRHOP{$op} = $opnum{$op}; 382 } 383 if ($arg =~ /^F/) { 384 # record opnums of these opnames 385 $OP_IS_SOCKET{$op} = $opnum{$op} if $arg =~ s/s//; 386 $OP_IS_FILETEST{$op} = $opnum{$op} if $arg =~ s/-//; 387 $OP_IS_FT_ACCESS{$op} = $opnum{$op} if $arg =~ s/\+//; 388 } 389 elsif ($arg =~ /^S</) { 390 $OP_IS_NUMCOMPARE{$op} = $opnum{$op} if $arg =~ s/<//; 391 } 392 my $argnum = ($arg =~ s/\?//) ? 8 : 0; 393 die "op = $op, arg = $arg\n" 394 unless exists $argnum{$arg}; 395 $argnum += $argnum{$arg}; 396 die "Argument overflow for '$op'\n" 397 if $argshift >= $ARGBITS || 398 $argnum > ((1 << ($ARGBITS - $argshift)) - 1); 399 $argsum += $argnum << $argshift; 400 $argshift += 4; 401 } 402 $argsum = sprintf("0x%08x", $argsum); 403 print $oc "\t", tab(3, "$argsum,"), "/* $op */\n"; 404} 405 406print $oc <<'END'; 407}; 408#endif 409 410#endif /* !PERL_GLOBAL_STRUCT_INIT */ 411 412END_EXTERN_C 413END 414 415# Emit OP_IS_* macros 416 417print $on <<'EO_OP_IS_COMMENT'; 418 419/* the OP_IS_* macros are optimized to a simple range check because 420 all the member OPs are contiguous in regen/opcodes table. 421 opcode.pl verifies the range contiguity, or generates an OR-equals 422 expression */ 423EO_OP_IS_COMMENT 424 425gen_op_is_macro( \%OP_IS_SOCKET, 'OP_IS_SOCKET'); 426gen_op_is_macro( \%OP_IS_FILETEST, 'OP_IS_FILETEST'); 427gen_op_is_macro( \%OP_IS_FT_ACCESS, 'OP_IS_FILETEST_ACCESS'); 428gen_op_is_macro( \%OP_IS_NUMCOMPARE, 'OP_IS_NUMCOMPARE'); 429gen_op_is_macro( \%OP_IS_DIRHOP, 'OP_IS_DIRHOP'); 430 431sub gen_op_is_macro { 432 my ($op_is, $macname) = @_; 433 if (keys %$op_is) { 434 435 # get opnames whose numbers are lowest and highest 436 my ($first, @rest) = sort { 437 $op_is->{$a} <=> $op_is->{$b} 438 } keys %$op_is; 439 440 my $last = pop @rest; # @rest slurped, get its last 441 die "Invalid range of ops: $first .. $last\n" unless $last; 442 443 print $on "\n#define $macname(op) \\\n\t("; 444 445 # verify that op-ct matches 1st..last range (and fencepost) 446 # (we know there are no dups) 447 if ( $op_is->{$last} - $op_is->{$first} == scalar @rest + 1) { 448 449 # contiguous ops -> optimized version 450 print $on "(op) >= OP_" . uc($first) 451 . " && (op) <= OP_" . uc($last); 452 } 453 else { 454 print $on join(" || \\\n\t ", 455 map { "(op) == OP_" . uc() } sort keys %$op_is); 456 } 457 print $on ")\n"; 458 } 459} 460 461my $pp = open_new('pp_proto.h', '>', 462 { by => 'opcode.pl', from => 'its data' }); 463 464{ 465 my %funcs; 466 for (@ops) { 467 my $name = $alias{$_} ? $alias{$_}[0] : "Perl_pp_$_"; 468 ++$funcs{$name}; 469 } 470 print $pp "PERL_CALLCONV OP *$_(pTHX);\n" foreach sort keys %funcs; 471} 472foreach ($oc, $on, $pp) { 473 read_only_bottom_close_and_rename($_); 474} 475 476# Some comments about 'T' opcode classifier: 477 478# Safe to set if the ppcode uses: 479# tryAMAGICbin, tryAMAGICun, SETn, SETi, SETu, PUSHn, PUSHTARG, SETTARG, 480# SETs(TARG), XPUSHn, XPUSHu, 481 482# Unsafe to set if the ppcode uses dTARG or [X]RETPUSH[YES|NO|UNDEF] 483 484# lt and friends do SETs (including ncmp, but not scmp) 485 486# Additional mode of failure: the opcode can modify TARG before it "used" 487# all the arguments (or may call an external function which does the same). 488# If the target coincides with one of the arguments ==> kaboom. 489 490# pp.c pos substr each not OK (RETPUSHUNDEF) 491# substr vec also not OK due to LV to target (are they???) 492# ref not OK (RETPUSHNO) 493# trans not OK (dTARG; TARG = sv_newmortal();) 494# ucfirst etc not OK: TMP arg processed inplace 495# quotemeta not OK (unsafe when TARG == arg) 496# each repeat not OK too due to list context 497# pack split - unknown whether they are safe 498# sprintf: is calling do_sprintf(TARG,...) which can act on TARG 499# before other args are processed. 500 501# Suspicious wrt "additional mode of failure" (and only it): 502# schop, chop, postinc/dec, bit_and etc, negate, complement. 503 504# Also suspicious: 4-arg substr, sprintf, uc/lc (POK_only), reverse, pack. 505 506# substr/vec: doing TAINT_off()??? 507 508# pp_hot.c 509# readline - unknown whether it is safe 510# match subst not OK (dTARG) 511# grepwhile not OK (not always setting) 512# join not OK (unsafe when TARG == arg) 513 514# Suspicious wrt "additional mode of failure": concat (dealt with 515# in ck_sassign()), join (same). 516 517# pp_ctl.c 518# mapwhile flip caller not OK (not always setting) 519 520# pp_sys.c 521# backtick glob warn die not OK (not always setting) 522# warn not OK (RETPUSHYES) 523# open fileno getc sysread syswrite ioctl accept shutdown 524# ftsize(etc) readlink telldir fork alarm getlogin not OK (RETPUSHUNDEF) 525# umask select not OK (XPUSHs(&PL_sv_undef);) 526# fileno getc sysread syswrite tell not OK (meth("FILENO" "GETC")) 527# sselect shm* sem* msg* syscall - unknown whether they are safe 528# gmtime not OK (list context) 529 530# Suspicious wrt "additional mode of failure": warn, die, select. 531