This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
5397dc07195831c80a345364e3f4c15b13f6818d
[perl5.git] / regen / regcomp.pl
1 #!/usr/bin/perl -w
2 #
3 #
4 # Regenerate (overwriting only if changed):
5 #
6 #    pod/perldebguts.pod
7 #    regnodes.h
8 #
9 # from information stored in
10 #
11 #    regcomp.sym
12 #    regexp.h
13 #
14 # pod/perldebguts.pod is not completely regenerated.  Only the table of
15 # regexp nodes is replaced; other parts remain unchanged.
16 #
17 # Accepts the standard regen_lib -q and -v args.
18 #
19 # This script is normally invoked from regen.pl.
20
21 BEGIN {
22     # Get function prototypes
23     require './regen/regen_lib.pl';
24 }
25 use strict;
26
27 # NOTE I don't think anyone actually knows what all of these properties mean,
28 # and I suspect some of them are outright unused. This is a first attempt to
29 # clean up the generation so maybe one day we can move to something more self
30 # documenting. (One might argue that an array of hashes of properties would
31 # be easier to use.)
32 #
33 # Why we use the term regnode and nodes, and not say, opcodes, I am not sure.
34
35 # General thoughts:
36 # 1. We use a single continuum to represent both opcodes and states,
37 #    and in regexec.c we switch on the combined set.
38 # 2. Opcodes have more information associated to them, states are simpler,
39 #    basically just an identifier/number that can be used to switch within
40 #    the state machine.
41 # 3. Some opcode are order dependent.
42 # 4. Output files often use "tricks" to reduce diff effects. Some of what
43 #    we do below is more clumsy looking than it could be because of this.
44
45 # Op/state properties:
46 #
47 # Property      In      Descr
48 # ----------------------------------------------------------------------------
49 # name          Both    Name of op/state
50 # id            Both    integer value for this opcode/state
51 # optype        Both    Either 'op' or 'state'
52 # line_num      Both    line_num number of the input file for this item.
53 # type          Op      Type of node (aka regkind)
54 # code          Op      Apparently not used
55 # suffix        Op      which regnode struct this uses, so if this is '1', it
56 #                       uses 'struct regnode_1'
57 # flags         Op      S for simple; V for varies
58 # longj         Op      Boolean as to if this node is a longjump
59 # comment       Both    Comment about node, if any.  Placed in perlredebguts
60 #                       as its description
61 # pod_comment   Both    Special comments for pod output (preceding lines in def)
62 #                       Such lines begin with '#*'
63
64 # Global State
65 my @all;    # all opcodes/state
66 my %all;    # hash of all opcode/state names
67
68 my @ops;    # array of just opcodes
69 my @states; # array of just states
70
71 my $longest_name_length= 0; # track lengths of names for nicer reports
72 my (%type_alias);           # map the type (??)
73
74 # register a newly constructed node into our state tables.
75 # ensures that we have no name collisions (on name anyway),
76 # and issues the "id" for the node.
77 sub register_node {
78     my ($node)= @_;
79
80     if ( $all{ $node->{name} } ) {
81         die "Duplicate item '$node->{name}' in regcomp.sym line $node->{line_num} "
82             . "previously defined on line $all{ $node->{name} }{line_num}\n";
83     } elsif (!$node->{optype}) {
84         die "must have an optype in node ", Dumper($node);
85     } elsif ($node->{optype} eq "op") {
86         push @ops, $node;
87     } elsif ($node->{optype} eq "state") {
88         push @states, $node;
89     } else {
90         die "Uknown optype '$node->{optype}' in ", Dumper($node);
91     }
92     $node->{id}= 0 + @all;
93     push @all, $node;
94     $all{ $node->{name} }= $node;
95
96     if ($node->{longj} && $node->{longj} != 1) {
97         die "longj field must be in [01] if present in ", Dumper($node);
98     }
99
100 }
101
102 # Parse and add an opcode definition to the global state.
103 # What an opcode definition looks like is given in regcomp.sym.
104 #
105 # Not every opcode definition has all of the components. We should maybe make
106 # this nicer/easier to read in the future. Also note that the above is tab
107 # sensitive.
108
109 # Special comments for an entry precede it, and begin with '#*' and are placed
110 # in the generated pod file just before the entry.
111
112 sub parse_opcode_def {
113     my ( $text, $line_num, $pod_comment )= @_;
114     my $node= {
115         line_num    => $line_num,
116         pod_comment => $pod_comment,
117         optype      => "op",
118     };
119
120     # first split the line into three, the initial NAME, a middle part
121     # that we call "desc" which contains various (not well documented) things,
122     # and a comment section.
123     @{$node}{qw(name desc comment)}= /^(\S+)\s+([^\t]+?)\s*;\s*(.*)/
124         or die "Failed to match $_";
125
126     # the content of the "desc" field from the first step is extracted here:
127     @{$node}{qw(type code args flags longj)}= split /[,\s]\s*/, $node->{desc};
128
129     defined $node->{$_} or $node->{$_} = ""
130         for qw(type code args flags longj);
131
132     register_node($node); # has to be before the type_alias code below
133
134     if ( !$all{ $node->{type} } and !$type_alias{ $node->{type} } ) {
135
136         #warn "Regop type '$node->{type}' from regcomp.sym line $line_num"
137         #     ." is not an existing regop, and will be aliased to $node->{name}\n"
138         #    if -t STDERR;
139         $type_alias{ $node->{type} }= $node->{name};
140     }
141
142     $longest_name_length= length $node->{name}
143         if length $node->{name} > $longest_name_length;
144 }
145
146 # parse out a state definition and add the resulting data
147 # into the global state. may create multiple new states from
148 # a single definition (this is part of the point).
149 # Format for states:
150 # REGOP \t typelist [ \t typelist]
151 # typelist= namelist
152 #         = namelist:FAIL
153 #         = name:count
154 # Eg:
155 # WHILEM          A_pre,A_min,A_max,B_min,B_max:FAIL
156 # BRANCH          next:FAIL
157 # CURLYM          A,B:FAIL
158 #
159 # The CURLYM definition would create the states:
160 # CURLYM_A, CURLYM_A_fail, CURLYM_B, CURLYM_B_fail
161 sub parse_state_def {
162     my ( $text, $line_num, $pod_comment )= @_;
163     my ( $type, @lists )= split /\s+/, $text;
164     die "No list? $type" if !@lists;
165     foreach my $list (@lists) {
166         my ( $names, $special )= split /:/, $list, 2;
167         $special ||= "";
168         foreach my $name ( split /,/, $names ) {
169             my $real=
170                 $name eq 'resume'
171                 ? "resume_$type"
172                 : "${type}_$name";
173             my @suffix;
174             if ( !$special ) {
175                 @suffix= ("");
176             }
177             elsif ( $special =~ /\d/ ) {
178                 @suffix= ( 1 .. $special );
179             }
180             elsif ( $special eq 'FAIL' ) {
181                 @suffix= ( "", "_fail" );
182             }
183             else {
184                 die "unknown :type ':$special'";
185             }
186             foreach my $suffix (@suffix) {
187                 my $node= {
188                     name        => "$real$suffix",
189                     optype      => "state",
190                     type        => $type || "",
191                     comment     => "state for $type",
192                     line_num    => $line_num,
193                 };
194                 register_node($node);
195             }
196         }
197     }
198 }
199
200 sub process_flags {
201     my ( $flag, $varname, $comment )= @_;
202     $comment= '' unless defined $comment;
203
204     my @selected;
205     my $bitmap= '';
206     for my $node (@ops) {
207         my $set= $node->{flags} && $node->{flags} eq $flag ? 1 : 0;
208
209         # Whilst I could do this with vec, I'd prefer to do longhand the arithmetic
210         # ops in the C code.
211         my $current= do {
212             no warnings;
213             ord substr $bitmap, ( $node->{id} >> 3 );
214         };
215         substr( $bitmap, ( $node->{id} >> 3 ), 1 )=
216             chr( $current | ( $set << ( $node->{id} & 7 ) ) );
217
218         push @selected, $node->{name} if $set;
219     }
220     my $out_string= join ', ', @selected, 0;
221     $out_string =~ s/(.{1,70},) /$1\n    /g;
222
223     my $out_mask= join ', ', map { sprintf "0x%02X", ord $_ } split '', $bitmap;
224
225     return $comment . <<"EOP";
226 #define REGNODE_\U$varname\E(node) (PL_${varname}_bitmask[(node) >> 3] & (1 << ((node) & 7)))
227
228 #ifndef DOINIT
229 EXTCONST U8 PL_${varname}\[] __attribute__deprecated__;
230 #else
231 EXTCONST U8 PL_${varname}\[] __attribute__deprecated__ = {
232     $out_string
233 };
234 #endif /* DOINIT */
235
236 #ifndef DOINIT
237 EXTCONST U8 PL_${varname}_bitmask[];
238 #else
239 EXTCONST U8 PL_${varname}_bitmask[] = {
240     $out_mask
241 };
242 #endif /* DOINIT */
243 EOP
244 }
245
246 sub read_definition {
247     my ( $file )= @_;
248     my ( $seen_sep, $pod_comment )= "";
249     open my $in_fh, "<", $file
250         or die "Failed to open '$file' for reading: $!";
251     while (<$in_fh>) {
252
253         # Special pod comments
254         if (/^#\* ?/) { $pod_comment .= "# $'"; }
255
256         # Truly blank lines possibly surrounding pod comments
257         elsif (/^\s*$/) { $pod_comment .= "\n" }
258
259         next if /\A\s*#/ || /\A\s*\z/;
260
261         s/\s*\z//;
262         if (/^-+\s*$/) {
263             $seen_sep= 1;
264             next;
265         }
266
267         if ($seen_sep) {
268             parse_state_def( $_, $., $pod_comment );
269         }
270         else {
271             parse_opcode_def( $_, $., $pod_comment );
272         }
273         $pod_comment= "";
274     }
275     close $in_fh;
276     die "Too many regexp/state opcodes! Maximum is 256, but there are ", 0 + @all,
277         " in file!"
278         if @all > 256;
279 }
280
281 # use fixed width to keep the diffs between regcomp.pl recompiles
282 # as small as possible.
283 my ( $width, $rwidth, $twidth )= ( 22, 12, 9 );
284
285 sub print_state_defs {
286     my ($out)= @_;
287     printf $out <<EOP,
288 /* Regops and State definitions */
289
290 #define %*s\t%d
291 #define %*s\t%d
292
293 EOP
294         -$width,
295         REGNODE_MAX => $#ops,
296         -$width, REGMATCH_STATE_MAX => $#all;
297
298     my %rev_type_alias= reverse %type_alias;
299     for my $node (@ops) {
300         printf $out "#define\t%*s\t%d\t/* %#04x %s */\n",
301             -$width, $node->{name}, $node->{id}, $node->{id}, $node->{comment};
302         if ( defined( my $alias= $rev_type_alias{ $node->{name} } ) ) {
303             printf $out "#define\t%*s\t%d\t/* %#04x %s */\n",
304                 -$width, $alias, $node->{id}, $node->{id}, "type alias";
305         }
306     }
307
308     print $out "\t/* ------------ States ------------- */\n";
309     for my $node (@states) {
310         printf $out "#define\t%*s\t(REGNODE_MAX + %d)\t/* %s */\n",
311             -$width, $node->{name}, $node->{id} - $#ops, $node->{comment};
312     }
313 }
314
315 sub print_regkind {
316     my ($out)= @_;
317     print $out <<EOP;
318
319 /* PL_regkind[] What type of regop or state is this. */
320
321 #ifndef DOINIT
322 EXTCONST U8 PL_regkind[];
323 #else
324 EXTCONST U8 PL_regkind[] = {
325 EOP
326     use Data::Dumper;
327     foreach my $node (@all) {
328         print Dumper($node) if !defined $node->{type} or !defined( $node->{name} );
329         printf $out "\t%*s\t/* %*s */\n",
330             -1 - $twidth, "$node->{type},", -$width, $node->{name};
331         print $out "\t/* ------------ States ------------- */\n"
332             if $node->{id} == $#ops and $node->{id} != $#all;
333     }
334
335     print $out <<EOP;
336 };
337 #endif
338 EOP
339 }
340
341 sub wrap_ifdef_print {
342     my $out= shift;
343     my $token= shift;
344     print $out <<EOP;
345
346 #ifdef $token
347 EOP
348     $_->($out) for @_;
349     print $out <<EOP;
350 #endif /* $token */
351
352 EOP
353 }
354
355 sub print_regarglen {
356     my ($out)= @_;
357     print $out <<EOP;
358
359 /* regarglen[] - How large is the argument part of the node (in regnodes) */
360
361 static const U8 regarglen[] = {
362 EOP
363
364     foreach my $node (@ops) {
365         my $size= 0;
366         $size= "EXTRA_SIZE(struct regnode_$node->{args})" if $node->{args};
367
368         printf $out "\t%*s\t/* %*s */\n", -37, "$size,", -$rwidth, $node->{name};
369     }
370
371     print $out <<EOP;
372 };
373 EOP
374 }
375
376 sub print_reg_off_by_arg {
377     my ($out)= @_;
378     print $out <<EOP;
379
380 /* reg_off_by_arg[] - Which argument holds the offset to the next node */
381
382 static const char reg_off_by_arg[] = {
383 EOP
384
385     foreach my $node (@ops) {
386         my $size= $node->{longj} || 0;
387
388         printf $out "\t%d,\t/* %*s */\n", $size, -$rwidth, $node->{name};
389     }
390
391     print $out <<EOP;
392 };
393
394 EOP
395 }
396
397 sub print_reg_name {
398     my ($out)= @_;
399     print $out <<EOP;
400
401 /* reg_name[] - Opcode/state names in string form, for debugging */
402
403 #ifndef DOINIT
404 EXTCONST char * PL_reg_name[];
405 #else
406 EXTCONST char * const PL_reg_name[] = {
407 EOP
408
409     my $ofs= 0;
410     my $sym= "";
411     foreach my $node (@all) {
412         my $size= $node->{longj} || 0;
413
414         printf $out "\t%*s\t/* $sym%#04x */\n",
415             -3 - $width, qq("$node->{name}",), $node->{id} - $ofs;
416         if ( $node->{id} == $#ops and @ops != @all ) {
417             print $out "\t/* ------------ States ------------- */\n";
418             $ofs= $#ops;
419             $sym= 'REGNODE_MAX +';
420         }
421     }
422
423     print $out <<EOP;
424 };
425 #endif /* DOINIT */
426
427 EOP
428 }
429
430 sub print_reg_extflags_name {
431     my ($out)= @_;
432     print $out <<EOP;
433 /* PL_reg_extflags_name[] - Opcode/state names in string form, for debugging */
434
435 #ifndef DOINIT
436 EXTCONST char * PL_reg_extflags_name[];
437 #else
438 EXTCONST char * const PL_reg_extflags_name[] = {
439 EOP
440
441     my %rxfv;
442     my %definitions;    # Remember what the symbol definitions are
443     my $val= 0;
444     my %reverse;
445     my $REG_EXTFLAGS_NAME_SIZE= 0;
446     foreach my $file ( "op_reg_common.h", "regexp.h" ) {
447         open my $in_fh, "<", $file or die "Can't read '$file': $!";
448         while (<$in_fh>) {
449
450             # optional leading '_'.  Return symbol in $1, and strip it from
451             # comment of line
452             if (s/^ \# \s* define \s+ ( _? RXf_ \w+ ) \s+ //xi) {
453                 chomp;
454                 my $define= $1;
455                 my $orig= $_;
456                 s{ /\* .*? \*/ }{ }x;    # Replace comments by a blank
457
458                 # Replace any prior defined symbols by their values
459                 foreach my $key ( keys %definitions ) {
460                     s/\b$key\b/$definitions{$key}/g;
461                 }
462
463                 # Remove the U suffix from unsigned int literals
464                 s/\b([0-9]+)U\b/$1/g;
465
466                 my $newval= eval $_;     # Get numeric definition
467
468                 $definitions{$define}= $newval;
469
470                 next unless $_ =~ /<</;    # Bit defines use left shift
471                 if ( $val & $newval ) {
472                     my @names= ( $define, $reverse{$newval} );
473                     s/PMf_// for @names;
474                     if ( $names[0] ne $names[1] ) {
475                         die sprintf
476                             "ERROR: both $define and $reverse{$newval} use 0x%08X (%s:%s)",
477                             $newval, $orig, $_;
478                     }
479                     next;
480                 }
481                 $val |= $newval;
482                 $rxfv{$define}= $newval;
483                 $reverse{$newval}= $define;
484             }
485         }
486     }
487     my %vrxf= reverse %rxfv;
488     printf $out "\t/* Bits in extflags defined: %s */\n", unpack 'B*', pack 'N',
489         $val;
490     my %multibits;
491     for ( 0 .. 31 ) {
492         my $power_of_2= 2**$_;
493         my $n= $vrxf{$power_of_2};
494         my $extra= "";
495         if ( !$n ) {
496
497             # Here, there was no name that matched exactly the bit.  It could be
498             # either that it is unused, or the name matches multiple bits.
499             if ( !( $val & $power_of_2 ) ) {
500                 $n= "UNUSED_BIT_$_";
501             }
502             else {
503
504                 # Here, must be because it matches multiple bits.  Look through
505                 # all possibilities until find one that matches this one.  Use
506                 # that name, and all the bits it matches
507                 foreach my $name ( keys %rxfv ) {
508                     if ( $rxfv{$name} & $power_of_2 ) {
509                         $n= $name . ( $multibits{$name}++ );
510                         $extra= sprintf qq{ : "%s" - 0x%08x}, $name,
511                             $rxfv{$name}
512                             if $power_of_2 != $rxfv{$name};
513                         last;
514                     }
515                 }
516             }
517         }
518         s/\bRXf_(PMf_)?// for $n, $extra;
519         printf $out qq(\t%-20s/* 0x%08x%s */\n), qq("$n",), $power_of_2, $extra;
520         $REG_EXTFLAGS_NAME_SIZE++;
521     }
522
523     print $out <<EOP;
524 };
525 #endif /* DOINIT */
526
527 #ifdef DEBUGGING
528 #  define REG_EXTFLAGS_NAME_SIZE $REG_EXTFLAGS_NAME_SIZE
529 #endif
530 EOP
531
532 }
533
534 sub print_reg_intflags_name {
535     my ($out)= @_;
536     print $out <<EOP;
537
538 /* PL_reg_intflags_name[] - Opcode/state names in string form, for debugging */
539
540 #ifndef DOINIT
541 EXTCONST char * PL_reg_intflags_name[];
542 #else
543 EXTCONST char * const PL_reg_intflags_name[] = {
544 EOP
545
546     my %rxfv;
547     my %definitions;    # Remember what the symbol definitions are
548     my $val= 0;
549     my %reverse;
550     my $REG_INTFLAGS_NAME_SIZE= 0;
551     foreach my $file ("regcomp.h") {
552         open my $fh, "<", $file or die "Can't read $file: $!";
553         while (<$fh>) {
554
555             # optional leading '_'.  Return symbol in $1, and strip it from
556             # comment of line
557             if (
558                 m/^ \# \s* define \s+ ( PREGf_ ( \w+ ) ) \s+ 0x([0-9a-f]+)(?:\s*\/\*(.*)\*\/)?/xi
559                 )
560             {
561                 chomp;
562                 my $define= $1;
563                 my $abbr= $2;
564                 my $hex= $3;
565                 my $comment= $4;
566                 my $val= hex($hex);
567                 $comment= $comment ? " - $comment" : "";
568
569                 printf $out qq(\t%-30s/* 0x%08x - %s%s */\n), qq("$abbr",),
570                     $val, $define, $comment;
571                 $REG_INTFLAGS_NAME_SIZE++;
572             }
573         }
574     }
575
576     print $out <<EOP;
577 };
578 #endif /* DOINIT */
579
580 EOP
581     print $out <<EOQ;
582 #ifdef DEBUGGING
583 #  define REG_INTFLAGS_NAME_SIZE $REG_INTFLAGS_NAME_SIZE
584 #endif
585
586 EOQ
587 }
588
589 sub print_process_flags {
590     my ($out)= @_;
591
592     print $out process_flags( 'V', 'varies', <<'EOC');
593 /* The following have no fixed length. U8 so we can do strchr() on it. */
594 EOC
595
596     print $out process_flags( 'S', 'simple', <<'EOC');
597
598 /* The following always have a length of 1. U8 we can do strchr() on it. */
599 /* (Note that length 1 means "one character" under UTF8, not "one octet".) */
600 EOC
601
602 }
603
604 sub do_perldebguts {
605     my $guts= open_new( 'pod/perldebguts.pod', '>' );
606
607     my $node;
608     my $code;
609     my $name_fmt= '<' x  ( $longest_name_length - 1 );
610     my $descr_fmt= '<' x ( 58 - $longest_name_length );
611     eval <<EOD or die $@;
612 format GuTS =
613  ^*~~
614  \$node->{pod_comment}
615  ^$name_fmt ^<<<<<<<<< ^$descr_fmt~~
616  \$node->{name}, \$code, defined \$node->{comment} ? \$node->{comment} : ''
617 .
618 1;
619 EOD
620     
621     my $old_fh= select($guts);
622     $~= "GuTS";
623
624     open my $oldguts, '<', 'pod/perldebguts.pod'
625         or die "$0 cannot open pod/perldebguts.pod for reading: $!";
626     while (<$oldguts>) {
627         print;
628         last if /=for regcomp.pl begin/;
629     }
630
631     print <<'END_OF_DESCR';
632
633  # TYPE arg-description [regnode-struct-suffix] [longjump-len] DESCRIPTION
634 END_OF_DESCR
635     for my $n (@ops) {
636         $node= $n;
637         $code= "$node->{code} " . ( $node->{args} || "" );
638         $code .= " $node->{longj}" if $node->{longj};
639         if ( $node->{pod_comment} ||= "" ) {
640
641             # Trim multiple blanks
642             $node->{pod_comment} =~ s/^\n\n+/\n/;
643             $node->{pod_comment} =~ s/\n\n+$/\n\n/;
644         }
645         write;
646     }
647     print "\n";
648
649     while (<$oldguts>) {
650         last if /=for regcomp.pl end/;
651     }
652     do { print } while <$oldguts>; #win32 can't unlink an open FH
653     close $oldguts or die "Error closing pod/perldebguts.pod: $!";
654     select $old_fh;
655     close_and_rename($guts);
656 }
657
658 read_definition("regcomp.sym");
659 my $out= open_new( 'regnodes.h', '>',
660     { by => 'regen/regcomp.pl', from => 'regcomp.sym' } );
661 print_state_defs($out);
662 print_regkind($out);
663 wrap_ifdef_print(
664     $out,
665     "REG_COMP_C",
666     \&print_regarglen,
667     \&print_reg_off_by_arg
668 );
669 print_reg_name($out);
670 print_reg_extflags_name($out);
671 print_reg_intflags_name($out);
672 print_process_flags($out);
673 read_only_bottom_close_and_rename($out);
674
675 do_perldebguts();