General-purpose symbol shortening for VMS.

Some folks like to write long sentences and then use them as
variable names, which doesn't come up that often, but when it
does, the build on VMS falls down hard if any of the resulting
symbols is longer than 31 characters.  The problem is not for
the compiler, which when using /NAMES=SHORTENED (which we now do
by default) will shorten the symbols, but for the linker, which
must have an exact list of the symbol names to be exported when
creating the perlshr.exe shareable image.

That list of potentially shortened symbols goes in a linker options
file created by vms/gen_shrfls.pl.  Until now we had no recourse
but to hard-code there a mapping of long symbols to shortened ones,
but the AUTODIN-II polynomial used by the compiler to do the
shortening is (partially) documented under the help for CC/NAMES,
and it was possible to extrapolate from there and create a pure-
Perl implementation that mimics precisely what the C compiler (and
the C++ compiler under "extern C" declarations) use for shortening
long symbol names.

Symbols like Perl__it_was_the_best_of_times_it_was_the_worst_of_times
can now be created freely without causing the VMS linker to seize up.

1 files changed, 108 insertions, 19 deletions

diff --git a/vms/gen_shrfls.pl b/vms/gen_shrfls.pl
index a75073c3c0..0cac88bd26 100644
--- a/vms/gen_shrfls.pl
+++ b/vms/gen_shrfls.pl
@@ -127,6 +127,7 @@ open my $makedefs, '<', $dir . 'makedef.lis' or die "Unable to open makedef.lis:
 
 while (my $line = <$makedefs>) {
   chomp $line;
+  $line = shorten_symbol($line, $care_about_case) if $shorten_symbols;
   # makedef.pl loses distinction between vars and funcs, so
   # use the start of the name to guess and add specific
   # exceptions when we know about them.
@@ -148,25 +149,6 @@ foreach (split /\s+/, $extnames) {
   print "Adding boot_$pkgname to \%fcns (for extension $_)\n" if $debug;
 }
 
-# For symbols over 31 characters, export the shortened name.
-# TODO: Make this general purpose so we can predict the shortened name the
-# compiler will generate for any symbol over 31 characters in length.  The
-# docs to CC/NAMES=SHORTENED describe the CRC used to shorten the name, but
-# don't describe its use fully enough to actually mimic what the compiler
-# does.
-
-if ($shorten_symbols) {
-  if (exists $fcns{'Perl_ck_entersub_args_proto_or_list'}) {
-    delete $fcns{'Perl_ck_entersub_args_proto_or_list'};
-    if ($care_about_case) {
-      $fcns{'Perl_ck_entersub_args_p11c2bjj$'}++;
-    }
-    else {
-      $fcns{'PERL_CK_ENTERSUB_ARGS_P3IAT616$'}++;
-    }
-  }
-}
-
 # Eventually, we'll check against existing copies here, so we can add new
 # symbols to an existing options file in an upwardly-compatible manner.
 
@@ -309,4 +291,111 @@ close OPTBLD;
 exec "\$ \@$drvrname" if $isvax;
 
 
+# Symbol shortening Copyright (c) 2012 Craig A. Berry
+#
+# Released under the same terms as Perl itself.
+#
+# This code provides shortening of long symbols (> 31 characters) using the
+# same mechanism as the OpenVMS C compiler.  The basic procedure is to compute
+# an AUTODIN II checksum of the entire symbol, encode the checksum in base32,
+# and glue together a shortened symbol from the first 23 characters of the
+# original symbol plus the encoded checksum appended.  The output format is
+# the same used in the name mangler database, stored by default in
+# [.CXX_REPOSITORY]CXX$DEMANGLER_DB.
+
+sub crc32 {
+    use constant autodin_ii_table => [
+        0x00000000, 0x77073096, 0xee0e612c, 0x990951ba, 0x076dc419, 0x706af48f,
+        0xe963a535, 0x9e6495a3, 0x0edb8832, 0x79dcb8a4, 0xe0d5e91e, 0x97d2d988,
+        0x09b64c2b, 0x7eb17cbd, 0xe7b82d07, 0x90bf1d91, 0x1db71064, 0x6ab020f2,
+        0xf3b97148, 0x84be41de, 0x1adad47d, 0x6ddde4eb, 0xf4d4b551, 0x83d385c7,
+        0x136c9856, 0x646ba8c0, 0xfd62f97a, 0x8a65c9ec, 0x14015c4f, 0x63066cd9,
+        0xfa0f3d63, 0x8d080df5, 0x3b6e20c8, 0x4c69105e, 0xd56041e4, 0xa2677172,
+        0x3c03e4d1, 0x4b04d447, 0xd20d85fd, 0xa50ab56b, 0x35b5a8fa, 0x42b2986c,
+        0xdbbbc9d6, 0xacbcf940, 0x32d86ce3, 0x45df5c75, 0xdcd60dcf, 0xabd13d59,
+        0x26d930ac, 0x51de003a, 0xc8d75180, 0xbfd06116, 0x21b4f4b5, 0x56b3c423,
+        0xcfba9599, 0xb8bda50f, 0x2802b89e, 0x5f058808, 0xc60cd9b2, 0xb10be924,
+        0x2f6f7c87, 0x58684c11, 0xc1611dab, 0xb6662d3d, 0x76dc4190, 0x01db7106,
+        0x98d220bc, 0xefd5102a, 0x71b18589, 0x06b6b51f, 0x9fbfe4a5, 0xe8b8d433,
+        0x7807c9a2, 0x0f00f934, 0x9609a88e, 0xe10e9818, 0x7f6a0dbb, 0x086d3d2d,
+        0x91646c97, 0xe6635c01, 0x6b6b51f4, 0x1c6c6162, 0x856530d8, 0xf262004e,
+        0x6c0695ed, 0x1b01a57b, 0x8208f4c1, 0xf50fc457, 0x65b0d9c6, 0x12b7e950,
+        0x8bbeb8ea, 0xfcb9887c, 0x62dd1ddf, 0x15da2d49, 0x8cd37cf3, 0xfbd44c65,
+        0x4db26158, 0x3ab551ce, 0xa3bc0074, 0xd4bb30e2, 0x4adfa541, 0x3dd895d7,
+        0xa4d1c46d, 0xd3d6f4fb, 0x4369e96a, 0x346ed9fc, 0xad678846, 0xda60b8d0,
+        0x44042d73, 0x33031de5, 0xaa0a4c5f, 0xdd0d7cc9, 0x5005713c, 0x270241aa,
+        0xbe0b1010, 0xc90c2086, 0x5768b525, 0x206f85b3, 0xb966d409, 0xce61e49f,
+        0x5edef90e, 0x29d9c998, 0xb0d09822, 0xc7d7a8b4, 0x59b33d17, 0x2eb40d81,
+        0xb7bd5c3b, 0xc0ba6cad, 0xedb88320, 0x9abfb3b6, 0x03b6e20c, 0x74b1d29a,
+        0xead54739, 0x9dd277af, 0x04db2615, 0x73dc1683, 0xe3630b12, 0x94643b84,
+        0x0d6d6a3e, 0x7a6a5aa8, 0xe40ecf0b, 0x9309ff9d, 0x0a00ae27, 0x7d079eb1,
+        0xf00f9344, 0x8708a3d2, 0x1e01f268, 0x6906c2fe, 0xf762575d, 0x806567cb,
+        0x196c3671, 0x6e6b06e7, 0xfed41b76, 0x89d32be0, 0x10da7a5a, 0x67dd4acc,
+        0xf9b9df6f, 0x8ebeeff9, 0x17b7be43, 0x60b08ed5, 0xd6d6a3e8, 0xa1d1937e,
+        0x38d8c2c4, 0x4fdff252, 0xd1bb67f1, 0xa6bc5767, 0x3fb506dd, 0x48b2364b,
+        0xd80d2bda, 0xaf0a1b4c, 0x36034af6, 0x41047a60, 0xdf60efc3, 0xa867df55,
+        0x316e8eef, 0x4669be79, 0xcb61b38c, 0xbc66831a, 0x256fd2a0, 0x5268e236,
+        0xcc0c7795, 0xbb0b4703, 0x220216b9, 0x5505262f, 0xc5ba3bbe, 0xb2bd0b28,
+        0x2bb45a92, 0x5cb36a04, 0xc2d7ffa7, 0xb5d0cf31, 0x2cd99e8b, 0x5bdeae1d,
+        0x9b64c2b0, 0xec63f226, 0x756aa39c, 0x026d930a, 0x9c0906a9, 0xeb0e363f,
+        0x72076785, 0x05005713, 0x95bf4a82, 0xe2b87a14, 0x7bb12bae, 0x0cb61b38,
+        0x92d28e9b, 0xe5d5be0d, 0x7cdcefb7, 0x0bdbdf21, 0x86d3d2d4, 0xf1d4e242,
+        0x68ddb3f8, 0x1fda836e, 0x81be16cd, 0xf6b9265b, 0x6fb077e1, 0x18b74777,
+        0x88085ae6, 0xff0f6a70, 0x66063bca, 0x11010b5c, 0x8f659eff, 0xf862ae69,
+        0x616bffd3, 0x166ccf45, 0xa00ae278, 0xd70dd2ee, 0x4e048354, 0x3903b3c2,
+        0xa7672661, 0xd06016f7, 0x4969474d, 0x3e6e77db, 0xaed16a4a, 0xd9d65adc,
+        0x40df0b66, 0x37d83bf0, 0xa9bcae53, 0xdebb9ec5, 0x47b2cf7f, 0x30b5ffe9,
+        0xbdbdf21c, 0xcabac28a, 0x53b39330, 0x24b4a3a6, 0xbad03605, 0xcdd70693,
+        0x54de5729, 0x23d967bf, 0xb3667a2e, 0xc4614ab8, 0x5d681b02, 0x2a6f2b94,
+        0xb40bbe37, 0xc30c8ea1, 0x5a05df1b, 0x2d02ef8d,
+    ];
+
+    my $input_string = shift;
+    my $crc = 0xFFFFFFFF;
+
+    for my $byte (unpack 'C*', $input_string) {
+        $crc = ($crc >> 8) ^ autodin_ii_table->[($crc ^ $byte) & 0xff];
+    }
+    return ~$crc;
+}
+
+sub base32 {
+    my $input = shift;
+    my $output = '';
+    use constant base32hex_table => [
+        '0', '1', '2', '3', '4', '5', '6', '7', '8', '9',
+        'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j',
+        'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't',
+        'u', 'v'
+    ];
+
+    # Grab lowest 5 bits and look up conversion in table.  Lather, rinse,
+    # repeat for a total of 7, 5-bit chunks to accommodate 32 bits of input.
+
+    for (0..6) {
+        $output  = base32hex_table->[$input & 0x1f] . $output;
+        $input >>= 5;     # position to look at next 5
+    }
+    $output .= '$';       #  It's DEC, so use '$' not '=' to pad.
+
+    return $output;
+}
+
+sub shorten_symbol {
+    my $input_symbol = shift;
+    my $as_is_flag = shift;
+    my $symbol = $input_symbol;
+
+    return $symbol unless length($input_symbol) > 31;
+
+    $symbol = uc($symbol) unless $as_is_flag;
+    my $crc = crc32($symbol);
+    $crc = ~$crc;  # Compiler uses non-inverted form.
+    my $b32 = base32($crc);
+    $b32 = uc($b32) unless $as_is_flag;
+
+    return substr($symbol, 0, 23) . $b32;
+}
+
 __END__
+