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