Make Perl_keyword() another 30% faster.

p4raw-id: //depot/perl@23914

1 files changed, 40 insertions, 268 deletions

diff --git a/perl_keyword.pl b/perl_keyword.pl
index 957f8f9994..b06527c256 100644
--- a/perl_keyword.pl
+++ b/perl_keyword.pl
@@ -1,58 +1,9 @@
-#!./perl -w
 
 # How to generate the logic of the lookup table Perl_keyword() in toke.c
 
+use Devel::Tokenizer::C 0.04;
 use strict;
-package Toke;
-use vars qw(@ISA %types);
-require ExtUtils::Constant::Base;
-@ISA = 'ExtUtils::Constant::Base';
-
-%types = (pos => "KEY_", neg => "-KEY_");
-
-# We're allowing scalar references to produce evil customisation.
-sub valid_type {
-  defined $types{$_[1]} or ref $_[1];
-}
-
-
-# This might actually be a return statement
-sub assignment_clause_for_type {
-  my ($self, $args, $value) = @_;
-  my ($type, $item) = @{$args}{qw(type item)};
-  my $comment = '';
-  $comment = " /* Weight $item->{weight} */" if defined $item->{weight};
-  return "return $types{$type}$value;$comment" if $types{$type};
-  "$$type$value;$comment";
-}
-
-sub return_statement_for_notfound {
-  "return 0;"
-}
-
-# Ditch the default "const"
-sub name_param_definition {
-  "char *" . $_[0]->name_param;
-}
-
-sub C_constant_return_type {
-  "I32";
-}
-
-
-sub C_constant_prefix_param {
-  "aTHX_ ";
-}
-
-sub C_constant_prefix_param_defintion {
-  "pTHX_ ";
-}
-
-sub namelen_param_definition {
-  'I32 ' . $_[0] -> namelen_param;
-}
-
-package main;
+use warnings;
 
 my @pos = qw(__DATA__ __END__ AUTOLOAD BEGIN CHECK DESTROY do delete defined
 	     END else eval elsif exists for format foreach grep goto glob INIT
@@ -83,224 +34,45 @@ my @neg = qw(__FILE__ __LINE__ __PACKAGE__ and abs alarm atan2 accept bless
 	     times telldir truncate uc utime umask unpack unlink unshift
 	     ucfirst values vec warn wait write waitpid wantarray x xor);
 
-my %frequencies = (map {/(.*):\t(.*)/} <DATA>);
+my %pos = map { ($_ => 1) } @pos;
+
+my $t = Devel::Tokenizer::C->new( TokenFunc     => \&perl_keyword
+                                , TokenString   => 'name'
+                                , StringLength  => 'len'
+                                , MergeSwitches => 1
+                                );
+
+$t->add_tokens(@pos, @neg, 'elseif');
 
-my @names;
-push @names, map {{name=>$_, type=>"pos", weight=>$frequencies{$_}}} @pos;
-push @names, map {{name=>$_, type=>"neg", weight=>$frequencies{$_}}} @neg;
-push @names, {name=>'elseif', type=>\"", value=><<'EOC'};
-/* This is somewhat hacky.  */
+my $switch = $t->generate(Indent => '  ');
+
+print <<END;
+/*
+ *  The following code was generated by $0.
+ */
+
+I32
+Perl_keyword (pTHX_ char *name, I32 len)
+{
+$switch
+unknown:
+  return 0;
+}
+END
+
+sub perl_keyword
+{
+  my $k = shift;
+  my $sign = $pos{$k} ? '' : '-';
+
+  if ($k eq 'elseif') {
+    return <<END;
 if(ckWARN_d(WARN_SYNTAX))
   Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif");
-break;
-EOC
-
-print Toke->C_constant ({subname=>'Perl_keyword', breakout=>~0}, @names);
+END
+  }
 
-__DATA__
-my:	3785925
-if:	2482605
-sub:	2053554
-return:	1401629
-unless:	913955
-shift:	904125
-eq:	797065
-defined:	694277
-use:	686081
-else:	527806
-qw:	415641
-or:	405163
-s:	403691
-require:	375220
-ref:	347102
-elsif:	322365
-undef:	311156
-and:	284867
-foreach:	281720
-local:	262973
-push:	256975
-package:	245661
-print:	220904
-our:	194417
-die:	192203
-length:	163975
-next:	153355
-m:	148776
-caller:	148457
-exists:	145939
-eval:	136977
-keys:	131427
-join:	130820
-substr:	121344
-while:	120305
-for:	118158
-map:	115207
-ne:	112906
-__END__:	112636
-vec:	110566
-goto:	109258
-do:	96004
-last:	95078
-split:	93678
-warn:	91372
-grep:	75912
-delete:	74966
-sprintf:	72704
-q:	69076
-bless:	62111
-no:	61989
-not:	55868
-qq:	55149
-index:	51465
-CORE:	47391
-pop:	46933
-close:	44077
-scalar:	43953
-wantarray:	43024
-open:	39060
-x:	38549
-lc:	38487
-__PACKAGE__:	36767
-stat:	36702
-unshift:	36504
-sort:	36394
-chr:	35654
-time:	32168
-qr:	28519
-splice:	25143
-BEGIN:	24125
-tr:	22665
-chomp:	22337
-ord:	22221
-chdir:	20317
-unlink:	18616
-int:	18549
-chmod:	18455
-each:	18414
-uc:	16961
-pack:	14491
-lstat:	13859
-binmode:	12301
-select:	12209
-closedir:	11986
-readdir:	11716
-reverse:	10571
-chop:	10172
-tie:	10131
-values:	10110
-tied:	9749
-read:	9434
-opendir:	9007
-fileno:	8591
-exit:	8262
-localtime:	7993
-unpack:	7849
-abs:	7767
-printf:	6874
-cmp:	6808
-ge:	5666
-pos:	5503
-redo:	5219
-rindex:	5005
-rename:	4918
-syswrite:	4437
-system:	4326
-lock:	4210
-oct:	4195
-le:	4052
-gmtime:	4040
-utime:	3849
-sysread:	3729
-hex:	3629
-END:	3565
-quotemeta:	3120
-mkdir:	2951
-continue:	2925
-AUTOLOAD:	2713
-tell:	2578
-write:	2525
-rmdir:	2493
-seek:	2174
-glob:	2172
-study:	1933
-rand:	1824
-format:	1735
-umask:	1658
-eof:	1618
-prototype:	1602
-readlink:	1537
-truncate:	1351
-fcntl:	1257
-sysopen:	1230
-ucfirst:	1012
-getc:	981
-gethostbyname:	970
-ioctl:	967
-formline:	959
-gt:	897
-__FILE__:	888
-until:	818
-sqrt:	766
-getprotobyname:	755
-sysseek:	721
-getpeername:	713
-getpwuid:	681
-xor:	619
-y:	567
-syscall:	560
-CHECK:	538
-connect:	526
-err:	522
-sleep:	519
-sin:	499
-send:	496
-getpwnam:	483
-cos:	447
-exec:	429
-link:	425
-exp:	423
-untie:	420
-INIT:	418
-waitpid:	414
-__DATA__:	395
-symlink:	386
-kill:	382
-setsockopt:	356
-atan2:	350
-pipe:	344
-lt:	335
-fork:	327
-times:	310
-getservbyname:	299
-telldir:	294
-bind:	290
-dump:	274
-flock:	260
-recv:	250
-getsockopt:	243
-getsockname:	235
-accept:	233
-getprotobynumber:	232
-rewinddir:	218
-__LINE__:	209
-qx:	177
-lcfirst:	165
-getlogin:	158
-reset:	127
-gethostbyaddr:	68
-getgrgid:	67
-srand:	41
-chown:	34
-seekdir:	20
-readline:	19
-semctl:	17
-getpwent:	12
-getgrnam:	11
-getppid:	10
-crypt:	8
-DESTROY:	7
-getpriority:	5
-getservent:	4
-gethostent:	3
-setpriority:	2
-setnetent:	1
+  return <<END;
+return ${sign}KEY_$k;
+END
+}