ext/Encode/compile

   1 #!../../perl -w
   2 BEGIN {
   3     unshift @INC, qw(../../lib ../../../lib);
   4     $ENV{PATH} .= ';../..;../../..' if $^O eq 'MSWin32';
   5 }
   6 use strict;
   7 use Getopt::Std;
   8 my @orig_ARGV = @ARGV;
   9 my $perforce  = '$Id$';
  10
  11 # These may get re-ordered.
  12 # RAW is a do_now as inserted by &enter
  13 # AGG is an aggreagated do_now, as built up by &process
  14 use constant {
  15   RAW_NEXT => 0,
  16   RAW_IN_LEN => 1,
  17   RAW_OUT_BYTES => 2,
  18   RAW_FALLBACK => 3,
  19
  20   AGG_MIN_IN => 0,
  21   AGG_MAX_IN => 1,
  22   AGG_OUT_BYTES => 2,
  23   AGG_NEXT => 3,
  24   AGG_IN_LEN => 4,
  25   AGG_OUT_LEN => 5,
  26   AGG_FALLBACK => 6,
  27 };
  28 # (See the algorithm in encengine.c - we're building structures for it)
  29
  30 # There are two sorts of structures.
  31 # "do_now" (an array, two variants of what needs storing) is whatever we need
  32 # to do now we've read an input byte.
  33 # It's housed in a "do_next" (which is how we got to it), and in turn points
  34 # to a "do_next" which contains all the "do_now"s for the next input byte.
  35
  36 # There will be a "do_next" which is the start state.
  37 # For a single byte encoding it's the only "do_next" - each "do_now" points
  38 # back to it, and each "do_now" will cause bytes. There is no state.
  39
  40 # For a multi-byte encoding where all characters in the input are the same
  41 # length, then there will be a tree of "do_now"->"do_next"->"do_now"
  42 # branching out from the start state, one step for each input byte.
  43 # The leaf "do_now"s will all be at the same distance from the start state,
  44 # only the leaf "do_now"s cause output bytes, and they in turn point back to
  45 # the start state.
  46
  47 # For an encoding where there are varaible length input byte sequences, you
  48 # will encounter a leaf "do_now" sooner for the shorter input sequences, but
  49 # as before the leaves will point back to the start state.
  50
  51 # The system will cope with escape encodings (imagine them as a mostly
  52 # self-contained tree for each escape state, and cross links between trees
  53 # at the state-switching characters) but so far no input format defines these.
  54
  55 # The system will also cope with having output "leaves" in the middle of
  56 # the bifurcating branches, not just at the extremities, but again no
  57 # input format does this yet.
  58
  59 # There are two variants of the "do_now" structure. The first, smaller variant
  60 # is generated by &enter as the input file is read. There is one structure
  61 # for each input byte. Say we are mapping a single byte encoding to a
  62 # single byte encoding, with  "ABCD" going "abcd". There will be
  63 # 4 "do_now"s, {"A" => [...,"a",...], "B" => [...,"b",...], "C"=>..., "D"=>...}
  64
  65 # &process then walks the tree, building aggregate "do_now" structres for
  66 # adjacent bytes where possible. The aggregate is for a contiguous range of
  67 # bytes which each produce the same length of output, each move to the
  68 # same next state, and each have the same fallback flag.
  69 # So our 4 RAW "do_now"s above become replaced by a single structure
  70 # containing:
  71 # ["A", "D", "abcd", 1, ...]
  72 # ie, for an input byte $_ in "A".."D", output 1 byte, found as
  73 # substr ("abcd", (ord $_ - ord "A") * 1, 1)
  74 # which maps very nicely into pointer arithmetic in C for encengine.c
  75
  76 sub encode_U
  77 {
  78  # UTF-8 encode long hand - only covers part of perl's range
  79  ## my $uv = shift;
  80  # chr() works in native space so convert value from table
  81  # into that space before using chr().
  82  my $ch = chr(utf8::unicode_to_native($_[0]));
  83  # Now get core perl to encode that the way it likes.
  84  utf8::encode($ch);
  85  return $ch;
  86 }
  87
  88 sub encode_S
  89 {
  90  # encode single byte
  91  ## my ($ch,$page) = @_; return chr($ch);
  92  return chr $_[0];
  93 }
  94
  95 sub encode_D
  96 {
  97  # encode double byte MS byte first
  98  ## my ($ch,$page) = @_; return chr($page).chr($ch);
  99  return chr ($_[1]) . chr $_[0];
 100 }
 101
 102 sub encode_M
 103 {
 104  # encode Multi-byte - single for 0..255 otherwise double
 105  ## my ($ch,$page) = @_;
 106  ## return &encode_D if $page;
 107  ## return &encode_S;
 108  return chr ($_[1]) . chr $_[0] if $_[1];
 109  return chr $_[0];
 110 }
 111
 112 my %encode_types = (U => \&encode_U,
 113                     S => \&encode_S,
 114                     D => \&encode_D,
 115                     M => \&encode_M,
 116                    );
 117
 118 # Win32 does not expand globs on command line
 119 eval "\@ARGV = map(glob(\$_),\@ARGV)" if ($^O eq 'MSWin32');
 120
 121 my %opt;
 122 # I think these are:
 123 # -Q to disable the duplicate codepoint test
 124 # -q to remove comments written to output files
 125 # -O to enable the (brute force) substring optimiser
 126 # -o <output> to specify the output file name (else it's the first arg)
 127 # -f <inlist> to give a file with a list of input files (else use the args)
 128 # -n <name> to name the encoding (else use the basename of the input file.
 129 getopts('QqOo:f:n:',\%opt);
 130
 131 # This really should go first, else the die here causes empty (non-erroneous)
 132 # output files to be written.
 133 my @encfiles;
 134 if (exists $opt{'f'}) {
 135     # -F is followed by name of file containing list of filenames
 136     my $flist = $opt{'f'};
 137     open(FLIST,$flist) || die "Cannot open $flist:$!";
 138     chomp(@encfiles = <FLIST>);
 139     close(FLIST);
 140 } else {
 141     @encfiles = @ARGV;
 142 }
 143
 144 my $cname = (exists $opt{'o'}) ? $opt{'o'} : shift(@ARGV);
 145 chmod(0666,$cname) if -f $cname && !-w $cname;
 146 open(C,">$cname") || die "Cannot open $cname:$!";
 147
 148 my $dname = $cname;
 149 my $hname = $cname;
 150
 151 my ($doC,$doEnc,$doUcm,$doPet);
 152
 153 if ($cname =~ /\.(c|xs)$/)
 154  {
 155   $doC = 1;
 156   $dname =~ s/(\.[^\.]*)?$/_def.h/;
 157   chmod(0666,$dname) if -f $cname && !-w $dname;
 158   open(D,">$dname") || die "Cannot open $dname:$!";
 159   $hname =~ s/(\.[^\.]*)?$/.h/;
 160   chmod(0666,$hname) if -f $cname && !-w $hname;
 161   open(H,">$hname") || die "Cannot open $hname:$!";
 162
 163   foreach my $fh (\*C,\*D,\*H)
 164   {
 165    print $fh <<"END" unless $opt{'q'};
 166 /*
 167  !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
 168  This file was autogenerated by:
 169  $^X $0 @orig_ARGV
 170 */
 171 END
 172   }
 173
 174   if ($cname =~ /(\w+)\.xs$/)
 175    {
 176     print C "#include <EXTERN.h>\n";
 177     print C "#include <perl.h>\n";
 178     print C "#include <XSUB.h>\n";
 179     print C "#define U8 U8\n";
 180    }
 181   print C "#include \"encode.h\"\n";
 182
 183  }
 184 elsif ($cname =~ /\.enc$/)
 185  {
 186   $doEnc = 1;
 187  }
 188 elsif ($cname =~ /\.ucm$/)
 189  {
 190   $doUcm = 1;
 191  }
 192 elsif ($cname =~ /\.pet$/)
 193  {
 194   $doPet = 1;
 195  }
 196
 197 my %encoding;
 198 my %strings;
 199 my $saved = 0;
 200 my $subsave = 0;
 201 my $strings = 0;
 202
 203 sub cmp_name
 204 {
 205  if ($a =~ /^.*-(\d+)/)
 206   {
 207    my $an = $1;
 208    if ($b =~ /^.*-(\d+)/)
 209     {
 210      my $r = $an <=> $1;
 211      return $r if $r;
 212     }
 213   }
 214  return $a cmp $b;
 215 }
 216
 217
 218 foreach my $enc (sort cmp_name @encfiles)
 219  {
 220   my ($name,$sfx) = $enc =~ /^.*?([\w-]+)\.(enc|ucm)$/;
 221   $name = $opt{'n'} if exists $opt{'n'};
 222   if (open(E,$enc))
 223    {
 224     if ($sfx eq 'enc')
 225      {
 226       compile_enc(\*E,lc($name));
 227      }
 228     else
 229      {
 230       compile_ucm(\*E,lc($name));
 231      }
 232    }
 233   else
 234    {
 235     warn "Cannot open $enc for $name:$!";
 236    }
 237  }
 238
 239 if ($doC)
 240  {
 241   print STDERR "Writing compiled form\n";
 242   foreach my $name (sort cmp_name keys %encoding)
 243    {
 244     my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
 245     output(\*C,$name.'_utf8',$e2u);
 246     output(\*C,'utf8_'.$name,$u2e);
 247     push(@{$encoding{$name}},outstring(\*C,$e2u->{Cname}.'_def',$erep));
 248    }
 249   foreach my $enc (sort cmp_name keys %encoding)
 250    {
 251     my ($e2u,$u2e,$rep,$min_el,$max_el,$rsym) = @{$encoding{$enc}};
 252     my @info = ($e2u->{Cname},$u2e->{Cname},$rsym,length($rep),$min_el,$max_el);
 253     my $sym = "${enc}_encoding";
 254     $sym =~ s/\W+/_/g;
 255     print C "encode_t $sym = \n";
 256     print C " {",join(',',@info,"{\"$enc\",(const char *)0}"),"};\n\n";
 257    }
 258
 259   foreach my $enc (sort cmp_name keys %encoding)
 260    {
 261     my $sym = "${enc}_encoding";
 262     $sym =~ s/\W+/_/g;
 263     print H "extern encode_t $sym;\n";
 264     print D " Encode_XSEncoding(aTHX_ &$sym);\n";
 265    }
 266
 267   if ($cname =~ /(\w+)\.xs$/)
 268    {
 269     my $mod = $1;
 270     print C <<'END';
 271
 272 static void
 273 Encode_XSEncoding(pTHX_ encode_t *enc)
 274 {
 275  dSP;
 276  HV *stash = gv_stashpv("Encode::XS", TRUE);
 277  SV *sv    = sv_bless(newRV_noinc(newSViv(PTR2IV(enc))),stash);
 278  int i = 0;
 279  PUSHMARK(sp);
 280  XPUSHs(sv);
 281  while (enc->name[i])
 282   {
 283    const char *name = enc->name[i++];
 284    XPUSHs(sv_2mortal(newSVpvn(name,strlen(name))));
 285   }
 286  PUTBACK;
 287  call_pv("Encode::define_encoding",G_DISCARD);
 288  SvREFCNT_dec(sv);
 289 }
 290
 291 END
 292
 293     print C "\nMODULE = Encode::$mod\tPACKAGE = Encode::$mod\n\n";
 294     print C "BOOT:\n{\n";
 295     print C "#include \"$dname\"\n";
 296     print C "}\n";
 297    }
 298   # Close in void context is bad, m'kay
 299   close(D) or warn "Error closing '$dname': $!";
 300   close(H) or warn "Error closing '$hname': $!";
 301
 302   my $perc_saved    = $strings/($strings + $saved) * 100;
 303   my $perc_subsaved = $strings/($strings + $subsave) * 100;
 304   printf STDERR "%d bytes in string tables\n",$strings;
 305   printf STDERR "%d bytes (%.3g%%) saved spotting duplicates\n",
 306     $saved, $perc_saved              if $saved;
 307   printf STDERR "%d bytes (%.3g%%) saved using substrings\n",
 308     $subsave, $perc_subsaved         if $subsave;
 309  }
 310 elsif ($doEnc)
 311  {
 312   foreach my $name (sort cmp_name keys %encoding)
 313    {
 314     my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
 315     output_enc(\*C,$name,$e2u);
 316    }
 317  }
 318 elsif ($doUcm)
 319  {
 320   foreach my $name (sort cmp_name keys %encoding)
 321    {
 322     my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
 323     output_ucm(\*C,$name,$u2e,$erep,$min_el,$max_el);
 324    }
 325  }
 326
 327 # writing half meg files and then not checking to see if you just filled the
 328 # disk is bad, m'kay
 329 close(C) or die "Error closing '$cname': $!";
 330
 331 # End of the main program.
 332
 333 sub compile_ucm
 334 {
 335  my ($fh,$name) = @_;
 336  my $e2u = {};
 337  my $u2e = {};
 338  my $cs;
 339  my %attr;
 340  while (<$fh>)
 341   {
 342    s/#.*$//;
 343    last if /^\s*CHARMAP\s*$/i;
 344    if (/^\s*<(\w+)>\s+"?([^"]*)"?\s*$/i) # " # Grrr
 345     {
 346      $attr{$1} = $2;
 347     }
 348   }
 349  if (!defined($cs =  $attr{'code_set_name'}))
 350   {
 351    warn "No <code_set_name> in $name\n";
 352   }
 353  else
 354   {
 355    $name = $cs unless exists $opt{'n'};
 356   }
 357  my $erep;
 358  my $urep;
 359  my $max_el;
 360  my $min_el;
 361  if (exists $attr{'subchar'})
 362   {
 363    my @byte;
 364    $attr{'subchar'} =~ /^\s*/cg;
 365    push(@byte,$1) while $attr{'subchar'} =~ /\G\\x([0-9a-f]+)/icg;
 366    $erep = join('',map(chr(hex($_)),@byte));
 367   }
 368  print "Reading $name ($cs)\n";
 369  my $nfb = 0;
 370  my $hfb = 0;
 371  while (<$fh>)
 372   {
 373    s/#.*$//;
 374    last if /^\s*END\s+CHARMAP\s*$/i;
 375    next if /^\s*$/;
 376    my ($u,@byte);
 377    my $fb = '';
 378    $u = $1 if (/^<U([0-9a-f]+)>\s+/igc);
 379    push(@byte,$1) while /\G\\x([0-9a-f]+)/igc;
 380    $fb = $1 if /\G\s*(\|[0-3])/gc;
 381    # warn "$_: $u @byte | $fb\n";
 382    die "Bad line:$_" unless /\G\s*(#.*)?$/gc;
 383    if (defined($u))
 384     {
 385      my $uch = encode_U(hex($u));
 386      my $ech = join('',map(chr(hex($_)),@byte));
 387      my $el  = length($ech);
 388      $max_el = $el if (!defined($max_el) || $el > $max_el);
 389      $min_el = $el if (!defined($min_el) || $el < $min_el);
 390      if (length($fb))
 391       {
 392        $fb = substr($fb,1);
 393        $hfb++;
 394       }
 395      else
 396       {
 397        $nfb++;
 398        $fb = '0';
 399       }
 400      # $fb is fallback flag
 401      # 0 - round trip safe
 402      # 1 - fallback for unicode -> enc
 403      # 2 - skip sub-char mapping
 404      # 3 - fallback enc -> unicode
 405      enter($u2e,$uch,$ech,$u2e,$fb+0) if ($fb =~ /[01]/);
 406      enter($e2u,$ech,$uch,$e2u,$fb+0) if ($fb =~ /[03]/);
 407     }
 408    else
 409     {
 410      warn $_;
 411     }
 412   }
 413  if ($nfb && $hfb)
 414   {
 415    die "$nfb entries without fallback, $hfb entries with\n";
 416   }
 417  $encoding{$name} = [$e2u,$u2e,$erep,$min_el,$max_el];
 418 }
 419
 420 sub compile_enc
 421 {
 422  my ($fh,$name) = @_;
 423  my $e2u = {};
 424  my $u2e = {};
 425
 426  my $type;
 427  while ($type = <$fh>)
 428   {
 429    last if $type !~ /^\s*#/;
 430   }
 431  chomp($type);
 432  return if $type eq 'E';
 433  # Do the hash lookup once, rather than once per function call. 4% speedup.
 434  my $type_func = $encode_types{$type};
 435  my ($def,$sym,$pages) = split(/\s+/,scalar(<$fh>));
 436  warn "$type encoded $name\n";
 437  my $rep = '';
 438  # Save a defined test by setting these to defined values.
 439  my $min_el = ~0; # A very big integer
 440  my $max_el = 0;  # Anything must be longer than 0
 441  {
 442   my $v = hex($def);
 443   $rep = &$type_func($v & 0xFF, ($v >> 8) & 0xffe);
 444  }
 445  my $seen;
 446  # use -Q to silence the seen test. Makefile.PL uses this by default.
 447  $seen = {} unless $opt{Q};
 448  do
 449   {
 450    my $line = <$fh>;
 451    chomp($line);
 452    my $page = hex($line);
 453    my $ch = 0;
 454    my $i = 16;
 455    do
 456     {
 457      # So why is it 1% faster to leave the my here?
 458      my $line = <$fh>;
 459      die "Line should be exactly 65 characters long including newline"
 460        unless length ($line) == 65;
 461      # Split line into groups of 4 hex digits, convert groups to ints
 462      # This takes 65.35
 463      # map {hex $_} $line =~ /(....)/g
 464      # This takes 63.75 (2.5% less time)
 465      # unpack "n*", pack "H*", $line
 466      # There's an implicit loop in map. Loops are bad, m'kay. Ops are bad, m'kay
 467      # Doing it as while ($line =~ /(....)/g) took 74.63
 468      foreach my $val (unpack "n*", pack "H*", $line)
 469       {
 470        next if $val == 0xFFFD;
 471        my $ech = &$type_func($ch,$page);
 472        if ($val || (!$ch && !$page))
 473         {
 474          my $el  = length($ech);
 475          $max_el = $el if $el > $max_el;
 476          $min_el = $el if $el < $min_el;
 477          my $uch = encode_U($val);
 478          if ($seen) {
 479            # We're doing the test.
 480            # We don't need to read this quickly, so storing it as a scalar,
 481            # rather than 3 (anon array, plus the 2 scalars it holds) saves
 482            # RAM and may make us faster on low RAM systems. [see __END__]
 483            if (exists $seen->{$uch})
 484              {
 485                warn sprintf("U%04X is %02X%02X and %04X\n",
 486                             $val,$page,$ch,$seen->{$uch});
 487              }
 488            else
 489              {
 490                $seen->{$uch} = $page << 8 | $ch;
 491              }
 492          }
 493          # Passing 2 extra args each time is 3.6% slower!
 494          # Even with having to add $fallback ||= 0 later
 495          enter_fb0($e2u,$ech,$uch);
 496          enter_fb0($u2e,$uch,$ech);
 497         }
 498        else
 499         {
 500          # No character at this position
 501          # enter($e2u,$ech,undef,$e2u);
 502         }
 503        $ch++;
 504       }
 505     } while --$i;
 506   } while --$pages;
 507  die "\$min_el=$min_el, \$max_el=$max_el - seems we read no lines"
 508    if $min_el > $max_el;
 509  $encoding{$name} = [$e2u,$u2e,$rep,$min_el,$max_el];
 510 }
 511
 512 # my ($a,$s,$d,$t,$fb) = @_;
 513 sub enter {
 514   my ($current,$inbytes,$outbytes,$next,$fallback) = @_;
 515   # state we shift to after this (multibyte) input character defaults to same
 516   # as current state.
 517   $next ||= $current;
 518   # Making sure it is defined seems to be faster than {no warnings;} in
 519   # &process, or passing it in as 0 explicity.
 520   # XXX $fallback ||= 0;
 521
 522   # Start at the beginning and work forwards through the string to zero.
 523   # effectively we are removing 1 character from the front each time
 524   # but we don't actually edit the string. [this alone seems to be 14% speedup]
 525   # Hence -$pos is the length of the remaining string.
 526   my $pos = -length $inbytes;
 527   while (1) {
 528     my $byte = substr $inbytes, $pos, 1;
 529     #  RAW_NEXT => 0,
 530     #  RAW_IN_LEN => 1,
 531     #  RAW_OUT_BYTES => 2,
 532     #  RAW_FALLBACK => 3,
 533     # to unicode an array would seem to be better, because the pages are dense.
 534     # from unicode can be very sparse, favouring a hash.
 535     # hash using the bytes (all length 1) as keys rather than ord value,
 536     # as it's easier to sort these in &process.
 537
 538     # It's faster to always add $fallback even if it's undef, rather than
 539     # choosing between 3 and 4 element array. (hence why we set it defined
 540     # above)
 541     my $do_now = $current->{Raw}{$byte} ||= [{},-$pos,'',$fallback];
 542     # When $pos was -1 we were at the last input character.
 543     unless (++$pos) {
 544       $do_now->[RAW_OUT_BYTES] = $outbytes;
 545       $do_now->[RAW_NEXT] = $next;
 546       return;
 547     }
 548     # Tail recursion. The intermdiate state may not have a name yet.
 549     $current = $do_now->[RAW_NEXT];
 550   }
 551 }
 552
 553 # This is purely for optimistation. It's just &enter hard coded for $fallback
 554 # of 0, using only a 3 entry array ref to save memory for every entry.
 555 sub enter_fb0 {
 556   my ($current,$inbytes,$outbytes,$next) = @_;
 557   $next ||= $current;
 558
 559   my $pos = -length $inbytes;
 560   while (1) {
 561     my $byte = substr $inbytes, $pos, 1;
 562     my $do_now = $current->{Raw}{$byte} ||= [{},-$pos,''];
 563     unless (++$pos) {
 564       $do_now->[RAW_OUT_BYTES] = $outbytes;
 565       $do_now->[RAW_NEXT] = $next;
 566       return;
 567     }
 568     $current = $do_now->[RAW_NEXT];
 569   }
 570 }
 571
 572
 573 sub outstring
 574 {
 575  my ($fh,$name,$s) = @_;
 576  my $sym = $strings{$s};
 577  if ($sym)
 578   {
 579    $saved += length($s);
 580   }
 581  else
 582   {
 583    if ($opt{'O'}) {
 584        foreach my $o (keys %strings)
 585         {
 586          next unless (my $i = index($o,$s)) >= 0;
 587          $sym = $strings{$o};
 588          $sym .= sprintf("+0x%02x",$i) if ($i);
 589          $subsave += length($s);
 590          return $strings{$s} = $sym;
 591        }
 592    }
 593    $strings{$s} = $sym = $name;
 594    $strings += length($s);
 595    my $definition = sprintf "static const U8 %s[%d] = { ",$name,length($s);
 596    # Maybe we should assert that these are all <256.
 597    $definition .= join(',',unpack "C*",$s);
 598    # We have a single long line. Split it at convenient commas.
 599    $definition =~ s/(.{74,77},)/$1\n/g;
 600    print $fh "$definition };\n\n";
 601   }
 602  return $sym;
 603 }
 604
 605 sub process
 606 {
 607   my ($name,$a) = @_;
 608   $name =~ s/\W+/_/g;
 609   $a->{Cname} = $name;
 610   my $raw = $a->{Raw};
 611   my ($l, $agg_max_in, $agg_next, $agg_in_len, $agg_out_len, $agg_fallback);
 612   my @ent;
 613   $agg_max_in = 0;
 614   foreach my $key (sort keys %$raw) {
 615     #  RAW_NEXT => 0,
 616     #  RAW_IN_LEN => 1,
 617     #  RAW_OUT_BYTES => 2,
 618     #  RAW_FALLBACK => 3,
 619     my ($next, $in_len, $out_bytes, $fallback) = @{$raw->{$key}};
 620     # Now we are converting from raw to aggregate, switch from 1 byte strings
 621     # to numbers
 622     my $b = ord $key;
 623     $fallback ||= 0;
 624     if ($l &&
 625         # If this == fails, we're going to reset $agg_max_in below anyway.
 626         $b == ++$agg_max_in &&
 627         # References in numeric context give the pointer as an int.
 628         $agg_next == $next &&
 629         $agg_in_len == $in_len &&
 630         $agg_out_len == length $out_bytes &&
 631         $agg_fallback == $fallback
 632         # && length($l->[AGG_OUT_BYTES]) < 16
 633        ) {
 634       #     my $i = ord($b)-ord($l->[AGG_MIN_IN]);
 635       # we can aggregate this byte onto the end.
 636       $l->[AGG_MAX_IN] = $b;
 637       $l->[AGG_OUT_BYTES] .= $out_bytes;
 638     } else {
 639       # AGG_MIN_IN => 0,
 640       # AGG_MAX_IN => 1,
 641       # AGG_OUT_BYTES => 2,
 642       # AGG_NEXT => 3,
 643       # AGG_IN_LEN => 4,
 644       # AGG_OUT_LEN => 5,
 645       # AGG_FALLBACK => 6,
 646       # Reset the last thing we saw, plus set 5 lexicals to save some derefs.
 647       # (only gains .6% on euc-jp  -- is it worth it?)
 648       push @ent, $l = [$b, $agg_max_in = $b, $out_bytes, $agg_next = $next,
 649                        $agg_in_len = $in_len, $agg_out_len = length $out_bytes,
 650                        $agg_fallback = $fallback];
 651     }
 652     if (exists $next->{Cname}) {
 653       $next->{'Forward'} = 1 if $next != $a;
 654     } else {
 655       process(sprintf("%s_%02x",$name,$b),$next);
 656     }
 657   }
 658   # encengine.c rules say that last entry must be for 255
 659   if ($agg_max_in < 255) {
 660     push @ent, [1+$agg_max_in, 255,undef,$a,0,0];
 661   }
 662   $a->{'Entries'} = \@ent;
 663 }
 664
 665 sub outtable
 666 {
 667  my ($fh,$a) = @_;
 668  my $name = $a->{'Cname'};
 669  # String tables
 670  foreach my $b (@{$a->{'Entries'}})
 671   {
 672    next unless $b->[AGG_OUT_LEN];
 673    my $s = $b->[AGG_MIN_IN];
 674    my $e = $b->[AGG_MAX_IN];
 675    outstring($fh,sprintf("%s__%02x_%02x",$name,$s,$e),$b->[AGG_OUT_BYTES]);
 676   }
 677  if ($a->{'Forward'})
 678   {
 679    print $fh "\nstatic encpage_t $name\[",scalar(@{$a->{'Entries'}}),"];\n";
 680   }
 681  $a->{'Done'} = 1;
 682  foreach my $b (@{$a->{'Entries'}})
 683   {
 684    my ($s,$e,$out,$t,$end,$l) = @$b;
 685    outtable($fh,$t) unless $t->{'Done'};
 686   }
 687  print $fh "\nstatic encpage_t $name\[",scalar(@{$a->{'Entries'}}),"] = {\n";
 688  foreach my $b (@{$a->{'Entries'}})
 689   {
 690    my ($sc,$ec,$out,$t,$end,$l,$fb) = @$b;
 691    $end |= 0x80 if $fb;
 692    print  $fh "{";
 693    if ($l)
 694     {
 695      printf $fh outstring($fh,'',$out);
 696     }
 697    else
 698     {
 699      print  $fh "0";
 700     }
 701    print  $fh ",",$t->{Cname};
 702    printf $fh ",0x%02x,0x%02x,$l,$end},\n",$sc,$ec;
 703   }
 704  print $fh "};\n";
 705 }
 706
 707 sub output
 708 {
 709  my ($fh,$name,$a) = @_;
 710  process($name,$a);
 711  # Sub-tables
 712  outtable($fh,$a);
 713 }
 714
 715 sub output_enc
 716 {
 717  my ($fh,$name,$a) = @_;
 718  die "Changed - fix me for new structure";
 719  foreach my $b (sort keys %$a)
 720   {
 721    my ($s,$e,$out,$t,$end,$l,$fb) = @{$a->{$b}};
 722   }
 723 }
 724
 725 sub decode_U
 726 {
 727  my $s = shift;
 728 }
 729
 730 my @uname;
 731 sub char_names
 732 {
 733  my $s = do "unicore/Name.pl";
 734  die "char_names: unicore/Name.pl: $!\n" unless defined $s;
 735  pos($s) = 0;
 736  while ($s =~ /\G([0-9a-f]+)\t([0-9a-f]*)\t(.*?)\s*\n/igc)
 737   {
 738    my $name = $3;
 739    my $s = hex($1);
 740    last if $s >= 0x10000;
 741    my $e = length($2) ? hex($2) : $s;
 742    for (my $i = $s; $i <= $e; $i++)
 743     {
 744      $uname[$i] = $name;
 745 #    print sprintf("U%04X $name\n",$i);
 746     }
 747   }
 748 }
 749
 750 sub output_ucm_page
 751 {
 752   my ($cmap,$a,$t,$pre) = @_;
 753   # warn sprintf("Page %x\n",$pre);
 754   my $raw = $t->{Raw};
 755   foreach my $key (sort keys %$raw) {
 756     #  RAW_NEXT => 0,
 757     #  RAW_IN_LEN => 1,
 758     #  RAW_OUT_BYTES => 2,
 759     #  RAW_FALLBACK => 3,
 760     my ($next, $in_len, $out_bytes, $fallback) = @{$raw->{$key}};
 761     my $u = ord $key;
 762     $fallback ||= 0;
 763
 764     if ($next != $a && $next != $t) {
 765       output_ucm_page($cmap,$a,$next,(($pre|($u &0x3F)) << 6)&0xFFFF);
 766     } elsif (length $out_bytes) {
 767       if ($pre) {
 768         $u = $pre|($u &0x3f);
 769       }
 770       my $s = sprintf "<U%04X> ",$u;
 771       #foreach my $c (split(//,$out_bytes)) {
 772       #  $s .= sprintf "\\x%02X",ord($c);
 773       #}
 774       # 9.5% faster changing that loop to this:
 775       $s .= sprintf +("\\x%02X" x length $out_bytes), unpack "C*", $out_bytes;
 776       $s .= sprintf " |%d # %s\n",($fallback ? 1 : 0),$uname[$u];
 777       push(@$cmap,$s);
 778     } else {
 779       warn join(',',$u, @{$raw->{$key}},$a,$t);
 780     }
 781   }
 782 }
 783
 784 sub output_ucm
 785 {
 786  my ($fh,$name,$h,$rep,$min_el,$max_el) = @_;
 787  print $fh "# $0 @orig_ARGV\n" unless $opt{'q'};
 788  print $fh "<code_set_name> \"$name\"\n";
 789  char_names();
 790  if (defined $min_el)
 791   {
 792    print $fh "<mb_cur_min> $min_el\n";
 793   }
 794  if (defined $max_el)
 795   {
 796    print $fh "<mb_cur_max> $max_el\n";
 797   }
 798  if (defined $rep)
 799   {
 800    print $fh "<subchar> ";
 801    foreach my $c (split(//,$rep))
 802     {
 803      printf $fh "\\x%02X",ord($c);
 804     }
 805    print $fh "\n";
 806   }
 807  my @cmap;
 808  output_ucm_page(\@cmap,$h,$h,0);
 809  print $fh "#\nCHARMAP\n";
 810  foreach my $line (sort { substr($a,8) cmp substr($b,8) } @cmap)
 811   {
 812    print $fh $line;
 813   }
 814  print $fh "END CHARMAP\n";
 815 }
 816
 817
 818 __END__
 819 With %seen holding array refs:
 820
 821       865.66 real        28.80 user         8.79 sys
 822       7904  maximum resident set size
 823       1356  average shared memory size
 824      18566  average unshared data size
 825        229  average unshared stack size
 826      46080  page reclaims
 827      33373  page faults
 828
 829 With %seen holding simple scalars:
 830
 831       342.16 real        27.11 user         3.54 sys
 832       8388  maximum resident set size
 833       1394  average shared memory size
 834      14969  average unshared data size
 835        236  average unshared stack size
 836      28159  page reclaims
 837       9839  page faults
 838
 839 Yes, 5 minutes is faster than 15. Above is for CP936 in CN. Only difference is
 840 how %seen is storing things its seen. So it is pathalogically bad on a 16M
 841 RAM machine, but it's going to help even on modern machines.
 842 Swapping is bad, m'kay :-)