This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Rename pp_send to pp_syswrite, making send an alias for syswrite.
[perl5.git] / regen / opcode.pl
CommitLineData
d6480c9d 1#!/usr/bin/perl -w
6294c161
DM
2#
3# Regenerate (overwriting only if changed):
4#
5# opcode.h
6# opnames.h
897d3989 7# pp_proto.h
6294c161 8#
f8a58b02 9# from information stored in regen/opcodes, plus the
6294c161
DM
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
d6480c9d
NC
16use strict;
17
36bb303b
NC
18BEGIN {
19 # Get function prototypes
af001346 20 require 'regen/regen_lib.pl';
36bb303b 21}
79072805 22
d6480c9d
NC
23my $opcode_new = 'opcode.h-new';
24my $opname_new = 'opnames.h-new';
424a4936
NC
25my $oc = safer_open($opcode_new);
26my $on = safer_open($opname_new);
27select $oc;
79072805
LW
28
29# Read data.
30
d6480c9d 31my %seen;
e71197e2 32my (@ops, %desc, %check, %ckname, %flags, %args, %opnum);
d6480c9d 33
f8a58b02
NC
34open OPS, 'regen/opcodes' or die $!;
35
36while (<OPS>) {
79072805
LW
37 chop;
38 next unless $_;
39 next if /^#/;
d6480c9d
NC
40 my ($key, $desc, $check, $flags, $args) = split(/\t+/, $_, 5);
41 $args = '' unless defined $args;
c07a80fd 42
6342d5c5
FC
43 warn qq[Description "$desc" duplicates $seen{$desc}\n]
44 if $seen{$desc} and $key ne "transr";
c07a80fd
PP
45 die qq[Opcode "$key" duplicates $seen{$key}\n] if $seen{$key};
46 $seen{$desc} = qq[description of opcode "$key"];
47 $seen{$key} = qq[opcode "$key"];
48
79072805 49 push(@ops, $key);
e71197e2 50 $opnum{$key} = $#ops;
c07a80fd 51 $desc{$key} = $desc;
79072805
LW
52 $check{$key} = $check;
53 $ckname{$check}++;
54 $flags{$key} = $flags;
55 $args{$key} = $args;
56}
57
1d5774de
NC
58# Set up aliases
59
60my %alias;
61
62# Format is "this function" => "does these op names"
63my @raw_alias = (
6faeeb49 64 Perl_do_kv => [qw( keys values )],
d83386fa 65 Perl_unimplemented_op => [qw(padany mapstart custom)],
0b612f93
NC
66 # All the ops with a body of { return NORMAL; }
67 Perl_pp_null => [qw(scalar regcmaybe lineseq scope)],
68
69 Perl_pp_goto => ['dump'],
70 Perl_pp_require => ['dofile'],
71 Perl_pp_untie => ['dbmclose'],
72 Perl_pp_sysread => [qw(read recv)],
73 Perl_pp_sysseek => ['seek'],
74 Perl_pp_ioctl => ['fcntl'],
75 Perl_pp_ssockopt => ['gsockopt'],
76 Perl_pp_getpeername => ['getsockname'],
77 Perl_pp_stat => ['lstat'],
f1cb2d48 78 Perl_pp_ftrowned => [qw(fteowned ftzero ftsock ftchr ftblk
17ad201a
NC
79 ftfile ftdir ftpipe ftsuid ftsgid
80 ftsvtx)],
0b612f93
NC
81 Perl_pp_fttext => ['ftbinary'],
82 Perl_pp_gmtime => ['localtime'],
83 Perl_pp_semget => [qw(shmget msgget)],
84 Perl_pp_semctl => [qw(shmctl msgctl)],
0b612f93
NC
85 Perl_pp_ghostent => [qw(ghbyname ghbyaddr)],
86 Perl_pp_gnetent => [qw(gnbyname gnbyaddr)],
87 Perl_pp_gprotoent => [qw(gpbyname gpbynumber)],
88 Perl_pp_gservent => [qw(gsbyname gsbyport)],
89 Perl_pp_gpwent => [qw(gpwnam gpwuid)],
90 Perl_pp_ggrent => [qw(ggrnam ggrgid)],
957b0e1d 91 Perl_pp_ftis => [qw(ftsize ftmtime ftatime ftctime)],
605b9385 92 Perl_pp_chown => [qw(unlink chmod utime kill)],
ce6987d0 93 Perl_pp_link => ['symlink'],
af9e49b4
NC
94 Perl_pp_ftrread => [qw(ftrwrite ftrexec fteread ftewrite
95 fteexec)],
ca563b4e 96 Perl_pp_shmwrite => [qw(shmread msgsnd msgrcv semop)],
60504e18 97 Perl_pp_syswrite => ['send'],
c960fc3b 98 Perl_pp_defined => [qw(dor dorassign)],
62726f23
SP
99 Perl_pp_and => ['andassign'],
100 Perl_pp_or => ['orassign'],
12e9c124 101 Perl_pp_ucfirst => ['lcfirst'],
afd9910b 102 Perl_pp_sle => [qw(slt sgt sge)],
0d863452 103 Perl_pp_print => ['say'],
2723d216 104 Perl_pp_index => ['rindex'],
daa2adfd 105 Perl_pp_oct => ['hex'],
789b4bc9 106 Perl_pp_shift => ['pop'],
71302fe3 107 Perl_pp_sin => [qw(cos exp log sqrt)],
3658c1f1 108 Perl_pp_bit_or => ['bit_xor'],
17ab7946 109 Perl_pp_rv2av => ['rv2hv'],
878d132a 110 Perl_pp_akeys => ['avalues'],
cba5a3b0 111 Perl_pp_rkeys => [qw(rvalues reach)],
9561d06f
NC
112 Perl_pp_trans => ['transr'],
113 Perl_pp_chop => ['chomp'],
114 Perl_pp_schop => ['schomp'],
32b81f04 115 Perl_pp_bind => ['connect'],
9561d06f
NC
116 Perl_pp_preinc => ['i_preinc'],
117 Perl_pp_predec => ['i_predec'],
118 Perl_pp_postinc => ['i_postinc'],
119 Perl_pp_postdec => ['i_postdec'],
605b9385 120 );
1d5774de
NC
121
122while (my ($func, $names) = splice @raw_alias, 0, 2) {
916e4025
NC
123 foreach (@$names) {
124 $alias{$_} = $func;
125 }
1d5774de
NC
126}
127
79072805
LW
128# Emit defines.
129
748a9306 130print <<"END";
37442d52
RGS
131/* -*- buffer-read-only: t -*-
132 *
d6376244
JH
133 * opcode.h
134 *
699a97de
RGS
135 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
136 * 2001, 2002, 2003, 2004, 2005, 2006, 2007 by Larry Wall and others
d6376244
JH
137 *
138 * You may distribute under the terms of either the GNU General Public
139 * License or the Artistic License, as specified in the README file.
140 *
141 * !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
d006332c
FC
142 * This file is built by regen/opcode.pl from its data. Any changes made
143 * here will be lost!
d6376244 144 */
a27f85b3 145
27da23d5
JH
146#ifndef PERL_GLOBAL_STRUCT_INIT
147
9561d06f
NC
148END
149
150for (@ops) {
151 print "#define Perl_pp_$_ $alias{$_}\n" if $alias{$_};
152}
153
424a4936 154print $on <<"END";
37442d52
RGS
155/* -*- buffer-read-only: t -*-
156 *
d6376244
JH
157 * opnames.h
158 *
cfc85103 159 * Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
e8e5c75e 160 * 2007, 2008 by Larry Wall and others
d6376244
JH
161 *
162 * You may distribute under the terms of either the GNU General Public
163 * License or the Artistic License, as specified in the README file.
164 *
165 *
166 * !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
d006332c
FC
167 * This file is built by regen/opcode.pl from its data. Any changes made
168 * here will be lost!
d6376244 169 */
abdd5c84
GS
170
171typedef enum opcode {
172END
173
d6480c9d 174my $i = 0;
79072805 175for (@ops) {
424a4936 176 print $on "\t", &tab(3,"OP_\U$_"), " = ", $i++, ",\n";
79072805 177}
424a4936
NC
178print $on "\t", &tab(3,"OP_max"), "\n";
179print $on "} opcode;\n";
180print $on "\n#define MAXO ", scalar @ops, "\n";
79072805 181
c07a80fd 182# Emit op names and descriptions.
79072805
LW
183
184print <<END;
73c4f7a1
GS
185START_EXTERN_C
186
79072805 187#ifndef DOINIT
27da23d5 188EXTCONST char* const PL_op_name[];
79072805 189#else
27da23d5 190EXTCONST char* const PL_op_name[] = {
79072805
LW
191END
192
193for (@ops) {
c07a80fd
PP
194 print qq(\t"$_",\n);
195}
196
197print <<END;
198};
199#endif
200
201END
202
203print <<END;
204#ifndef DOINIT
27da23d5 205EXTCONST char* const PL_op_desc[];
c07a80fd 206#else
27da23d5 207EXTCONST char* const PL_op_desc[] = {
c07a80fd
PP
208END
209
210for (@ops) {
42d38218
MS
211 my($safe_desc) = $desc{$_};
212
a567e93b 213 # Have to escape double quotes and escape characters.
b0c6325e 214 $safe_desc =~ s/([\\"])/\\$1/g;
42d38218
MS
215
216 print qq(\t"$safe_desc",\n);
79072805
LW
217}
218
219print <<END;
220};
221#endif
222
73c4f7a1
GS
223END_EXTERN_C
224
27da23d5 225#endif /* !PERL_GLOBAL_STRUCT_INIT */
22c35a8c 226END
79072805 227
79072805
LW
228# Emit ppcode switch array.
229
230print <<END;
231
73c4f7a1
GS
232START_EXTERN_C
233
27da23d5 234#ifdef PERL_GLOBAL_STRUCT_INIT
97aff369 235# define PERL_PPADDR_INITED
27da23d5 236static const Perl_ppaddr_t Gppaddr[]
79072805 237#else
27da23d5 238# ifndef PERL_GLOBAL_STRUCT
97aff369 239# define PERL_PPADDR_INITED
27da23d5
JH
240EXT Perl_ppaddr_t PL_ppaddr[] /* or perlvars.h */
241# endif
242#endif /* PERL_GLOBAL_STRUCT */
243#if (defined(DOINIT) && !defined(PERL_GLOBAL_STRUCT)) || defined(PERL_GLOBAL_STRUCT_INIT)
97aff369 244# define PERL_PPADDR_INITED
27da23d5 245= {
79072805
LW
246END
247
248for (@ops) {
6faeeb49 249 if (my $name = $alias{$_}) {
6f3ed336 250 print "\tPerl_pp_$_,\t/* implemented by $name */\n";
6faeeb49
MB
251 }
252 else {
ef69c8fc 253 print "\tPerl_pp_$_,\n";
6faeeb49 254 }
79072805
LW
255}
256
257print <<END;
27da23d5 258}
79072805 259#endif
97aff369 260#ifdef PERL_PPADDR_INITED
27da23d5 261;
97aff369 262#endif
79072805
LW
263
264END
265
266# Emit check routines.
267
268print <<END;
27da23d5 269#ifdef PERL_GLOBAL_STRUCT_INIT
97aff369 270# define PERL_CHECK_INITED
27da23d5 271static const Perl_check_t Gcheck[]
79072805 272#else
27da23d5 273# ifndef PERL_GLOBAL_STRUCT
97aff369 274# define PERL_CHECK_INITED
27da23d5
JH
275EXT Perl_check_t PL_check[] /* or perlvars.h */
276# endif
277#endif
278#if (defined(DOINIT) && !defined(PERL_GLOBAL_STRUCT)) || defined(PERL_GLOBAL_STRUCT_INIT)
97aff369 279# define PERL_CHECK_INITED
27da23d5 280= {
79072805
LW
281END
282
283for (@ops) {
ef69c8fc 284 print "\t", &tab(3, "Perl_$check{$_},"), "\t/* $_ */\n";
79072805
LW
285}
286
287print <<END;
27da23d5 288}
79072805 289#endif
97aff369 290#ifdef PERL_CHECK_INITED
27da23d5 291;
97aff369 292#endif /* #ifdef PERL_CHECK_INITED */
79072805
LW
293
294END
295
296# Emit allowed argument types.
297
c2dedb93
MHM
298my $ARGBITS = 32;
299
79072805 300print <<END;
27da23d5
JH
301#ifndef PERL_GLOBAL_STRUCT_INIT
302
79072805 303#ifndef DOINIT
1ccb7c8d 304EXTCONST U32 PL_opargs[];
79072805 305#else
1ccb7c8d 306EXTCONST U32 PL_opargs[] = {
79072805
LW
307END
308
d6480c9d
NC
309my %argnum = (
310 'S', 1, # scalar
311 'L', 2, # list
312 'A', 3, # array value
313 'H', 4, # hash value
314 'C', 5, # code value
315 'F', 6, # file value
316 'R', 7, # scalar reference
79072805
LW
317);
318
d6480c9d 319my %opclass = (
db173bac
MB
320 '0', 0, # baseop
321 '1', 1, # unop
322 '2', 2, # binop
323 '|', 3, # logop
1a67a97c
SM
324 '@', 4, # listop
325 '/', 5, # pmop
350de78d 326 '$', 6, # svop_or_padop
7934575e 327 '#', 7, # padop
1a67a97c
SM
328 '"', 8, # pvop_or_svop
329 '{', 9, # loop
330 ';', 10, # cop
331 '%', 11, # baseop_or_unop
332 '-', 12, # filestatop
333 '}', 13, # loopexop
db173bac
MB
334);
335
c2dedb93
MHM
336my %opflags = (
337 'm' => 1, # needs stack mark
338 'f' => 2, # fold constants
339 's' => 4, # always produces scalar
340 't' => 8, # needs target scalar
903fd87c
NC
341 'T' => 8 | 16, # ... which may be lexical
342 'i' => 0, # always produces integer (unused since e7311069)
c2dedb93
MHM
343 'I' => 32, # has corresponding int op
344 'd' => 64, # danger, unknown side effects
345 'u' => 128, # defaults to $_
346);
347
a85d93d9
JH
348my %OP_IS_SOCKET;
349my %OP_IS_FILETEST;
6ecf81d6 350my %OP_IS_FT_ACCESS;
903fd87c
NC
351my $OCSHIFT = 8;
352my $OASHIFT = 12;
a85d93d9 353
c2dedb93 354for my $op (@ops) {
d6480c9d 355 my $argsum = 0;
c2dedb93
MHM
356 my $flags = $flags{$op};
357 for my $flag (keys %opflags) {
358 if ($flags =~ s/$flag//) {
cb7b5e07 359 die "Flag collision for '$op' ($flags{$op}, $flag)\n"
c2dedb93
MHM
360 if $argsum & $opflags{$flag};
361 $argsum |= $opflags{$flag};
362 }
363 }
cb7b5e07 364 die qq[Opcode '$op' has no class indicator ($flags{$op} => $flags)\n]
c2dedb93
MHM
365 unless exists $opclass{$flags};
366 $argsum |= $opclass{$flags} << $OCSHIFT;
367 my $argshift = $OASHIFT;
368 for my $arg (split(' ',$args{$op})) {
a85d93d9 369 if ($arg =~ /^F/) {
e71197e2
JC
370 # record opnums of these opnames
371 $OP_IS_SOCKET{$op} = $opnum{$op} if $arg =~ s/s//;
372 $OP_IS_FILETEST{$op} = $opnum{$op} if $arg =~ s/-//;
6ecf81d6 373 $OP_IS_FT_ACCESS{$op} = $opnum{$op} if $arg =~ s/\+//;
a85d93d9 374 }
d6480c9d 375 my $argnum = ($arg =~ s/\?//) ? 8 : 0;
c2dedb93
MHM
376 die "op = $op, arg = $arg\n"
377 unless exists $argnum{$arg};
79072805 378 $argnum += $argnum{$arg};
c2dedb93
MHM
379 die "Argument overflow for '$op'\n"
380 if $argshift >= $ARGBITS ||
381 $argnum > ((1 << ($ARGBITS - $argshift)) - 1);
382 $argsum += $argnum << $argshift;
383 $argshift += 4;
79072805
LW
384 }
385 $argsum = sprintf("0x%08x", $argsum);
c2dedb93 386 print "\t", &tab(3, "$argsum,"), "/* $op */\n";
79072805
LW
387}
388
389print <<END;
390};
391#endif
73c4f7a1 392
bae1192d
JH
393#endif /* !PERL_GLOBAL_STRUCT_INIT */
394
73c4f7a1 395END_EXTERN_C
27da23d5 396
79072805
LW
397END
398
e71197e2
JC
399# Emit OP_IS_* macros
400
424a4936 401print $on <<EO_OP_IS_COMMENT;
e71197e2
JC
402
403/* the OP_IS_(SOCKET|FILETEST) macros are optimized to a simple range
404 check because all the member OPs are contiguous in opcode.pl
f8a58b02 405 <OPS> table. opcode.pl verifies the range contiguity. */
e71197e2
JC
406
407EO_OP_IS_COMMENT
408
409gen_op_is_macro( \%OP_IS_SOCKET, 'OP_IS_SOCKET');
410gen_op_is_macro( \%OP_IS_FILETEST, 'OP_IS_FILETEST');
6ecf81d6 411gen_op_is_macro( \%OP_IS_FT_ACCESS, 'OP_IS_FILETEST_ACCESS');
e71197e2
JC
412
413sub gen_op_is_macro {
414 my ($op_is, $macname) = @_;
415 if (keys %$op_is) {
416
417 # get opnames whose numbers are lowest and highest
418 my ($first, @rest) = sort {
419 $op_is->{$a} <=> $op_is->{$b}
420 } keys %$op_is;
421
422 my $last = pop @rest; # @rest slurped, get its last
cb7b5e07 423 die "Invalid range of ops: $first .. $last\n" unless $last;
6ecf81d6 424
424a4936 425 print $on "#define $macname(op) \\\n\t(";
6ecf81d6 426
e71197e2
JC
427 # verify that op-ct matches 1st..last range (and fencepost)
428 # (we know there are no dups)
429 if ( $op_is->{$last} - $op_is->{$first} == scalar @rest + 1) {
430
431 # contiguous ops -> optimized version
424a4936
NC
432 print $on "(op) >= OP_" . uc($first) . " && (op) <= OP_" . uc($last);
433 print $on ")\n\n";
e71197e2
JC
434 }
435 else {
424a4936 436 print $on join(" || \\\n\t ",
6ecf81d6 437 map { "(op) == OP_" . uc() } sort keys %$op_is);
424a4936 438 print $on ")\n\n";
e71197e2
JC
439 }
440 }
a85d93d9
JH
441}
442
424a4936
NC
443print $oc "/* ex: set ro: */\n";
444print $on "/* ex: set ro: */\n";
37442d52 445
08858ed2
NC
446safer_close($oc);
447safer_close($on);
735e0d5c 448
424a4936
NC
449rename_if_different $opcode_new, 'opcode.h';
450rename_if_different $opname_new, 'opnames.h';
46f659cb 451
897d3989 452my $pp_proto_new = 'pp_proto.h-new';
22c35a8c 453
897d3989 454my $pp = safer_open($pp_proto_new);
a27f85b3 455
897d3989
NC
456print $pp <<"END";
457/* -*- buffer-read-only: t -*-
458 !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
459 This file is built by opcode.pl from its data. Any changes made here
460 will be lost!
461*/
a27f85b3 462
897d3989 463END
a27f85b3 464
981b7185
NC
465{
466 my %funcs;
467 for (@ops) {
468 my $name = $alias{$_} || "Perl_pp_$_";
469 ++$funcs{$name};
470 }
471 print $pp "PERL_CALLCONV OP *$_(pTHX);\n" foreach sort keys %funcs;
735e0d5c 472}
897d3989 473print $pp "\n/* ex: set ro: */\n";
735e0d5c 474
897d3989 475safer_close($pp);
735e0d5c 476
897d3989 477rename_if_different $pp_proto_new, 'pp_proto.h';
46f659cb 478
24600adc 479END {
897d3989 480 foreach ('opcode.h', 'opnames.h', 'pp_proto.h') {
24600adc
JH
481 1 while unlink "$_-old";
482 }
483}
484
79072805
LW
485###########################################################################
486sub tab {
d6480c9d 487 my ($l, $t) = @_;
79072805
LW
488 $t .= "\t" x ($l - (length($t) + 1) / 8);
489 $t;
490}
491###########################################################################
b162f9ea
IZ
492
493# Some comments about 'T' opcode classifier:
494
495# Safe to set if the ppcode uses:
496# tryAMAGICbin, tryAMAGICun, SETn, SETi, SETu, PUSHn, PUSHTARG, SETTARG,
497# SETs(TARG), XPUSHn, XPUSHu,
498
499# Unsafe to set if the ppcode uses dTARG or [X]RETPUSH[YES|NO|UNDEF]
500
501# lt and friends do SETs (including ncmp, but not scmp)
502
21f5b33c
GS
503# Additional mode of failure: the opcode can modify TARG before it "used"
504# all the arguments (or may call an external function which does the same).
505# If the target coincides with one of the arguments ==> kaboom.
506
b162f9ea
IZ
507# pp.c pos substr each not OK (RETPUSHUNDEF)
508# substr vec also not OK due to LV to target (are they???)
509# ref not OK (RETPUSHNO)
510# trans not OK (dTARG; TARG = sv_newmortal();)
511# ucfirst etc not OK: TMP arg processed inplace
69b47968 512# quotemeta not OK (unsafe when TARG == arg)
91e74348 513# each repeat not OK too due to list context
b162f9ea 514# pack split - unknown whether they are safe
dae78bb1
IZ
515# sprintf: is calling do_sprintf(TARG,...) which can act on TARG
516# before other args are processed.
b162f9ea 517
21f5b33c
GS
518# Suspicious wrt "additional mode of failure" (and only it):
519# schop, chop, postinc/dec, bit_and etc, negate, complement.
520
521# Also suspicious: 4-arg substr, sprintf, uc/lc (POK_only), reverse, pack.
522
523# substr/vec: doing TAINT_off()???
524
b162f9ea
IZ
525# pp_hot.c
526# readline - unknown whether it is safe
527# match subst not OK (dTARG)
528# grepwhile not OK (not always setting)
69b47968 529# join not OK (unsafe when TARG == arg)
b162f9ea 530
21f5b33c
GS
531# Suspicious wrt "additional mode of failure": concat (dealt with
532# in ck_sassign()), join (same).
533
b162f9ea
IZ
534# pp_ctl.c
535# mapwhile flip caller not OK (not always setting)
536
537# pp_sys.c
538# backtick glob warn die not OK (not always setting)
539# warn not OK (RETPUSHYES)
540# open fileno getc sysread syswrite ioctl accept shutdown
541# ftsize(etc) readlink telldir fork alarm getlogin not OK (RETPUSHUNDEF)
542# umask select not OK (XPUSHs(&PL_sv_undef);)
543# fileno getc sysread syswrite tell not OK (meth("FILENO" "GETC"))
544# sselect shm* sem* msg* syscall - unknown whether they are safe
545# gmtime not OK (list context)
546
21f5b33c 547# Suspicious wrt "additional mode of failure": warn, die, select.